+--------------------------------------------------------------------------------------+ | | | | | PASCAL COMPUTER LANGUAGE PROGRAMMING INFORMATION | | | | ======================================================== | | U S U S P A S C A L L I B R A R Y A R C H I V E | | ======================================================== | | | | COURTESY OF | | | | DAVID T CRAIG | | | | 09 APRIL 2004 | | | | | +--------------------------------------------------------------------------------------+ ======================================================================================== DOCUMENT Jefferson Computer Museum - UCS ======================================================================================== http://www.threedee.com/jcm/usus/ 09 April 2004 USUS SOFTWARE LIBRARY IN THE WEST WING OF THE JEFFERSON COMPUTER MUSEUM TERAK MUSEUM - UCSD PASCAL MUSEUM - USUS LIBRARY ANCIENT ALPHABETIC ART - LIBRARY - ALTAIR AND IMSAI EMULATORS REVIVING CASSETTE DATA - DISK UTILITIES - COMPUTER RESCUE WHAT'S WRONG WITH THIS PICTURE ------------------------------------------------------------------------ What was the USUS Software Library? Once upon a time there was a user group known as the UCSD p-System System Users Society (USUS).Ê They maintained a library of Pascal floppy disks containing source code and programs. I have found several people who own all or portions of the collection. Ê Someone sent me the disk images for volumes 1 through 29 of the US library, and volumes 3 and 4 of the USUS UK collection.Ê Using my disk utilities, I have burst these P-System disk images into their native files. I put all the files of all the disks in a single Zip file that you may download.Ê Note that the conversion process was aimed at producing an archive of text files in directories with long filenames with DOS line endings. The few .CODE program files in the library have been rendered useless by this process. You may also grab the raw disk images if you want to mount them directly on a P-System machine, or if you want to select different options for my disk utilities to preserve the .CODE programs or other files with hidden header blocks. What happened to USUS? There's few traces of them on the Web, and in several years of casual research, I've been unable to find anyone who admits to being the last of these Mohicans. Ê They were once reachable at USUS, Box 1148, La Jolla, CA 92038, or at Datamed Research, or at Softech MicroSystems.Ê According to the Apple II FAQ, Keith Frederick was once secretary, and the group was described as "an international non-profit organization dedicated to promoting and influencing software standards to aid in the development of portable software. They have a large software library including a lot of source code (for almost every language or computer)." According to a history of the Texas Instruments TI-99/4A computer, which could run the P-System, Robert Peterson was voted president of USUS in September 1982, in Dallas, Texas. What's the copyright status of these files? Back in those wild and wooly days, computer users were not as stringent about copyright as we are today.Ê In this case, it means the USUS disks contained less-than-precise messages about copyright.Ê The most common message is "For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes."Ê I suspect that USUS once tried to control the sale of disks from its collection as a means of fundraising. ------------------------------------------------------------------------ Return to the main page of the Jefferson Computer Museum. Copyright 2003 jfoust@threedee.com, All Rights Reserved. THIS PAGE MAY NOT BE USED OR PUBLISHED IN ANY FORM (WRITTEN, CD-ROM, ETC.) WITHOUT EXPRESS WRITTEN (HARDCOPY) PERMISSION FROM JOHN FOUST. www.threedee.com - www.goJefferson.com - www.foust.org - www.saltglaze.com ======================================================================================== DOCUMENT :usus Folder:readme.doc.txt ======================================================================================== December 16, 1999 This Zip contains the USUS Software Library, volumes 1 through 29 plus USUS UK volumes UK3 and UK4. This archive was derived from .SVOL disk images that are available on my web site. All files were translated from UCSD P-System text file format to DOS format, which means the .CODE files are present but not intact. Using the utilities on my web site, you can burst the disk images in a different fashion if you like. John Foust jfoust@threedee.com http://www.threedee.com/jcm/ ======================================================================================== DOCUMENT :usus Folder:VOL01:catalog1.text ======================================================================================== VOLUME ONE, UCSD PASCAL USERS' GROUP -- CATALOG NOTE WELL: Let it be said here for all the files on this disk that UCSD Pascal is a trademark of the Regents of the University of California. All software on this disk may be given away but NOT sold without prior arrangement with SofTec and/or Datamed Research. CATALOG1.TEXT.......what you're reading now. COMBINE.TEXT........a simple little thing to combine 2 or more text files. CPM.DOC.TEXT........documentation of 8080/Z-80 interfaces and programs. CPMCOPY.TEXT........an all-Pascal CP/M file copier. CRC16.TEXT..........assembly-language CRC generator/checker for MODEM.TEXT. CRT.I.O.TEXT........very powerful, crash-proof data entry UNIT for CRT menus. DISKREAD.TEXT.......assembly-language direct track/sector disk reader. FORMAT.DOC.TEXT.....documentation (from Pascal News) for FORMAT. FORMAT.TEXT.........large, wonderful Pascal program prettyprinter. FORMAT1.TEXT........part of FORMAT.TEXT (subfile). FORMAT2.TEXT........part of FORMAT.TEXT (subfile). GETCPM.TEXT.........reads CP/M files --> UCSD-format disks. GETCPM2.TEXT........another version of GETCPM.TEXT. GOTCHA.DOC.TEXT.....read all about UCSD's hidden gotchas for 8080/Z-80 users. INITVAR.TEXT........part of PRETTY.TEXT (subfile). INOUTREADY.TEXT.....assembly-language routines: read/write to i/o port, etc. INTRODUCTN.TEXT.....a statement of purpose--why we are here, how we work. L.TEXT..............a short but effective text printer with several options. MODEM.TEXT..........1st of 2 D.C. Hayes Modem drivers (S-100 version). MODEM1.TEXT.........the second " " " " " . PRETTY.TEXT.........the second Pascal prettyprinter, from the Pascal News. PRETTY.DOC.TEXT.....documentation for both FORMAT and PRETTY. RWCPM.TEXT..........assembly-language direct disk reading/writing. SIMP.TEXT...........cute program to produce random text; sounds "professional." TYPESET.TEXT........takes text from editors & right-justifies it. UNITS.DOC.TEXT......re UNITS, SEGMENTS, & EXTERNAL routines. VOLUME1.TEXT........how this disk is organized (more detail). Have fun! Let me know if you spot bugs or errors in any software or docu- mentation on this disk, or if you can clear up further mysteries of UCSD Pascal. Jim Gagne, DATAMED RESEARCH ======================================================================================== DOCUMENT :usus Folder:VOL01:combine.text ======================================================================================== PROGRAM Combine; VAR i: integer; yn: char; Fileno: string [6]; Infilename, Outfilename: string [20]; s: string[200]; Infile1, Infile2, Infile3, Infile4, Outfile: text; BEGIN Writeln ('This program combines 2 to 4 textfiles.'); Writeln ( 'Please note that the filetype ".TEXT" is assumed, and should NOT' ); WRITELN ('be included when you type the file names.'); Writeln; Write ('Please type the name of the OUTPUT file: '); READLN (Outfilename); Outfilename := CONCAT (outfilename, '.TEXT'); REWRITE (outfile, outfilename); Writeln; Write ('Please type the name of the first file to be combined: '); READLN (infilename); Infilename := CONCAT (infilename, '.TEXT'); reset (Infile1, infilename); j WHILE NOT eof (Infile1) DO BEGIN Readln (Infile1, s); Writeln (Outfile, s) END; Writeln ('File copied.'); yn := 'Y'; i := 1; While ((yn = 'Y') or (yn = 'y')) AND (i < 4) do BEGIN i := succ (i); CASE i OF 2: Fileno := 'second'; 3: Fileno := 'third'; 4: Fileno := 'fourth' END; Write ('Please type the name of the ', Fileno, ' file you wish to add: '); READLN (Infilename); Infilename := CONCAT (Infilename, '.TEXT'); CASE i OF 2: BEGIN RESET (Infile2, Infilename); WHILE NOT eof (Infile2) DO BEGIN Readln (Infile2, s); Writeln (Outfile, s) END END; 3: BEGIN RESET (Infile3, Infilename); WHILE NOT eof (Infile3) DO BEGIN Readln (Infile3, s); Writeln (Outfile, s) END END; 4: BEGIN RESET (Infile4, Infilename); WHILE NOT eof (Infile4) DO BEGIN Readln (Infile4, s); Writeln (Outfile, s) END END END (*case*); Write ('File copied. Got more files (y/n)? '); READ (yn); END; CLOSE (outfile, lock) END. ======================================================================================== DOCUMENT :usus Folder:VOL01:cpm.doc.text ======================================================================================== SOME MISCELLANEOUS 8080/Z-80 INTERPRETER DOCUMENTATION PLUS NOTES ON THE 8080 I/O ROUTINES AND CP/M-UCSD DISK CONVERSIONS THE INTERPRETER does not use ANYTHING in page 0 (0000 to 00FF hex) except the BIOS jump address at location 0001 and 0002. This area is available for your use. The cold start and warm reboot jump vectors at the start of a standard CP/M BIOS jump vector table are used only as place holders; to save space, place any initializing code within the PINIT.ASM file, where it will be overwritten by SYSTEM.PASCAL once the interpreter has been read in. It's best if those first two jump vectors jump to a RETurn instruction somewhere in your BIOS. Location 200 hex contains a jump vector that will always send you back into whatever the system was supposed to be doing at the moment. I've found it useful, for instance, if I tried to save something I was editing with the disks out of the drives, and the system crashed. After stopping the processor and reinserting the disks, I can generally get going again by starting up at location 200, unless the whole thing is dead. The closest thing to a warm reboot is a reinitialization, which occurs if a) a run-time error occurs or b) you type an "I" while at the system Command level. Useful if your system is behaving strangely after something went wrong. The only way I know of to get going again after you've hung up in some way (ie, infinite loop in a program) is to totally reboot. THE 8080/Z-80 ASSEMBLY LANGUAGE I/O ROUTINES ON THIS DISK consist of two or three sets of everything, by different authors. INOUTREADY.TEXT contains two versions of console status checking (whether a character has been typed) and direct port i/o routines. Direct disk reading (to a numbered track and sector) is provided by DISKREAD.TEXT, READCPM.TEXT, and RWCPM.TEXT. Only the last file allows direct writing to a numbered track and sector, but the others should be easily altered. Most of these routines require an intact CP/M-style jump vector table at the start of the BIOS, which I have dispensed with in reorganizing the i/o section of the interpreter (see the file BOOTER.ASM on a subsequent disk), so I have not personally checked them out. Assemble them and stick them in your SYSTEM.LIBRARY. THERE ARE TWO CP/M-UCSD disk conversion programs on this disk, both written primarily in Pascal but calling assembly language routines to do the actual reading and writing. You'll need to have included the necessary routines in your SYSTEM.LIBRARY as noted above. The first program consists of GETCPM.TEXT, also present as GETCPM2.TEXT, both written by Barry Cole. I have not tried them myself but understand that they work well. Documentation on program workings is sparce. The second is written entirely in Pascal, CPMCOPY.TEXT, by J. M. Wierda, and is well documented. ======================================================================================== DOCUMENT :usus Folder:VOL01:cpmcopy.text ======================================================================================== PROGRAM cpmcopy; (*Written by J. M. Wierda This program will transfer a CP/M file from a disk in unit 5 to a Pascal disk in unit 4. Note that when the filename is requested, it must be 11 characters long and include all spaces. This program does not remove the LFs from the CP/M file as the transfer is made, so a replace command in the Pascal editor should be used to delete the LFs. During successful file transfers the program prints an expanded CP/M directory of the file being tranferred. Attempts to transfer empty or non-existent files are ignored.*) CONST blkslip = 2; quadsperblk = 4; trkslip = 6; blkspertrk = 6.5; secpergrp = 8; lastsec = 26; lasttrk = 76; TYPE groupbuffer = packed array[0..1023] of char; VAR sectortbl : ARRAY[1..lastsec] OF integer; grptrk : ARRAY[1..secpergrp] OF integer; grpsec : ARRAY[1..secpergrp] OF integer; quadmap : ARRAY[1..lastsec] OF integer; blockmap : ARRAY[1..lastsec] OF integer; blockbuffer : PACKED ARRAY[0..511] OF char; directbuffer : groupbuffer; transferbuffer : groupbuffer; prevtrk, filectr : integer; currfile, filename : string; outfile : string; file2 : text; PROCEDURE trackmap(track : integer); VAR sector,sect,blk,quad,firstsect : integer; firstblkquad : real; BEGIN IF track <> prevtrk THEN BEGIN firstblkquad := (track-1)*blkspertrk; blk := trunc(firstblkquad); firstsect := (((track-1)*trkslip)+1) MOD lastsec; quad := trunc((firstblkquad-blk)*quadsperblk); sect := firstsect; FOR sector := 1 TO lastsec DO BEGIN blockmap[sect] := blk; quadmap[sect] := quad; sect := (sect + blkslip) MOD lastsec; IF sect = 0 THEN sect := lastsec; IF sect = firstsect THEN sect := sect + 1; quad := (quad+1) MOD quadsperblk; IF quad = 0 THEN blk := blk + 1 END END END; PROCEDURE initsectbl; BEGIN sectortbl[1] := 1; sectortbl[2] := 7; sectortbl[3] := 13; sectortbl[4] := 19; sectortbl[5] := 25; sectortbl[6] := 5; sectortbl[7] := 11; sectortbl[8] := 17; sectortbl[9] := 23; sectortbl[10] := 3; sectortbl[11] := 9; sectortbl[12] := 15; sectortbl[13] := 21; sectortbl[14] := 2; sectortbl[15] := 8; sectortbl[16] := 14; sectortbl[17] := 20; sectortbl[18] := lastsec; sectortbl[19] := 6; sectortbl[20] := 12; sectortbl[21] := 18; sectortbl[22] := 24; sectortbl[23] := 4; sectortbl[24] := 10; sectortbl[25] := 16; sectortbl[lastsec] := 22 END; PROCEDURE cpmgrp(group : integer); VAR j, track, sector : integer; BEGIN track := ((group * 8) DIV lastsec) + 2; sector := ((group * 8) MOD lastsec) + 1; FOR j := 1 TO secpergrp DO BEGIN grptrk[j] := track; grpsec[j] := sectortbl[sector]; sector := sector + 1; IF sector > lastsec THEN BEGIN sector := 1; track := track + 1 END END END; procedure readgroup(group : integer; VAR buffer : groupbuffer); var j, k, l : integer; begin cpmgrp(group); l := 0; for j := 1 to secpergrp do begin trackmap(grptrk[j]); unitread(5,blockbuffer,512,blockmap[grpsec[j]],0); for k := ((quadmap[grpsec[j]])*128) to k+127 do begin buffer[l] := blockbuffer[k]; l := l+1 end end end; PROCEDURE printentries; VAR j, k : integer; begin j := 0; while j < 1024 do BEGIN IF (ord(directbuffer[j]) = 0) AND (ord(directbuffer[j+12]) = 0) AND (directbuffer[j+1] IN [' '..'Z']) THEN BEGIN FOR k := j+1 TO j+11 DO write(directbuffer[k]); filectr := filectr + 1; IF (filectr MOD 4) = 0 THEN writeln ELSE write(' ') END; j := j+32 END end; PROCEDURE findentry; VAR extent, sectors, j, k, l : integer; eoffound : boolean; BEGIN j := 0; WHILE j < 1024 DO BEGIN IF ord(directbuffer[j]) = 0 THEN BEGIN currfile := ' '; extent := ord(directbuffer[j+12]); sectors := ord(directbuffer[j+15]); FOR k := j+1 TO j+11 DO currfile[k-j] := directbuffer[k]; IF (currfile = filename) AND (sectors > 0) THEN BEGIN IF extent = 0 THEN BEGIN write('Output Filename.Ext ? '); readln(outfile); rewrite(file2, outfile); writeln(currfile); writeln('Ex Sec Groups') END; write(extent: 2,sectors: 4); FOR k := j+16 TO (k+((sectors-1) DIV 8)) DO begin write(ord(directbuffer[k]): 4); readgroup(ord(directbuffer[k]), transferbuffer); l := 0; eoffound := false; WHILE l <= 1023 DO begin IF (ord(transferbuffer[l]) <> 26) and (not eoffound) then write(file2, transferbuffer[l]) else begin eoffound := true; write(file2, chr(0)) end; l := l + 1 end; end; IF sectors < 128 THEN close(file2,lock); writeln END END; j := j+32 END END; BEGIN filectr := 0; prevtrk := 0; initsectbl; writeln('CP/M File Transfer, 7-Jun-79'); readgroup(0, directbuffer); printentries; readgroup(1, directbuffer); printentries; writeln; writeln(filectr,' Files'); REPEAT REPEAT writeln; write('Transfer which file ? '); readln(filename); IF NOT (length(filename) IN [0,11]) THEN BEGIN write('Enter 11 character filename exactly as listed'); writeln(', including spaces,'); writeln('or CR to exit program.') END UNTIL length(filename) IN [0,11]; IF length(filename) = 11 THEN BEGIN readgroup(0, directbuffer); findentry; readgroup(1, directbuffer); findentry END; UNTIL length(filename) = 0; END . ======================================================================================== DOCUMENT :usus Folder:VOL01:crc16.text ======================================================================================== ; COMPUTE CRC16 {INTERMEDIATE CALC FOR ONE BYTE} ; ARGUMENTS ARE THE OLD CRC {TWO BYTES PASSED AS CHAR} ; AND NEWCHR {THE NEXT BYTE TO BE INCLUDED IN CRC} ; FUNCTION RETURNS UPDATED CRC AS AN INTEGER ; ; NEWCRC:=CRC16(CRC0,CRC1,NEWCHR:CHAR):INTEGER ; .FUNC CRC16,3 .PRIVATE RETADDR POP HL ;RET ADDR LD (RETADDR),HL ;SAVE IT POP HL POP HL ;TWO ZEROS POP DE ;NEW CHARACTER POP BC ;FIRST BYTE TO C POP HL LD B,L ;SECOND BYTE TO B LD HL,0A001H ;GENERATING POLYNOMIAL LD A,E ;NEW CHARACTER TO A LD E,8H ;COUNT OF BITS IN CHAR CRCY: RRA ;ROTATE RIGHT THRU CARRY LD D,A ;SAVE IN D LD A,C RRA LD C,A ;SHIFT RIGHTMOST BIT INTO BYTE IN C LD A,B ;NOW DO 2ND BYTE OF CRC RRA LD B,A JP NC,CRCZ ;NO DIVISION IF NO CARRY XOR L ;EXCLUSIVE OR WITH L LD B,A LD A,C XOR H ;EXCLUSIVE OR WITH H LD C,A CRCZ: LD A,D ;NEW BYTE BACK TO A DEC E ;DECR BIT COUNT JP NZ,CRCY ;ITERATE FOR 8 BITS LD HL,(RETADDR) ;GET BACK RETURN ADDR LD D,C LD E,B ;SWITCH BYTES PUSH DE ;FUNCTION RETURN BACK ON STACK JP (HL) ;BYE .END ======================================================================================== DOCUMENT :usus Folder:VOL01:crt.i.o.text ======================================================================================== UNIT CRTINPUT; INTERFACE VAR Infilename : string [30]; Typed: string; Infile: text; PROCEDURE ClearScreen; PROCEDURE GetString (x,y, maxlength: integer); PROCEDURE GetFile; PROCEDURE GetNo (x,y, LowerLimit, UpperLimit: integer; VAR DesiredNo: integer); PROCEDURE GetBoolean (x, y: integer; VAR DesiredValue: boolean); IMPLEMENTATION PROCEDURE ClearScreen (*allpurpose, hardware independent*); VAR Fillcr: ARRAY [1..24] OF char; i: integer; BEGIN Gotoxy (0,23); FOR i := 1 TO 24 DO Fillcr [i] := CHR (13); UNITWRITE (1, Fillcr, 24); Gotoxy (0,0) END; PROCEDURE GetString; VAR j, k: integer; Gotstring: boolean; bell: char; BEGIN bell := CHR (7); Gotstring := false; REPEAT Gotoxy (x,y); FOR j := 1 TO maxlength DO write ('.'); Gotoxy (x,y); Readln (typed); k := length (typed); IF k > maxlength THEN BEGIN Gotoxy (x,y); Write (' ':k); Gotoxy (0,23); Write (bell, 'You have entered too many characters in this line. ', 'Please try again.') END ELSE Gotstring := true UNTIL Gotstring; Gotoxy ((x+k),y); Write (' ':(maxlength - k)); Gotoxy (2,22); Write (' ':70); Gotoxy (0,73); Write (' ':70) END (*GetString*); PROCEDURE GetFile; VAR gotfn: boolean; bell, response: char; BEGIN Bell := CHR (7); REPEAT Gotoxy (11,20); Write ('Please type the name of the file you wish to print.'); Gotoxy (15,21); Write ('--> '); Gotoxy (11,22); Write (' (Or just press the key if you wish to quit.)'); Typed := ''; GetString (20,21, 23); IF LENGTH (typed) = 0 THEN BEGIN Gotoxy (11,23); Write ('Would you prefer to quit this program (Y/N)? '); Read (Keyboard, response); Gotoxy (11,23); Write (' ':47); IF (Response = 'Y') OR (Response = 'y') THEN EXIT (Program) END ELSE BEGIN Infilename := Typed; (*$I-*) Reset (Infile, Infilename); IF IORESULT > 0 THEN Reset (Infile, CONCAT (Infilename, '.TEXT')); (*$I+*) Gotfn := IORESULT = 0; IF NOT Gotfn THEN BEGIN Gotoxy (0,23); Write (bell, '<<**** ERROR ****>> ', 'Wrong volume or file name. Type to continue.'); REPEAT Read (Keyboard, Response) UNTIL Response = ' '; Gotoxy (0,23); Write (' ':78) END END(*else*) UNTIL Gotfn; END (*GetFile*); PROCEDURE GetInteger (x,y, LowerLimit, UpperLimit: Integer VAR DesiredNo: Integer); VAR ch, cr, bell, escape, Backspace: char; TypedEscape, Gotit: boolean; NumberEntered: integer; BEGIN Backspace := CHR (8); Bell := CHR (7); cr := CHR (13); escape := CHR (27); TypedEscape := false; Gotit := false; WHILE NOT Gotit OR TypedEscape DO BEGIN NumberEntered := 0; REPEAT READ (KEYBOARD, ch); IF ch = cr THEN ch := ' '; IF (ch IN ['0'..'9']) AND (NumberEntered*10 <= Maxint) THEN NumberEntered := NumberEntered*10 + ORD (ch) - ORD ('0'); IF ch = BackSpace THEN BEGIN (* dump a digit and keep going *) ch := '0' (* stay in this loop *); NumberEntered := NumberEntered DIV 10 END; Gotoxy (x,y); Write (NumberEntered:3) UNTIL (NumberEntered >= UpperLimit) OR NOT (ch IN ['0'..'9']); IF ch = escape THEN BEGIN Gotoxy (0,23); Write (' ':40); EXIT (Getinteger) END; IF (NumberEntered = 0) AND NOT (ch IN [' ', '0'..'9']) THEN BEGIN Gotoxy (0,23); Write (' ':78); Gotoxy (0,23); Write (bell, 'Please enter a NUMBER between ', LowerLimit, ' and ', UpperLimit); Gotoxy (x,y); Write (' '); Gotoxy (x,y) END ELSE IF NumberEntered < LowerLimit THEN BEGIN Gotoxy (0,23); WRITE (' ':40); Gotoxy (0,23); WRITE (bell, 'Please type a number greater than ', LowerLimit-1, ': '); Gotoxy (x,y) END ELSE IF NumberEntered > UpperLimit THEN BEGIN Gotoxy (0,23); WRITE (' ':40); Gotoxy (0,23); WRITE (bell, 'Please type a number less than ', UpperLimit+1, ': '); Gotoxy (x,y) END ELSE Gotit := true END; (*while*) Gotoxy (0,23); Write (' ':40); DesiredNo := NumberEntered END; (*GetInteger*) PROCEDURE GetNo; BEGIN Gotoxy (2,22); Write ('Type the desired number, then a space. To leave unchanged,'); Write (' type .'); Gotoxy (x+3,y); GetInteger (x,y, lowerlimit, upperlimit, DesiredNo); Gotoxy (2,22); Write (' ':76); Gotoxy (x,y); Write (DesiredNo:3) END; PROCEDURE GetBoolean; VAR ch, escape: char; BEGIN escape := CHR (27); Gotoxy (2,22); ch := '0'; Write ('Type "Y" for yes, or "N" for no.', ' ':40); Gotoxy (x,y); WHILE NOT (ch IN ['Y', 'y', 'N', 'n', escape]) DO Read (keyboard, ch); CASE ch OF 'Y', 'y': BEGIN Write ('YES'); DesiredValue := true END; 'N', 'n': BEGIN Write (' no'); DesiredValue := false END END; Gotoxy (2,22); Write (' ':32) END; END. ======================================================================================== DOCUMENT :usus Folder:VOL01:diskread.text ======================================================================================== ; FUNCTION DISKREAD(TRACK,SECTOR,DISKNO) ; ; THIS ROUTINE CALLS THE BIOS ROUTINES TO READ THE SPECIFIED SECTOR ; FROM THE SPECIFIED DISK. THE 128 BYTES READ ARE RETURNED TO A ; PUBLIC ARRAY NAMED IOBUFFER. THIS DISK PRIMITIVE IS PRIMARILY ; INTENDED TO ALLOW PASCAL PROGRAMS TO ACCESS CP/M FILES. ; THE DISK NUMBER MAY BE SPECIFIED EITHER AS 0 OR 1 AS IN THE BIOS ; OR AS 4 OR 5 AS USED BY PASCAL. THE FUNCTION RETURNS A BOOLEAN ; FUNCTION AS AN ERROR CODE. TRUE IF NO ERROR, FALSE FOR ANY DISK ; ERROR. ; .FUNC DISKREAD,3 ;THREE ARGUMENT .PRIVATE RETADDR,DISKNO,SECTOR,TRACK .PUBLIC IOBUFFER POP HL ;RETURN ADDR LD (RETADDR),HL ;SAVE RETURN POP HL POP HL ;TWO ZEROS POP HL ;DISK NUMBER LD (DISKNO),HL ;SAVE IT LD A,L ;DISK NO AND 1 ;EXTRACT LEAST SIGNIFICANT BIT LD C,A ;MOVE IT TO C LD L,1BH ;SELECT DISK CALL BIOS POP HL ;SECTOR LD (SECTOR),HL ;SAVE IT LD A,L ;SECTOR NO CP 28 ;CHECK SIZE JP P,ERROR ;EXIT ON ERROR LD C,A ;MOVE TO C LD L,21H ;SET SECTOR ENTRY CALL BIOS ;SET SECTOR POP HL ;TRACK NO LD (TRACK),HL ;SAVE IT LD A,L ;TRACK NO CP 77 ;CHECK LIMIT JP P,ERROR ;ERROR IF > 76 LD C,A ;TO C LD L,1EH ;SET TRACK ENTRY CALL BIOS ;SELECT TRACK LD BC,IOBUFFER ;POINT TO INPUT BUFFER LD L,24H ;SET DMA ENTRY CALL BIOS ;SET DMA ADDR LD L,27H ;DISK READ ENTRY CALL BIOS OR A ;TEST RETURN FLAG JP NZ,ERROR ;ERROR IF NOT ZERO EXIT: LD HL,(RETADDR) ;GET BACK RETURN ADDR PUSH DE ;RETURN ARGUMENT JP (HL) ;EXIT ERROR: LD DE,0 ;RETURN FALSE JP EXIT BIOS: LD` A,(0002H) ;PAGE NO IN LOCATION 02H LD H,A JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL01:format.doc.text ======================================================================================== FORMAT DOCUMENTATION The following text accompanied the program listing in Pascal News, No. 13 (December 1978). For further comments, see "PRETTY.DOC.TEXT" elsewhere on this disk. What Format Does Format is a flexible prettyprinter for Pascal programs. It takes as input a syntactically correct Pascal program and produces as output an equivalent but reformatted Pascal program. The resulting program consists of the same sequence of Pascal symbols and comments, but they are rearranged with respect to line boundaries and columns for readability. Format maintains consistent spacing between symbols, breaks control and data structures onto new lines if necessary, indents lines to reflect the syntactic level of statements and declarations, and more. Miscellaneous features, such as supplying line numbers and automatic comments or deleting all unnecessary blanks to save space, are described below. The flexibility of Format is accomplished by allowing you to supply various directives (options) which override the default values. Rather than being a rigid prettyprinter which decides for you how your program is to be formatted, you have the ability to control how formatting is done, not only prior to execution, but also during execution through the use of prettyprinter directives embedded in your program. Experience with Format over the last three years has shown that most users can find a set of values for the directives which produce satisfactory results. The default values are typical. How To Use Format The use of Format will vary from implementation to implementation, but will involve one major input file containing a Pascal program and one output file for the reformatted program. Additionally it may be possible to supply the initial values of directives to Format when it begins execution. [NOTE to UCSD users: I did not implement this feature, though it should be easy to do.] Directives to Format may always be specified in the program itself inside comments with a special syntax. Thus the first line of a program is an ideal spot for a comment containing directives. Subsequent use of embedded directives allows you to change the kind of formatting for different sections of your program. The syntax of these special comments is given below (The syntax is given using "EBNF"--Extended Backus-Naur Form--see Communications ACM, November, 1977, page 822.): DirectiveComment = "(*" DirectiveList "*)" | "(*$" CompilerOptionList CommentText DirectiveList"*)". DirectiveList = "[" Directive {"," Directive} "]" CommentText. Directive = Letter Setting. Letter = "A"| "B"| "C"| "D"| "E"| "F"| "G"| "H"| "I"| "L"| "N"| "P"| "R"| "S"| "W". Setting = Switch | Value | Range. Switch = "+" | "-". Value = "=" Unsigned Integer. Range = "="UnsignedInteger "-" UnsignedInteger ["<" | ">"]. UnsignedInteger = Digit(Digit). CommentText = (Any character except "]" or close-comment). Note: As defined above, a Directive may be within a comment specifying a Pascal CompilerOptionList. On most implementations this is a "$" followed by a series of letters and values ("+", "-", or digits), separated by commas. See your local manual. Examples of DirectiveComments: (*[A=15, E=3, N=1,1<]*) - good for publication quality. (*[G-0, W=1-100, C+]*) - good for compact storage. (*$U+ [R=1-72, I=2]*) - an example of a DirectiveList with a CompilerOptionList. Directives to Format. A=n Align declarations. The A directive forces the alignment of ":" and "=" in declarations. If A is set to a value greater than O, then n should be equal to the maximum identifier length for that section of your program. The A directive visually clarifies the declaration part of your program. See example below. Default: A=O (no alignment). B+ or B- Bunch statements and declarations reasonably. B+ will place as many statements or declarations onto one line as will fit within the specified write margins (W directive) subject to read- ability constraints. Bunching (B+) when the display is off (D-) has no effect. In general, B+ saves paper and prevents your program from becoming overly stretched in the vertical direction. See example below. Default: B- (one statement or statement part per line). C+ or C- Fully Compress program. C+ removes all non-essential blanks, end-of-lines, and comments from your program. A compilable, packed program will be written within the specified write margins (W directive). The number of spaces specified by the G directive will still be written between symbols. C+ might save some space on long-term storage media such as disk; you might store a program in compressed form and expand it later by reformatting with C-. Default: C-. D+ or D- Turn Display on or off. D allows you to selectively display portions of your program during formatting. Therefore, D must be switched on and off with directives which are appropriately placed in your program. D is perhaps useful to obtain program fragments for publication (such as one or more pro- cedures) without having to print the whole program. Default: D+. E=n Supply END comments. The E directive generates comments after "END" symbols if none are already there. Common Pascal coding stylms frequently employ these comments. E=1 creates comments after the "END" symbol in compound statements which are within structured statements, as well as those constituting procedure and function bodies. The comments take the form: (*StatementPart*) or (*ProcedureName*). E=2 creates comments after the "BEGIN" and "END" symbols constituting procedure and func- tion bodies only. E=O creates no comments at all. E=3 means E=1 and E=2. See example below. Default: E=2. F+ or F- Turn Formatting on or off. F allows you to format selected portions of your program. F- causes Format to copy the input program directly with no changes. Therefore by switching F on and off with directives which are appropriately placed in your program, you can preserve text which is already properly formatted (such as comments). Default: F+ (of course!). G=n Specify symbol Gap. The G directive determines the number of spaces placed between Pascal symbols during formatting. G=O still places one space between two identifiers and reserved words. The symbols [] () , and : are handled independently of G. Default: G=1. I=n Specify Indent tab. I indents each nesting level of statements and declarations a given number of columns. Using I=2 or I=1 helps prevent excessively- narrow lines within the specified write margins (W directive) where there are heavily-nested constructs. Default: I=3. L=n Specify Line-wraparound indent tab. L determines the indentation of the remainder of statements or declarations which are too long to fit on one line. Default: L=3. N=x-y< or N=x-y> Generate line-numbers on the left or right. The N directive indicates the starting line-number (x) and the incre- ment (y) for each succeeding line-number. If y > O then line-numbers are written outside the specified write margins for the formatted pro- gram in sequential order starting at x; y = O shuts off line-number- ing. "<" writes up to 4-digit, right-justified line numbers together with a trailing space ot the left of each line. ">" writes 6-digit, zero-filled line numbers to the right of each line. Use the N directive along with the W directive. Default: N=0-0> (no line numbers). P=n Specify spacing between Procedure and function declarations. The P directive determines the number of blank lines to be placed between procedure and function declarations. n>2 makes procedures and functions visually stand out. Default: P=2. R=x-y Specify Read margins. The R directive indicates which columns are significant when Format reads from the input file. R allows Format to accept files which have line numbers in the first (x-1) columns or after the y~h column. Default: R=1-999 (large enough to read end-of-line in most cases). S=n Specify Statement separation. The S directive determines the number of spaces between statements bunched on the same line by the use of the B+ directive. Note that this directive is in effect only if B+ is used. Default: S=3. W=x-y Specify Write margins. The W directive indicates which columns are used for writing the reformatted program on the output file. Any line numbers generated (N directive) are written outside these margins. Default: N=1-72. EXAMPLES The A directive. Here is a sample program fragment before using Format: PROGRAM SAMPLE(OUTPUT); CONST A=6; ABC='LETTERS'; THREE=3; TYPE RANGE=1..6; COLOR=(RED,BLUE); VAR I,I2,I33,I444,I555:RANGE; YES,NO,MAYBE:BOOLEAN; BEGIN END. Here is the output from Format with all defaults set: PROGRAM SAMPLE(OUTPUT); CONST A = 6; ABC = 'LETTERS'; THREE = 3; TYPE RANGE = 1 .. 6; COLOR = (RED, BLUE); VAR I, I2, I33, I444, I5555: RANGE; YES, NO, MAYBE: BOOLEAN; BEGIN END (*SAMPLE*). Here is the output from Format with an added A=5 directive: (*[A=5] ALIGN DECLARATIONS. *) PROGRAM SAMPLE(OUTPUT); CONST A = 6; ABC = 'LETTERS'; THREE = 3; TYPE RANGE = 1 .. 6; COLOR = (RED, BLUE); VAR I, I2, I33, I444, I5555: RANGE; YES, NO, MAYBE: BOOLEAN; BEGIN END (*SAMPLE*). The B Directive. If the input to Format is: PROGRAM T(OUTPUT); CONST INCREMENT = 5; VAR I,J,N:INTEGER; BEGIN N:=0; J:=3; I:=SQR(N); N:=N+INCREMENT; IF N>73 THEN BEGIN DOTHIS; DOTHAT END ; IF N>5 THEN IF J>6 THEN DOSOMETHINGELSE; END. then the output from Format (using the default, B-) is: PROGRAM T(OUTPUT); CONST INCREMENT = 5; VAR I,J,N:INTEGER; BEGIN N:=0; J:=3; I:=SQR(N); N:=N + INCREMENT; IF N>73 THEN BEGIN DOTHIS; DOTHAT END; IF N>5 THEN IF J>6 THEN DOSOMETHINGELSE; END (*T*). and the output from Format with B directives embedded is: (*[B+] BUNCH STATEMENTS. *) PROGRAM T(OUTPUT); CONST INCREMENT = 5; VAR I,J,N:INTEGER; BEGIN N:=0; J:=3; I:=SQR(N); N:=N + INCREMENT; IF N>73 THEN BEGIN DOTHIS; DOTHAT END; (*[B-] UNBUNCH. *) IF N>5 THEN IF J>6 THEN DOSOMETHINGELSE; END (*T*). The E Directive. Suppose that a Pascal program fragment looked like: PROCEDURE SAMPLE; PROCEDURE INNER; BEGIN END; BEGIN IF X=3 THEN BEGIN X := 1; I := I+1 END ELSE BEGIN X := X+I; I := 0 END; WHILE (CH <> 'X') AND FLAG1 DO BEGIN I := I+3; INNER END; END; then using Format with E=3 produces: PROCEDURE SAMPLE; PROCEDURE INNER; BEGIN END (*INNER*); BEGIN (*SAMPLE*) IF X=3 THEN BEGIN X := 1; I := I+1 END (*IF*) ELSE BEGIN X := X+I; I := 0 END (*ELSE*); WHILE (CH <> 'X') AND FLAG1 DO BEGIN I := I+3; INNER END (*WHILE*); END (*SAMPLE*); How Format Works. Format parses your program by performing syntax analysis similar to the Pascal compiler: recursive descent within nested declarations and statements. It gathers characters into a buffer in which the indenting count of each character is maintained. The characters are being continually emptied from the buffer as new ones are added. Format has limited error-recovery facilities, and no results are guaranteed if a syntactically incorrect program is input. The bane of most Pascal prettyprinters is the treatment of comments. Format considers them in the context of a declaration or statement. Therefore using comments like: CONST LS=6 (*LINESIZE*); is a good idea because Format will carry the comment along with the declaration. Similarly: BEGIN (* 'Z' < CH <= ' ' *) is also okay. Stand-alone comments, however, receive rough treatment from Format. The first line of such comments is always left justified and placed on a separate line. See the F directive. Thus: CONST LS=6; (*LINESIZE*) will be reformatted as: CONST LS = 6; (*LINESIZE*) Proper treatment of comments is certainly an area of future development for Format. Error Messages. Format issues the following error messages: 1. " *** 'PROGRAM' EXPECTED." The Pascal program you fed to Format did not contain a Standard Pascal program declaration. 2. " *** ERRORS FOUND IN PASCAL PROGRAM." Your program is syntactically incorrect. The output from Format probably does not contain all of the text from your input file. The cause could be any syntactic error, most commonly unmatched "BEGIN-END" pairs or the lack of semicolons, string quotation marks, or the final period. 3. " *** STRING TOO LONG." Your program contains a character string (including both the quotes) which is wider than the specified write margins (W directive). 4. " *** NO PROGRAM FOUND TO FORMAT." The input file is empty. ======================================================================================== DOCUMENT :usus Folder:VOL01:format.text ======================================================================================== (* PROGRAM Format *) (*$IFORMAT1.TEXT*) (*$IFORMAT2.TEXT*) BEGIN (*DoStatment*) BlksOnCurrntLine := 0; Successful := false; BlksAddedByThisStmt := 0; ChangeMarginTo (ActualLeftMargin + IndentIndex); StartNewLineAndIndent; StatmtBeginning := CharCount; IF SymbolIsNumber THEN BEGIN WITH UnWritten [Oldest] DO BEGIN IndentAfterEOL := IndentAfterEOL - 1 - Length - SymbolGap; IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0 END; WriteSymbol; ReadSymbol (*Write LABEL*); WriteSymbol; ReadSymbol (*Write COLON*) END; CASE StatementTypeOf [SymbolName] OF ForWithWhileStatement: BEGIN (* PACK (Symbol, 1, StatmtSymbol [1]); EQUIVALENT: *) FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I]; StmtSymLength := Length; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = DoSymbol; WriteSymbol; ReadSymbol; StatmtPart [1] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := BlksOnCurrntLine + AddedBlanks; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; Bunch (StatmtBeginning, StatmtPart [1], CharCount, SymbolGap) END; RepeatStatemtnt: DoStmtList (UntilSymbol); IfStatement: BEGIN (* PACK (Symbol, 1, StatmtSymbol [1]); EQUIVALENT: *) FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I]; StmtSymLength := Length; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = ThenSymbol; StartNewLineAndIndent; StatmtPart [1] := CharCount; WriteSymbol; ReadSymbol; StatmtPart [2] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := AddedBlanks; BlksAddedByThisStmt := AddedBlanks; Bunch (StatmtPart [1], StatmtPart [2], CharCount, SymbolGap); IF Successful THEN Bunch (StatmtBeginning, StatmtPart [1], CharCount, StatmtSeparation) ELSE IfThenBunchNeeded := true; If SymbolName = ElseSymbol THEN BEGIN (* PACK (Symbol, 1, StatmtSymbol [1]); EQUIVALENT: *) FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I]; StmtSymLength := Length; IfThenBunchNeeded := false; StartNewLineAndIndent; StatmtPart [3] := CharCount; WriteSymbol; ReadSymbol; StatmtPart [4] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := AddedBlanks; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; Bunch (StatmtPart [3], StatmtPart [4], CharCount, SymbolGap); BlksOnCurrntLine := BlksAddedByThisStmt; IF Successful THEN Bunch (StatmtBeginning, StatmtPart [3], CharCount, StatmtSeparation) END ELSE IF (CharCount - StatmtBeginning) < BufferSize THEN BEGIN BunchWanted := NOT BunchWanted; BlksOnCurrntLine := 0; Bunch (StatmtBeginning, StatmtPart [1], StatmtPart [2], SymbolGap); BunchWanted := NOT BunchWanted; END; IfThenBunchNeeded := false END (*IfStatement*); CaseStatement: BEGIN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = OfSymbol; WriteSymbol; ReadSymbol; ChangeMarginTo (ActualLeftMargin + IndentIndex); WHILE SymbolName <> EndSymbol DO BEGIN StartNewLineAndIndent; StatmtPart [1] := CharCount; (* FOR I := 0 TO (Length - 1) DIV AlfaLeng DO PACK (Symbol, (I + AlfaLeng + 1), StatmtSymbol [I + 1]);*) (* EQUIVALENT: *) FOR I := 0 TO (Length - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO StatmtSymbol [I + 1, J] := Symbol [J + I * AlfaLeng]; StmtSymLength := Length; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = ColonSymbol; WriteSymbol; ReadSymbol; IF NOT (SymbolName IN [Semicolon, EndSymbol]) THEN BEGIN StatmtPart [2] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := AddedBlanks; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; Bunch (StatmtPart [1], StatmtPart [2], CharCount, SymbolGap); END; IF SymbolName = Semicolon THEN BEGIN WriteSymbol; ReadSymbol END END (*while*); ChangeMarginTo (ActualLeftMargin - IndentIndex); StartNewLineAndIndent; WriteSymbol; ReadSymbol; IF EndCommentsWanted AND (LastSymbol = EndSymbol) THEN BEGIN StatmtSymbol [1] := 'CASE '; StmtSymLength := 4; WriteComment END END (*CaseStatement*); OtherStatement: WHILE NOT (SymbolName IN [Semicolon, UntilSymbol, EndSymbol, ElseSymbol]) DO BEGIN WriteSymbol; ReadSymbol END; CompoundStatement: DoStmtList (EndSymbol) END (*main case *); AddedBlanks := BlksAddedByThisStmt; ChangeMarginTo (ActualLeftMargin - IndentIndex); END (*DoStatement*); BEGIN (*DoBlock*) IF CharCount > BufferSize * 2 THEN CharCount := (CharCount MOD BufferSize) + BufferSize; LastProgPartWasBody := LastProgPartWasBody AND (SymbolName = BeginSymbol); IF SymbolName = LabelSymbol THEN DoDeclarationUntil (EndLabel); IF SymbolName = ConstSymbol THEN DoDeclarationUntil (EndConst); IF SymbolName = TypeSymbol THEN DoDeclarationUntil (EndType ); IF SymbolName = VarSymbol THEN DoDeclarationUntil (EndVar ); WHILE SymbolName IN [FuncSymbol, ProcSymbol] DO DoProcedures; IF SymbolName = BeginSymbol THEN BEGIN IF LastProgPartWasBody THEN FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent; IfThenBunchNeeded := false; AtProcBeginning := true; ChangeMarginTo (ActualLeftMargin - IndentIndex); DoStatement (I, BlockName, BlockNmLength) (*I is dummy param*); LastProgPartWasBody := true; ChangeMarginTo (ActualLeftMargin + IndentIndex) END ELSE BEGIN WriteSymbol; ReadSymbol (*Write FORWARD *) END END (*DoBlock*); PROCEDURE Initialize; VAR I: Width; InfileName, OutfileName: string [25]; BEGIN (*Constants:*) Digits := ['0'..'9']; Letters := ['A'..'Z', 'a'..'z']; LettersAndDigits := Letters + Digits; AlphaSymbols := [ProgSymbol, BeginSymbol, EndSymbol, ConstSymbol, TypeSymbol, RecordSymbol, CaseSymbol, IfSymbol, ThenSymbol, ElseSymbol, DoSymbol, OfSymbol, ForSymbol, WithSymbol, WhileSymbol, RepeatSymbol, UntilSymbol, Identifier, VarSymbol, ProcSymbol, FuncSymbol, LabelSymbol, AlphaOperator]; EndLabel := [ConstSymbol, TypeSymbol, VarSymbol, ProcSymbol, FuncSymbol, BeginSymbol]; EndConst := EndLabel - [ConstSymbol]; EndType := EndConst - [TypeSymbol]; EndVar := EndConst - [VarSymbol]; (* Initialize Column Data: *) WriteColumn := 0; LeftMargin := 0; ActualLeftMargin := 0; OutputCol := 1; ReadLeftCol := 1; ReadRightCol := MaxReadRightCol; WriteLeftCol := 1; WriteRightCol := MaxWriteRightCol; Oldest := 1; CharCount := 1; LineNumber := 0; Increment := 0; (* Initialize Boolean Parameters: *) PackerIsOff := true; BunchWanted := false; DisplayIsOn := true; ProcNamesWanted := true; EndCommentsWanted := false; NoFormatting := false; (* Initialize Numeric Parameters: *) IndentIndex := 3; LongLineIndent := 3; ProcSeparation := 2; SymbolGap := 1; StatmtSeparation := 3; DeclarAlignment := 0; (* Initialize Input Context Data: *) ReadColumn := 1; ChIsEOL := false; NextChIsEOL := false; FOR I := 0 TO BufferSize DO Symbol [I] := ' '; LastSymbol := PeriodSymbol; LastProgPartWasBody := false; (* Now get filenames *) Writeln; Writeln ('Welcome to the P a s c a l F O R M A T T E R.':60); I := 1; REPEAT Writeln; Write ('Please type input file name --> '); Readln (Infilename); IF Infilename = '' THEN EXIT (Program); (*$I-*) Reset (Infile, Infilename); (*$I+*) I := IORESULT; IF I > 0 THEN BEGIN Writeln ('Oops, something''s wrong. IORESULT = ', I); Writeln ('To exit the program, just type .'); END UNTIL I = 0; Write ('Now the output filename ("PRINTER:" if you wish to print): '); Readln (Outfilename); Rewrite (Outfile, outfilename); END (*Initialize *); BEGIN (*MAIN PROGRAM !!!*) ConstantsInitialization; Initialize; IF eof(Input) THEN Writeln (' *** No Program Found To Format') ELSE BEGIN ReadACharacter; ReadSymbol; IF SymbolName <> ProgSymbol THEN Writeln (' *** "PROGRAM" EXPECTED.') ELSE BEGIN (******************************************************** * * * F O R M A T T H E P R O G R A M * * - - - - - - - - - - - - - - - - * * * ********************************************************) StartNewLineAndIndent; WriteSymbol; ReadSymbol; (* FOR I := 0 TO (Length - 1) DIV AlfaLeng DO PACK (Symbol, (I * AlfaLeng + 1), Main [I + 1]); *) (*EQUIVALENT:*) FOR I := 0 TO (Length - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO Main [I + 1, J] := Symbol [J + I * AlfaLeng]; MainNmLength := Length; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = Semicolon; WriteSymbol; ReadSymbol; StartNewLineAndIndent; DoBlock (Main, MainNmLength); WriteA ('.'); FlushUnwrittenBuffer; Close (Outfile, lock) END END END (*main program *). ======================================================================================== DOCUMENT :usus Folder:VOL01:format1.text ======================================================================================== (*$S+*) PROGRAM Format; CONST AlfaLeng = 10; MinChar = 0; MaxChar = 127; (* minimum/max char values *) LastPascSymbol = 29; (* if needed, change the values on the following line TOGETHER *) BufferSize = 160; BuffSzP1 = 161; BuffSzM1 = 159; BuffSzDiv10 = 16; MaxReadRightCol = 999; MaxWriteRightCon = 72; TYPE Alfa = PACKED ARRAY [1..AlfaLeng] OF char; CharSet = SET OF char; StatmntTypes = (ForWithWhileStatement, RepeatStatement, IfStatement, CaseStatement, CompoundStatement, OtherStatement); Symbols = (ProgSymbol, Comment, BeginSymbol, EndSymbol, SemiColon, ConstSymbol, TypeSymbol, RecordSymbol, ColonSymbol, EqualSymbol, PeriodSymbol, Range, CaseSymbol, OtherSymbol, IfSymbol, ThenSymbol, ElseSymbol, DoSymbol, OfSymbol, ForSymbol, WithSymbol, WhileSymbol, RepeatSymbol, UntilSymbol, Identifier, VarSymbol, ProcSymbol, FuncSymbol, LeftBracket, RightBracket, CommaSymbol, LabelSymbol, LeftParenth, RightParenth, AlphaOperator); Width = 0..BufferSize; Margins = -100..BufferSize; SymbolSet = SET OF Symbols; OptionSize = -99..99; CommentText = ARRAY [1..BuffSzDiv10] OF Alfa; SymbolString = ARRAY [Width] OF char; (*the only UNPACKED char array*) VAR ChIsEOL, NextChIsEOL: Boolean; I, J: Integer (*loop counters *); Character: char; ReadColumn, ReadRightCol: 0..1000; Length, Oldest: Width; OutputCol, WriteColumn, LeftMargin, ActualLeftMargin, ReadLeftCol, WriteLeftCol, WriteRightCol : Margins; DisplayIsOn, ProcNamesWanted, EndCommentsWanted, PackerIsOff, SavedBunch, BunchWanted, NoFormatting: boolean; LineNumber, Increment: integer; IndentIndex, LongLineIndent, SymbolGap, DeclarAlignment, StatmtSeparation, ProcSeparation: OptionSize; SymbolIsNumber, LastProgPartWasBody: Boolean; LastSymbol, SymbolName: Symbols; CharCount: integer; AlphaSymbols, EndLabel, EndConst, EndType, EndVar: SymbolSet; Symbol: SymbolString; Digits, Letters, LettersAndDigits: CharSet; Main: CommentText; MainNmLength: Width; Blanks, Zeroes: Alfa; UnWritten: ARRAY [Width] OF RECORD Ch: char; ChIsEndLine: boolean; IndentAfterEOL: margins END; PascalSymbol: ARRAY [1..LastPascSymbol] OF Alfa; PascSymbolName: ARRAY [1..LastPascSymbol] OF Symbols; NameOf: ARRAY [Char] OF Symbols; StatementTypeOf: ARRAY [Symbols] OF StatmntTypes; Infile, Outfile: text; PROCEDURE Const1Init; BEGIN Main [1] := 'MAIN '; MainNmLength := 4; Blanks := ' '; Zeroes := '0000000000'; FOR I := 0 TO BuffSzM1 DO WITH UnWritten [I] DO BEGIN ch := 'A'; ChIsEndLine := false; IndentAfterEOL := 0 END; FOR Character := Chr (MinChar) TO chr (MaxChar) DO NameOf [Character] := OtherSymbol; Character := ' '; NameOf ['('] := LeftParenth; NameOf [')'] := RightParenth; NameOf ['='] := EqualSymbol; NameOf [','] := CommaSymbol; NameOf ['.'] := PeriodSymbol; NameOf ['['] := LeftBracket; NameOf [']'] := RightBracket; NameOf [':'] := ColonSymbol; NameOf ['<'] := EqualSymbol; NameOf ['>'] := EqualSymbol; NameOf [';'] := Semicolon; PascalSymbol [ 1] := 'PROGRAM '; PascalSymbol [ 2] := 'BEGIN '; PascalSymbol [ 3] := 'END '; PascalSymbol [ 4] := 'CONST '; PascalSymbol [ 5] := 'TYPE '; PascalSymbol [ 6] := 'VAR '; PascalSymbol [ 7] := 'RECORD '; PascalSymbol [ 8] := 'CASE '; PascalSymbol [ 9] := 'IF '; PascalSymbol [10] := 'THEN '; PascalSymbol [11] := 'ELSE '; PascalSymbol [12] := 'DO '; PascalSymbol [13] := 'OF '; PascalSymbol [14] := 'FOR '; PascalSymbol [15] := 'WHILE '; PascalSymbol [16] := 'WITH '; PascalSymbol [17] := 'REPEAT '; PascalSymbol [18] := 'UNTIL '; PascalSymbol [19] := 'PROCEDURE '; PascalSymbol [20] := 'FUNCTION '; PascalSymbol [21] := 'LABEL '; PascalSymbol [22] := 'IN '; PascalSymbol [23] := 'MOD '; PascalSymbol [24] := 'DIV '; PascalSymbol [25] := 'AND '; PascalSymbol [26] := 'OR '; PascalSymbol [27] := 'NOT '; PascalSymbol [28] := 'ARRAY '; PascalSymbol [29] := 'NOSYMBOL '; END; PROCEDURE ConstantsInitialization; BEGIN Const1Init; PascSymbolName [ 1] := ProgSymbol; PascSymbolName [ 2] := BeginSymbol; PascSymbolName [ 3] := EndSymbol; PascSymbolName [ 4] := ConstSymbol; PascSymbolName [ 5] := TypeSymbol; PascSymbolName [ 6] := VarSymbol; PascSymbolName [ 7] := RecordSymbol; PascSymbolName [ 8] := CaseSymbol; PascSymbolName [ 9] := IfSymbol; PascSymbolName [10] := ThenSymbol; PascSymbolName [11] := ElseSymbol; PascSymbolName [12] := DoSymbol; PascSymbolName [13] := OfSymbol; PascSymbolName [14] := ForSymbol; PascSymbolName [15] := WhileSymbol; PascSymbolName [16] := WithSymbol; PascSymbolName [17] := RepeatSymbol; PascSymbolName [18] := UntilSymbol; PascSymbolName [19] := ProcSymbol; PascSymbolName [20] := FuncSymbol; PascSymbolName [21] := LabelSymbol; PascSymbolName [29] := Identifier; FOR I := 22 TO 28 DO PascSymbolName [I] := AlphaOperator; FOR SymbolName := ProgSymbol TO AlphaOperator DO StatementTypeOf [SymbolName] := OtherStatement; StatementTypeOf [ BeginSymbol] := CompoundStatement; StatementTypeOf [ CaseSymbol] := CaseStatement; StatementTypeOf [ IfSymbol] := IfStatement; StatementTypeOf [ ForSymbol] := ForWithWhileStatement; StatementTypeOf [ WhileSymbol] := ForWithWhileStatement; StatementTypeOf [ WithSymbol] := ForWithWhileStatement; StatementTypeOf [RepeatSymbol] := RepeatStatement; END (*ConstantsInitialization*); PROCEDURE WriteA (Character: char); VAR I: Width; TestNo: Integer; BEGIN CharCount := CharCount + 1; Oldest := CharCount MOD BufferSize; WITH UnWritten [Oldest] DO BEGIN IF CharCount > BuffSzP1 THEN BEGIN IF ChIsEndLine THEN BEGIN IF IndentAfterEOL < 0 THEN BEGIN Write (Outfile, Blanks: - IndentAfterEOL); OutputCol := OutputCol - IndentAfterEOL; END ELSE BEGIN IF Increment < 0 THEN BEGIN I := WriteRightCol - OutputCol + 1; IF I > 0 THEN Write (Outfile, Blanks: I); TestNo := LineNumber; I := 0; REPEAT TestNo := TestNo DIV 10; I := I + 1; UNTIL TestNo = 0; Write (Outfile, Zeroes: (6 - I), LineNumber: I); LineNumber := LineNumber + Increment; IF LineNumber > 9999 THEN LineNumber := LineNumber - 10000; Writeln (Outfile); END ELSE BEGIN Writeln (Outfile); IF Increment > 0 THEN BEGIN Write (Outfile, LineNumber: 4,' '); LineNumber := LineNumber + Increment; END END; IF IndentAfterEOL > 0 THEN Write (Outfile, Blanks: IndentAfterEOL); OutputCol := IndentAfterEOL + 1; END; ChIsEndLine := false; END (*IF ChIsEndLine*) ELSE BEGIN Write (Outfile, ch); OutputCol := OutputCol + 1; END; END (*IF CharCount > *); Ch := Character; WriteColumn := WriteColumn + 1; END (*with*) END (*WriteA*); PROCEDURE FlushUnwrittenBuffer; BEGIN WriteA (' '); WITH UnWritten [Oldest] DO BEGIN ChIsEndLine := true; IndentAfterEOL := 0; END; WriteColumn := 0; FOR I := 0 TO BuffSzM1 DO WriteA (' '); END; PROCEDURE StartNewLineAndIndent; BEGIN IF PackerIsOff AND DisplayIsOn THEN BEGIN WriteA (' '); LastSymbol := PeriodSymbol; WITH UnWritten [Oldest] DO BEGIN ChIsEndLine := true; IndentAfterEOL := WriteLeftCol + LeftMargin - 1; END; WriteColumn := WriteLeftCol + LeftMargin; END END; PROCEDURE ReadACharacter; BEGIN IF ReadColumn > ReadRightCol THEN BEGIN IF ReadRightCol < MaxReadRightCol THEN BEGIN NextChIsEOL := true; Readln (Infile) END ELSE ReadColumn := 2 END ELSE IF ReadColumn = 1 THEN WHILE ReadColumn < ReadLeftCol DO BEGIN IF EOLN (Infile) THEN ReadColumn := 1 ELSE BEGIN ReadColumn := ReadColumn + 1; Get (Infile) END END; IF NextChIsEOL THEN BEGIN Character := ' '; NextChIsEOL := false; ChIsEOL := true; ReadColumn := 1; IF NoFormatting THEN BEGIN WriteA (' '); WITH UnWritten [Oldest] DO BEGIN ChIsEndLine := true; IndentAfterEOL := WriteLeftCol - 1; END; WriteColumn := WriteLeftCol - 1; END; END ELSE IF NOT eof (Infile) THEN BEGIN Character := Infile^; ReadColumn := ReadColumn + 1; NextChIsEOL := EOLN (Infile); Get (Infiÿe); ChIsEOL := false; IF NoFormatting THEN WriteA (Character) END ELSE BEGIN FlushUnwrittenBuffer; EXIT (Program) END END (*ReadACharacter*); PROCEDURE WriteSymbol; VAR I: Width; NumberBlanksToWrite: OptionSize; BEGIN IF DisplayIsOn THEN BEGIN NumberBlanksToWrite := SymbolGap; IF (LastSymbol IN [LeftParenth, LeftBracket, PeriodSymbol]) OR (SymbolName IN [Semicolon, RightParenth, RightBracket, CommaSymbol, PeriodSymbol, ColonSymbol]) OR (SymbolName IN [LeftBracket, LeftParenth]) AND (LastSymbol = Identifier) THEN NumberBlanksToWrite := 0 ELSE IF (SymbolName IN AlphaSymbols) AND (LastSymbol IN AlphaSymbols) THEN IF WriteColumn <= WriteRightCol THEN BEGIN WriteA (' '); NumberBlanksToWrite := SymbolGap - 1; END; IF WriteColumn + Length + NumberBlanksToWrite - 1 > WriteRightCol THEN BEGIN WriteA (' '); WITH UnWritten [Oldest] DO BEGIN ChIsEndLine := true; IF PackerIsOff THEN BEGIN IF WriteLeftCol + LeftMargin + LongLineIndent + Length - 1 > WriteRightCol THEN Length := 10; IndentAfterEOL := WriteLeftCol - 1 + LeftMargin + LongLineIndent; WriteColumn := WriteLeftCol + LeftMargin + LongLineIndent END ELSE BEGIN IF Length > WriteRightCol - WriteLeftCol + 1 THEN Length := WriteRightCol - WriteLeftCol + 1; IndentAfterEOL := WriteLeftCol - 1; WriteColumn := WriteLeftCol END; END (*with*); END (*then*) ELSE FOR I := 1 TO NumberBlanksToWrite DO WriteA (' '); FOR I := 1 TO Length DO WriteA (Symbol [I]); END (*IF DisplayIsOn*); LastSymbol := SymbolName END (*WriteSymbol*); PROCEDURE CopyACharacter; BEGIN IF DisplayIsOn THEN BEGIN IF WriteColumn > WriteRightCol THEN BEGIN WHILE (Character = ' ') AND NOT ChIsEOL DO ReadACharacter; IF NOT ChIsEOL THEN StartNewLineAndIndent END; IF ChIsEOL THEN BEGIN LeftMargin := 0; StartNewLineAndIndent; LeftMargin := ActualLeftMargin END ELSE WriteA (Character) END; ReadACharacter END (*CopyACharacter*); PROCEDURE DoFormatterDirectives; CONST Invalid = -1; TYPE ParamCount = 1..2; Params = ARRAY [ParamCount] OF integer; VAR Specification: Params; FormatOption: char; PrevDisplay, PrevNoFormatting: boolean; EndDirectiv: CharSet; PROCEDURE ReadIn (N: ParamCount; VAR Specification: Params); VAR I: ParamCount; BEGIN FOR I := 1 TO N DO BEGIN WHILE NOT (Character IN (Digits + EndDirectv)) DO CopyACharacter; Specification [I] := 0; IF NOT (Character IN EndDirectiv) THEN REPEAT Specification [I] := 10 * Specification [I] + ORD (Character) - ORD ('0'); CopyACharacter UNTIL NOT (Character IN Digits) ELSE Specification [I] := Invalid; END END (*ReadIn*); BEGIN (*DoFormatterDirectives*); EndDirective := ['*', ']']; REPEAT IF Character IN ['A'..'G', 'I', 'L', 'N', 'P', 'R', 'S', 'W'] THEN BEGIN FormatOption := Character; CASE FormatOption OF 'A', 'E', 'I', 'G', 'P', 'L', 'S': BEGIN ReadIn (1, Specification); IF (Specification [1] < WriteRightCol - WriteLeftCol - 9) OR (FormatOption = 'P') THEN CASE FormatOption OF 'A': DeclarAlignment := Specification [1]; 'E': IF Specification [1] < 4 THEN BEGIN ProcNamesWanted := Specification [1] > 1; EndCommentsWanted := Odd(Specification [1]) END; 'G': SymbolGap := Specification [1]; 'I': IndentIndex := Specification [1]; 'L': LongLineIndent := Specification [1]; 'P': ProcSeparation := Specification [1]; 'S': StatmtSeparation := Specification [1] END (*case*) END (*1st 7 letters*); 'W', 'R', 'N': BEGIN ReadIn (2, Specification); IF Specification [2] <> Invalid THEN CASE FormatOption OF 'W': IF (Specification [1] > 0) AND (Specification [2] < BufferSize - 2) AND (Specification [2] - Specification [1] > 8) THEN BEGIN WriteLeftCol := Specification [1]; WriteRightCol := Specification [2] END; 'R': IF (Specification [1] > 0) AND (Specification [2] - Specification [1] > 8) THEN BEGIN ReadLeftCol := Specification [1]; ReadRightCol := Specification [2] END; 'N': BEGIN LineNumber := Specification [1]; Increment := Specification [2]; WHILE NOT (Character IN (['<'] + EndDirectv)) AND (Character <> '>') DO CopyACharacter; IF Character = '>' THEN Increment := - Increment END END (*case*); END (*Next 2 letters*); 'B', 'C', 'D', 'F': BEGIN REPEAT CopyACharacter UNTIL Character IN (['+', '-'] + EndDirectv); IF Character IN ['+', '-'] THEN CASE FormatOption OF 'B': IF DisplayIsOn THEN BunchWanted := Character = '+'; 'C': PackerIsOff := Character = '-'; 'D': BEGIN PrevDisplay := DisplayIsOn; DisplayIsOn := Character = '+'; IF PrevDisplay AND NOT DisplayIsOn THEN BEGIN WriteA ('*'); WriteA (')'); SavedBunch := BunchWanted; BunchWanted := false END ELSE IF NOT PrevDisplay AND DisplayIsOn THEN BEGIN StartNewLineAndIndent; WriteA ('('); WriteA ('*'); BunchWanted := SavedBunch END END; 'F': BEGIN PrevNoFormatting := NoFormatting; NoFormatting := Character = '-'; DisplayIsOn := NOT NoFormatting; IF PrevNoFormatting AND NOT NoFormatting THEN ReadACharacter; IF NOT PrevNoFormatting AND NoFormatting THEN WriteA ('-'); END END (*case*) END (*boolean parameters*) END (*main case statement*); END (*then*) ELSE IF NOT (Character IN EndDirectv) THEN CopyACharacter UNTIL Character IN EndDirectv; IF Character = ']' THEN CopyACharacter END (*DoFormatterDirectives*); PROCEDURE ReadSymbol; CONST ReadNextCh = true; DontReadNextCh = false; VAR TestSymbol: Alfa; CharNumber, I: Width; PROCEDURE SkipComment; BEGIN REPEAT WHILE Character <> '*' DO ReadACharacter; ReadACharacter UNTIL Character = ')'; ReadACharacter; LastSymbol := comment; ReadSymbol END; PROCEDURE DoComment; VAR I: OptionSize; PROCEDURE CompilerDirectives; BEGIN REPEAT CopyACharacter UNTIL Character IN ['[', '*'] END; BEGIN (*DoComment*) BEGIN IF LastSymbol IN [Comment, Semicolon] THEN BEGIN LeftMargin := 0; StartNewLineAndIndent; LeftMargin := ActualLeftMargin END; WriteSymbol; If Character = '$' THEN CompilerDirectives; IF Character = '[' THEN DoFormatterDirectives; REPEAT WHILE Character <> '*' DO CopyACharacter; CopyACharacter UNTIL Character = ')'; CopyACharacter; LastSymbol := Comment; ReadSymbol END END (*DoComment*); PROCEDURE CheckFor (SecondChar: char; TwoCharSymbol: Symbols; ReadAllowed: Boolean); BEGIN IF ReadAllowed THEN BEGIN Length := 1; Symbol[1] := Character; SymbolName := NameOf [Character]; ReadACharacter END; IF Character = SecondChar THEN BEGIN Symbol [2] := Character; Length := 2; SymbolName := TwoCharSymbol; ReadACharacter; IF (NOT PackerIsOff) AND (SymbolName = Comment) THEN Length := 0 END END (*CheckFor*); ======================================================================================== DOCUMENT :usus Folder:VOL01:format2.text ======================================================================================== BEGIN (*ReadSymbol*) IF (Character IN Letters) THEN BEGIN CharNumber := 1; SymbolIsNumber := false; REPEAT Symbol [CharNumber] := Character; ReadACharacter; CharNumber := CharNumber + 1 UNTIL NOT (Character IN LettersAndDigits); Length := CharNumber - 1; FOR CharNumber := CharNumber TO AlfaLeng DO Symbol [CharNumber] := ' '; (* PACK (Symbol, 1, TestSymbol); *) (*EQUIVALENT (WITH ADDED UPPER/LOWER CASE TRANSPARENCY): *) FOR I := 1 TO AlfaLeng DO BEGIN TestSymbol [I] := Symbol [I]; IF (TestSymbol [I] IN ['a'..'z']) THEN TestSymbol [I] := CHR (ORD (TestSymbol [I]) + ORD ('A') - ORD ('a')) END; I := 1; PascalSymbol [LastPascSymbol] := TestSymbol; WHILE PascalSymbol [I] <> TestSymbol DO I := I + 1; SymbolName := PascSymbolName [I] END (*letters*) ELSE IF (Character IN ['0'..'9', ' ', '(', '.', ':', '''', '<', '>']) THEN CASE Character OF '(': BEGIN CheckFor ('*', Comment, ReadNextCh); IF (SymbolName = Comment) AND PackerIsOff THEN DoComment ELSE IF SymbolName = Comment THEN SkipComment END; '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': BEGIN SymbolIsNumber := true; CharNumber := 1; REPEAT Symbol [CharNumber] := Character; ReadACharacter; CharNumber := CharNumber + 1 UNTIL NOT (Character IN Digits + ['.']); IF Character IN ['B', 'E'] THEN BEGIN Symbol [CharNumber] := Character; ReadACharacter; CharNumber := CharNumber + 1; IF Character IN Digits + ['+', '-'] THEN REPEAT Symbol [CharNumber] := Character; ReadACharacter; CharNumber := CharNumber + 1 UNTIL NOT (Character IN Digits) END; Length := CharNumber - 1; SymbolName := Identifier; END (*numbers*); ' ': BEGIN REPEAT ReadACharacter UNTIL Character <> ' '; ReadSymbol END; '>', ':': CheckFor ('=', OtherSymbol, ReadNextCh); '<': BEGIN CheckFor ('=', OtherSymbol, ReadNextCh); IF SymbolName <> OtherSymbol THEN CheckFor ('>', OtherSymbol, DontReadNextCh) END; '.': IF LastSymbol <> EndSymbol THEN CheckFor ('.', Range, ReadNextCh) ELSE SymbolName := PeriodSymbol; '''': BEGIN CharNumber := 1; REPEAT REPEAT Symbol [CharNumber] := Character; CharNumber := CharNumber + 1; ReadACharacter UNTIL Character = ''''; Symbol [CharNumber] := Character; CharNumber := CharNumber + 1; ReadACharacter UNTIL Character <> ''''; Length := CharNumber - 1; SymbolName := OtherSymbol; IF Length > WriteRightCol - WriteLeftCol + 1 THEN BEGIN FlushUnwrittenBuffer; WriteLn; Writeln (' *** STRING TOO LONG.'); EXIT (Program) END; END (*string*) END (*then case*) ELSE BEGIN Symbol [1] := Character; SymbolName := NameOf [Character]; Length := 1; ReadACharacter END END (*ReadSymbol*); PROCEDURE ChangeMarginTo (NewLeftMargin: Margins); VAR IndentedLeftMargin: Margins; BEGIN ActualLeftMargin := NewLeftMargin; LeftMargin := NewLeftMargin; IF LeftMargin < 0 THEN LeftMargin := 0 ELSE BEGIN IndentedLeftMargin := WriteRightCol - 9 - LongLineIndent; IF LeftMargin > IndentedLeftMargin THEN LeftMargin := IndentedLeftMargin END END (*ChangeMarginTo*); PROCEDURE DoDeclarationUntil (EndDeclaration: SymbolSet); PROCEDURE DoParentheses; VAR SavedLgLnId: OptionSize; BEGIN SavedLgLnId := LongLineIndent; IF DeclarAlignment > 0 THEN BEGIN LongLineIndent := WriteColumn + SymbolGap + 1 - LeftMargin - WriteLeftCol; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = RightParenth; WriteSymbol; ReadSymbol END ELSE BEGIN LongLineIndent := 1; ChangeMarginTo (ActualLeftMargin + IndentIndex); StartNewLineAndIndent; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = RightParenth; WriteSymbol; ReadSymbol; ChangeMarginTo (ActualLeftMargin - IndentIndex); END; LongLineIndent := SavedLgLnId END (*DoParentheses*); PROCEDURE DoFieldListUntil (EndFieldList: SymbolSet); VAR LastEOL: Margins; AlignColumn: Width; PROCEDURE DoRecord; VAR SavedLeftMargin: Width; BEGIN SavedLeftMargin := ActualLeftMargin; WriteSymbol; ReadSymbol; ChangeMarginTo (WriteColumn - 6 + IndentIndex - WriteLeftCol); StartNewLineAndIndent; DoFieldListUntil ([EndSymbol]); ChangeMarginTo (ActualLeftMargin - IndentIndex); StartNewLineAndIndent; WriteSymbol; ReadSymbol; ChangeMarginTo (SavedLeftMargin); END (*DoRecord*); PROCEDURE DoVariantRecordPart; VAR SavedLeftMargin, OtherSavedMargin: Margins; BEGIN OtherSavedMargin := ActualLeftMargin; IF DeclarAlignment > 0 THEN BEGIN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName IN [ColonSymbol, OfSymbol]; IF SymbolName = ColonSymbol THEN BEGIN WriteSymbol; ReadSymbol; WITH UnWritten [LastEOL] DO BEGIN IndentAfterEOL := IndentAfterEOL + AlignColumn - WriteColumn; IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0 END; WriteColumn := AlignColumn; ChangeMarginTo (ActualLeftMargin + AlignColumn - WriteColumn) END END (*then*); IF SymbolName <> OfSymbol THEN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = OfSymbol; ChangeMarginTo (ActualLeftMargin + IndentIndex); REPEAT WriteSymbol; ReadSymbol; IF SymbolName <> EndSymbol THEN BEGIN StartNewLineAndIndent; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName IN [LeftParenth, SemiColon, EndSymbol]; IF SymbolName = LeftParenth THEN BEGIN WriteSymbol; ReadSymbol; SavedLeftMargin := ActualLeftMargin; ChangeMarginTo (WriteColumn - WriteLeftCol); DoFieldListUntil ([RightParenth]); WriteSymbol; ReadSymbol; ChangeMarginTo (SavedLeftMargin) END END; UNTIL SymbolName <> Semicolon; ChangeMarginTo (OtherSavedMargin) END (*DoVariantRecordPart*); BEGIN (*DoFieldListUntil*) LastEOL := Oldest; IF LastSymbol = LeftParenth THEN FOR I := 1 TO DeclarAlignment - Length DO WriteA (' '); AlignColumn := LeftMargin + WriteLeftCol + DeclarAlignment + 1; WHILE NOT (SymbolName IN EndFieldList) DO BEGIN IF LastSymbol IN [Semicolon, Comment] THEN IF SymbolName <> Semicolon THEN BEGIN StartNewLineAndIndent; LastEOL := Oldest END; IF SymbolName IN [RecordSymbol, CaseSymbol, LeftParenth, CommaSymbol, ColonSymbol, EqualSymbol] THEN CASE SymbolName OF RecordSymbol: DoRecord; CaseSymbol: DoVariantRecordPart; LeftParenth: DoParentheses; CommaSymbol, ColonSymbol, EqualSymbol: BEGIN WriteSymbol; IF DeclarAlignment > 0 THEN IF NOT (EndLabel <= EndFieldList) THEN BEGIN WITH UnWritten [LastEOL] DO BEGIN IndentAfterEOL := IndentAfterEOL + AlignColumn - WriteColumn; IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0; WriteColumn := AlignColumn END; IF SymbolName = CommaSymbol THEN BEGIN StartNewLineAndIndent; LastEOL := Oldest END END (*then*); ReadSymbol END (* , : = *) END (*case*) ELSE BEGIN WriteSymbol; ReadSymbol END; END (*while*) END (*DoFieldListUntil*); BEGIN (*DoDeclarationUntil*) StartNewLineAndIndent; WriteSymbol; ChangeMarginTo (ActualLeftMargin + IndentIndex); StartNewLineAndIndent; ReadSymbol; DoFieldListUntil (EndDeclaration); StartNewLineAndIndent; ChangeMarginTo (ActualLeftMargin - IndentIndex) END (*DoDeclarationUntil*); PROCEDURE DoBlock (BlockName: CommentText; BlockNmLength: Width); VAR I: Width; IfThenBunchNeeded, AtProcBeginning: boolean; PROCEDURE DoProcedures; VAR I: 0..20; ProcName: CommentText; ProcNmLenght: Width; BEGIN FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent; StartNewLineAndIndent; WriteSymbol; ReadSymbol; (* FOR I := 0 TO (Length - 1) DIV AlfaLeng DO Pack (Symbol, I * AlfaLeng + 1, ProcName [I + 1]; *) (* Equivalent: *) FOR I := 0 TO (Length - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO ProcName [I + 1, J] := Symbol [J + I*AlfaLeng]; ProcNmLength := Length; WriteSymbol; ReadSymbol; IF SymbolName = LeftParenth THEN BEGIN WriteSymbol; REPEAT ReadSymbol; WriteSymbol UNTIL SymbolName = RightParenth; ReadSymbol END; IF SymbolName = ColonSymbol THEN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = Semicolon; WriteSymbol; ReadSymbol; ChangeMarginTo (ActualLeftMargin + IndentIndex); StartNewLineAndIndent; LastProgPartWasBody := true; ChangeMarginTo (ActualLeftMargin - IndentIndex); WriteSymbol; ReadSymbol; StartNewLineAndIndent END (*DoProcedures*); PROCEDURE DoStatement (VAR AddedBlanks: Width; StatmtSymbol: CommentText; StmtSymLength: Width); VAR I: Width; StatmtBeginning, BlksOnCurrntLine, BlksAddedByThisStmt: integer; StatmtPart: ARRAY [1..4] OF integer; Successful: boolean; PROCEDURE Bunch (Beginning, Breakpt, Ending: integer; StatmtSeparation: OptionSize); BEGIN IF BunchWanted OR IfThenBunchNeeded THEN BEGIN IF StatmtSeparation < 1 THEN StatmtSeparation := 1; BlksOnCurrntLine := BlksOnCurrntLine + StatmtSeparation - 1; Successful := ((Ending - Beginning + BlksOnCurrntLine + UnWritten [Beginning MOD BufferSize].IndentAfterEOL) | WriteRightCol) AND (CharCount - Beginning < BufferSize); IF Successful THEN BEGIN BlksAddedByThisStmt := BlksAddedByThisStmt + StatmtSeparation - 1; UnWritten [Breakpt MOD BufferSize].IndentAfterEOL := - StatmtSeparation; END END END (*bunch*); PROCEDURE WriteComment; VAR I, SavedLength: Width; SavedSymbolName: Symbols; SavedChars: SymbolString; BEGIN SavedSymbolName := SymbolName; FOR I := 1 TO Length DO SavedChars [I] := Symbol [I]; SavedLength := Length; SymbolName := OtherSymbol; Symbol [1] := '('; Symbol [2] := '*'; Length := 2; WriteSymbol; (* FOR I := 0 TO (StmtSymLength - 1) DIV AlfaLeng DO Unpack (StatmtSymbol [I + 1], Symbol, (I * AlfaLeng + 1));*) (* EQUIVALENT: *) FOR I := 0 TO (StmtSymLength - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO Symbol [J + I * AlfaLeng] := StatmtSymbol [I + 1, J]; Length := StmtSymLength; SymbolName := PeriodSymbol; LastSymbol := PeriodSymbol; WriteSymbol; Symbol [1] := '*'; Symbol[2] := ')'; Length := 2; WriteSymbol; SymbolName := SavedSymbolName; Length := SavedLength; FOR I := 1 TO Length DO Symbol [I] := SavedChars [I] END (*WriteComment*); PROCEDURE DoStmtList (EndList: Symbols); VAR BlksAfterPrt2: Width; AtProcEnd: boolean; BEGIN AtProcEnd := AtProcBeginning; WriteSymbol; ReadSymbol; StatmtPart [1] := CharCount + 1; StatmtPart [2] := StatmtPart [1]; IF SymbolName <> EndList THEN BEGIN IF ProcNamesWanted THEN IF AtProcBeginning THEN IF LastProgPartWasBody THEN IF LastSymbol = BeginSymbol THEN WriteComment; AtProcBeginning := false; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksAfterPrt2 := AddedBlanks; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; WHILE SymbolName <> EndList DO BEGIN WriteSymbol; ReadSymbol; IF SymbolName <> EndList THEN BEGIN StatmtPart [3] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := AddedBlanks + BlksAfterPrt2; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; Bunch (StatmtPart [2], StatmtPart [3], CharCount, StatmtSeparation); IF NOT Successful THEN BEGIN BlksAfterPrt2 := AddedBlanks; StatmtPart [2] := StatmtPart [3]; END ELSE BlksAfterPrt2 := BlksOnCurrntLine; END (*then*) END (*while*) END (*main then*); BlksOnCurrntLine := BlksAddedByThisStmt; Bunch (StatmtBeginning, StatmtPart [1], CharCount, SymbolGap); StartNewLineAndIndent; StatmtPart [1] := CharCount; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName IN [Semicolon, UntilSymbol, EndSymbol, ElseSymbol, PeriodSymbol]; IF Successful THEN BEGIN IF EndList = UntilSymbol THEN StatmtPart [4] := StatmtSeparation ELSE StatmtPart [4] := SymbolGap; Bunch (StatmtBeginning, StatmtPart [1], CharCount, StatmtPart [4]); END; IF NOT (Successful AND BunchWanted) THEN IF EndList = EndSymbol THEN IF LastSymbol = EndSymbol THEN IF AtProcEnd AND ProcNamesWanted THEN WriteComment END (*DoStmtList*); ======================================================================================== DOCUMENT :usus Folder:VOL01:getcpm.text ======================================================================================== PROGRAM GETCPM; (* COPYRIGHT 1979 BY BARRY A. COLE *) CONST SPACES=' '; BUFSIZE=32750; VAR I,J,K,INDEX,NEXTEX,BIGP,BLANKS,BLOCKS,ROOM,COL: INTEGER; DISKBUF: PACKED ARRAY[0..1023] OF CHAR; BIGBUF: PACKED ARRAY[0..BUFSIZE] OF CHAR; F:FILE; DELAY: CHAR; CPMTITLE,PASCTITLE: STRING[13]; EXTENTS: ARRAY[1..64] OF INTEGER; NEWLINE: BOOLEAN; PROCEDURE READCPM(PARAM: INTEGER); EXTERNAL; procedure tack(value:integer); begin if bigp=bufsize then begin write(chr(value)); exit(tack); end; bigbuf[bigp]:=chr(value); bigp:=bigp+1; col:=col+1; end; procedure putit(ind: integer); begin if ord(diskbuf[ind])<>0 then begin extents[nextex]:=ord(diskbuf[ind]); nextex:=nextex+1; end; end; PROCEDURE SEARCH; VAR FOUND: BOOLEAN; K,BLOCK,I: INTEGER; BEGIN FOR BLOCK:=0 TO 1 DO BEGIN READCPM(BLOCK); FOR I:=0 TO 31 DO BEGIN FOUND:=TRUE; FOR J:=1 TO 11 DO IF DISKBUF[32*I+J]<>CPMTITLE[J] THEN FOUND:=FALSE; IF FOUND THEN FOR K:=32*I+16 TO 32*I+31 DO PUTIT(K); END; END; END; {eop search} procedure process; var i,tabcol: integer; begin for i:=1 to nextex-1 do begin READCPM(extents[i]); FOR J:=0 TO 1023 DO BEGIN K:=ORD(DISKBUF[J]); IF K=26 THEN EXIT(PROCESS); {EOF FOUND} IF (K<>32) AND NEWLINE THEN BEGIN TACK(16); TACK(BL{NKS); COL:=BLANKS-32; BLANKS:=32; NEWLINE:=FALSE; END; IF (K=32) AND NEWLINE THEN BLANKS:=BLANKS+1 ELSE IF K>=32 THEN TACK(K); IF K=9 THEN FOR TABCOL:=COL MOD 8 TO 7 DO TACK(32); {TAB} IF K=13 THEN BEGIN {CR} TACK(13); NEWLINE:=TRUE; BLANKS:=32; ROOM:=1024-(BIGP MOD 1024); IF ROOM<82 THEN REPEAT BEGIN TACK(0); ROOM:=ROOM-1; END UNTIL ROOM=0; END; END; end; end; {end of process } BEGIN REPEAT BEGIN WRITELN('PLACE CP/M DISK IN DRIVE A'); WRITE('FILE NAME? '); READLN(CPMTITLE); I:=POS('.',CPMTITLE); END UNTIL (I>0) AND (I<10); {IF (I=0) OR (I>9) THEN WRITELN('ILLEGAL FILE NAME FORMAT') ELSE BEGIN } PASCTITLE:=CONCAT(COPY(CPMTITLE,1,I),'TEXT'); CPMTITLE:=CONCAT(COPY(CPMTITLE,1,I-1), COPY(SPACES,1,9-I),COPY(CPMTITLE,I+1,3)); {END;} WRITELN('SEARCHING FOR "',CPMTITLE,'"'); BLANKS:=32; NEWLINE:=TRUE; BIGP:=0; NEXTEX:=1; SEARCH; IF NEXTEX=1 THEN WRITELN('FILE NOT FOUND') ELSE BEGIN WRITELN('FILE IS ',NEXTEX-1,' EXTENT(S) LONG'); PROCESS; BLOCKS:=(BIGP DIV 512)+2; FOR I:=BIGP TO BLOCKS*512-1 DO BIGBUF[I]:=CHR(0); WRITELN('PLACE PASCAL DISK IN DRIVE A, HIT KEY WHEN READY'); READ(DELAY); {SWITCH DISK DELAY } WRITELN('WRITING ',BLOCKS+2,' BLOCKS TO ',PASCTITLE); REWRITE(F,PASCTITLE); IF BLOCKS<31 THEN J:=BLOCKWRITE(F,BIGBUF,BLOCKS,2) ELSE BEGIN J:=BLOCKWRITE(F,BIGBUF,30,2); J:=BLOCKWRITE(F,BIGBUF[15360],BLOCKS-30,32); END; CLOSE(F,LOCK); END; END. ======================================================================================== DOCUMENT :usus Folder:VOL01:getcpm2.text ======================================================================================== PROGRAM GETCPM; (* COPYRIGHT 1979 BY BARRY A. COLE *) (* GET SOURCE FILE FROM CPM DISK(#5) AND PUT ON PASCAL DISK(#4) *) CONST SPACES=' '; VAR I,J,K,INDEX,NEXTEX,BIGP,BLANKS,BLOKNUM,ROOM,COL: INTEGER; DISKBUF,BIGBUF: PACKED ARRAY[0..1023] OF CHAR; NEWLINE: BOOLEAN; F:FILE; CPMTITLE,PASCTITLE: STRING[13]; EXTENTS: ARRAY[1..255] OF INTEGER; PROCEDURE RWCPM(XTENT,RWFLAG: INTEGER); EXTERNAL; procedure tack(value:integer); var retcd: integer; begin bigbuf[bigp]:=chr(value); bigp:=bigp+1; col:=col+1; if bigp=1024 then begin write('P'); retcd:=blockwrite(f,bigbuf,2,bloknum); bloknum:=bloknum+2; bigp:=0; end; end; procedure putit(ind: integer); begin if ord(diskbuf[ind])<>0 then begin extents[nextex]:=ord(diskbuf[ind]); nextex:=nextex+1; end; end; PROCEDURE SEARCH; VAR FOUND: BOOLEAN; K,BLOCK,I: INTEGER; BEGIN FOR BLOCK:=0 TO 1 DO BEGIN RWCPM(BLOCK,0); FOR I:=0 TO 31 DO BEGIN FOUND:=TRUE; FOR J:=1 TO 11 DO IF DISKBUF[32*I+J]<>CPMTITLE[J] THEN FOUND:=FALSE; IF FOUND THEN FOR K:=32*I+16 TO 32*I+31 DO PUTIT(K); END; END; END; {eop search} procedure process; var i,tabcol: integer; begin for i:=1 to nextex-1 do begin WRITE('C'); RWCPM(extents[i],0); FOR J:=0 TO 1023 DO BEGIN K:=ORD(DISKBUF[J]); IF K=26 THEN EXIT(PROCESS); {EOF FOUND} IF (K<>32) AND NEWLINE THEN BEGIN TACK(16); TACK(BLANKS); COL:=BLANKS-32; BLANKS:=32; NEWLINE:=FALSE; END; IF (K=32) AND NEWLINE THEN BLANKS:=BLANKS+1 ELSE IF K>=32 THEN TACK(K); IF K=9 THEN FOR TABCOL:=COL MOD 8 TO 7 DO TACK(32); {TAB} IF K=13 THEN BEGIN {CR} TACK(13); NEWLINE:=TRUE; BLANKS:=32; ROOM:=1024-(BIGP MOD 1024); IF ROOM<82 THEN REPEAT BEGIN TACK(0); ROOM:=ROOM-1; END UNTIL ROOM=0; END; END; end; end; {end of process } BEGIN REPEAT BEGIN WRITELN('PLACE CP/M DISK IN DRIVE B'); WRITE('FILE NAME? '); READLN(CPMTITLE); I:=POS('.',CPMTITLE); END UNTIL (I>0) AND (I<10); PASCTITLE:=CONCAT(COPY(CPMTITLE,1,I),'TEXT'); CPMTITLE:=CONCAT(COPY(CPMTITLE,1,I-1), COPY(SPACES,1,9-I),COPY(CPMTITLE,I+1,3)); WRITELN('SEARCHING FOR "',CPMTITLE,'"'); BLANKS:=32; NEWLINE:=TRUE; BIGP:=0; NEXTEX:=1; SEARCH; IF NEXTEX=1 THEN WRITELN('FILE NOT FOUND') ELSE BEGIN WRITELN('FILE IS ',NEXTEX-1,' EXTENT(S) LONG'); REWRITE(F,PASCTITLE); BLOKNUM:=0; FOR I:=0 TO 1023 DO IF I=122 THEN TACK(63) ELSE IF I=124 THEN TACK(5) ELSE TACK(0); PROCESS; FOR I:=BIGP TO 1024 DO TACK(0); {PUT OUT LAST SECTION} CLOSE(F,LOCK); WRITELN; WRITELN(BLOKNUM,' BLOCKS HAVE BEEN WRITTEN TO ',PASCTITLE); END; END. ======================================================================================== DOCUMENT :usus Folder:VOL01:gotcha.doc.text ======================================================================================== HIDDEN GOTCHA DOCUMENTATION FOR GETTING UP UCSD PASCAL I bought the first UCSD system advertised for the Z-80 nearly two years ago; it took me nearly six months to get it to run properly. Many of the difficulties with which I had to contend are now adequately documented, but I will present them here anyway for your edification. Most of my difficulties were in getting the CRT to handle the demands of the text editor. I would recommend that you handle the maximum number of CRT character manipulation within your BIOS in machine code, for purposes of speed. I had to contend with a memory-mapped video terminal, which did nothing but what was programmed; others have had to work their way around a "dumb" terminal, such as an ADM-3. If you have one of the newer generation of CRT terminals with cursor addressing, line and screen erasure, and line insertion and deletion, then you should have no problem; just follow the directions in SETUP. Don't forget to ensure that you save your product from your session with SETUP on the disk, and that this file is called "SYSTEM.MISCINFO". This file is read in at boot time and is used by the editor. There are two other items to which you with the better terminals will need to attend. First, make sure that your screen is cleared if your BIOS receives an ASCII FORMFEED (12 decimal; 0C hex): change this to whatever your CRT actually requires within the BIOS. Similarly, your printer driver should cause a formfeed (go to the top of the next page) upon receipt of the same character. This way, your CRT and printer will respond appropriately if someone writes a "PAGE (output)" within a Pascal program, and the hideous machination of having to rewrite a "ClearScreen" procedure for each program can finally end. Second, follow the directions in BINDER to set up a valid GOTOXY procedure and bind it into the system. Since the normal SYSTEM.EDITOR will do strange things until there is a valid GOTOXY within the SYSTEM.PASCAL, you will have to use YALOE, the line editor, to write this program (either temporarily rename this SYSTEM.EDITOR or get to it by typing "X" for X(ecute, while at the Command level, then type "YALOE "). Note that once the GOTOXY is present within your system, it can be used as a standard procedure within your programs, as well. However, there are several gotchas in writing the GOTOXY procedure: 1) it must be written in Pascal; there is no way that BINDER will accept an assembly language program. 2) The brute force way is to print a series of "nondestructive forward spaces" for the horizontal dimension (X), and a series of line feeds for Y. While acceptable, this is too slow (the screen editor is always going to XY), and you have to avoid the mistake of writing SPACES for X, like I first did (and you can imagine that the guys at UCSD had NO idea what was wrong), erasing the first part of the line you are on. 3)The best way is to output a character or series of characters which toggle a GOTOXY sequence, followed by the X and the Y dimensions. You MUST, however, be sure to add 32 (20 hex) to both X and Y before sending them, and then remove this when forcing the GOTOXY in the BIOS. (Most intellegent terminals require that 32 be added to both dimensions, so if you have one, don't you go stripping this off in advance.) The reason for this requirement is that the interpreter always adds a linefeed when it sees a 13 (hex 0D, ASCII carriage return), and treats a 16 (10H) as a special code indicating that the next character is the number of spaces to insert at this point. Don't forget these two characters when designing your BIOS control characters, either. Once you have figured out the best way to set up a GOTOXY, write a Pascal procedure that will call it. Don't forget to include range-checking somewhere in the system (IF x < 0 THEN x = 0; IF x > MaxCharsPerLine THEN x = MaxCharsPerLine (*whatever this is in your system - substitute the real number*)). When you type this in, call your procedure and your file "GOTOXY1" or some other name not identical with "GOTOXY", or you will confuse the system. Further, the procedure must be part of a program or it will not compile; start your text file with a program declaration (like "PROGRAM DUMMY;") and end it with a dummy "BEGIN"-"END." pair (and don't forget the period). Finally, compile the program; make up a disk with nothing on it but your program, SYSTEM.PASCAL and the BINDER.CODE (needs a lot of room); and then X(ecute BINDER, giving it the name of your CODE file. When you're all done, save the new SYSTEM.PASCAL on all your system disks; make it the first file on the disk and you won't have to reboot every time you K(runch a disk. There is a table of reserved characters at the end of this file; be cer- tain your system can handle them. For those souls with dumb terminals or memory-mapped CRT's. First, if you skipped the above discussion, you'd better go back and read it; it applies to you, too. Next, it will be up to you to design a BIOS that will handle the demands of Pascal. As it turns out, this is also useful if you use WordStar or certain other sophisticated CP/M text editors; your effort will net you many gains. 1. Basic necessities. Your BIOS-terminal (or BIOS-CRT) combination will have to support the following basic commands: a. GOTOXY (see the previous discussion). b. One-character cursor movement in all 4 directions, without erasing underlying text. This works out to a backspace, a nondestructive-forward- space, a line feed, and a reverse line feed. Note that the horizontal movement should NOT take you off a given line, and that the reverse line feed need not bring you higher than the top of the screen (ie, no reverse scroll required, although if you have it is OK). However, it is expected that if a line feed occurs when the cursor is on the last line, the CRT will scroll and display a blank last line. c. Automatic expansion of ASCII horizontal tabs (8) to the next eighth column. Make sure underlying text is not erased (write nondestructive spaces to the next eighth column). Your PRINTER must handle this command, as well (note the difference from CP/M). d. Your system must either beep or do nothing upon receipt of an ASCII bell (7), and is expected to do nothing if it receives a NUL (00). One recommendation: if your system makes a sound when it receives a bell character, make sure it is pleasant -- UCSD uses it a lot. e. A home-cursor command (to the upper left corner). f. Erase-to-end-of-line and erase-to-end-of-screen commands. Cursor location must not be disturbed. Next, NOTHING should take you to another line but a line feed or vertical cursor movement. In particular, horizontal cursor movement and text hanging over the end of a line should be gobbled. Otherwise, especially with screen sizes smaller than 24x80, your displays will be very strange. 2. Features desirable but not essential. The following commands are strongly advised. a. Clear screen and home cursor, driven by an ASCII formfeed (12., 0C hex). b. If easily implemented on your system, insert-line and delete-line commands. These involve moving text below the line involved either down or up one line, to either make room for the insertion or cover up the deletion, respectively. c. Some way of stopping a display as it's going by, useful while examining files while in the F(iler. For systems with an interrupt-driven keyboard, this is easy -- your interrupt handler simply examines whatever you've just typed; if it's your "freeze output" command, then the system hangs up until the command is typed a second time. Usually, this command is a "control S" or 13 hex. If you have a polled keyboard (the most common kind), then the simplest way to freeze your CRT is to see if a keyboard character has been typed at the time of each linefeed, and proceeding as for an interrupt- driven system if so. d. UCSD recommends a "dump output" command in addition to the "stop output" command. "Dumping" output is just that -- any characters going to your CRT are ignored. I haven't used this much, and I feel it would be much more important if you have a slow terminal, such as one that writes on paper. It is implemented in the same manner as noted above in c. e. At the time you set up stop and/or dump output commands, it is simple to make the commands extend to the printer, as well. Finally, here is a list of embellishments: a. I have an interrupt-driven keyboard, and I have found that a keyboard queue is extremely useful. It works like this: any characters I type, up to a maximum of 16, are accepted by the interrupt handler and stored in a buffer. The characters are removed in a first-in, first-out fashion when the requesting program is ready to accept them by the console input routine. The advantages of this setup are two: 1) my system never drops characters if it is in the middle of doing something while I am typing away, and 2) I can type a series of those UCSD one-letter commands, each of which produces action with the disk, and avoid slowing down the system performance which it is waiting for me to type something after doing something. Normally, you can keep only one character ahead. b. I think it's useful to have a control-character toggle that forces your printer to follow your CRT output. This is helpful for recording program bugs during compilation, for instance. c. My system has another toggle character which, together with a series of secondary commands, allows you to: 1) slow down the rate of scrolling as desired, and 2) switch to a page mode of text outputting, where the screen is filled with text and the system waits until a character is typed before erasing the screen and filling it up again. In this mode, characters hanging over the end of a line are moved to the start of the next one, so I miss nothing. d. Since normally, every ASCII carriage return (13, 0D hex) is followed by an obligate line feed, I think it's useful to designate another control character as an alternate carriage return. This way, my printer can go over the same line of text to underline or retype for boldface. A TABLE OF RESERVED CONTROL CHARACTERS -- UCSD PASCAL Character Meaning Must be recognized by: (decimal) CRT PRINTER 00 NUL (do nothing) X X 07 BEL (beep! or nothing) X X 08 HTAB (horizontal tab) X X 09 BACKSPACE X optional 10 LINEFEED X X 12 FORMFEED recommended recommended 13 CARRIAGE RETURN X X 16 compressed blanks symbol no (handled by in- no ** avoid ** terpreter) Some final remarks. Pascal uses a great deal of memory, and anything you can do to increase the RAM available to the UCSD system will repay you handsomely. If you aren't doing much in the way of mathematics, reassemble the interpreter without the transcendental mathematical functions; the 1K space saved is worth the hassle of going to another disk with the complete system if you need it. Because I have a memory-mapped terminal and most of my console and printer driver software on EPROM, taking up 8K of room, I am trying to get a bank switching scheme going so I can replace that 8K with RAM and then switch to the console drivers when needed, character by character. I recognize that for a novice without much programming experience, the above considerations must seem totally overwhelming. You're probably better off buying a system that someone has already set up and has running. However, if you've had SOME assembly language experience, get the CP/M-compatible disk from us that has complete BIOS drivers already present, with a good deal of help on one of them (BOOTER) to assist you in reconfiguring the drivers to your system. ======================================================================================== DOCUMENT :usus Folder:VOL01:initvar.text ======================================================================================== PROCEDURE Initvar1; (* initializing the following variables: *) (VAR topofstack, currlinepos, currmargin: integer; VAR keyword : keywordtable; VAR dblchars : dblchrset; VAR dblchar : dblchartable; VAR sglchar : sglchartable; VAR recordseen : boolean; VAR currchar, nextchar: charinfo; VAR currsym, nextsym: symbolinfo); BEGIN topofstack := 0; currlinepos := 0; currmargin := 0; recordseen := false; keyword [progsym ] := 'program '; keyword [funcsym ] := 'function '; keyword [procsym ] := 'procedure '; keyword [labelsym ] := 'label '; keyword [constsym ] := 'const '; keyword [typesym ] := 'type '; keyword [varsym ] := 'var '; keyword [beginsym ] := 'begin '; keyword [repeatsym ] := 'repeat '; keyword [recordsym ] := 'record '; keyword [casesym ] := 'case '; keyword [casevarsym] := 'case '; keyword [ofsym ] := 'of '; keyword [forsym ] := 'for '; keyword [whilesym ] := 'while '; keyword [withsym ] := 'with '; keyword [dosym ] := 'do '; keyword [ifsym ] := 'if '; keyword [thensym ] := 'then '; keyword [elsesym ] := 'else '; keyword [endsym ] := 'end '; keyword [untilsym ] := 'until '; dblchars := [becomes, opencomment]; dblchar [becomes ] := ':=' ; dblchar [opencomment] := '(*' ; sglchar [semicolon ] := ';' ; sglchar [colon ] := ':' ; sglchar [equals ] := '=' ; sglchar [openparen ] := '(' ; sglchar [closeparen ] := ')' ; sglchar [openbracket ] := '{' ; sglchar [closebracket] := '}' ; sglchar [period ] := '.' ; END (*Initvar1*); PROCEDURE Initvar2 (VAR ppoption: optiontable); BEGIN WITH ppoption [progsym] DO BEGIN optionsselected := [blanklinebefore, spaceafter]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [funcsym] DO BEGIN optionsselected := [blanklinebefore, dindentonkeys, spaceafter]; dindentsymbols := [labelsym, constsym, typesym, varsym]; gobbleterminators:= [] END; WITH ppoption [procsym] DO BEGIN optionsselected := [blanklinebefore, dindentonkeys, spaceafter]; dindentsymbols := [labelsym, constsym, typesym, varsym]; gobbleterminators:= [] END; WITH ppoption [labelsym] DO BEGIN optionsselected := [blanklinebefore, spaceafter, indenttoclp]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [constsym] DO BEGIN optionsselected := [blanklinebefore, dindentonkeys, spaceafter, indenttoclp]; dindentsymbols := [labelsym]; gobbleterminators:= [] END; WITH ppoption [typesym] DO BEGIN optionsselected := [blanklinebefore, dindentonkeys, spaceafter, indenttoclp]; dindentsymbols := [labelsym, constsym]; gobbleterminators:= [] END; WITH ppoption [varsym] DO BEGIN optionsselected := [blanklinebefore, dindentonkeys, spaceafter, indenttoclp]; dindentsymbols := [labelsym, constsym, typesym]; gobbleterminators:= [] END; WITH ppoption [beginsym] DO BEGIN optionsselected := [dindentonkeys, indentbytab, crafter]; dindentsymbols := [labelsym, constsym, typesym, varsym]; gobbleterminators:= [] END; WITH ppoption [repeatsym] DO BEGIN optionsselected := [indentbytab, crafter]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [recordsym] DO BEGIN optionsselected := [indentbytab, crafter]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [casesym] DO BEGIN optionsselected := [spaceafter, indentbytab, gobblesymbols, crafter]; dindentsymbols := []; gobbleterminators:= [ofsym] END; WITH ppoption [casevarsym] DO BEGIN optionsselected := [spaceafter, indentbytab, gobblesymbols, crafter]; dindentsymbols := []; gobbleterminators:= [ofsym] END; WITH ppoption [ofsym] DO BEGIN optionsselected := [crsuppress, spacebefore]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [forsym] DO BEGIN optionsselected := [spaceafter, indentbytab, gobblesymbols, crafter]; dindentsymbols := []; gobbleterminators:= [dosym] END; WITH ppoption [whilesym] DO BEGIN optionsselected := [spaceafter, indentbytab, gobblesymbols, crafter]; dindentsymbols := []; gobbleterminators:= [dosym] END; WITH ppoption [withsym] DO BEGIN optionsselected := [spaceafter, indentbytab, gobblesymbols, crafter]; dindentsymbols := []; gobbleterminators:= [dosym] END; WITH ppoption [dosym] DO BEGIN optionsselected := [crsuppress, spacebefore]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [ifsym] DO BEGIN optionsselected := [spaceafter, indentbytab, gobblesymbols, crafter]; dindentsymbols := []; gobbleterminators:= [thensym] END; WITH ppoption [thensym] DO BEGIN optionsselected := [indentbytab, crafter]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [elsesym] DO BEGIN optionsselected := [crbefore, dindentonkeys, dindent, indentbytab, crafter]; dindentsymbols := [ifsym, elsesym]; gobbleterminators:= [] END; WITH ppoption [endsym] DO BEGIN optionsselected := [crbefore, dindentonkeys, dindent, crafter]; dindentsymbols := [ifsym, thensym, elsesym, forsym, whilesym, withsym, casevarsym, colon, equals]; gobbleterminators:= [] END; WITH ppoption [untilsym] DO BEGIN optionsselected := [crbefore, dindentonkeys, dindent, spaceafter, gobblesymbols, crafter]; dindentsymbols := [ifsym, thensym, elsesym, forsym, whilesym, withsym, colon, equals]; gobbleterminators:= [endsym, untilsym, elsesym, semicolon] END END (*Initvar2*); PROCEDURE Initvar3 (VAR ppoption: optiontable); BEGIN WITH ppoption [becomes] DO BEGIN optionsselected := [spacebefore, spaceafter, gobblesymbols]; dindentsymbols := []; gobbleterminators:= [endsym, untilsym, elsesym, semicolon] END; WITH ppoption [opencomment] DO BEGIN optionsselected := [crsuppress]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [closecomment] DO BEGIN optionsselected := [crsuppress]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [semicolon] DO BEGIN optionsselected := [crsuppress, dindentonkeys, crafter]; dindentsymbols := [ifsym, thensym, elsesym, forsym, whilesym, withsym, colon, equals]; gobbleterminators:= [] END; WITH ppoption [colon] DO BEGIN optionsselected := [spaceafter, indenttoclp]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [equals] DO BEGIN optionsselected := [spacebefore, spaceafter, indenttoclp]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [openparen] DO BEGIN optionsselected := [gobblesymbols]; dindentsymbols := []; gobbleterminators:= [closeparen] END; WITH ppoption [closeparen] DO BEGIN optionsselected := []; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [openbracket] DO BEGIN optionsselected := [crsuppress]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [closebracket] DO BEGIN optionsselected := [crsuppress]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [period] DO BEGIN optionsselected := [crsuppress]; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [endoffile] DO BEGIN optionsselected := []; dindentsymbols := []; gobbleterminators:= [] END; WITH ppoption [othersym] DO BEGIN optionsselected := []; dindentsymbols := []; gobbleterminators:= [] END; END (* Initvar3 *); ======================================================================================== DOCUMENT :usus Folder:VOL01:inoutready.text ======================================================================================== ; FUNCTION INPUT(PORT) AND FUNCTION OUTPUT(PORT) ; INPUT AND OUTPUT FROM SPECIFIED I/O PORTS. FUNCTIONS RETURN VALUES ; AS INTEGERS FOR MORE CONVENIENT TESTING. ; PORT RANGE MUST BE BETWEEN 0 AND 255. (NO TESTING IS DONE) ; I:=INPUT(2) J:=OUTPUT(10) .FUNC INPUT,1 ;ONE ARGUMENT POP HL ;RETURN ADDR POP DE ;ZERO POP DE ;ZERO POP DE ;ARGUMENT LD A,E ;LOW BYTE TO A LD ($+4),A ;MAKE INPUT CMND IN A,(0) ;INPUT TO A LD E,A ;DATA INPUT TO E PUSH DE ;BACK ON STACK JP (HL) ;EXIT .END ; PROCEDURE OUTPUT(PORT,NUMBER) ; INPUT AND OUTPUT FROM SPECIFIED I/O PORTS. FUNCTIONS RETURN VALUES ; AS INTEGERS FOR MORE CONVENIENT TESTING. ; PORT RANGE MUST BE BETWEEN 0 AND 255. (NO TESTING IS DONE) ; OUTPUT(10,65) .PROC OUTPUT,2 ;ONE ARGUMENT POP HL ;RETURN ADDR POP BC ;ARGUMENT 2 (NUMBER) POP DE ;ARGUMENT 1 (PORT) LD A,E ;LOW BYTE TO A LD ($+5),A ;MAKE OUTPUT CMND LD A,C ;NUMBER TO A OUT (0),A ;OUTPUT TO A JP (HL) ;EXIT .END ; THIS FUNCTION CALLS THE CP/M CONSOLE READY ENTRY POINT AND RETURNS ; A BOOLEAN VALUE (TRUE OR FALSE). CODE WILL OPERATE ON EITHER 8080 OR Z80 ; .FUNC READY ;TESTS CONSOLE CHAR READY AND RETURNS T ! F POP DE ;RETURN ADDR POP HL POP HL ;ZEROS LD L,06H ;CP/M CONSOLE READY ENTRY POINT CALL BIOS LD L,A PUSH HL ;BOOLEAN RESULT TO STACK EX DE,HL ;RETURN ADDR TO HL HERE: JP (HL) ;EXIT BIOS: LD A,(0002H) ;PAGE NO IN LOCATION 02H LD H,A JP (HL) .END ***************************** What follows is another version of the above. ***************************** ; ; .FUNC STAT,3 ; POP HL ;GET RETURN ADDRESS POP DE ;GET ZERO POP BC ;GET ZERO POP BC ;GET MASK POP DE ;GET EXPECTED RESULT LD D,C POP BC ;GET PORT LD A,C ;PUT PORT IN A LD ($1+1),A ;STUFF PORT $1 IN A,(0) ;PORT LOADED ABOVE AND D ;AND DATA & MASK CP E ;COMPARE WITH EXPECTED RESULTS JP NZ,$2 LD DE,1 ;LOAD BOOLEAN TRUE PUSH DE ;RETURN RESULT ON STACK JP (HL) $2 LD DE,0 ;LOAD BOOLEAN FALSE PUSH DE ;RETURN RESULT ON STACK JP (HL) ;RETURN ; ; .FUNC INPUT,2 ; POP HL ;GET RETURN ADDRESS POP DE ;GET ZERO POP BC ;GET ZERO POP DE ;GET MASK POP BC ;GET INPUT PORT LD A,C ;PUT PORT IN A LD ($1+1),A ;STUFF PORT $1 IN A,(0) ;PORT LOADED ABOVE AND E ;MASK DATA LD E,A PUSH DE ;RETURN RESULT ON STACK JP (HL) ;RETURN ; ; .PROC OUTPUT,2 ; POP HL ;GET RETURN ADDRESS POP DE ;GET DATA POP BC ;GET OUTPUT PORT LD A,C ;PUT PORT IN A LD ($1+1),A ;STUFF PORT LD A,E ;PUT DATA IN A $1 OUT (0),A ;PORT LOADED ABOVE JP (HL) ;RETURN ; ; .END ======================================================================================== DOCUMENT :usus Folder:VOL01:introductn.text ======================================================================================== Introduction. The UCSD Pascal language system is one of the most sophisticated microcomputer software systems available today. Because of the ease with which one can write and maintain high quality programs of most types, from systems software to business applications to games, the UCSD system promises to be the vanguard of an enormous interest in Pascal in the coming decade. Already a number of other Pascal implementations have appeared for microprocessors, though none so complete. However, by the time you have received this disk, several full-standard native-code compilers will have been released for microprocessors. UCSD Pascal compiles its programs to P-code, designed for a hypothetical 16-bit stack machine that must be emulated in software on most microprocessors. Even though this P-code interpretation system runs three times slower than assembly language, it is much faster than any other interpretive language available for micros, and has the additional advantage that P-code occupies approximately one third the space of native machine language. (Now, however, at least two manufacturers have produced computers that execute P-code directly, as their machine language, offering extremely rapid execution.) In addition, once the P-code interpreter has been installed, programs written in UCSD Pascal may be run on any microprocessor without modification. Even the disk formats are the same, except for the minifloppies used for the Apple, North Star, or TRS-80. So disk software in source or object form may be freely shared among users of such diverse machines as a PDP-11 or an 8080. The Pascal Users Group. It would seem natural for a large users group to arise to share software. To date, however, only the original Pascal Users Group ("PUG") serves this function. The PUG sprang into existence in 1976 to serve as a forum for the then few hundred Pascal programmers. Primarily, they support the standard language based on the Jensen and Wirth Pascal User Manual and Report, discuss the horrors certain programmers would like to add to the language to make it fit their needs, and report on available Pascal implementations and programmer opportunities. Only secondarily does the PUG disseminate software (based on Jensen and Wirth Pascal), although since 1978 the PUG has published several superb "software tools", such as automatic formatters to print programs clearly and a large and extremely sophisticated text formatter. They can be reached c/o Rick Shaw, Digital Equipment Corporation, 5775 Peachtree Dunwoody Road, Atlanta, Georgia 30342. A subscription is now $6 per academic year. I suggest you start your collection from the 1977-1978 year. (Back issues are available at $10 per academic year.) The PUG newsletter presents several difficulties to the user of UCSD Pascal who wishes to share software. First, relatively little software is published, albeit that which does appear is of high quality. Second, the programs must be adapted for UCSD Pascal. It turns out that this task is trivial, and concerns primarily disk i/o. Third, the programs are a little slower because the nonstandard UCSD functions like strings aren't used; strings run more quickly on a UCSD system than the character-by-character approach needed by standard Pascal. The overwhelming problem, however, is that the Pascal Users Group publication, the "Pascal News," appears only on PAPER (yecch!). And even if they did use machine-readable media, most members run large computers that talk to each other via tape. So you have to type the software into the machine on your own. I can assure you, having done it, that this is no mean task. A UCSD Pascal Users Group on machine-readable media. In the interests of promoting the more widespread use of Pascal and building up a sizable program base, Datamed Research has announced the formation of a UCSD Pascal users' group. It takes a form similar to the CP/M Users Group: all offerings will be on 8-inch, single density, IBM-compatible soft-sectored floppies, offered virtually at cost ($10 per disk). Software will be donated by interested users. Software donors will receive a free disk volume of their choice in acknowledgement of their donation. For software to be accepted for distribution it MUST (a) work (no known bugs) and (b) come with at least adequate documentation on the disk. Further, with rare exceptions it must be supplied in source code to allow other users to adapt it to their systems. There is one exception to the requirement for source code. If you were developing a sophisticated program that you hoped to sell, but needed assistance in discovering remaining bugs and system incompatibilities, you might donate the interim P-code to the users group. Then, users who first discovered a particular problem or gave other feedback you considered valuable would receive an incentive such as a discount on the completed program. In the meantime, users would benefit from a program that worked most of the time. Potential sources of Pascal software abound; by no means must you donate only original work. There is a mountain of public-domain Basic software that is easily adapted to Pascal. In the process, you can usually spruce up the program a good deal, because Pascal is so much easier to work with than Basic. It will be important, in addition, for the users to begin a library of Pascal procedures and functions to handle the more common programming problems. For example, we need a set of mathematical functions for complex variables, statistical functions, and basic business software support (routines to translate integers into dollars and cents and vice versa) to realize the full power of the langwage. I am presently writing a program which will automate the production of CRT screen masks and (more exciting) handle data input from the CRT directly. This program will accept in simplified form the desired CRT mask directly from the system editor, plus needed data about the variables to be typed in by the user. The program will generate Pascal source code for incorporation into your applications programs and handle automatically things like goof proofing (preventing the program from crashing if the wrong`types of data are entered), variable declarations, saving the CRT mask data within the procedure or on the disk as you wished, etc. By the way, since it is relatively trivial to transfer text from the UCSD disk format (similar to the PDP-11 RT11 format) to CP/M, all volumes will also be available on CP/M disks for those using CP/M-compatible Pascal. However, you will be on your own to get the programs to fit into your memory (remember that native code versions are three times larger) and adapted to your system. We will be happy, though, to accept Pascal software on CP/M disks if it can be readily adapted to the UCSD system. Software already in the hopper as of February 15, 1980, includes: 1. The powerful pretty printer and formatting programs, to beautify Pascal source code, from the Pascal News Vol 13. 2. A Pascal driver for a D.C. Hayes modem, so your computers can talk with one another. This should not be hard to modify for other modems. Two versions of this program have been prepared by different authors. 3. A file printer offering several options in page headings and page numbering, as well as single to quad line spacing. Good for programs and manuscripts. 4. An assortment of games, ranging from CHASE to SKYLANES. (As of yet, no STARTREK.) 5. Two programs in Pascal to convert UCSD-format disks to the CP/M format, and vice versa. 6. A nifty restructuring of the 8080/Z-80 interpreter and BIOS to support disks formatted with 512-byte blocks (single or double density), for a 23% greater disk capacity and a breathtaking increasw in disk access speed, as well as a slight shrinkage of the interpreter. The modified BIOS accepts 128- byte and 512-byte sectored disks transparently, although you have to reboot if you change disk density. In addition, the BIOS contains complete cursor-handling routines for a dumb terminal such as an ADM-3A. Note that this offering will be on two disks: one of UCSD format (interpreter sources, including changes made to the original) and the other CP/M compatible, so your CP/M-based assemblers and editors can work on the code. (However, the CP/M disk will be translated to UCSD format for those without CP/M. Not recommended, however.) 7. If you've tried to get up UCSD Pascal in a CP/M environment, you've noticed that the UCSD system is considerably more demanding of your BIOS than was CP/M. We have notes on providing the extra functions required, plus many of the aspects of the 8080/Z-80 implementation not documented. Possible future directions. Since there is little question that Pascal will grow by leaps and bounds, the major question is how to keep up with the machine-readable formats required by the various micros and minis utilizing Pascal. For now, we are limited to standard 8-inch floppies, and if there were enough demand I would consider distributing the volumes in hard-copy form at a modest increase in price for those who could not utilize full-size disks. But perhaps there are others with the hardware capabilities of transferring programs from one format to another (e.g., to North Star or Apple disks) or who are willing to copy the smaller disks for distribution. If we can provide these services, then other formats could be distributed as well. Although programs would be the main emphasis, I hope to have other features on the disks as well as software. Information on programming tips would certainly be a useful addition. For example, there are a number of "hidden gotchas" in the UCSD system, as well as features that are inadequately documented. Also, I don't think it's clear just which programming techniques are the most portable from system to system. For example, including a PAGE (OUTPUT) within a program in my system clears my screen or causes a formfeed on the printer. It does nothing in systems that do not recognize an ASCII formfeed character (12 decimal). One could clear the screen on ANY UCSD system by jumping to the bottom of the screen, doing 24 WRITELN's, then jumping to the upper left of the screen. Is there an easier way that will always work? Finally, we should share algorithms and reviews of commercial Pascal software. For further information. You can find out more about the present status of the users group by sending a self-addressed, stamped envelope to the following address: UCSD Pascal Users Group DATAMED RESEARCH 1433 Roscomare Road Los Angeles, CA 90024 Alternatively, 8-inch floppies can be ordered at $10 per volume. Make sure you specify UCSD or CP/M format. ======================================================================================== DOCUMENT :usus Folder:VOL01:l.text ======================================================================================== PROGRAM LISTFILE; CONST linesperpage = 60; pagewidth = 80; (* columns per line *) quarterwidth = 20; VAR printhead, printfname: boolean; i, pageno, startpage, endpage, LFname, Lmsg: integer; ioerror: 0..12; lineno: 0..70; spacing: 1..4; spaceL, spaceR: -15..pagewidth; formfeed: char; (* if your system needs nulls or other char to move your printer to the top of the next page, make formfeed an array and fill it with whatever you need. *) s: string [135]; filename: string [25]; msg: string; f, list: text; PROCEDURE INITIALIZE; VAR ch: char; successful: boolean; BEGIN Formfeed := CHR (12); (* this is what my printer wants to start new page *) Successful := false; REPEAT Write ('Please type name of file to be listed --> '); READLN (filename); LFname := LENGTH (filename); IF LFname = 0 THEN EXIT (Program); (*$I-*) RESET (f, filename); (*$I+*) ioerror := IORESULT; IF ioerror = 0 THEN successful := true ELSE BEGIN Writeln ('Oops, there''s a problem. IORESULT = ', ioerror, '.'); Writeln ('Try again. To quit just type '); Writeln END UNTIL Successful; REWRITE (list, 'PRINTER:'); Write ('Single-space each line? '); Read (ch); Writeln; IF (ch IN ['Y', 'y']) THEN Spacing := 1 ELSE BEGIN REPEAT Write ('How many spaces per line (1 - 4)? '); Read (ch); Writeln UNTIL (ch IN ['1'..'4']); Spacing := ORD (ch) - ORD ('0') END; WRITE ('Do you wish a page heading? '); READ (ch); WRITELN; Msg := ''; (* empty string *); IF (ch in ['Y', 'y']) THEN BEGIN printhead := TRUE; WRITELN ('If you wish a date or other heading or title,', ' type it here: '); READLN (msg); Lmsg := LENGTH (msg); WRITE ('Do you want to include the filename in the heading? '); READ (ch); WRITELN; IF (ch IN ['Y', 'y']) THEN (* yes, print it and expand heading as well. *) BEGIN Printfname := TRUE; (* Don't forget to change SpaceL and SpaceR here if you're not going to expand your page heading to double width. *) SpaceL := (pagewidth DIV 4) - (LFname + (Lmsg DIV 2)); IF spaceL < 1 THEN spaceL := 1; SpaceR := (pagewidth DIV 2) - (LFname + SpaceL + Lmsg + 7) END ELSE (* no, skip filename and don't expand heading. *) BEGIN Printfname := FALSE; SpaceL := 0; SpaceR := pagewidth - (Lmsg + 7) END; IF spaceR < 1 THEN spaceR := 1 END ELSE printhead := FALSE; Pageno := 1; WRITE ('Do you want to print the whole file? '); READ (ch); WRITELN; IF (ch in ['Y', 'y']) THEN BEGIN Startpage := 0; Endpage := MAXINT END ELSE BEGIN WRITE ('Start with page no. --> '); READ (startpage); WRITE ('End after page no. --> '); READ (endpage); WRIToLN END END (*initialize*); PROCEDURE HEADING; (* This procedure prints the following: 1. If printfilename flag is on, then the filename is flush left, the message centered, and the page number flush right, all double width. 2. Otherwise any message is flush left and the pageno flush right, standard width char. In addition, the page 1 heading is skipped.*) BEGIN IF printfname THEN WRITE (list, CHR (14) (*char to expand title*), filename, ' ':spaceL); i := SpaceR; (* move 'page' to right if pageno less than 3 digits *) IF pageno < 10 THEN i :=3i + 1; IF pageno < 100 THEN i := i + 1; IF printfname OR (pageno > 1) THEN WRITE (list, msg, ' ':i, 'Page ', pageno); Writeln (list); Writeln (list); Writeln (list); Lineno := 4 END; PROCEDURE PRINTPAGE; BEGIN WHILE (NOT EOF(f)) AND (lineno <= linesperpage) DO BEGIN READLN (f,s); WRITE (list,s); FOR i := 1 TO Spacing DO BEGIN Writeln (list); Lineno := SUCC (lineno) END END; WRITE (list, formfeed); Pageno := SUCC (pageno) END; PROCEDURE DUMMYPAGE; BEGIN IF printhead THEN lineno := 4 ELSE lineno := 1; WHILE (NOT EOF (f)) AND (lineno <= linesperpage) DO BEGIN READLN (f,s); FOR i := 1 TO Spacing DO Lineno := SUCC (lineno) END; Pageno := SUCC (pageno) END; {Main program]} BEGIN Initialize; WHILE (startpage > pageno) AND (NOT EOF(f)) DO Dummypage; WHILE (endpage >= pageno) AND (NOT EOF(f)) DO BEGIN Lineno := 1; IF printhead THEN Heading; Printpage END END. ======================================================================================== DOCUMENT :usus Folder:VOL01:modem.text ======================================================================================== {VERSION 14 MAR 1979} PROGRAM MODEM; CONST WORD = 31; {8 BITS, NO PARITY, 2 STOP BITS} DATA = 128; {MODEM DATA PORT} STAT = 129; {MODEM STATUS PORT} MODE = 130; {MODEM CONTROL PORT} FOREVER = FALSE; SCREENWIDTH=64; {DISPLAY SCREEN WIDTH IN CHAR} CLRSCR = 26; {CLEAR SCREEN CODE (ADM-3)} ANMESS = 'PASCAL 80/103 MODEM SPEAKING'; DELAYCON= 75; {TIMING DELAY CONST Z-80 = 150, 8080 = 75} TYPE INSET = SET OF 0..7; ATYPE = RECORD CASE BOOLEAN OF TRUE: (CHAREP:CHAR); FALSE:(SETREP:INSET) END; PACKEDNUM = RECORD CASE BOOLEAN OF TRUE: (INT:INTEGER); FALSE:(CH:PACKED ARRAY[0..1] OF CHAR) END; PACKEDBYTE = RECORD CASE BOOLEAN OF TRUE: (CH:CHAR); FALSE:(PNUM:PACKED ARRAY[0..1] OF 0..15) END; VAR MODEBYTE: ATYPE; INBYTE: ATYPE; IBYTE: ATYPE; INB: ATYPE; DBYTE: ATYPE; CBYTE: ATYPE; CSET: ATYPE; TXE,TXOFF:INSET; RRF,TRE: INSET; BRS: INSET; NOTBRS: INSET; ORGANS: INSET; OFFMASK: INSET; ONMASK: INSET; MS,NOTMS: INSET; CARDET: INSET; RNGDET: INSET; MASK: INSET; BK: INSET; CRC: PACKEDNUM; C: PACKED ARRAY[0..1] OF CHAR; SHORTBUF: PACKED ARRAY[0..4] OF CHAR; IOBUF: PACKED ARRAY[0..519] OF CHAR; FILEBUF: PACKED ARRAY[0..511] OF CHAR; SOH: CHAR; STX: CHAR; EOT: CHAR; ETX: CHAR; ACK: CHAR; NAK: CHAR; MWORD: CHAR; CONTRLB: CHAR; CONTRLC: CHAR; CONTRLD: CHAR; CONTRLE: CHAR; CONTRLH: CHAR; BELL: CHAR; CR,LF: CHAR; NULL: CHAR; EOTFLG: BOOLEAN; EFLAG: BOOLEAN; HEX: BOOLEAN; BLK: BOOLEAN; CPM: BOOLEAN; HISPEED: BOOLEAN; CALLMADE: BOOLEAN; AUTOLF: BOOLEAN; FIRSTBLK: BOOLEAN; EXITFLG: BOOLEAN; RECFLG: BOOLEAN; CONECHO: BOOLEAN; MESSAGE: STRING[30]; PHONENUM: STRING[20]; S: STRING[1]; FUNCT: STRING[64]; NAME: STRING; BLKSIZE: INTEGER; BLKINDX: INTEGER; BLKNUM: INTEGER; DISPINDX: INTEGER; TIMER: INTEGER; NAKCNT: INTEGER; I: INTEGER; RBINDX: 0..512; UBLKNUM: INTEGER; TEXTFILE: TEXT; UTEXTFILE:FILE; FUNCTION READY:BOOLEAN; EXTERNAL; FUNCTION INPUT(PORT:INTEGER):CHAR; EXTERNAL; PROCEDURE OUTPUT(PORT:INTEGER;DATA:CHAR); EXTERNAL; FUNCTION CRC16(CRC0,CRC1,NEXTBYTE:CHAR):INTEGER; EXTERNAL; PROCEDURE INITIALIZE; BEGIN SOH:=CHR(1); {ASCII CONTROL CODES} STX:=CHR(2); ETX:=CHR(3); EOT:=CHR(4); ACK:=CHR(6); NAK:=CHR(21); TXE:=[1]; {02H TRANSMIT ENABLE} TXOFF:=[0,2,3,4,5,6,7]; {0FDH TRANSMIT DISABLE} RRF:=[0]; {01H RECEIVE REGISTER FILLED} BRS:=[0]; {01H BIT RATE SELECT} TRE:=[1]; {02H TRANSMIT REGISTER EMPTY} MS:=[2]; {04H MODE SELECT (1=ORIG 0=ANSW)} CARDET:=[6]; {40H CARRIER DETECT} RNGDET:=[7]; {80H RING DETECT} OFFMASK:=[7]; {80H} ONMASK:=[0,1,2,3,4,5,6]; {7FH} NOTBRS:=[1,2,3,4,5,6,7]; {0FEH NOT BRS} NOTMS:=[0,1,3,4,5,6,7]; {0FBH NOT MS) ORGANS:=[2]; {04H ORIGINATE/ANSWER BIT} BK:=[3]; {08H BREAK BIT) NULL:=CHR(0); {00H} CONTRLB:=CHR(2); {02H} CONTRLC:=CHR(3); {03H} CONTRLD:=CHR(4); {04H} CONTRLE:=CHR(5); {05H} CONTRLH:=CHR(8); {08H} BELL:=CHR(7); {07H} CR:=CHR(13); {13H} LF:=CHR(10); {10H} MWORD:=CHR(WORD); EOTFLG:=FALSE; MODEBYTE.SETREP:=BRS; {01H INITIALIZE TO 300 BAUD} HISPEED:=TRUE; CPM:=FALSE; BLK:=FALSE; AUTOLF:=FALSE; EXITFLG:=FALSE; CONECHO:=TRUE; S:=' '; OUTPUT(MODE,MODEBYTE.CHAREP); OUTPUT(STAT,NULL) END; PROCEDURE BINARY(NUMBER:INSET); VAR I:INTEGER; BEGIN FOR I:=7 DOWNTO 0 DO IF I IN NUMBER THEN WRITE('1') ELSE WRITE('0') END; PROCEDURE HEXOUT (C:CHAR); TYPE HEX = PACKED ARRAY[0..1] OF 0..15; ALIASTYPE = RECORD CASE BOOLEAN OF TRUE: (CHAREP:CHAR); FALSE: (HEXREP:HEX) END; VAR ALIAS:ALIASTYPE; I:0..1; BEGIN ALIAS.CHAREP:=C; FOR I:=1 DOWNTO 0 DO IF ALIAS.HEXREP[I] < 10 THEN WRITE(ALIAS.HEXREP[I]) ELSE WRITE(CHR(ALIAS.HEXREP[I]+55)); END; PROCEDURE DELAY(N:INTEGER); VAR I,J:INTEGER; BEGIN FOR J:=1 TO N DO FOR I:=1 TO DELAYCON DO; END; PROCEDURE BREAK; {SENDS 120 MS OF SPACE} BEGIN WRITELN; WRITELN(' *** Break char received from keyboard ***'); WITH MODEBYTE DO BEGIN SETREP:=SETREP+BK; {08H TURNS ON BREAK BIT} OUTPUT(MODE,CHAREP); DELAY(3); {120 MS (OR SO) OF DELAY} SETREP:=SETREP-BK; {TAKE IT OUT} OUTPUT(MODE,CHAREP); {RESET} END; {WITH} END; {BREAK} PROCEDURE OFFHOOK; BEGIN MODEBYTE.SETREP:=MODEBYTE.SETREP+OFFMASK; OUTPUT(MODE,MODEBYTE.CHAREP) END; PROCEDURE ONHOOK; BEGIN MODEBYTE.SETREP:=MODEBYTE.SETREP*ONMASK; OUTPUT(MODE,MODEBYTE.CHAREP) END; PROCEDURE TRANON; BEGIN MODEBYTE.SETREP:=MODEBYTE.SETREP+TXE; OUTPUT(MODE,MODEBYTE.CHAREP) END; PROCEDURE TRANOFF; BEGIN MODEBYTE.SETREP:=MODEBYTE.SETREP*TXOFF; OUTPUT(MODE,MODEBYTE.CHAREP) END; PROCEDURE ANCALL; BEGIN IF HISPEED THEN MODEBYTE.SETREP:=MODEBYTE.SETREP+BRS ELSE MODEBYTE.SETREP:=MODEBYTE.SETREP*NOTBRS; MODEBYTE.SETREP:=MODEBYTE.SETREP*NOTMS; OUTPUT(MODE,MODEBYTE.CHAREP); OUTPUT(STAT,MWORD) END; PROCEDURE ORCALL; BEGIN IF HISPEED THEN MODEBYTE.SETREP:=MODEBYTE.SETREP+BRS ELSE MODEBYTE.SETREP:=MODEBYTE.SETREP*NOTBRS; MODEBYTE.SETREP:=MODEBYTE.SETREP+MS; OUTPUT(MODE,MODEBYTE.CHAREP); OUTPUT(STAT,MWORD) END; PROCEDURE HANGUP; BEGIN EOTFLG:=TRUE; ONHOOK; TRANOFF END; FUNCTION CHECKC:BOOLEAN; {RETURNS TRUE IF ^C ENTERED ON KEYBOARD} BEGIN IF READY THEN BEGIN UNITREAD(2,C[0],1); IF C[0]=CONTRLC THEN CHECKC:=TRUE ELSE CHECKC:=FALSE END END; FUNCTION RECBYTE:CHAR; BEGIN TIMER:=7500; REPEAT TIMER:=TIMER-1; IF(CHECKC OR (TIMER=0)) THEN BEGIN EXITFLG:=TRUE; EXIT(RECBYTE) END; IBYTE.CHAREP:=INPUT(STAT) UNTIL IBYTE.SETREP*RRF<>[]; DBYTE.CHAREP:=INPUT(DATA); RECBYTE:=DBYTE.CHAREP END; PROCEDURE TRANSMIT(DATABYTE:CHAR); BEGIN REPEAT CBYTE.CHAREP:=INPUT(STAT) UNTIL CBYTE.SETREP*TRE<>[]; OUTPUT(DATA,DATABYTE) END; PROCEDURE SBLKSEND(C:CHAR); {SEND SHORT BLOCK} VAR I:0..4; BEGIN WRITELN; SHORTBUF[0]:=SOH; SHORTBUF[1]:=NULL; SHORTBUF[2]:=C; SHORTBUF[3]:=NULL; SHORTBUF[4]:=NULL; CRC.CH[0]:=SHORTBUF[1]; CRC.CH[1]:=SHORTBUF[2]; FOR I:=3 TO 4 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],SHORTBUF[I]); SHORTBUF[3]:=CRC.CH[0]; SHORTBUF[4]:=CRC.CH[1]; FOR I:=0 TO 4 DO BEGIN HEXOUT(SHORTBUF[I]); TRANSMIT(SHORTBUF[I]) END; IF C=ACK THEN WRITE(' ACK') ELSE IF C=NAK THEN WRITE(' NAK',BELL) ELSE IF C=EOT THEN WRITE(' EOT') END; FUNCTION SBLKREC:CHAR; {RECEIVE SHORT BLOCK} VAR I:0..4; BEGIN WRITELN; REPEAT SHORTBUF[0]:=RECBYTE; IF EXITFLG THEN EXIT(SBLKREC); UNTIL SHORTBUF[0]=SOH; FOR I:=1 TO 4 DO BEGIN SHORTBUF[I]:=RECBYTE; HEXOUT(SHORTBUF[I]) END; CRC.CH[0]:=SHORTBUF[1]; CRC.CH[1]:=SHORTBUF[2]; FOR I:=3 TO 4 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],SHORTBUF[I]); IF CRC.INT<>0 THEN BEGIN WRITELN('SHORT BLOCK CRC ERROR - NAK',BELL); SBLKREC:=NAK END ELSE BEGIN SBLKREC:=SHORTBUF[2]; IF SHORTBUF[2]=ACK THEN WRITE(' ACK') ELSE WRITE(' NAK',BELL) END END; PROCEDURE DISPHEX(DISPCHAR:CHAR); BEGIN IF DISPINDX<=SCREENWIDTH THEN HEXOUT(DISPCHAR) ELSE BEGIN DISPINDX:=1; WRITELN; HEXOUT(DISPCHAR) END; DISPINDX:=DISPINDX+2 END; PROCEDURE BLKTRANS(DATABYTE:CHAR); VAR I:INTEGER; C:CHAR; LEN:PACKEDNUM; SEQTYP:PACKEDBYTE; BEGIN IF BLKINDX>BLKSIZE THEN BEGIN REPEAT WRITELN;WRITELN; DISPINDX:=1; BLKINDX:=1; WRITELN('BLOCK ',BLKNUM,' BYTES ',(BLKNUM)*BLKSIZE); IOBUF[0]:=SOH; SEQTYP.PNUM[1]:=BLKNUM MOD 16; SEQTYP.PNUM[0]:=1; IOBUF[1]:=SEQTYP.CH; LEN.INT:=BLKSIZE; IOBUF[2]:=LEN.CH[1]; IOBUF[3]:=LEN.CH[0]; IOBUF[4]:=STX; IOBUF[BLKSIZE+5]:=ETX; IOBUF[BLKSIZE+6]:=NULL; IOBUF[BLKSIZE+7]:=NULL; CRC.CH[0]:=IOBUF[BLKSIZE+6]; CRC.CH[1]:=IOBUF[BLKSIZE+7]; FOR I:=1 TO BLKSIZE+7 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],IOBUF[I]); IOBUF[BLKSIZE+6]:=CRC.CH[0]; IOBUF[BLKSIZE+7]:=CRC.CH[1]; FOR I:=0 TO BLKSIZE+7 DO BEGIN DISPHEX(IOBUF[I]); TRANSMIT(IOBUF[I]) END UNTIL ((SBLKREC=ACK) OR EXITFLG); IF EXITFLG THEN EXIT(BLKTRANS); BLKNUM:=BLKNUM+1 END; IOBUF[BLKINDX+4]:=DATABYTE; BLKINDX:=BLKINDX+1 END; PROCEDURE ANSBACK; VAR I:INTEGER; BEGIN MESSAGE:=ANMESS; FOR I:=1 TO LENGTH(MESSAGE) DO TRANSMIT(MESSAGE[I]); TRANSMIT(CR);TRANSMIT(LF) END; PROCEDURE ANSWCALL; VAR I:INTEGER; CARR:BOOLEAN; BEGIN ANCALL; OFFHOOK; TRANON; CALLMADE:=FALSE; WRITELN; WRITELN('PHONE ANSWERED'); OUTPUT(MODE,MODEBYTE.CHAREP); I:=0; CARR:=FALSE; REPEAT I:=I+1; DELAY(10); INBYTE.CHAREP:=INPUT(STAT); INB.CHAREP:=INPUT(255); IF((INBYTE.SETREP*CARDET<>[]) OR (INB.SETREP*CARDET<>[])) THEN BEGIN CARR:=TRUE; CALLMADE:=TRUE END; UNTIL ((I=20) OR CARR); WRITELN;WRITELN; IF CARR THEN BEGIN ANSBACK; WRITELN('CALL COMPLETE',BELL) END ELSE BEGIN WRITELN; WRITELN(BELL,'NO CARRIER DETECTED IN 10 SECONDS '); HANGUP; WRITELn; WRITE('WAITING FOR RING OR CONTROL B ') END END; PROCEDURE PULSE(N:INTEGER); VAR I,J:INTEGER; BEGIN IF N=0 THEN I:=10 ELSE I:=N; FOR I:=I DOWNTO 1 DO BEGIN ONHOOK; DELAY(1); OFFHOOK; DELAY(1) END; DELAY(10) END; PROCEDURE MAKECALL; VAR I,J:INTEGER; ANSW:BOOLEAN; BEGIN ONHOOK; TRANOFF; ORCALL; WRITELN; WRITE('INPUT TELEPHONE NUMBER '); READLN(PHONENUM); WRITELN; WRITE('DIALING...'); OFFHOOK; DELAY(40); {WAIT FOR DIAL TONE} FOR I:=1 TO LENGTH(PHONENUM) DO BEGIN WRITE(PHONENUM[I]); J:=ORD(PHONENUM[I])-48; IF (PHONENUM[I] IN ['0'..'9']) THEN PULSE(J) END; I:=0; ANSW:=FALSE; CALLMADE:=FALSE; REPEAT I:=I+1; DELAY(10); INBYTE.CHAREP:=INPUT(STAT); INB.CHAREP:=INPUT(255); IF((INBYTE.SETREP*CARDET<>[]) OR (INB.SETREP*CARDET<>[])) THEN ANSW:=TRUE UNTIL ((I=50) OR ANSW); IF ANSW THEN BEGIN CALLMADE:=TRUE; WRITELN; WRITELN('CALL COMPLETE',BELL) END ELSE BEGIN WRITELN; WRITELN('SORRY, NO ANSWER'); WRITELN; WRITE('WAITING FOR RING OR CONTROL B ') END END; PROCEDURE CONNECT; BEGIN MODEBYTE.SETREP:=MODEBYTE.SETREP+TXE; OUTPUT(MODE,MODEBYTE.CHAREP); IF MODEBYTE.SETREP+ORGANS=[] THEN ANSBACK END; PROCEDURE QUIT; BEGIN HANGUP; EXIT(PROGRAM) END; PROCEDURE GETCHAR; {GET CHARACTER FROM MODEM} BEGIN DBYTE.CHAREP:=INPUT(DATA); DBYTE.SETREP:=DBYTE.SETREP*ONMASK; IF DBYTE.CHAREP<>LF THEN WRITE(DBYTE.CHAREP); IF DBYTE.CHAREP=CONTRLD THEN EOTFLG:=TRUE END; FUNCTION CONVERT(VAR NAME:STRING):INTEGER; VAR I,N:INTEGER; S:STRING; BEGIN S:=NAME; N:=0; FOR I:=1 TO LENGTH(NAME) DO BEGIN IF NOT (NAME[I] IN ['0'..'9']) THEN BEGIN CONVERT:=-1; WRITELN('ERROR, NON NUMERIC CHARACTER IN NUMBER',BELL); EXIT(CONVERT) END; N:=N*10+ORD(NAME[I])-48; END; CONVERT:=N END; FUNCTION NEXTSTR(I:INTEGER):BOOLEAN; VAR B,E,J:INTEGER; BEGIN E:=LENGTH(FUNCT); WHILE FUNCT[I]<>' ' DO I:=I+1; WHILE ((FUNCT[I]=' ') AND (I' ' DO I:=I+1; NAME:=COPY(FUNCT,B,I-B); NEXTSTR:=TRUE END; PROCEDURE BLOCK; BEGIN I:=POS('BLOC',FUNCT); BLKSIZE:=128; BLK:=TRUE; BLKINDX:=1; BLKNUM:=0; RBINDX:=512; UBLKNUM:=0; IF NEXTSTR(I) THEN BEGIN BLKSIZE:=CONVERT(NAME); IF BLKSIZE=0 THEN BLK:=FALSE; IF BLKSIZE<0 THEN BEGIN BLKSIZE:=128; EXIT(BLOCK) END ELSE IF BLKSIZE>512 THEN BEGIN BLKSIZE:=512; WRITELN('ERROR, MAXIMUM BLOCK SIZE ALLOWED IS 512 BYTES',BELL) END END ELSE WRITELN('MISSING BLOCK SIZE VALUE') END; PROCEDURE SPEED; VAR NUM:INTEGER; I:INTEGER; BEGIN I:=POS('SPEED',FUNCT); HISPEED:=TRUE; IF NEXTSTR(I) THEN BEGIN IF NAME='300' THEN HISPEED:=TRUE ELSE IF NAME='110' THEN HISPEED:=FALSE ELSE WRITELN('ERROR, SPEED MUST BE 110 OR 300 BAUD') END ELSE WRITELN('MISSING SPEED VALUE, DEFAULT TO 300 BAUD'); IF HISPEED THEN MODEBYTE.SETREP:=MODEBYTE.SETREP+BRS ELSE MODEBYTE.SETREP:=MODEBYTE.SETREP*NOTBRS; OUTPUT(MODE,MODEBYTE.CHAREP) END; FUNCTION READBLKCH:CHAR; {RETURN NEXT CHAR IN DISK FILE} VAR I:INTEGER; BEGIN IF RBINDX>511 THEN BEGIN WRITELN; I:=BLOCKREAD(UTEXTFILE,FILEBUF,1); WRITELN; UBLKNUM:=UBLKNUM+1; RBINDX:=0 END; READBLKCH:=FILEBUF[RBINDX]; RBINDX:=RBINDX+1 END; PROCEDURE WRITEBLK; {WRITE A BLOCK OF CHAR TO DISK FILE} VAR I,J:INTEGER; BEGIN FOR J:=5 TO BLKSIZE+4 DO BEGIN IF RBINDX>511 THEN BEGIN WRITELN; I:=BLOCKWRITE(UTEXTFILE,FILEBUF,1); RBINDX:=0 END; FILEBUF[RBINDX]:=IOBUF[J]; RBINDX:=RBINDX+1 END END; PROCEDURE FLUSHBUFFER; {EMPTY DISK WRITE BUFFER TO DISK} VAR I:INTEGER; BEGIN FOR I:=RBINDX TO 511 DO FILEBUF[I]:=NULL; I:=BLOCKWRITE(UTEXTFILE,FILEBUF,1) END; PROCEDURE TEST; BEGIN RBINDX:=1; BLKSIZE:=512; REWRITE(UTEXTFILE,'TEST.TEXT'); FOR I:=0 TO 511 DO IOBUF[I]:='A'; WRITEBLK; WRITEBLK; FLUSHBUFFER; CLOSE(UTEXTFILE,LOCK) END; FUNCTION RECEIVEBLK:CHAR; {RECEIVE BLOCK RETURN SEQ/TYP} VAR I:INTEGER; LEN:PACKEDNUM; BEGIN NAKCNT:=0; REPEAT REPEAT IOBUF[0]:=RECBYTE; IF EXITFLG THEN BEGIN WRITELN; WRITELN('RECEIVE TIME OUT, NAK SENT',BELL); SBLKSEND(NAK); NAKCNT:=NAKCNT+1; IF NAKCNT=4 THEN EXIT(RECEIVEBLK) ELSE EXITFLG:=FALSE END UNTIL IOBUF[0]=SOH; DISPHEX(IOBUF[0]); FOR I:=1 TO 4 DO BEGIN IOBUF[I]:=RECBYTE; DISPHEX(IOBUF[I]) END; CRC.CH[0]:=IOBUF[1]; CRC.CH[1]:=IOBUF[2]; IF IOBUF[1]=NULL THEN BEGIN FOR I:=3 TO 4 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],IOBUF[I]); IF CRC.INT<>0 THEN BEGIN WRITELN('RECEIVE BLOCK CRC ERROR'); EXIT(PROGRAM) END ELSE RECEIVEBLK:=IOBUF[2] END ELSE BEGIN IF FIRSTBLK THEN BEGIN LEN.CH[1]:=IOBUF[2]; LEN.CH[0]:=IOBUF[3]; BLKSIZE:=LEN.INT; FIRSTBLK:=FALSE END; FOR I:=5 TO BLKSIZE+7 DO BEGIN IOBUF[I]:=RECBYTE; DISPHEX(IOBUF[I]) END; FOR I:=3 TO BLKSIZE+7 DO CRC.INT:=CRC16(CRC.CH[0],CRC.CH[1],IOBUF[I]) END; DISPINDX:=1; IF CRC.INT<>0 THEN SBLKSEND(NAK) UNTIL CRC.INT=0; WRITEBLK; WRITELN; WRITELN('BLOCK ',BLKNUM,' BYTES ',BLKSIZE*BLKNUM); WRITELN; BLKNUM:=BLKNUM+1; IF IOBUF[1]<>NULL THEN SBLKSEND(ACK) ELSE IF IOBUF[2]=EOT THEN SBLKSEND(EOT) END; PROCEDURE RECEIVE; VAR I:INTEGER; ERR:INTEGER; CH:CHAR; BEGIN I:=POS('RECEIVE',FUNCT); IF NEXTSTR(I) THEN BEGIN RECFLG:=TRUE; DISPINDX:=1; RBINDX:=0; BLKNUM:=0; IF POS('HEX',FUNCT)<>0 THEN HEX:=TRUE ELSE HEX:=FALSE; I:=0; {$I-} RESET(UTEXTFILE,NAME); {$I+} ERR:=IORESULT; IF ERR=10 THEN REWRITE(UTEXTFILE,NAME) ELSE IF ERR=0 THEN BEGIN WRITE(NAME,' ALREADY EXISTS, DO YOU WANT TO OVERWRITE IT (Y/N) '); READ(CH); IF CH<>'Y' THEN EXIT(RECEIVE) ELSE REWRITE(UTEXTFILE,NAME) END ELSE BEGIN WRITELN('ERROR IN OPENING FILE ',NAME); EXIT(RECEIVE) END; FIRSTBLK:=TRUE; DBYTE.CHAREP:=INPUT(DATA); {CLEAR MODEM INPUT} WHILE ((RECEIVEBLK<>EOT) AND NOT EXITFLG) DO WRITEBLK; FLUSHBUFFER; IF NOT EXITFLG THEN CLOSE(UTEXTFILE,LOCK) ELSE CLOSE(UTEXTFILE); IF TIMER=0 THEN BEGIN WRITELN;WRITELN; WRITE('RECEIVE TERMINATED NO MESSAGE',BELL) END; EXITFLG:=FALSE END ELSE BEGIN WRITELN; WRITE('MISSING FILE NAME') END END; PROCEDURE SEND; VAR I:INTEGER; ERR:INTEGER; CH:CHAR; BEGIN RECFLG:=FALSE; I:=POS('SEND',FUNCT); IF NEXTSTR(I) THEN BEGIN IF POS('HEX',FUNCT)<>0 THEN HEX:=TRUE ELSE HEX:=FALSE; I:=0; {$I-} IF BLK THEN RESET(UTEXTFILE,NAME) ELSE RESET(TEXTFILE,NAME); {$I+} ERR:=IORESULT; IF ERR<>0 THEN WRITELN('ERROR IN OPENING FILE') ELSE IF BLK THEN BEGIN WHILE NOT EOF(UTEXTFILE) DO BEGIN CH:=READBLKCH; BLKTRANS(CH); IF EXITFLG THEN BEGIN CLOSE(UTEXTFILE); BLK:=FALSE; EXITFLG:=FALSE; IF TIMER=0 THEN BEGIN WRITELN; WRITELN('TRANSMIT TIME-OUT NO ACKNOWLEDGEMENT',BELL); END; EXIT(SEND) END END; CLOSE(UTEXTFILE); BLK:=FALSE; SBLKSEND(EOT) END ELSE WHILE NOT EOF(TEXTFILE) DO BEGIN IF CHECKC THEN BEGIN CLOSE(TEXTFILE); EXIT(SEND) END ELSE BEGIN READ(TEXTFILE,CH); TRANSMIT(CH); IF HEX THEN BEGIN HEXOUT(CH); I:=I+2; IF I> SCREENWIDTH THEN BEGIN I:=0; WRITELN END END ELSE BEGIN WRITE(CH); IF EOLN(TEXTFILE) THEN WRITELN END; IF EOLN(TEXTFILE) THEN BEGIN TRANSMIT(CR); IF CPM THEN TRANSMIT(LF) END END END; CLOSE(TEXTFILE) END ELSE BEGIN WRITELN; WRITE('MISSING FILE SPECIFICATION',BELL) END END; PROCEDURE STATUS; {DISPLAY CURRENT STATUS} BEGIN WRITE(CHR(CLRSCR)); WRITELN;WRITELN; WRITE('CURRENT MODEM STATUS':45); WRITELN;WRITELN;WRITELN; WRITE('PHONE '); IF MODEBYTE.SETREP*[7]<>[] THEN WRITELN('OFFHOOK') ELSE WRITELN('ONHOOK'); WRITE('MODE '); IF MODEBYTE.SETREP*[2]<>[] THEN WRITELN('ORIGINATE') ELSE WRITELN('ANSWER'); WRITE('BAUD RATE '); IF MODEBYTE.SETREP*[0]<>[] THEN WRITELN('110 BAUD') ELSE WRITELN('300 BAUD'); WRITE('TRANSMITTER '); IF MODEBYTE.SETREP*[1]<>[] THEN WRITELN('ON') ELSE WRITELN('OFF'); WRITE('CARRIER '); CBYTE.CHAREP:=INPUT(STAT); IF CBYTE.SETREP*[6]<>[] THEN WRITELN('ON') ELSE WRITELN('OFF'); END; PROCEDURE CONVERSE; BEGIN EFLAG:=FALSE; EOTFLG:=FALSE; CONNECT; REPEAT INBYTE.CHAREP:=INPUT(STAT); INB.CHAREP:=INPUT(255);M IF((INBYTE.SETREP*CARDET<>[]) OR (INB.SETREP*CARDET<>[])) THEN BEGIN IBYTE.CHAREP:=INPUT(STAT); IF IBYTE.SETREP*RRF<>[] THEN GETCHAR; IF READY THEN BEGIN UNITREAD(2,C[0],1); IF C[0]=NAK THEN BREAK; IF CONECHO THEN WRITE(C[0]); IF((C[0]=CR) AND AUTOLF) THEN TRANSMIT(LF); IF C[0]=CONTRLE THEN EFLAG:=TRUE; IF C[0]=CONTRLH THEN BEGIN WRITE(' ',CONTRLH); TRANSMIT(CONTRLH); TRANSMIT(' ') END; IF C[0]=CONTRLD THEN BEGIN EOTFLG:=TRUE; WRITELN; WRITELN('EOT') END; TRANSMIT(C[0]) END; END ELSE BEGIN WRITELN; WRITE('LOST CARRIER',BELL); EOTFLG:=TRUE END UNTIL (EOTFLG OR EFLAG); END; {CONVERSE} PROCEDURE RING; BEGIN REPEAT WRITELN;WRITELN; WRITE('WAITING FOR RING OR CONTROL B '); CALLMADE:=FALSE; EFLAG:=FALSE; EOTFLG:=FALSE; REPEAT IF READY THEN BEGIN UNITREAD(2,C[0],1); IF C[0]=CONTRLB THEN MAKECALL; IF C[0]=CONTRLE THEN EXIT(RING) END; INBYTE.CHAREP:=INPUT(STAT); INB.CHAREP:=INPUT(255); IF((INBYTE.SETREP*RNGDET=[]) OR (INB.SETREP*RNGDET<>[])) THEN ANSWCALL UNTIL CALLMADE; CONVERSE; IF NOT EFLAG THEN HANGUP; UNTIL EFLAG END; {RING} BEGIN {MAIN PROG} WRITELN;WRITELN;WRITELN; WRITELN('PASCAL MODEM PROGRAM':45); INITIALIZE; REPEAT WRITELN;WRITELN; WRITE('ENTER FUNCTION '); UNITREAD(2,C[0],1); IF C[0]=CONTRLC THEN QUIT; WRITE(C[0]); READLN(FUNCT); S[1]:=C[0]; FUNCT:=CONCAT(S,FUNCT,' '); IF POS('CONECHO',FUNCT)<>0 THEN CONECHO:=NOT CONECHO; IF POS('STAT',FUNCT)<>0 THEN STATUS; IF POS('CPM',FUNCT)<>0 THEN CPM:=NOT CPM; IF POS('AUTOLF',FUNCT)<>0 THEN AUTOLF:=NOT AUTOLF; IF POS('SPEED',FUNCT)<>0 THEN SPEED; IF POS('BLOC',FUNCT)<>0 THEN BLOCK; IF POS('PHONE',FUNCT)<>0 THEN RING; IF POS('CONV',FUNCT)<>0 THEN CONVERSE; IF POS('SEND',FUNCT)<>0 THEN SEND; IF POS('RECEI',FUNCT)>0 THEN RECEIVE UNTIL FOREVER END. ======================================================================================== DOCUMENT :usus Folder:VOL01:modem1.text ======================================================================================== PROGRAM MODEM; {Written by J. M. Wierda This program is basically a re-write in PASCAL of Ward Christensen's Modem Program which was distributed in CP/M User's Group Volume 25. Identical and compatible options are provided to allow this program to work directly with Ward's program running under CP/M. One difference is that when sending files the PASCAL or CP/M transfer mode must be selected. The PASCAL mode transfers files between two systems running PASCAL, while the CP/M mode is used when the receiving system is running CP/M. Basically the CP/M mode provides the linefeeds required to make a PASCAL file compatible with CP/M. When CP/M files are received they contain linefeeds, these can be deleted using the editor to make the file compatible with PASCAL. CP/M files may also contain tabs which the PASCAL editor does not expand. External assembly language routines are used to read the status, and read or wrkte the keyboard and modem ports. These routines are available as separate files for the 8080 and Z80 processors. The port and flag definitions, and the timing constant for the one second delay should be changed as required for your particular hardware. The program has been tested with text files only, and may not work correctly for code or other types of files. The PDP-10 mode transfers PASCAL files to a DEC SYSTEM-10 computer.} CONST NUL=0; SOH=1; CTRLC=3; EOT=4; ERRORMAX=5; RETRYMAX=5; CTRLE=5; ACK=6; TAB=9; LF=10; CR=13; CTRLQ=17; CTRLS=19; NAK=21; CTRLZ=26; SPACE=32; DELETE=127; LASTBYTE=127; TIMEOUT=256; LOOPSPERSEC=1800; {1800 LOOPS PER SECOND AT 4MHZ} KBSP=0; {KEYBOARD STATUS PORT} KBDRF=128; {KEYBOARD DATA READY FLAG} KBDP=1; {KEYBOARD DATA PORT} KBMASK=127; {KEYBOARD DATA MASK} DCHDP=128; {D. C. HAYES DATA PORT} DCHMASK=255; {D. C. HAYES DATA MASK} DCHSP=129; {D. C. HAYES STATUS PORT} {STATUS PORT BIT ASSIGNMENTS} RRF = 1; {RECEIVE REGISTER FULL} TRE = 2; {TRANSMIT REGISTER EMPTY} PERR = 4; {PARITY ERROR} FERR = 8; {FRAMING ERROR} OERR = 16; {OVERFLOW ERROR} CD = 64; {CARRIER DETECT} NRI = 128; {NO RINGING INDICATOR} DCHCP1=129; {D. C. HAYES CONTROL PORT 1} {CONTROL PORT 1 BIT ASSIGNMENTS} EPE = 1; {EVEN PARITY ENABLE} LS1 = 2; {LENGTH SELECT 1} LS2 = 4; {LENGTH SELECT 2} SBS = 8; {STOP BIT SELECT} PI = 16; {PARITY INHIBIT} DCHCP2=130; {D. C. HAYES CONTROL PORT 2} {CONTROL PORT 2 BIT ASSIGNMENTS} BRS = 1; {BIT RATE SELECT} TXE = 2; {TRANSMIT ENABLE} MS = 4; {MODE SELECT} ES = 8; {ECHO SUPPRESS} ST = 16; {SELF TEST} RID = 32; {RING INDICATOR DISABLE} OH = 128; {OFF HOOK} VAR FILE1 : TEXT; OPTION, HANGUP, RETURN, MODE, BAUDRATE, DISPLAY, FILEMODE : CHAR; SECTOR : ARRAY[0..LASTBYTE] OF INTEGER; DCHCW2 : INTEGER; OVRN1, OVRN2, SHOWRECV, SHOWTRANS : BOOLEAN; FUNCTION STAT(PORT,EXR,MASK:INTEGER):BOOLEAN; EXTERNAL; FUNCTION INPUT(PORT,MASK:INTEGER):INTEGER; EXTERNAL; PROCEDURE OUTPUT(PORT,DATA:INTEGER); EXTERNAL; PROCEDURE SENDLINE(SLDATA:INTEGER); BEGIN REPEAT UNTIL STAT(DCHSP,TRE,TRE); OUTPUT(DCHDP,SLDATA); IF SHOWTRANS THEN IF (SLDATA = CR) OR ((SLDATA >= SPACE) AND (SLDATA <= DELETE)) THEN WRITE(CHR(SLDATA)) END; FUNCTION READLINE(SECONDS:INTEGER):INTEGER; VAR J : INTEGER; BEGIN J := LOOPSPERSEC * SECONDS; REPEAT J := J-1 UNTIL (STAT(DCHSP,RRF,RRF)) OR (J = 0); IF J = 0 THEN READLINE := TIMEOUT ELSE BEGIN J := INPUT(DCHDP,DCHMASK); IF SHOWRECV THEN IF (J = CR) OR ((J >= SPACE) AND (J <= DELETE)) THEN WRITE(CHR(J)); READLINE := J END END; PROCEDURE SENDSTR(STR:STRING); VAR J:INTEGER; BEGIN FOR J := 1 TO LENGTH(STR) DO SENDLINE(ORD(STR[J])) END; FUNCTION UPPERCASE(CH : CHAR) : CHAR; BEGIN IF CH IN ['a'..'z'] THEN UPPERCASE := CHR(ORD(CH)-SPACE) ELSE UPPERCASE := CH END; PROCEDURE PURGELINE; VAR J : INTEGER; BEGIN REPEAT J := INPUT(DCHDP,DCHMASK); {PURGE THE RECEIVE REGISTER} UNTIL NOT STAT(DCHSP,RRF,RRF) END; PROCEDURE DCHINITIALIZE; BEGIN WRITELN('Waiting for carrier'); REPEAT BEGIN IF OPTION IN ['R','S'] THEN BEGIN OUTPUT(DCHCP1,PI+LS2+LS1); OUTPUT(DCHCP2,OH+RID+TXE+DCHCW2) END; IF OPTION IN ['C','P','T'] THEN BEGIN OUTPUT(DCHCP1,LS2+EPE); OUTPUT(DCHCP2,OH+RID+TXE+DCHCW2) END END UNTIL (STAT(DCHSP,CD,CD)) OR (INPUT(KBDP,KBMASK) = CTRLE); PURGELINE; WRITELN('Carrier detected') END; PROCEDURE MAKESECTOR; VAR J : INTEGER; CH : CHAR; BEGIN J := 0; IF OVRN1 THEN BEGIN SECTOR[J] := CR; J := J+1 END; IF OVRN2 THEN BEGIN SECTOR[J] := LF; J := J+1 END; OVRN1 := FALSE; OVRN2 := FALSE; WHILE (NOT EOF(FILE1)) AND (J <= LASTBYTE) DO BEGIN WHILE (NOT EOLN(FILE1)) AND (J <= LASTBYTE) DO BEGIN READ(FILE1,CH); IF ORD(CH) <> LF THEN BEGIN SECTOR[J] := ORD(CH); J := J+1 END END; IF EOLN(FILE1) THEN BEGIN READLN(FILE1); IF FILEMODE IN ['P'] THEN IF J <= LASTBYTE THEN BEGIN SECTOR[J] := CR; J := J+1 END ELSE OVRN1 := TRUE ELSE BEGIN IF J <= (LASTBYTE-1) THEN BEGIN SECTOR[J] := CR; SECTOR[J+1] := LF; J := J+2 END ELSE IF J = LASTBYTE THEN BEGIN SECTOR[J] := CR; J := J+1; OVRN1 := TRUE END ELSE IF J > LASTBYTE THEN BEGIN OVRN1 := TRUE; OVRN2 := TRUE END END END END; CASE FILEMODE OF 'P' : IF J <= LASTBYTE THEN FOR J := J TO LASTBYTE DO SECTOR[J] := SPACE; 'C' : IF J <= LASTBYTE THEN FOR J := J TO LASTBYTE DO SECTOR[J] := CTRLZ END END; PROCEDURE TERMCOMP; VAR KBDATA, DCHDATA : INTEGER; CRFLAG : BOOLEAN; BEGIN CRFLAG := FALSE; DCHINITIALIZE; WHILE STAT(DCHSP,CD,CD) AND (KBDATA <> CTRLE) DO BEGIN IF STAT(KBSP,KBDRF,KBDRF) THEN BEGIN KBDATA := INPUT(KBDP,KBMASK); IF OPTION IN ['C'] THEN WRITE(CHR(KBDATA)); OUTPUT(DCHDP,KBDATA) END; IF STAT(DCHSP,RRF,RRF) THEN BEGIN DCHDATA := INPUT(DCHDP,DCHMASK); IF OPTION IN ['C'] THEN OUTPUT(DCHDP,DCHDATA); IF DCHDATA = CR THEN CRFLAG := TRUE; IF (DCHDATA = LF) AND CRFLAG THEN CRFLAG := FALSE ELSE WRITE(CHR(DCHDATA)) END END END; PROCEDURE PDP10; VAR WAIT10 : BOOLEAN; DCHDATA : INTEGER; CH : CHAR; FILENAME, PDP10FILE : STRING; BEGIN SHOWRECV := FALSE; SHOWTRANS := TRUE; WAIT10 := FALSE; WRITE('Filename.Ext ? '); READLN(FILENAME); RESET(FILE1,FILENAME); WRITE('PDP-10 Filename.Ext ? '); READLN(PDP10FILE); DCHINITIALIZE; SENDLINE(CR); SENDSTR('R PIP'); SENDLINE(CR); REPEAT UNTIL READLINE(5) IN [ORD('*'),TIMEOUT]; SENDSTR(PDP10FILE); SENDSTR('=TTY:'); SENDLINE(CR); WHILE (NOT EOF(FILE1)) AND (STAT(DCHSP,CD,CD)) DO BEGIN WHILE NOT EOLN(FILE1) DO BEGIN IF NOT WAIT10 THEN BEGIN READ(FILE1,CH); SENDLINE(ORD(CH)) END; IF STAT(DCHSP,RRF,RRF) THEN BEGIN DCHDATA := INPUT(DCHDP,DCHMASK); IF DCHDATA = CTRLS THEN WAIT10 := TRUE; IF DCjDATA = CTRLQ THEN WAIT10 := FALSE END END; READLN(FILE1); SENDLINE(CR) END; CLOSE(FILE1); REPEAT UNTIL READLINE(1)=TIMEOUT; SENDLINE(CTRLZ); SENDLINE(CTRLC); TERMCOMP END; PROCEDURE SENDFILE; VAR J, K, SECTORNUM, COUNTER, CHECKSUM : INTEGER; FILENAME : STRING; BEGIN WRITE('Filename.Ext ? '); READLN(FILENAME); RESET(FILE1,FILENAME); SECTORNUM := 1; DCHINITIALIZE; OVRN1 := FALSE; OVRN2 := FALSE; REPEAT COUNTER := 0; MAKESECTOR; REPEAT WRITELN; WRITELN('Sending sector ', SECTORNUM); SENDLINE(SOH); SENDLINE(SECTORNUM); SENDLINE(-SECTORNUM-1); CHECKSUM := 0; FOR J := 0 TO LASTBYTE DO BEGIN SENDLINE(SECTOR[J]); CHECKSUM := (CHECKSUM + SECTOR[J]) MOD 256 END; SENDLINE(CHECKSUM); PURGELINE; COUNTER := COUNTER + 1; UNTIL (READLINE(10) = ACK) OR (COUNTER = RETRYMAX); SECTORNUM := SECTORNUM + 1 UNTIL (EOF(FILE1)) OR (COUNTER = RETRYMAX); IF COUNTER = RETRYMAX THEN BEGIN WRITELN; WRITELN('No ACK on sector') END ELSE BEGIN COUNTER := 0; REPEAT SENDLINE(EOT); COUNTER := COUNTER + 1 UNTIL (READLINE(10) = ACK) OR (COUNTER = RETRYMAX); IF COUNTER = RETRYMAX THEN BEGIN WRITELN; WRITELN('No ACK on EOT') END ELSE BEGIN WRITELN; WRITELN('Transfer complete') END END; CLOSE(FILE1) END; PROCEDURE READFILE; VAR J, FIRSTCHAR, SECTORNUM,SECTORCURRENT, SECTORCOMP, ERRORS, CHECKSUM : INTEGER; ERRORFLAG : BOOLEAN; FILENAME : STRING; BEGIN WRITE('Filename.Ext ? '); READLN(FILENAME); REWRITE(FILE1,FILENAME); SECTORNUM := 0; ERRORS := 0; DCHINITIALIZE; REPEAT ERRORFLAG := FALSE; REPEAT FIRSTCHAR :=READLINE(15) UNTIL FIRSTCHAR IN [SOH,EOT,TIMEOUT]; IF FIRSTCHAR = TIMEOUT THEN BEGIN WRITELN; WRITELN('SOH error'); END; IF FIRSTCHAR = SOH THEN BEGIN SECTORCURRENT := READLINE(1); SECTORCOMP := READLINE(1); IF (SECTORCURRENT+SECTORCOMP)=255 THEN BEGIN IF (SECTORCURRENT=SECTORNUM+1) THEN BEGIN CHECKSUM := 0; FOR J := 0 TO LASTBYTE DO BEGIN SECTOR[J] := READLINE(1); CHECKSUM := (CHECKSUM+SECTOR[J]) MOD 256 END; IF CHECKSUM=READLINE(1) THEN BEGIN FOR J := 0 TO LASTBYTE DO WRITE(FILE1,CHR(SECTOR[J])); ERRORS:=0; SECTORNUM := SECTORCURRENT; WRITELN; WRITELN('Received sector ',SECTORCURRENT); SENDLINE(ACK) END ELSE BEGIN WRITELN; WRITELN('Checksum error'); ERRORFLAG := TRUE END END ELSE IF (SECTORCURRENT=SECTORNUM) THEN BEGIN REPEAT UNTIL READLINE(1)=TIMEOUT; WRITELN; WRITELN('Received duplicate sector ', SECTORCURRENT); SENDLINE(ACK) END ELSE BEGIN WRITELN; WRITELN('Synchronization error'); ERRORFLAG := TRUE END END ELSE BEGIN WRITELN; WRITELN('Sector number error'); ERRORFLAG := TRUE END END; IF (ERRORFLAG=TRUE) THEN BEGIN ERRORS := ERRORS+1; REPEAT UNTIL READLINE(1)=TIMEOUT; SENDLINE(NAK) END; UNTIL (FIRSTCHAR IN [EOT,TIMEOUT]) OR (ERRORS = ERRORMAX); IF (FIRSTCHAR = EOT) AND (ERRORS < ERRORMAX) THEN BEGIN SENDLINE(ACK); CLOSE(FILE1,LOCK); WRITELN; WRITELN('Transfer complete') END ELSE BEGIN CLOSE(FILE1); WRITELN; WRITELN('Aborting') END END; BEGIN {MAINLINE} WRITELN('Modem, 1-May-79'); REPEAT REPEAT WRITE('Option : C(omputer), P(DP-10), R(eceive), S(end), T(erminal) ? '); READ(OPTION); OPTION := UPPERCASE(OPTION); WRITELN UNTIL OPTION IN ['C','P','R','S','T']; REPEAT WRITE('Mode : A(nswer), O(riginate) ? '); READ(MODE); MODE := UPPERCASE(MODE); WRITELN UNTIL MODE IN ['A','O']; IF MODE IN ['O'] THEN DCHCW2 := MS ELSE DCHCW2 := 0; REPEAT WRITE('Baud rate : 1(00), 3(00) ? '); READ(BAUDRATE); WRITELN UNTIL BAUDRATE IN ['1','3']; IF BAUDRATE='3' THEN DCHCW2 := DCHCW2+BRS; IF OPTION IN ['R','S'] THEN BEGIN REPEAT WRITE('Display : N(o), R(eceived), T(ransmitted) data ? '); READ(DISPLAY); DISPLAY := UPPERCASE(DISPLAY); WRITELN UNTIL DISPLAY IN ['N','R','T']; IF OPTION = 'S' THEN BEGIN REPEAT WRITE('File mode : C(pm), P(ascal) ? '); READ(FILEMODE); FILEMODE := UPPERCASE(FILEMODE); WRITELN UNTIL FILEMODE IN ['C','P'] END; CASE DISPLAY OF 'N':BEGIN SHOWRECV := FALSE; SHOWTRANS := FALSE END; 'R':BEGIN SHOWRECV := TRUE; SHOWTRANS := FALSE END; 'T':BEGIN SHOWRECV := FALSE; SHOWTRANS := TRUE END END {CASE} END; CASE OPTION OF 'C': TERMCOMP; 'P': PDP10; 'R': READFILE; 'S': SENDFILE; 'T': TERMCOMP END; {CASE} REPEAT WRITELN; WRITE('Hangup : Y(es), N(o) ? '); READ(HANGUP); HANGUP := UPPERCASE(HANGUP); WRITELN UNTIL HANGUP IN ['Y','N']; IF HANGUP IN ['Y'] THEN OUTPUT(DCHCP2,0); REPEAT WRITELN; WRITE('Return to system : Y(es), N(o) ? '); READ(RETURN); RETURN := UPPERCASE(RETURN); WRITELN UNTIL RETURN IN ['Y','N']; UNTIL RETURN IN ['Y'] END. ======================================================================================== DOCUMENT :usus Folder:VOL01:pretty.doc.text ======================================================================================== DOCUMENTATION FOR THE PASCAL PRETTYPRINTERS There are two Pascal source formatting and beautifying programs on this disk, both from the Pascal News Number 13 (December 1978). Because they were prepared on the E6 editor, which does not allow text longer than memory (10K to 25K available depending on how much RAM there is in your system), each program is provided in parts that are drawn into the compiler via the I(nclude compiler option. Since I already had to partition the compiler to compile both programs on my medium-sized (56K) system, I did not further split up the files to fit within a smaller RAM space for editing, since they will not then compile. If subfiles do not share the same name (plus a number) as the main file, this is noted below. Further, each program has been modified to run under UCSD Pascal, usually by changing plain "Write (X)" statements to "Write (Outfile, X)," and similarly with read. Initializing text was added to set up the input and output files at run time. Finally, several PACK and UNPACK statements in FORMAT (noted within the source file) were changed to their equivalents, since the UCSD compiler does not support these standard procedures. PRETTY.TEXT (which pulls in INITVARS.TEXT as a subfile--this contains the variable initializing portion of the program) is the simpler and more forgiving of the Pascal formatters. Unlike FORMAT, programs which are syntactically incorrect MAY get through the beautifying process. What PRETTY does to your file is fixed at compile time; however, it respects line ends and other spacing already present within the file to a degree. FORMAT.TEXT and subfiles is fully documented in FORMAT.DOC.TEXT, which I copied from the Pascal News. Andy Mickel, then the editor of the Pascal News, claims that FORMAT is especially clear-cut in its variable names and procedure layout; I agree. There is a hidden gotcha, apparantly: Pascal News Number 15 noted letters from irate users, who found bugs in certain areas, such as the lack of inserted spaces before the ".." (range) symbol and "ugly breaking upon wraparound of several expressions in assignment statements." Fixes are promised in a forthcoming issue of Pascal News. Frankly, I think the thing works fairly well and is a big improvement over manually breaking out the structure of a program you plan to publish. And it has some VERY nice features; I am particularly enamoured of being able to automatically add comments after an "END" statement pointing out of which program statement it is the end! If you have the UCSD system you will note that both programs run slowly, victims of multiple procedure calls for each letter of the source file and output file. This problem can be solved by 1) waiting, 2) getting a machine- language compiler, or, preferably, 3) hanging on until the 16-bit microprocessors are available, which handle procedure calls with applomb (particularly the M68000). If you rewrote the reading/writing parts to accept UCSD-type strings, it would run faster but might not work on your next Pascal system. ======================================================================================== DOCUMENT :usus Folder:VOL01:pretty.text ======================================================================================== (*$S+*) PROGRAM PRETTYPRINT; CONST maxsymbolsize = 200 (* max # of char in symbol scanned by scanner*); maxstacksize = 100 (* max # of symbols causing indentation that may be stacked *); maxkeylength = 10 (* max length Pascal reserved word *); maxlinesize = 72 (* max length of line output by program *); slofail1 = 30 (* up to this column position, margin will be indented by "indent1". *); slofail2 = 48 (* up to this column positn, each time "indentbytab" is invoked, the margin will be indented by "indent2." *); indent1 = 3; indent2 = 1; space = ' '; TYPE keysymbol = (progsym, funcsym, procsym, labelsym, constsym, typesym, varsym, beginsym, repeatsym, recordsym, casesym, casevarsym, ofsym, forsym, whilesym, withsym, dosym, ifsym, thensym, elsesym, endsym, untilsym, becomes, opencomment, closecomment,semicolon, colon, equals, openparen, closeparen, openbracket, closebracket, period, endoffile, othersym); option = (crsuppress, crbefore, blanklinebefore, dindentonkeys, dindent, spacebefore, spaceafter, gobblesymbols, indentbytab, indenttoclp, crafter); optionset = SET OF option; keysymset = SET OF keysymbol; tableentry = RECORD optionsselected : optionset; dindentsymbols : keysymset; gobbleterminators: keysymset END; optiontable = ARRAY [keysymbol] OF tableentry; key = PACKED ARRAY [1..maxkeylength] OF CHAR; keywordtable = ARRAY [progsym..untilsym] OF key; specialchar = PACKED ARRAY [1..2] OF CHAR; dblchrset = SET OF becomes..opencomment; dblchartable = ARRAY [becomes..opencomment] of specialchar; sglchartable = ARRAY [semicolon..period] OF char; lstring = ARRAY [1..maxsymbolsize] OF char; symbol = RECORD name : keysymbol; valu : lstring; lngth : integer; spacesbefore : integer; crsbefore : integer END; symbolinfo = ^symbol; charname = (letter, digit, blank, quote, endofline, filemark, otherchar); charinfo = RECORD name : charname; valu : char END; stackentry = RECORD indentsymbol: keysymbol; prevmargin : integer END; symbolstack = ARRAY [1..maxstacksize] OF stackentry; VAR recordseen: boolean; currchar, nextchar : charinfo; currsym, nextsym : symbolinfo; crpending : boolean; ppoption : optiontable; keyword : keywordtable; dblchars : dblchrset; dblchar : dblchartable; sglchar : sglchartable; stack : symbolstack; top : integer; startpos, (* starting position of last symbol written *) currlinepos, currmargin: integer; infile, outfile : TEXT; infilename, outfilename: STRING [20]; (*$IINITVAR.TEXT*) PROCEDURE Getchar (* from input *) ((* updating *) VAR nextchar: charinfo; (* returning *)VAR currchar: charinfo); BEGIN (* getchar *) currchar := nextchar; WITH nextchar DO BEGIN IF eof (infile) THEN name := filemark ELSE IF eoln (infile) THEN name := endofline ELSE IF infile^ IN ['A'..'Z', 'a'..'z'] THEN name := letter ELSE IF infile^ in ['0'..'9'] THEN name := digit ELSE IF infile^ = '''' THEN name := quote ELSE IF infile^ = space THEN name := blank ELSE name := otherchar; IF name IN [filemark, endofline] THEN valu := space ELSE valu := infile^; IF name <> filemark THEN get(infile) END (*with*) END; (*getchar*) PROCEDURE Storenextchar (* from input *) ( (*updating *) VAR lngth : integer; VAR currchar, nextchar : charinfo; (*placing in*)VAR valu : lstring); BEGIN (*storenextchar*) getchar (nextchar, currchar); IF lngth < maxsymbolsize THEN BEGIN lngth := succ (lngth); valu [lngth] := currchar.valu END END (*storenextchar*); PROCEDURE Skipspaces ( (* updating*) VAR currchar, nextchar : charinfo; (*returning*) VAR spacesbefore, crsbefore: integer); BEGIN spacesbefore := 0; crsbefore := 0; WHILE nextchar.name IN [blank, endofline] DO BEGIN getchar (nextchar, currchar); CASE currchar.name OF blank : spacesbefore := succ (spacesbefore); endofline : BEGIN crsbefore := succ (crsbefore); spacesbefore := 0 END END (*case*) END (*while*) END (*Skipspaces*); PROCEDURE Getcomment (* from input, updating: *) (VAR currchar, nextchar: charinfo; VAR name : keysymbol; VAR valu : lstring; VAR lngth : integer); BEGIN name := opencomment; WHILE NOT ( ((currchar.valu = '*') AND (nextchar.valu = ')')) OR (currchar.valu = '}') OR (nextchar.name = endofline) OR (nextchar.name = filemark)) DO storenextchar (lngth, currchar, nextchar, valu); IF (currchar.valu = '*') AND (nextchar.valu = ')') THEN BEGIN storenextchar (lngth, currchar, nextchar, valu); name := closecomment END; IF currchar.valu = '}' THEN name := closebracket END (*Getcomment*); FUNCTION Idtype ( (*of*) valu:lstring; (*using*) lngth:integer): keysymbol; VAR i: integer; keyvalu: key; hit: boolean; thiskey: keysymbol; BEGIN idtype := othersym; IF lngth <= maxkeylength THEN BEGIN FOR i := 1 TO lngth DO IF valu [i] IN ['A'..'Z'] (* switch to lower case*) THEN keyvalu [i] := CHR (ORD (valu [i]) + ORD ('a') - ORD ('A')) ELSE keyvalu [i] := valu [i]; FOR i := lngth+1 TO maxkeylength DO keyvalu [i] := space; thiskey := progsym; hit := false; WHILE NOT (hit OR (thiskey = succ(untilsym))) DO IF keyvalu = keyword [thiskey] THEN hit := true ELSE thiskey := succ (thiskey); IF hit THEN idtype := thiskey END END (*Idtype*); PROCEDURE Getidentifier ( (*from input*) (* updating *) VAR currchar, nextchar: charinfo; (* returning*) VAR name : keysymbol; VAR valu : lstring; VAR lngth: integer ); BEGIN WHILE nextchar.name IN [letter, digit] DO Storenextchar (lngth, currchar, nextchar, valu); name := idtype (valu, lngth); IF name IN [recordsym, casesym, endsym] THEN CASE name OF recordsym : recordseen := true; casesym : IF recordseen THEN name := casevarsym; endsym : recordseen := false END (*case*) END (*Getidentifier*); PROCEDURE Getnumber ( (*from input*) (* updating *) VAR currchar, nextchar: charinfo; (* returning*) VAR name : keysymbol; VAR valu : lstring; VAR lngth : integer ); BEGIN WHILE nextchar.name = digit DO Storenextchar (lngth, currchar, nextchar, valu); name := othersym END (*Getnumber*); PROCEDURE Getcharliteral ( (* from input *) (* updating *) VAR currchar, nextchar: charinfo; (* returning*) VAR name : keysymbol; VAR valu : lstring; VAR lngth : integer ); BEGIN WHILE nextchar.name = quote DO BEGIN Storenextchar (lngth, currchar, nextchar, valu); WHILE NOT (nextchar.name IN [quote, endofline, filemark]) DO Storenextchar (lngth, currchar, nextchar, valu); IF nextchar.name = quote THEN Storenextchar (lngth, currchar, nextchar, valu) END; name := othersym END (*getcharliteral*); FUNCTION Chartype (currchar, nextchar: charinfo): keysymbol; VAR nexttwochars: specialchar; hit: boolean; thischar: keysymbol; BEGIN nexttwochars[1] := currchar.valu; nexttwochars[2] := nextchar.valu; thischar := becomes; hit := false; (* Find out if chartype is ":=" or "(*" *) WHILE NOT (hit or (thischar = closecomment)) DO IF nexttwochars = dblchar [thischar] THEN hit := true ELSE thischar := succ(thischar); (* now is chartype ;, :, (, ), {, }, or . *) IF NOT hit THEN BEGIN thischar := semicolon; WHILE NOT (hit OR (pred(thischar) = period)) DO IF currchar.valu = sglchar[thischar] THEN hit := true ELSE thischar := succ(thischar) END; IF hit THEN chartype := thischar ELSE chartype := othersym END (*Chartype*); PROCEDURE Getspecialchar ( (* from input *) (* updating *) VAR currchar, nextchar: charinfo; (* returning*) VAR name : keysymbol; VAR valu : lstring; VAR lngth : integer ); BEGIN Storenextchar (lngth, currchar, nextchar, valu); name := Chartype (currchar, nextchar); IF name IN dblchars THEN Storenextchar (lngth, currchar, nextchar, valu); END (* Getspecialchar *); PROCEDURE Getnextsymbol ( (* from input *) (* updating *) VAR currchar, nextchar: charinfo; (* returning*) VAR name : keysymbol; VAR valu : lstring; VAR lngth : integer ); BEGIN CASE nextchar.name OF letter : Getidentifier (currchar, nextchar, name, valu, lngth); digit : Getnumber (currchar, nextchar, name, valu, lngth); quote : Getcharliteral(currchar, nextchar, name, valu, lngth); otherchar: BEGIN Getspecialchar (currchar, nextchar, name, valu, lngth); IF (name = opencomment) OR (name = openbracket) THEN Getcomment (currchar, nextchar, name, valu, lngth) END; filemark : name := endoffile END (* case *) END (* Getnextsymbol *); PROCEDURE Getsymbol ( (*from input*) (* updating *) VAR nextsym: symbolinfo; (* returning*) VAR currsym: symbolinfo); VAR dummy: symbolinfo; BEGIN dummy := currsym; currsym := nextsym; nextsym := dummy; WITH nextsym^ DO BEGIN skipspaces (currchar, nextchar, spacesbefore, crsbefore); lngth := 0; IF currsym^.name = opencomment THEN Getcomment (currchar, nextchar, name, valu, lngth) ELSE Getnextsymbol (currchar, nextchar, name, valu, lngth) END END (* Getsymbol *); PROCEDURE Initfiles; BEGIN WRITELN ('Welcome to the Pascal prettyprinter. Please type the name of'); WRITE ('the textfile you wish as input --> '); READLN (infilename); RESET (infile, infilename); WRITELN('Now the filename to which you want the output sent.'); WRITELN (' (NOTE: if you simply want to print it out,'); WRITE (' type "PRINTER:") -->'); READLN (outfilename); REWRITE (outfile, outfilename); Getchar (nextchar, currchar); new (currsym); new (nextsym); Getsymbol (nextsym, currsym) END (*Initfiles*); FUNCTION Stackempty: boolean; BEGIN IF top = 0 THEN stackempty := true ELSE stackempty := false END; FUNCTION Stackfull: boolean; BEGIN IF top = maxstacksize THEN stackfull := true ELSE stackfull := false END; PROCEDURE Popstack ( (*returning*) VAR indentsymbol: keysymbol; VAR prevmargin : integer); BEGIN IF NOT stackempty THEN BEGIN indentsymbol := stack[top].indentsymbol; prevmargin := stack[top].prevmargin; top := top-1 END ELSE BEGIN indentsymbol := othersym; prevmargin := 0 END END (*Popstack*); PROCEDURE Pushstack (indentsymbol: keysymbol; prevmargin: integer); BEGIN top := top+1; stack[top].indentsymbol := indentsymbol; stack[top].prevmargin := prevmargin END; PROCEDURE Writecrs (numberofcrs: integer; VAR currlinepos: integer); VAR i: integer; BEGIN IF numberofcrs > 0 THEN BEGIN FOR I := 1 TO numberofcrs DO WRITELN (outfile); currlinepos := 0 END END; PROCEDURE Insertcr (VAR currsym: symbolinfo); CONST once = 1; BEGIN IF currsym^.crsbefore = 0 THEN BEGIN writecrs (once, currlinepos); currsym^.spacesbefore := 0 END END; PROCEDURE Insertblankline (VAR currsym: symbolinfo); CONST once = 1; twice = 2; BEGIN IF currsym^.crsbefore = 0 THEN BEGIN IF currlinepos = 0 THEN Writecrs (once, currlinepos) ELSE Writecrs (twice, currlinepos); currsym^.spacesbefore := 0 END ELSE IF currsym^.crsbefore = 1 THEN IF currlinepos > 0 THEN Writecrs (once, currlinepos) END (*Insertblankline*); PROCEDURE Lshifton (dindentsymbols: keysymset); VAR indentsymbol: keysymbol; prevmargin : integer; BEGIN IF NOT stackempty THEN BEGIN REPEAT popstack (indentsymbol, prevmargin); IF indentsymbol IN dindentsymbols THEN currmargin := prevmargin UNTIL NOT (indentsymbol IN dindentsymbols) OR stackempty; IF NOT (indentsymbol IN dindentsymbols) THEN Pushstack (indentsymbol, prevmargin) END END (*Lshifton*); PROCEDURE Lshift; VAR indentsymbol: keysymbol; prevmargin: integer; BEGIN IF NOT stackempty THEN BEGIN Popstack (indentsymbol, prevmargin); currmargin := prevmargin END END; PROCEDURE Insertspace (VAR symbol: symbolinfo); BEGIN IF currlinepos < maxlinesize THEN BEGIN WRITE (outfile, space); currlinepos := succ (currlinepos); WITH symbol^ DO IF (crsbefore = 0) AND (spacesbefore > 0) THEN spacesbefore := pred (spacesbefore) END END (*Insertspace*); PROCEDURE Movelinepos ( (*to*) newlinepos: integer; (*from*) VAR currlinepos: integer); VAR i: integer; BEGIN FOR i := currlinepos+1 TO newlinepos DO WRITE (outfile, space); currlinepos := newlinepos END; PROCEDURE Printsymbol (currsym: symbolinfo; VAR currlinepos: integer); VAR i: integer; BEGIN WITH currsym^ DO BEGIN FOR i := 1 TO lngth DO write (outfile, valu[i]); startpos := currlinepos; currlinepos := currlinepos + lngth END END (*Printsymbol*); PROCEDURE Ppsymbol (currsym: symbolinfo); CONST once = 1; VAR newlinepos: integer; BEGIN WITH currsym^ DO BEGIN Writecrs (crsbefore, currlinepos); IF (currlinepos + spacesbefore > currmargin) OR (name IN [opencomment, closecomment, openbracket, closebracket]) THEN newlinepos := currlinepos + spacesbefore ELSE newlinepos := currmargin; IF newlinepos + lngth > maxlinesize THEN BEGIN Writecrs (once, currlinepos); IF currmargin + lngth <= maxlinesize THEN newlinepos := currmargin ELSE IF lngth < maxlinesize THEN newlinepos := maxlinesize - lngth ELSE newlinepos := 0 END; Movelinepos (newlinepos, currlinepos); Printsymbol (currsym, currlinepos) END (*with*) END (*Ppsymbol*); PROCEDURE Rshifttoclp (currsym:keysymbol); FORWARD; PROCEDURE Gobble ( (*up to*) terminators: keysymset; (*updating*) VAR currsym, nextsym: symbolinfo); BEGIN Rshifttoclp (currsym^.name); WHILE NOT (nextsym^.name IN (terminators + [endoffile])) DO BEGIN Getsymbol (nextsym, currsym); Ppsymbol (currsym) END; Lshift END (*Gobble*); PROCEDURE Rshift (currsym: keysymbol); BEGIN IF NOT stackfull THEN Pushstack (currsym, currmargin); (* If extra indentation was used, update margin.*) IF startpos > currmargin THEN currmargin := startpos; IF currmargin < slofail1 THEN currmargin := currmargin + indent1 ELSE IF currmargin < slofail2 THEN currmargin := currmargin + indent2 END (*Rshift*); PROCEDURE Rshifttoclp; BEGIN IF NOT stackfull THEN Pushstack (currsym, currmargin); currmargin := currlinepos END (*Rshifttoclp*); BEGIN (* main program, at last *); Initvar1 (top, currlinepos, currmargin, keyword, dblchars, dblchar, sglchar, recordseen, currchar, nextchar, currsym, nextsym); Initvar2 (ppoption); Initvar3 (ppoption); Initfiles; crpending := false; WHILE (nextsym^.name <> endoffile) DO BEGIN Getsymbol (nextsym, currsym); WITH ppoption [currsym^.name] DO BEGIN IF (crpending AND NOT (crsuppress IN optionsselected)) OR (crbefore IN optionsselected) THEN BEGIN Insertcr (currsym); crpending := false END; IF blankliebefore IN optionsselected THEN BEGIN Insertblankline (currsym); crpending := false END; IF dindentonkeys IN optionsselected THEN Lshifton (dindentsymbols); IF dindent IN optionsselected THEN Lshift; IF spacebefore IN optionsselected THEN Insertspace (currsym); Ppsymbol (currsym); IF spaceafter IN optionsselected THEN Insertspace (nextsym); IF indentbytab IN optionsselected THEN Rshift (currsym^.name); IF indenttoclp IN optionsselected THEN Rshifttoclp (currsym^.name); IF gobblesymbols IN optionsselected THEN Gobble (gobbleterminators, currsym, nextsym); IF crafter IN optionsselected THEN crpending := true END (*with*) END (*while*); IF crpending THEN WRITELN (outfile); CLOSE (outfile,lock) END. ======================================================================================== DOCUMENT :usus Folder:VOL01:readcpm.text ======================================================================================== .PROC READCPM,1 .PUBLIC DISKBUF .ORG 0 POP HL ; EXTENT PASSED AS PARAMETER EX (SP),HL ; UNDER RETURN ADDRESS LD BC,DISKBUF ADD HL,HL ADD HL,HL ADD HL,HL FETCH PUSH HL PUSH BC LD B,1 LD DE,0-26 DIVL ADD HL,DE INC B LD A,H OR A JP P,DIVL LD DE,TABLE+26 ADD HL,DE LD C,(HL) LD L,21H ; OFFSET OF SETSEC CALL BIOS LD C,B LD L,1EH ; OFFSET OF SETTRK CALL BIOS POP BC LD L,24H ; OFFSET OF SETDMA CALL BIOS LD HL,128 ADD HL,BC PUSH HL LD L,27H ; OFFSET OF READ CALL BIOS POP BC POP HL INC HL LD A,7 (AND L JR NZ,FETCH RET BIOS LD A,(2) LD H,A JP (HL) TABLE .BYTE 01H,07H,0DH,13H,19H,05H .BYTE 0BH,11H,17H,03H,09H,0FH,15H .BYTE 02H,08H,0EH,14H,1AH,06H,0CH .BYTE 12H,18H,04H,0AH,10H,16H .END ======================================================================================== DOCUMENT :usus Folder:VOL01:rwcpm.text ======================================================================================== .PROC RWCPM,2 .PUBLIC DISKBUF ; CPM EXTENT DISKIO-COPYRIGHT 1979 BY BARRY A. COLE ; PASCAL CALLS RWCPM(EXTENT,FLAG) ; FLAG=0 FOR READ, FLAG=3 FOR WRITE ; DATA IS PASSED VIA SHARED BUFFER 'DISKBUF' LD C,1 LD L,1BH ;OFFSET OF SELDSK CALL BIOS POP DE ;RETURN ADDRESS POP AF ;READ=0/WRITE=3 FLAG ADD A,27H ; OFFSET OF READ EX AF ;SAVE FOR FUTURE REFERENCE POP HL ; EXTENT PASSED AS PARAMETER PUSH DE ;PUT BACK RETURN ADDRESS LD BC,DISKBUF ADD HL,HL ADD HL,HL ADD HL,HL FETCH PUSH HL PUSH BC LD B,1 LD DE,0-26 DIVL ADD HL,DE INC B LD A,H OR A JP P,DIVL LD DE,TABLE+26 ADD HL,DE LD C,(HL) LD L,21H ; OFFSET OF SETSEC CALL BIOS LD C,B LD L,1EH ; OFFSET OF SETTRK CALL BIOS POP BC LD L,24H ; OFFSET OF SETDMA CALL BIOS LD HL,128 ADD HL,BC PUSH HL EX AF LD L,A ; OFFSET OF READ OR WRITE EX AF CALL BIOS POP BC POP HL INC HL LD A,7 AND L JR NZ,FETCH LD C,0 LD L,1BH ;OFFSET OF SELDSK, AND EXIT BIOS LD A,(2) LD H,A JP (HL) TABLE .BYTE 01H,07H,0DH,13H,19H,05H .BYTE 0BH,11H,17H,03H,09H,0FH,15H .BYTE 02H,08H,0EH,14H,1AH,06H,0CH .BYTE 12H,18H,04H,0AH,10H,16H .END ======================================================================================== DOCUMENT :usus Folder:VOL01:simp.text ======================================================================================== {SIMP - Simplified Integrated Modular Prose} {PASCAL version by S. J. Singer 10 Feb 1979} {This program is a further refined version of the superb} {program developed by T. R. Stokes (in BASIC). The original} {information from which these programs were developed was} {published in Scientific American, December 1974, p 134} PROGRAM SIMP; VAR CHARACTERS: INTEGER; {CHAR PER LINE} PARAGRAPHS: INTEGER; {PARAGRAPHS PER MEMO} RNUM: REAL; {USED IN RANDOM NO GENERATOR} LINES: 0..10; P: INTEGER; I,J: INTEGER; K: 0..3; LST,FIRST: BOOLEAN; CH: CHAR; CRLF: PACKED ARRAY[0..2] OF CHAR; A,B,C,D,F: ARRAY[0..10] OF STRING[90]; {PHRASE TABLES} TABLE: ARRAY[0..3,0..10] OF BOOLEAN; {PHRASE USAGE FLAGS} TOO: STRING; FROM: STRING; SUBJECT: STRING; BUFFER: STRING; TXT: STRING[255]; List: TEXT; PROCEDURE CLEARTABL; {RESET PHRASE USAGE TABLE} VAR I,J: INTEGER; BEGIN FOR I:=0 TO 3 DO FOR J:=0 TO 10 DO TABLE[I,J] := TRUE END; FUNCTION RND(LO,HI:INTEGER): INTEGER; {RANDOM NUMBER GENERATOR} VAR Q : REAL; I : INTEGER; BEGIN REPEAT RNUM := RNUM*21.182813+31.415917; RNUM := RNUM-TRUNC(RNUM); I := TRUNC(RNUM*(HI+1)); UNTIL I>=LO; RND := I; END; FUNCTION RN(LO,HI,TBLINDX:INTEGER): INTEGER; {USE PHRASE ONLY ONCE/PARAGRAPH} VAR R: INTEGER; BEGIN REPEAT R := RND(LO,HI) UNTIL TABLE[TBLINDX,R]; TABLE[TBLINDX,R] := FALSE; RN := R END; PROCEDURE INIT1; {INITIALIZE PHRASE TABLE} BEGIN {SIMP TABLE A} A[0] := 'in respect to specific goals,'; A[1] := 'in particular,'; A[2] := 'on the other hand,'; A[3] := 'however,'; A[4] := 'similarly,'; A[5] := 'as a resultant implication,'; A[6] := 'in this regard,'; A[7] := 'based on integral subsystem considerations,'; A[8] := 'for example,'; A[9] := 'thus,'; A[10] := 'let it be noted that,'; {SIMP TABLE B} B[0] := 'a primary interrelationship between system and/or subsystem technologies' ; B[1] := 'a large portion of the interface coordination communication' ; B[2] := 'a constant flow of effective information'; B[3] := 'the characterization of specific criteria'; B[4] := 'initiation of critical subsystem developement'; B[5] := 'the fully integrated test program'; B[6] := 'the product configuration baseline'; B[7] := 'any associated supporting element'; B[8] := 'the incorporation of additional mission restraints'; B[9] := 'the independent function principle'; END; {INIT1} PROCEDURE INIT2; {INITIALIZE PHRASE TABLE} BEGIN {SIMP TABLE C} C[0] := 'adds overriding performance constraints to'; C[1] := 'must utilize and be functionallly interwoven with'; C[2] := CONCAT( 'maximizes the probability of project success and minimizes', ' the cost and time required for'); C[3] := 'adds specific performance limits to'; C[4] := 'necessitates that urgent consideration be applied to'; C[5] := 'requires considerable systems analysis and trade off studies to arrive at' ; C[6] := 'is further compounded, when taking into account'; C[7] := 'presents extremely interesting challenges to'; C[8] := 'recognizes the importance of other systems and the necessity for' ; C[9] := 'effects a significant implementation of'; END; {INIT2} PROCEDURE INIT3; {INITIALIZE PHRASE TABLE} BEGIN {SIMP TABLE D} D[0] := 'the total system rational'; D[1] := 'the sophisticated hardware'; D[2] := 'the anticipated fourth generation equipment'; D[3] := 'the subsystem compatibility testing'; D[4] := 'the structural design based on system engineering concepts'; D[5] := 'the preliminary qualification limit'; D[6] := 'the evolution of specifications over a given period of time' ; D[7] := 'the philosophy of commonality and standardization'; D[8] := 'the greater flight-worthiness concept'; D[9] := 'any discrete configuration mode'; {SIMP TABLE F} F[0] := 'It has come to my attention that '; F[1] := 'I wish to point out that '; F[2] := 'It is my conclusion that '; F[3] := 'As part of my duty, I must assure you that '; F[4] := 'As a cognizant support representative, I would like to report that ' ; F[5] := 'I feel it is imperative I inform you that '; F[6] := 'Due to or in spite of the present status, I must advise you that ' ; F[7] := CONCAT('In order to assess future impact/upgrade ratios,', ' I feel you should consider that '); F[8] := 'Acting in my advisory capacity, I wish to notify you that '; F[9] := 'From an international standpoint, it is clear to me that '; END; {INIT3} PROCEDURE PARAMETERS; {INPUT REPORT PARAMETERS} BEGIN PAGE (OUTPUT); REWRITE (list, 'PRINTER:'); RNUM := 12.345; CRLF[0] := CHR(13); CRLF[1] := CHR(10); CRLF[2] := CHR(10); TXT := ' '; WRITELN; WRITELN; WRITE('SIMPLIFIED INTEGRATED MODULAR PROSE GENERATOR':60); WRITELN; WRITELN; WRITELN; WRITE('TO: '); READLN(TOO); WRITE('FROM: '); READLN(FROM); WRITE('SUBJECT: '); READLN(SUBJECT); WRITELN; WRITE('CHARACTERS PER LINE '); READLN(CHARACTERS); WRITE('PARAGRAPHS '); READLN(PARAGRAPHS); WRITE('PRINTED OUTPUT (Y/N) '); READ(CH); IF (CH<>'Y') AND (CH<>'y') THEN LST := FALSE ELSE LST := TRUE; WRITELN; WRITELN; WRITE('ENTER A 4 DIGIT RANDOM NUMBER '); READLN(RNUM) END; {PARAMETERS} {THERE ARE 4 POSSIBLE PERMUTATIONS OF THE 4 PHRASES} PROCEDURE PERM0; {TEXT PERMUTATION 0} BEGIN BUFFER := A[RN(0,10,0)]; BUFFER[1] := CHR(ORD(BUFFER[1])-32); TXT := CONCAT(TXT,BUFFER,' ',B[RN(0,9,1)],' ', C[RN(0,9,2)],' ',D[RN(0,9,3)],'.') END; {PERM0} PROCEDURE PERM1; {TEXT PERMUTATION 1} BEGIN BUFFER := D[RN(0,9,3)]; BUFFER[1] := CHR(ORD(BUFFER[1])-32); TXT := CONCAT(TXT,BUFFER,' ',A[RN(0,10,0)],' ', C[RN(0,9,2)],' ',B[RN(0,9,1)],'.') END; {PERM1} PROCEDURE PERM2; {TEXT PERMUTATION 2} BEGIN BUFFER := B[RN(0,9,1)]; BUFFER[1] := CHR(ORD(BUFFER[1])-32); TXT := CONCAT(TXT,BUFFER,' ',A[RN(0,10,0)],' ', C[RN(0,9,2)],' ',D[RN(0,9,3)],'.') END; {PERM2} PROCEDURE PERM3; {TEXT PERMUTATION 3} BEGIN BUFFER := A[RN(0,10,0)]; BUFFER[1] := CHR(ORD(BUFFER[1])-32); TXT := CONCAT(TXT,BUFFER,' ',D[RN(0,9,3)],' ', C[RN(0,9,2)],' ',B[RN(0,9,1)],'.') END; {PERM3} PROCEDURE HEADING; {DISPLAY AND PRINT MEMORANDUM HEADING} BEGIN WRITELN ('M E M O R A N D U M':40); IF LST THEN BEGIN WRITELN (List, ' M E M O R A N D U M'); WRITELN (List); WRITELN (List); WRITELN (List, 'TO: ', too); WRITELN (List, 'FROM: ', from); WRITELN (List); WRITELN (List, 'COPIES TO: ALL SUBORDINATES'); WRITELN (List, 'SUBJECT: ', subject); WRITELN (List); WRITELN (List); END END; {HEADING} PROCEDURE INITIALIZE; BEGIN INIT1; INIT2; INIT3; PARAMETERS END; {INITIALIZE} BEGIN {MAIN PROGRAM} INITIALIZE; FIRST := TRUE; HEADING; FOR P:=PARAGRAPH DOWNTO 1 DO BEGIN CLEARTABL; LINES := RND(3,9); {GENERATE 3 TO 9 LINES} J := 1; WHILE LINES > 0 DO BEGIN I := 0; K := RND(0,3); {PERMUTATION SELECTOR} IF FIRST THEN BEGIN TXT := CONCAT(TXT,F[RND(0,9)],B[RN(0,9,1)],' ', C[RN(0,9,2)],' ',D[RN(0,9,3)],'.'); FIRST := FALSE END; CASE K OF 0: PERM0; 1: PERM1; 2: PERM2; 3: PERM3; END; REPEAT I := I + 1; J := J + 1; WRITE (TXT[I]); IF LST THEN WRITE (List, txt [i]); IF ((J >= CHARACTERS) AND (TXT[I]=' ')) THEN BEGIN J := 1; IF LST THEN WRITELN (List); WRITELN END UNTIL TXT[Iÿ='.'; LINES := LINES-1; TXT := ' ' END; WRITELN; IF lst THEN WRITELN (List); TXT := ' ' END END. {MAIN PROGRAM} ======================================================================================== DOCUMENT :usus Folder:VOL01:typeset.text ======================================================================================== PROGRAM TYPESET; CONST MAXCHAR = 80; {MAXIMUM NUMBER OF CHARACTERS PER LINE} ESC = 27; {ESCAPE CHARACTER} TYPE LINEPOS = 1..MAXCHAR; VAR I,J : INTEGER; COLWIDTH : INTEGER; W,JW : TEXT; C,D : CHAR; LINE : ARRAY[1..MAXCHAR] OF CHAR; {UNJUSTIFIED} DLINE : ARRAY[1..MAXCHAR] OF CHAR; {JUSTIFIED FOR DISPLAY} FILL : INTEGER; {MAX % FILL ALLOWED} INFILE : STRING[15]; OUTFILE : STRING[15]; NSP : INTEGER; {NUMBER OF SPACES IN CURRENT LINE} P : BOOLEAN; {PARAGRAPH FLAG} PITCH : 5..6; SPACING : INTEGER; JUST,STOP : BOOLEAN; SPCNT : INTEGER; NEEDSP: INTEGER; ADDSP : INTEGER; EXTSP : INTEGER; PROCEDURE CLEARSCREEN; BEGIN WRITE(CHR(26),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0)) END; PROCEDURE OPTIONS; VAR C:CHAR; BEGIN CLEARSCREEN; WRITELN('DARLENE''S SUPER TYPESETTING PROGRAM':52); GOTOXY(10,6); WRITE('INPUT FILE NAME '); READLN(INFILE); IF LENGTH(INFILE)=0 THEN INFILE:='SYSTEM.WRK'; INFILE:=CONCAT(INFILE,'.TEXT'); GOTOXY(10,7); WRITE('OUTPUT FILE NAME '); READLN(OUTFILE); GOTOXY(10,9); WRITE('ENTER COLUMN WIDTH '); READ(COLWIDTH); SPACING:=1; PITCH:=6; GOTOXY(10,12); WRITELN('THE CURRENT PROGRAM OPTIONS ARE:'); WRITELN('TYPE PITCH - 5 (ELITE)':40); WRITELN('MAXIMUM PERCENT FILL - 80%':40); WRITELN('SINGLE SPACE TEXT':30); WRITELN;WRITELN;WRITE('WOULD YOU LIKE TO CHANGE THEM (Y/N) ':46); RESET(INPUT); FILL:=80; PITCH:=6; READ(C); IF C='Y' THEN BEGIN CLEARSCREEN; WRITELN;WRITELN; WRITE('PICA OR ELITE (P/E) ':35); {EAD(C); IF C='P' THEN PITCH:=6 ELSE PITCH:=5; WRITELN; WRITE('MAXIMUM FILL PERCENT ':35); READLN(FILL) END END; PROCEDURE BLANKSCAN(LINELENGTH:LINEPOS); VAR I,J : INTEGER; B : BOOLEAN; BEGIN B:=FALSE; NSP:=0; FOR I:=1 TO LINELENGTH DO BEGIN IF ((LINE[I]=' ') AND B) THEN NSP:=NSP+1; IF LINE[I]<>' ' THEN B:=TRUE END; IF NSP>0 THEN BEGIN JUST:=TRUE; NEEDSP:=(COLWIDTH-LINELENGTH)*PITCH; ADDSP:=NEEDSP DIV NSP; EXTSP:=NEEDSP-ADDSP*NSP; END ELSE JUST:=FALSE END; PROCEDURE VARLINE(LINELENGTH:LINEPOS); VAR K,L : INTEGER; B : BOOLEAN; C : CHAR; ESP : INTEGER; BEGIN SPCNT:=0; ESP:=NSP DIV 2; B:=FALSE; K:=1;L:=1; REPEAT C:=LINE[L]; IF ((C=' ') AND B AND JUST) THEN BEGIN WRITE(JW,CHR(ESC)); K:=K+1; SPCNT:=SPCNT+1; IF SPCNT=ESP THEN WRITE(JW,CHR(32+PITCH+ADDSP+EXTSP)) ELSE WRITE(JW,CHR(32+PITCH+ADDSP)); END ELSE WRITE(JW,C); IF C<>' ' THEN B:=TRUE; K:=K+1; L:=L+1 UNTIL L>LINELENGTH; WRITELN(JW) END; PROCEDURE FILLINE(LINELENGTH:LINEPOS); VAR K,L,SP,NSPL:INTEGER; B:BOOLEAN; BEGIN IF (LINELENGTH*100 DIV COLWIDTH) < FILL THEN JUST:=FALSE ELSE JUST:=TRUE; SP:=COLWIDTH-LINELENGTH; NSPL:=SP-NSP; B:=FALSE; K:=1;L:=1; REPEAT DLINE[K]:=LINE[L]; IF ((DLINE[K]=' ') AND (SP<>0) AND B AND JUST) THEN BEGIN K:=K+1; SP:=SP-1; DLINE[K]:=' '; IF NSPL>0 THEN BEGIN K:=K+1; SP:=SP-1; NSPL:=NSPL-1; DLINE[K]:=' ' END END; IF DLINE[K]<>' ' THEN B:=TRUE; K:=K+1; L:=L+1 UNTIL L>LINELENGTH; IF K<=COLWIDTH THEN FOR K:=K TO COLWIDTH DO DLINE[K]:=' ' END; BEGIN {-MAIN PROGRAM-} OPTIONS; FOR I:=1 TO MAXCHAR DO BEGIN LINE[I]:=' '; DLINE[I]:=' ' END; STOP:=FALSE; I:=1; CLEARSCREEN; RESET(W,INFILE); REWRITE(JW,OUTFILE); WRITELN; WHILE NOT EOF(W) DO BEGIN READ(W,C); IF EOLN(W) THEN BEGIN LINE[I]:=C; BLANKSCAN(I); FILLINE(I); VARLINE(I); GET(W); D:=W^; IF NOT STOP THEN FOR J:=1 TO COLWIDTH DO WRITE(DLINE[J]) ELSE BEGIN J:=1; WHILE DLINE[J]<>' ' DO BEGIN WRITE(DLINE[J]); J:=J+1 END; WRITELN(' <<<= HYPHENATE PLEASE.'); EXIT(PROGRAM) END; IF ((NOT JUST) AND (D<>' ')) THEN STOP:=TRUE; IF EOLN(W) THEN BEGIN GET(W); WRITELN; WRITELN(JW) END; I:=1; WRITELN END ELSE BEGIN LINE[I]:=C; I:=I+1 END END; CLOSE(JW,LOCK) END. ======================================================================================== DOCUMENT :usus Folder:VOL01:units.doc.text ======================================================================================== SOME DOCUMENTATION ABOUT UCSD SEGMENTS AND UNITS Since the release of version 1.5 in early 1979, UCSD Pascal has supported several very useful extensions to Standard Pascal (a la Jensen and Wirth) that assist modular compilation and/or execution of programs. These are: 1. Programs may declare procedures or functions EXTERNAL in the same way they may be declared FORWARD (ie, a full 1st procedure/function declaration line is required). The program may not be run until it has been L(inked; the linker usually expects to find the missing code in the SYSTEM.LIBRARY. EXTERNAL procedures are reserved for assembly language procedures; the entire process is well documented in the UCSD handout. One item that is not completely clear is the way parameters are passed. The called routine will find the following items on the stack, in descending (normal "POP xx" order): 1) the return address (this must be saved); 2) IF the called routine is a function, two words of zeros, which reserve space for the result of the function (these two words are skipped if the routine is a procedure); 3) the parameters being passed to the routine, in reverse order (ie, the last declared parameter is popped off first). 2. You can construct a separate UNIT, which contains text that performs some involved but functionally distinct process within your program. This is then compiled separately, and the calling program merely states "USES , ,...,;" at the second line of the program (right after the main program declaration). Normally, you should incorporate the code from the correctly compiled UNIT into the SYSTEM.LIBRARY, where it is available to the linker. The documentation is not clear about how common variables are actually declared: any constant, type, variable, procedure, or function declared in the INTERFACE portion of the unit is read first thing at the time of compilation of the main program, and these declarations are copied verbatim into the text of the main program by the compiler. This means that you should NOT declare the same constants, types, etc., within the main program, even if you use them -- you will get an error, since they are already there. (If this is not clear, try setting up a UNIT and a main program that uses it, then examine a listing of the main program after compilation.) I have used the UNIT approach with great success for a complicated text processing program, for two functions: 1) the program begins with a detailed menu that reads in user requests for margins, page length, etc. Not only is this code quite long, it stands by itself (simply passing initialized variables to the main program) and was best debugged by itself. 2) I added an automatic hyphenation routine, which also was quite long and needed to be debugged separately. 3. Finally, it is possible (but within the main program ONLY) to declare certain procedures or functions SEGMENT procedures/functions. The compilation process is not changed, but when the program is actually run, the declared procedures are drawn into memory only when required, and are overwritten by data or code at other times. This approach is essential if you have a complicated program that uses a lot of memory and has one or more long procedures (most commonly an initialization routine) you expect to use rarely, before the memory fills up. Unlike some other Pascal implementations, all other code (not explicitly declared a SEGMENT procedure/function) is always memory resident while the program is running. Further, there is no clean way for one program to load another and then pass execution to it. (You have to have some way of fudging the console input buffer in the BIOS, then quit the execution of the present program, then trick the operating system with your phony console input.) However, I'll bet that someone familiar with the operating system could cook up a way of feeding data directly to the program execution section; it would require compiling your routine (usually simply a menu) at the 0th lex level with the (*$U-*) compiler command. The reason this may be important is that many business programs use multiple separate procedures driven by a menu, and the Pascal system at present limits you to 6 procedure segments. It is absolutely not mentioned anywhere, but although external UNITS are given new segment numbers by the compiler, they are ALWAYS resident in memory at run time. If you want to have the code in a unit work as a SEGMENT PROCEDURE or FUNCTION, you MUST include the source within the main file and declare it a SEGMENT PROCEDURE or FUNCTION. ======================================================================================== DOCUMENT :usus Folder:VOL01:volume1.text ======================================================================================== A GUIDE TO THIS VOLUME First, a list of the documentation files on the disk and to which programs they refer: CPM.DOC.TEXT. Miscellaneous comments on the operation of the 8080/Z-80 interpreter. Also contains the documentation for DISKREAD, GETCPM and GETCPM2, RWCPM, READCPM, and INOUTREADY. (Note that a UCSD-to-CP/M file copier will be included on a subsequent disk; these all go the other way.) PRETTY.DOC. This discusses PRETTY (including INITVAR) and FORMAT (including FORMAT1 and FORMAT2). FORMAT.DOC. More extensive user instructions for FORMAT thru FORMAT2. GOTCHA.DOC. Stand-alone comments on the hidden hardware requirements for Z-80 and 8080 users. UNITS.DOC. More stand-alone comments, this time distinguishing UNITS, EXTERNAL procedures/functions, and SEGMENT procedures/functions. INTRODUCTN. This file is a copy of the paper in the Proceedings of the Fourth West Coast Computer Faire, and represents the initial goals of this library of software and other comments. I have since been in touch with SofTec; the present status of the Users' Group Library should be documented separately. Next, let's look at the other files: COMBINE. This is a very early attempt by me. Problems include less than perfect file-getting (see CRT.I.O for a superior version) and the slowest procedure in UCSD Pascal: reading and writing lines of text. CRT.I.O. I like this set of routines a great deal, and I hope you find them useful. They are designed to assist you in obtaining data from a naive user in an interactive environment in a way that is "chimpanzee proof": no matter what you type (within limits), you can't crash the program or mar the display. All but GETFILE are designed to enter data directly into a menu on the CRT, and require the X-Y locations of the data requested. Except GETFILE, all routines can be exited by typing , leaving the original data undisturbed. Further, the integer routine does automatic range checking and won't let the user out until the data is correct or the user types . GETFILE allows the user to quit the program by typing an empty line in response to a filename request, though this action is first verified. L. This stands for L(ist, and is a very handy file lister. At present it is configured for my Malibu dot-matrix printer, and expands headings if the filename is to be included. It is designed to list both programs (ask it to include the filename) and manuscripts (heading optional; not printed on first page nor expanded). The options are as follows: 1) Line spacing, single to 4 lines. 2) Whether or not to print a page heading. 3) If you choose a heading, you can include the filename and limited other data (printed expanded) or skip the filename and write another heading of your choice (none is required). 4) You can print all or part of a file by specifying beginning and ending page numbers. MODEM (includes the 8080 routine CRC16) and MODEM1. These two D. C. Hayes drivers should be fairly self-documenting. I don't have a modem and haven't tested them. The main problem with these sorts of programs is that as yet, there is no data transmission standard, so the guy on the other end of the line must agree with your protocol. SIMP stands for Simplified Integral Modular Prose generator. I think it's much more fun if you see what it does for yourself; it will dump its output on the console or the printer (your choice). TYPESET is Sam Singer's gift to his wife, and simply right justifies any text presented to it. It is designed for his Qume and personalized Qume driver, but should be easy to modify for other printers with micro spacing. The text output is a single, long column, of the same basic column width as the original (set in the Editor). Sam tried for hyphenation but couldn't get it to work. ======================================================================================== DOCUMENT :usus Folder:VOL03:blackjack.text ======================================================================================== PROGRAM BLACKJK; {GAME OF BLACKJACK WRITTEN IN PASCAL BY T.R. STOKES} CONST XINST = 10; {VARIOUS X-Y COORDS FOR SCREEN MESSAGES} YINST = 3; XWIN = 11; YWIN = 2; XBET = 8; YBET = 1; XOVER = 5; YOVER = 4; YHAND0= 6; {LEVEL-1 OF CARDS PLAYED} TYPE VEGAS = (PLAYER,DEALER); VAR DECK :ARRAY[1..52] OF INTEGER; RANK,SUIT :INTEGER; NAMRANK,NAMSUIT :STRING; CARDSLEFT :INTEGER; SEED :INTEGER; PERSON :VEGAS; HANDVAL :ARRAY[1..2] OF INTEGER; NACES :ARRAY[1..2] OF INTEGER; HANDSIZE :ARRAY[1..2] OF INTEGER; BET,DOLLARS :INTEGER; BUST,BJACK,PUSH,WIN :BOOLEAN; XPLYR,YPLYR :INTEGER; XDELR,YDELR :INTEGER; I,J :INTEGER; {GENERAL PURPOSE INDICES} CARDVAL :INTEGER; REPLY :CHAR; CHOICE :SET OF CHAR; XHOLE,YHOLE :INTEGER; HOLSUIT,HOLRANK :STRING; DBLDOWN :BOOLEAN; PROCEDURE NEWSCREEN; BEGIN WRITE(CHR(1),CHR(12)); END; {NEWSCREEN} PROCEDURE CLEARTOP; BEGIN GOTOXY(0,0); WRITE(CHR(17)); {CLEAR TO END OF LINE} END; {CLEARTOP} PROCEDURE CLEREOL(X,Y:INTEGER); BEGIN GOTOXY(X,Y); WRITE(CHR(17)); {CLEAR TO END OF LINE} END; {CLEREOL} PROCEDURE CLERBOT; BEGIN GOTOXY(0,YPLYR); WRITE(CHR(12)); {CLEAR TO END OF SCREEN} END; {CLERBOT} PROCEDURE SHUFMES; BEGIN CLEARTOP; GOTOXY(5,0); WRITE('SHUFFLING- HAVE A DRINK ON THE HOUSE.'); END; {SHUFMES} FUNCTION RND:REAL; BEGIN RND:=SEED/32767; SEED:=(12585*SEED+6975) MOD 32767; END; {RND} PROCEDURE FRESHDECK; BEGIN FOR I:=1 TO 52 DO BEGIN DECK[I]:=I; END; {FOR} END; {FRESHDECK} PROCEDURE SHUFFLE; VAR TEMP,RI:INTEGER; BEGIN SHUFMES; CARDSLEFT:=52; FOR I:=1 TO 52 DO BEGIN TEMP:=DECK[I]; RI:=TRUNC(52*RND+1); DECK[I]:=DECK[RI]; DECK[RI]:=TEMP; END; {FOR} CLEARTOP; END; {SHUFFLE} PROCEDURE NAMECARD; BEGIN NAMRANK:=' '; {MAKE IT ONE BYTE LONG} NAMRANK[1]:=CHR(RANK+48); {SO THIS WILL WORK} IF RANK=1 THEN NAMRANK:='ACE ' ELSE IF RANK>9 THEN BEGIN CASE RANK OF 10:NAMRANK:='10 '; 11:NAMRANK:='JACK '; 12:NAMRANK:='QUEEN'; 13:NAMRANK:='KING '; END {RANKCASE} END; BEGIN CASE SUIT OF 1:NAMSUIT:='CLUBS '; 2:NAMSUIT:='DIAMONDS'; 3:NAMSUIT:='HEARTS '; 4:NAMSUIT:='SPADES '; END {SUITCASE} END; END; {NAMECARD} PROCEDURE RANSUIT(CARD:INTEGER); BEGIN RANK:=CARD MOD 13; IF RANK=0 THEN RANK:=13; SUIT:=(CARD-1) DIV 13 + 1; END; {RANSUIT} PROCEDURE SETUP; BEGIN BUST:=FALSE; BJACK:=FALSE; PUSH:=FALSE; WIN:=FALSE; DBLDOWN:=FALSE; XPLYR:=0; YPLYR:=YHAND0; XDELR:=26; YDELR:=YHAND0; FOR I:=1 TO 2 DO BEGIN HANDVAL[I]:=0; NACES[I]:=0; HANDSIZE[I]:=0; END; {FOR} END; {SETUP} PROCEDURE SHOWHAND; VAR X,Y,CN :INTEGER; BEGIN CASE PERSON OF PLAYER: BEGIN YPLYR:=YPLYR+1; Y:=YPLYR; X:=XPLYR; END; DEALER: BEGIN YDELR:=YDELR+1; Y:=YDELR; X:=XDELR; END; END; {CASE} NAMECARD; GOTOXY(X,Y); CN:=Y-YHAND0; WRITE(CN:3,')',NAMRANK:6,' OF ',NAMSUIT); END; {SHOWHAND} PROCEDURE SCORE; VAR ANACE,NAC,CARDVAL:INTEGER; BEGIN CASE PERSON OF PLAYER:I:=1; DEALER:I:=2; END; {CASE} CARDVAL:=RANK; IF RANK>10 THEN CARDVAL:=10; IF RANK=1 THEN NACES[I]:=NACES[I]+1; NAC:=NACES[I]; ANACE:=0; IF RANK=1 THEN ANACE:=1; HANDVAL[I]:=HANDVAL[I]+CARDVAL+10*ANACE; WHILE (HANDVAL[I]>21) AND (NAC>0) DO BEGIN NACES[I]:=NACES[I]-1; HANDVAL[I]:=HANDVAL[I]-10; END; {WHILE} IF HANDVAL[I]>21 THEN BUST:=TRUE END; {SCORE} PROCEDURE PSCORE; BEGIN GOTOXY(XPLYR+6,YPLYR+1); WRITE('TOTAL = ',HANDVAL[1]:3); END; {PSCORE} PROCEDURE HSCORE; BEGIN GOTOXY(XDELR+6,YDELR+1); WRITE('TOTAL = ',HANDVAL[2]:3); END; {HSCORE} PROCEDURE WINNINGS; BEGIN IF NOT PUSH THEN BEGIN IF DBLDOWN THEN BET:=BET+BET; IF WIN THEN DOLLARS:=DOLLARS+BET ELSE DOLLARS:=DOLLARS-BET END; {NOT PUSH} CLEREOL(XWIN,YWIN); WRITE('In U.S. of A. Dollars you have $',DOLLARS); END; {WINNINGS} PROCEDURE DOWHAT; BEGIN CLEREOL(XOVER,YOVER); REPEAT GOTOXY(XOVER,YOVER); WRITE('YOUR MONEY ? '); READ(REPLY); UNTIL REPLY IN CHOICE; IF (REPLY='D') AND (HANDSIZE[1]>2) THEN BEGIN CLEREOL(XINST,YINST); WRITE('NO-NO, NOT AFTER 3 OR MORE!!'); DOWHAT; END; END; {DOWHAT} PROCEDURE NOSHOW; VAR CN:INTEGER; BEGIN YDELR:=YDELR+1; GOTOXY(XDELR,YDELR); CN:=YDELR-YHAND0; WRITE(CN:3,') ?????????'); XHOLE:=XDELR; YHOLE:=YDELR; HOLSUIT:=NAMSUIT; HOLRANK:=NAMRANK; END; {NOSHOW} PROCEDURE INSTRUCTIONS; BEGIN GOTOXY(XINST,YINST); WRITE('H)it, G)ood, D)oubledown, S)plitpair'); END; {INSTRUCTIONS} PROCEDURE PLAYERIN; VAR B:CHAR; BEGIN CLEREOL(XBET,YBET); WRITE('HOUSE LIMIT IS $200.. BET LIMIT ? (Y/N) '); READ(B); IF B<>'N' THEN BET:=200 ELSE BEGIN REPEAT CLEREOL(XBET,YBET); WRITE('HOUSE LIMIT IS $200.. BET PLEASE ? '); READLN(BET); UNTIL BET<201 END; {REPEAT} END; {PLAYERIN} PROCEDURE SHOHOLE; VAR CN:INTEGER; BEGIN GOTOXY(XHOLE,YHOLE); CN:=YHOLE-YHAND0; WRITE(CN:3,')',HOLRANK:6,' OF ',HOLSUIT); END; {SHOHOLE} PROCEDURE DEAL; VAR K,CARD:INTEGER; BEGIN K:=CARDSLEFT; CARD:=DECK[K]; RANSUIT(CARD); NAMECARD; CARDSLEFT:=CARDSLEFT-1; IF CARDSLEFT=0 THEN SHUFFLE; IF PERSON=PLAYER THEN HANDSIZE[1]:=HANDSIZE[1]+1 ELSE HANDSIZE[2]:=HANDSIZE[2]+1; END; {DEAL} PROCEDURE DEAL2; VAR C:INTEGER; BEGIN FOR C:=1 TO 2 DO BEGIN FOR PERSON:=PLAYER TO DEALER DO BEGIN DEAL; SCORE; IF (PERSON=DEALER) AND (C=1) THEN NOSHOW ELSE SHOWHAND END; {PERSON} END; {FOR} END; {DEAL2} PROCEDURE TEST21; BEGIN IF (HANDVAL[1]=21) OR (HANDVAL[2]=21) THEN BEGIN BJACK:=TRUE; SHOHOLE; IF HANDVAL[1]=HANDVAL[2] THEN BEGIN PUSH:=TRUE; CLEREOL(XOVER,YOVER); WRITE('* * DOUBLE BLACKJACK !!! - PUSH -'); END {PUSH} ELSE IF HANDVAL[1]=21 THEN BEGIN WIN:=TRUE; BET:=BET+BET DIV 2; CLEREOL(XOVER,YOVER); WRITE('* * * BLACKJACK !! - PAY 1.5 TIMES BET '); END {PLAYERS BLACKJACK} ELSE BEGIN CLEREOL(XOVER,YOVER); WRITE('* * DEALER HAS A BLACKJACK !!'); END; END; {BJACK:=TRUE} END; {TEST21 - NO BLACKJACK} PROCEDURE DEALPLAYER; BEGIN PERSON:=PLAYER; REPEAT DOWHAT; IF (REPLY='H') OR (REPLY='D') THEN BEGIN DEAL; SHOWHAND; SCORE; END UNTIL BUST OR (REPLY<>'H') OR (REPLY='D'); IF BUST THEN BEGIN CLEREOL(XOVER,YOVER); WRITE('YOU BUSTED WITH ',HANDVAL[1]:3); END; {IF BUST} IF REPLY='D' THEN DBLDOWN:=TRUE; END; {DEALPLAYER} PROCEDURE DEALHOUSE; BEGIN PERSON:=DEALER; SHOHOLE; WHILE (HANDVAL[2]<17) OR ((HANDVAL[2]=17) AND (NACES[2]>0)) DO BEGIN DEAL; SHOWHAND; SCORE; END; {WHILE} HSCORE; END; {DEALHOUSE} PROCEDURE EVALUATE; VAR HV:INTEGER; BEGIN IF BUST THEN BEGIN WIN:=TRUE; CLEREOL(XOVER,YOVER); WRITE('THE HOUSE BUSTED WITH ',HANDVAL[2]:3); END ELSE IF HANDVAL[1]=HANDVAL[2] THEN PUSH:=TRUE ELSE IF HANDVAL[1]>HANDVAL[2] THEN WIN:=TRUE; IF PUSH THEN BEGIN CLEREOL(XOVER,YOVER); WRITE(' - PUSH -'); END; HV:=HANDVAL[2]; IF (NOT PUSH) AND (NOT BUST) THEN BEGIN CLEREOL(XOVER,YOVER); IF HV=21 THEN WRITE('DEALER HAS 21!!') ELSE WRITE('PAY ',HV+1); END; {NOT PUSH} END; {EVALUATE} BEGIN {MAIN PROGRAM} CHOICE:=['H','G','D','S']; NEWSCREEN; WRITE(' PLEASE ENTER A RANDOM NUMBER - '); READLN(SEED); FRESHDECK; SHUFFLE; SETUP; INSTRUCTIONS; PLAYERIN; DOLLARS:=0; REPEAT IF BET>0 THEN BEGIN DEAL2; TEST21; IF NOT BJACK THEN BEGIN DEALPLAYER; PSCORE; IF NOT BUST THEN BEGIN DEALHOUSE; EVALUATE; END; {IF NOT BUST} END; {NOT BJACK} END; {BET>0} INSTRUCTIONS; WINNINGS; PLAYERIN; SETUP; CLERBOT; UNTIL BET<0 END. {MAIN PROGRAM} ======================================================================================== DOCUMENT :usus Folder:VOL03:catalog.3.text ======================================================================================== VOLUME 3 CATALOG, UCSD PASCAL USERS' GROUP LIBRARY Prose, games, and some ideas.* BLACKJACK.TEXT.....Now you can play it in Pascal. Appropriate for 1980: allows negative money. CHASE.TEXT.........A good implementation of an old favorite. Get away from the robots, but don't get zapped by the electric fence! DEBTS.TEXT.........Home finance program, keeps track of your bills. Nicely menu driven, easy to use. OTHELLO.TEXT.......VERY nice implementation of OTHELLO, the best I've seen. OTHELL1.TEXT OTHELL2.TEXT OTHELLINIT.TEXT....Subfiles of OTHELLO. POLICY.DOC.TEXT....How the Users' Group Library works. PROSE.DOC1.TEXT PROSE.DOC2.TEXT....A subset of the documentation of Prose, copied from the Pas- cal News No. 15. What you really need to know to use it. PROSE.TEXT.........A copy of the fancy text-formatting program from the Pascal News, No. 15, adapted for UCSD Pascal by its author, J. P. Strait, of the University of Minnesota. Requires most of 64K of memory to compile. PROSE.0.TEXT PROSE.A.TEXT PROSE.B.TEXT PROSE.C.TEXT PROSE.D.TEXT PROSE.E.TEXT PROSE.F.TEXT.......Subfiles of Prose. PROSE.I.5.CODE.....Object version for those without sufficient memory to com- pile; will run under UCSD versions I.4 and I.5. REQUESTS.TEXT......Some ideas for some very needed programs and routines. SNOOPY.TEXT........Snoopy calendar, featuring the W.W. I flying ace. STORE.DATA.........Sample data file for DEBTS.TEXT. UNIVERSAL.TEXT.....Suggestion for a UNIT that will let us use each other's pro- grams without having to edit in hardware-specific routines. * NOTE: UCSD Pascal is a trademark of the Regents of the University of Calofornia. Please read the file POLICY.DOC.TEXT regarding the software on this disk. All programs should be self-documenting, though you'll have to fix hard- ware-specific procedures in the game programs (see UNIVERSAL.TEXT for a discus- sion of this subject); as a rule, any code your system does not support (e.g., KeyPress or a system clock) can just be deleted. ======================================================================================== DOCUMENT :usus Folder:VOL03:chase.text ======================================================================================== PROGRAM CHASE; CONST MAN = 'O'; {SYMBOL FOR THE MAN} EDGE = 'I'; {SYMBOL FOR THE FENCE} OBST = '*'; {SYMBOL FOR AN OBSTRUCTION} ROBOT = 'R'; {SYMBOL FOR A ROBOT} BLANK = ' '; {AN ASCII BLANK} DROB = 3; {STARTING NO OF ROBOTS} ROBMAX = 20; {MAX NO OF ROBOTS ALLOWED} XMAX = 39; {MAX HORIZONTAL FIELD DIMENSION} YMAX = 14; {MAX VERTICAL FIELD DIMENSION} TOP = 2; {SPACE ABOVE FIELD} SIDE = 5; {SPACE TO LEFT OF FIELD} CLRSCRN = 26; {CLEAR SCREEN CODE} VAR FIELD : PACKED ARRAY[0..XMAX,0..YMAX] OF CHAR; AGAIN,PLAY : BOOLEAN; WIN : BOOLEAN; MI,MJ : INTEGER; {COORDINATES OF THE MAN} R : INTEGER; {NUMBER OF ROBOTS LEFT} RI,RJ : ARRAY[1..ROBMAX] OF INTEGER; {ROBOT COORDINATES} RNUM : REAL; DIFF : INTEGER; {DIFFICULTY} IDIFF : 0..10; {INITIAL DIFFICULTY} GAMENU : INTEGER; {GAME NUMBER} M : CHAR; NROB : INTEGER; {NUMBER OF ROBOTS} WINS : INTEGER; {NUMBER OF GAMES WON} GOODCHAR : SET OF CHAR; {GOOD CHARACTERS} MOVES : INTEGER; {COUNT OF MOVES} CRASH : INTEGER; {NO OF ROBOTS "CRASHED"} FUNCTION RND(LO,HI:INTEGER):INTEGER; {RANDOM NUMBER GENERATOR} VAR Q :REAL; I :INTEGER; BEGIN REPEAT RNUM:=RNUM*21.182813+31.415917; RNUM:=RNUM-TRUNC(RNUM); I:=TRUNC(RNUM*HI); UNTIL I>LO; RND:=I; END; PROCEDURE DOMOVE(COL,ROW:INTEGER;SYMBOL:CHAR); {DISPLAY SYMBOL AT I,J ON FIELD} BEGIN GOTOXY(COL,ROW); {POSITION CURSOR} WRITE(SYMBOL) END; {END OF DOMOVE PROCEDURE} PROCEDURE CLEARSCREEN; {FOR AN ADM3-A CHANGE IT FOR OTHER TERMINAL} BEGIN WRITE(CHR(CLRSCRN),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0)) END; PROCEDURE INSTRUCTIONS; {DISPLAY INSTRUCTIONS} VAR M:CHAR; BEGIN CLEARSCREEN; WRITELN('WELCOME TO THE WONDERFUL EXCITING GAME OF CHASE':60); GOTOXY(0,3); WRITE('WOULD YOU LIKE INSTRUCTIONS ? (Y OR N) ':55); READ(M); IF M='Y' THEN BEGIN WRITELN;WRITELN; WRITELN(' HERE ARE SOME INSTRUCTIONS'); WRITELN('YOU,"O",ARE IN A HIGH VOLTAGE MAZE.'); WRITELN('THE ROBOT COMPUTERS,"R",ARE TRYING TO DESTROY YOU.'); WRITELN('TO WIN, YOU MUST DESTROY THE COMPUTERS.'); WRITELN('THIS IS DONE BY RUNNING THEM INTO FENCE POSTS,"*",'); WRITELN('OR BY RUNNING THEM INTO EACH OTHER.'); WRITELN('THE DIAGRAM BELOW THE MAZE SHOWS HOW YOU CAN MOVE'); WRITELN('THE ROBOTS WILL TRY TO FOLLOW YOU.'); WRITELN('THERE ARE 3 ROBOTS TO START FOR A BEGINNER.'); WRITELN('THE NUMBER WILL INCREASE AS YOU WIN GAMES !'); WRITELN; WRITELN(' GOOD LUCK!!!!!') END; END; {END OF INSTRUCTIONS} PROCEDURE STARTGAME; VAR SK: CHAR; BEGIN WRITELN;WRITELN;WRITELN; WRITE('ENTER A NUMBER FOLLOWED BY RETURN ':51);READLN(RNUM); IF RNUM=0 THEN RNUM:=12.345; WHILE RNUM > 200 DO RNUM:=RNUM-200; CLEARSCREEN; WRITELN(' HOW GOOD A PLAYER ARE YOU ?'); WRITELN; WRITELN(' BEGINNER - B'); WRITELN(' INTERMEDIATE - I'); WRITELN(' EXPERT - E'); WRITELN(' OLD PRO - P'); WRITELN; WRITE(' TYPE IN YOUR SKILL '); READ (SK); WRITELN; WHILE NOT (SK IN ['B','I','E','P']) DO BEGIN GOTOXY(10,10); WRITE(' WHAT WAS THAT AGAIN PLEASE ? ',CHR(7)); READ (SK); WRITELN END; CASE SK OF 'B': IDIFF:=0; 'I': IDIFF:=1; 'E': IDIFF:=3; 'P': IDIFF:=5; END; END; PROCEDURE INITIALIZE; {SET UP BLANK FIELD SURROUNDED BY FENCE} VAR I,J:INTEGER; BEGIN FOR I:=0 TO XMAX DO BEGIN FOR J:=0 TO YMAX DO IF((I=0) OR (I=XMAX) OR (J=0) OR (J=YMAX)) THEN FIELD[I,J]:=EDGE ELSE FIELD[I,J]:=BLANK END; END; {END OF INITIALIZE} PROCEDURE INNERFIELD; {SET UP MAN, ROBOTS AND OBSTRUCTIONS} VAR I,J,L,POSTS:INTEGER; BEGIN MI:=RND(0,XMAX); MJ:=RND(0,YMAX); {LOCATE MAN AT ANY RANDOM POSITION} FIELD[MI,MJ]:=MAN; R:=NROB; FOR L:=1 TO R DO {NOW DO R ROBOTS} BEGIN REPEAT I:=RND(0,XMAX);J:=RND(0,YMAX); UNTIL FIELD[I,J]=BLANK; FIELD[I,J]:=ROBOT; RI[L]:=I; RJ[L]:=J END; POSTS:=RND(25,35); {NOW SET UP 25 TO 35 POSTS} FOR L:=1 TO POSTS DO BEGIN REPEAT IF DIFF>3 THEN BEGIN I:=RND(0,XMAX); J:=RND(0,YMAX) END ELSE BEGIN I:=RND(1,XMAX-1); J:=RND(1,YMAX-1) END; UNTIL FIELD[I,J]=BLANK; FIELD[I,J]:=OBST END; END; {END OF INNERFIELD} PROCEDURE MAP; {DISPLAY PLAYING FIELD} VAR I,J:INTEGER; BEGIN CLEARSCREEN; WRITELN('GAME DIFF ROBOTS WINS MOVE':79); WRITE(' ':44,GAMENU:3,DIFF:5,R:8,WINS:10,MOVES:8); GOTOXY(0,0); FOR J:=0 TO YMAX DO BEGIN FOR I:=0 TO XMAX DO WRITE(FIELD[I,J]); WRITELN END; WRITELN; WRITELN('1 2 3 Q = QUIT'); WRITELN('4 X 6 5 = NO MOVE'); WRITE('7 8 9 MOVE => '); END; {END OF MAP} PROCEDURE MOVE; {ENTER YOUR MOVE FROM KEYBOARD} VAR M : INTEGER; C : CHAR; BAD : BOOLEAN; BEGIN BAD:=FALSE; REPEAT WRITE(' ',CHR(8)); READ (C); IF NOT (C IN GOODCHAR) THEN BEGIN GOTOXY(4,21); BAD:=TRUE; WRITE('BAD MOVE, PLEASE TRY AGAIN ':33,CHR(7)) END; UNTIL (C IN GOODCHAR); IF BAD THEN BEGIN GOTOXY(4,21); WRITE(' ':40); GOTOXY(10,22); END; IF C='Q' THEN BEGIN PLAY:=FALSE; WIN:=FALSE END; M:=ORD(C)-48; FIELD[MI,MJ]:=BLANK; DOMOVE(MI,MJ,BLANK); CASE M OF 1: BEGIN MI:=MI-1; MJ:=MJ-1 END; 2: MJ:=MJ-1; 3: BEGIN MI:=MI+1; MJ:=MJ-1 END; 4: MI:=MI-1; 5: ; 6: MI:=MI+1; 7: BEGIN MI:=MI-1; MJ:=MJ+1 END; 8: MJ:=MJ+1; 9: BEGIN MI:=MI+1; MJ:=MJ+1 END END; MOVES:=MOVES+1; IF FIELD[MI,MJ] = BLANK THEN BEGIN DOMOVE(MI,MJ,MAN); FIELD[MI,MJ]:=MAN END ELSE BEGIN IF FIELD[MI,MJ] = EDGE THEN BEGIN WIN:=FALSE; PLAY:=FALSE; WRITELN('OUCH, YOU GOT ELECTROCUTED!') END ELSE BEGIN IF FIELD[MI,MJ] = ROBOT THEN WRITELN('THWACK! YOU RAN INTO A ROBOT (TURKEY!)') ELSE WRITELN('ZZAP! YOU RAN INTO AN ELECTIFIED POST'); WIN:=FALSE; PLAY:=FALSE END; END; END; {END OF MOVE PROCEDURE} PROCEDURE ROBOTMOVE; {COMPUTE MOVE FOR R OR FEWER ROBOTS} VAR M,L,I,J:INTEGER; BEGIN FOR L:=1 TO NROB DO BEGIN IF((RI[L]<>0) AND (WIN)) THEN BEGIN FIELD[RI[L],RJ[L]]:=BLANK; DOMOVE(RI[L],RJ[L],BLANK); IF MI>RI[L] THEN RI[L]:=RI[L]+1; IF MIRJ[L] THEN RJ[L]:=RJ[L]+1; IF MJ2 THEN DIFF:=IDIFF+1; IF WINS>5 THEN DIFF:=IDIFF+2; IF WINS>8 THEN DIFF:=IDIFF+3; IF WINS>11 THEN DIFF:=IDIFF+4; IF WINS>15 THEN DIFF:=IDIFF+6; IF WINS>20 THEN DIFF:=IDIFF+8; IF WINS>30 THEN DIFF:=IDIFF+12; NROB:=DROB+2*DIFF END; END; END; END. ======================================================================================== DOCUMENT :usus Folder:VOL03:debts.text ======================================================================================== PROGRAM DEBTS; {KEEPS TRACK OF ALL REVOLVING DEBTS ON DISK FILE} {DISK FILE NAME IS STORE.DATA} CONST CLERSCRN=26; CLEREOL=28; CLEREOS=25; FIRSTLINE=3; FIRSTYR=70; LASTYR=99; TYPE MNTH=1..12; DAY=1..31; CHOICESET=SET OF CHAR; DATE= RECORD YY:INTEGER; MM:INTEGER; DD:INTEGER; END; STORECARD= RECORD NAME:STRING; LASTPAID:DATE; BALANCE:REAL; LASTPAYMENT:REAL; MINPAYMENT:REAL; CARRYCHARGE:REAL; MONTHLYCOST:REAL; TOTALCARRY:REAL; END; VAR LAST,INDEX :INTEGER; EXISTS,DONE :BOOLEAN; TODAY :DATE; THISPAYMENT :REAL; STORE :STORECARD; STORES :ARRAY[1..30] OF STORECARD; STORAL :FILE OF STORECARD; DATEISCURRENT :BOOLEAN; CHOICE :CHOICESET; REPLY :CHAR; DATERROR :BOOLEAN; PROCEDURE CLRSCRN; BEGIN WRITE(CHR(CLERSCRN)); END; PROCEDURE CLRFROM(LINE:INTEGER); BEGIN GOTOXY(0,LINE); WRITE(CHR(CLEREOS)); END; PROCEDURE CLREOL(LINE:INTEGER); BEGIN GOTOXY(0,LINE); WRITE(CHR(CLEREOL)); END; PROCEDURE CLRTO(LINE:INTEGER); VAR I:INTEGER; BEGIN FOR I:=0 TO LINE-1 DO BEGIN GOTOXY(0,I); CLREOL(I); END; {DO} END; PROCEDURE SHOWDATE; BEGIN WRITE(' ':14); WRITELN('TODAY IS: ',TODAY.MM,'/',TODAY.DD,'/',TODAY.YY); END; PROCEDURE SHOWMENU; BEGIN CLRFROM(FIRSTLINE); WRITELN('D)':6,' todays Date'); WRITELN('G)':6,' Global list of creditors'); WRITELN('P)':6,' Pay a creditor'); WRITELN('C)':6,' Correct a record'); WRITELN('A)':6,' Add a creditor'); WRITELN('L)':6,' list Late payments'); WRITELN('E)':6,' Expanded creditor info'); WRITELN('F)':6,' Figure minimum payment'); WRITELN('R)':6,' Remove a creditor'); WRITELN('T)':6,' Total all debts'); WRITELN('Q)':6,' Quit'); IF DATEISCURRENT THEN SHOWDATE ELSE WRITELN(' ':8,'**NOTE: FIRST COMMAND SHOULD BE -D- FOR DATE'); END; {SHOWMENU} PROCEDURE CHOOSE; BEGIN WRITE(' ':5,'Choose an item from the Menu->'); REPEAT READ(REPLY); UNTIL REPLY IN CHOICE END; {CHOOSE} PROCEDURE GETDATE(VAR ADAY:DATE); VAR M,D,Y:INTEGER; BEGIN DATERROR:=FALSE; WRITE(' Enter date as MM DD YY -> '); READLN(M,D,Y); IF (M<1) OR (M>12) THEN DATERROR:=TRUE; IF (D<1) OR (D>31) THEN DATERROR:=TRUE; IF (Y<20) OR (Y>99) THEN DATERROR:=TRUE; IF NOT DATERROR THEN BEGIN WITH ADAY DO BEGIN MM:=M; DD:=D; YY:=Y; WRITELN(' ':20,MM:2,'/',DD:2,'/',YY); END; END {NOT ERROR} ELSE BEGIN WRITELN(' ??? DATE DD/MM/YY = ',D,M,Y); WRITELN(' PLEASE TRY AGAIN'); END; END; {GETDATE} PROCEDURE ADD; VAR C :CHAR; X :REAL; BEGIN CLRSCRN; LAST:=LAST+1; INDEX:=LAST; WITH STORES[INDEX] DO BEGIN WRITELN; WRITELN(' ':10,'ADDING A NEW RECORD - -'); WRITELN; WRITE(' ENTER STORE/CREDITOR NAME-> '); READLN(NAME); WRITELN(' ENTER DATE OF LAST PAYMENT'); DATERROR:=TRUE; WHILE DATERROR DO GETDATE(LASTPAID); WRITE(' WHAT IS THE CURRENT BALANCE? '); READLN(BALANCE); WRITE(' IF YOU KNOW MIN. PAYMENT, ENTER IT, ELSE ENTER 0 '); READLN(X); IF X=0 THEN X:=BALANCE/10.0; MINPAYMENT:=X; WRITE(' HOW MUCH WAS THE LAST PAYMENT? '); READLN(LASTPAYMENT); WRITE(' WHAT IS THE CARRYING CHARGE IN PERCENT? '); READLN(CARRYCHARGE); MONTHLYCOST:=BALANCE*CARRYCHARGE/100.0; TOTALCARRY:=0; END; {WITH} CLRTO(FIRSTLINE); END; {ADD} PROCEDURE INFORM; BEGIN WRITELN(' THIS PROGRAM KEEPS PERMANENT RECORDS OF YOUR'); WRITELN('DEBTS TO STORES, ETC, THAT REQUIRE MONTHLY PAYMENTS'); WRITELN('THE DATA IS KEPT ON A FILE NAMED - STORE.DATA '); WRITELN; END; {INFORM} PROCEDURE OPENFILE; VAR C:CHAR; BEGIN REWRITE(STORAL,'STORE.DATA'); WRITELN; WRITELN('** NEW FILE - STORE.DATA - WAS CREATED'); INDEX:=0; LAST:=0; END; PROCEDURE REOPEN; BEGIN RESET(STORAL,'STORE.DATA'); INDEX:=1; STORES[INDEX]:=STORAL^; WHILE NOT EOF(STORAL) DO BEGIN INDEX:=INDEX+1; GET(STORAL); STORES[INDEX]:=STORAL^; END; {WHILE} INDEX:=INDEX-1; LAST:=INDEX; END; {REOPEN} PROCEDURE CLOSEFILE; BEGIN CLOSE(STORAL,LOCK); {CLOSE EXISTING FILE} REWRITE(STORAL,'STORE.DATA'); {OPEN A NEW ONE} FOR INDEX:=1 TO LAST DO BEGIN STORAL^:=STORES[INDEX]; PUT(STORAL); END; {OF INDEXING} CLOSE(STORAL,LOCK); {MAKE IT PERMANENT ON DIR.} DONE:=TRUE; END; {CLOSEFILE} PROCEDURE INIT; VAR C,C2:CHAR; BEGIN CLRSCRN; INFORM; DATEISCURRENT:=FALSE; DONE:=FALSE; CHOICE:=['D','G','P','C','A','L','E','F','R','T','Q']; WRITELN; WRITELN('WARNING - IF A DATA FILE DOES NOT EXIST'); WRITELN(' (it wont on the very first run)'); WRITELN('YOU MUST CREATE ONE BY USING THE'); WRITELN(' A (ADD) COMMAND'); WRITE('DOES A DATA FILE EXIST (Y/N)? '); READ(C); IF C<>'Y' THEN BEGIN WRITELN; WRITELN(' ANY EXISTING FILE WILL BE CLOBBERED!!'); WRITE(' DO YOU WANT TO START A NEW ONE ? '); READ(C2); IF C2<>'Y' THEN C:='Y'; END; EXISTS:=FALSE; IF C='Y' THEN EXISTS:=TRUE; IF EXISTS THEN REOPEN ELSE OPENFILE; CLRSCRN; END; {INIT} PROCEDURE QUIT; VAR C1,C2:CHAR; BEGIN CLRTO(FIRSTLINE); GOTOXY(5,0); WRITE(' DO YOU WANT TO QUIT (Y/N)? '); READ(C1); IF C1='Y' THEN BEGIN DONE:=TRUE; WRITELN; WRITE(' DO YOU WANT THIS TO BE THE NEW FILE (Y/N)? '); READ(C2); IF C2='Y' THEN CLOSEFILE; END; {IF C1='Y'} END; {QUIT} PROCEDURE GLOBALS; VAR C:CHAR; LIN:INTEGER; BEGIN CLRSCRN; GOTOXY(0,FIRSTLINE); FOR INDEX:=1 TO LAST DO BEGIN WITH STORES[INDEX] DO BEGIN LIN:=FIRSTLINE+INDEX-1; WRITE(INDEX:3,'. '); WRITE(NAME); GOTOXY(18,LIN); WRITE(BALANCE:8:2); WITH LASTPAID DO WRITE(MM:6,'/',DD:2,'/',YY:2); WRITE(LASTPAYMENT:8:2); WRITELN; END; {WITH} END; {DO} WRITELN('-----------------------------------------------'); IF REPLY='G' THEN BEGIN CLREOL(0); GOTOXY(9,0); WRITE(' Hit a key to continue'); READ(C); CLRTO(FIRSTLINE); END; {REPLY='G'} END; {GLOBALS} PROCEDURE GETTODAY; BEGIN CLRTO(FIRSTLINE); GOTOXY(0,0); DATERROR:=TRUE; WHILE DATERROR DO GETDATE(TODAY); DATEISCURRENT:=TRUE; END; PROCEDURE SHOWALL(I:INTEGER); VAR C:CHAR; BEGIN WITH STORES[I] DO BEGIN CLRSCRN; GOTOXY(10,0); WRITELN(I:2,') ',NAME); WRITELN; WRITE('Date of last payment :............. '); WITH LASTPAID DO WRITELN(MM:2,'/',DD:2,'/',YY:2); WRITELN; WRITELN('Total balance due = $........... ',BALANCE:8:2); WRITELN('Amount of last payment = $...... ',LASTPAYMENT:8:2); WRITELN('Monthly carrying charge: %...... ',CARRYCHARGE:8:2); WRITELN('Monthly finance charge = $...... ',MONTHLYCOST:8:2); WRITELN('Total charges to date = $...... ',TOTALCARRY:8:2); WRITELN('Minimum payment = $............. ',MINPAYMENT:8:2); WRITELN; END; {WITH} END; {SHOWALL} PROCEDURE PAY; VAR I:INTEGER; ANSWER:CHAR; BEGIN CLRSCRN; GLOBALS; GOTOXY(5,0); WRITE('Pay who ? '); READLN(I); IF (I<=LAST) AND (I>0) THEN BEGIN SHOWALL(I); WRITELN; WRITE(' ':10,'Pay how much ? '); READLN(THISPAYMENT); WITH STORES[I] DO BEGIN BALANCE:=BALANCE-THISPAYMENT; LASTPAYMENT:=THISPAYMENT; LASTPAID:=TODAY; END; {WITH} SHOWALL(I); WRITELN; WRITE(' ':10,'ALL O.K. ? '); READ(ANSWER); CLRTO(FIRSTLINE); IF ANSWER='N' THEN BEGIN GOTOXY(10,0); WRITE(' USE ''C'' TO CORRECT IT'); END; {IF} END {IF} ELSE BEGIN GOTOXY(6,0); WRITE('THAT NUMBER IS NOT IN THE LIST !'); END; {IF} END; {PAY} {START A GROUP OF DUMMY PROCS HERE} PROCEDURE LATE; BEGIN END; PROCEDURE EXPOSE; VAR I:INTEGER; C:CHAR; BEGIN CLRSCRN; GLOBALS; GOTOXY(5,0); WRITE('Expand which one (number) ? '); READLN(I); IF (I>0) AND (I<=LAST) THEN BEGIN SHOWALL(I); WRITE(' - - Hit a key to cont. '); READ(C); CLRTO(FIRSTLINE); END ELSE BEGIN GOTOXY(6,1); WRITE('THAT CHOICE IS NOT IN THE LIST'); END; {ELSE} END; {EXPOSE} PROCEDURE EXPAND; VAR C:CHAR; I:INTEGER; BEGIN CLRTO(FIRSTLINE); GOTOXY(5,0); WRITE('Do you want to step through all ? '); READ(C); IF C='Y' THEN BEGIN FOR I:=1 TO LAST DO BEGIN SHOWALL(I); WRITE(' - - Hit a key to cont. '); READ(C); CLRSCRN; END; {FOR} END {'Y'} ELSE EXPOSE END; {EXPAND} PROCEDURE FIGUREMIN; BEGIN END; PROCEDURE TOTALALL; VAR I :INTEGER; TOTALMONTH,TOTALBALANCE :REAL; C :CHAR; BEGIN CLRSCRN; TOTALMONTH:=0; TOTALBALANCE:=0; FOR I:=1 TO LAST DO WITH STORES[I] DO BEGIN TOTALBALANCE:=TOTALBALANCE+BALANCE; TOTALMONTH:=TOTALMONTH+MONTHLYCOST; END; {FOR-WITH} WRITELN; WRITELN; WRITELN(' Your Total balance is an incredible $ ', TOTALBALANCE:8:2); WRITELN; WRITELN(' And the total carrying charge per monthe is $ ', TOTALMONTH:7:2); WRITELN; WRITELN(' When you''ve seen enough'); WRITE(' press a key.... '); READ(C); CLRTO(FIRSTLINE); END; {TOTALALL} PROCEDURE REMOVE1; VAR I:INTEGER; C:CHAR; BEGIN CLRSCRN; GLOBALS; CLRTO(FIRSTLINE); GOTOXY(5,0); WRITE('Remove which one (number) ? '); READLN(I); IF (I>0) AND (I<=LAST) THEN BEGIN WITH STORES[I] DO WRITE(' Remove ',NAME,' ? '); READ(C); IF C='Y' THEN BEGIN LAST:=LAST-1; FOR INDEX:=I TO LAST DO STORES[INDEX]:=STORES[INDEX+1]; END; {C='Y'} END {IN LIST} ELSE {NOT IN LIST} BEGIN CLREOL(1); WRITE(' THAT NUMBER IS NOT IN THE LIST!!'); END; {ELSE) END; {IF} END; {REMOVE1} {END OF DUMMY PROCS} PROCEDURE CORRECT; VAR WHAT:CHAR; WHATSIT:SET OF CHAR; I:INTEGER; BEGIN WHATSIT:=['N','B','D','L','M','P','C','T','Q']; CLRSCRN; GLOBALS; GOTOXY(5,0); WRITE('Correct which record (number) ? '); READLN(I); IF (I>0) AND (I<=LAST) THEN BEGIN REPEAT SHOWALL(I); WRITELN('CORRECT one of the following:'); WRITELN('N)ame,B)alance,D)ate,L)astpmnt,M)inpmnt'); WRITELN('P)ercent,C)ost/mnth,T)otal charge,Q)uit'); REPEAT READ(KEYBOARD,WHAT) UNTIL WHAT IN WHATSIT; WITH STORES[I] DO CASE WHAT OF 'N':BEGIN WRITE('New Name? '); READLN(NAME); END; 'B':BEGIN WRITE('New Balance= '); READLN(BALANCE); END; 'D':BEGIN DATERROR:=TRUE; WHILE DATERROR DO GETDATE(LASTPAID); END; 'L':BEGIN WRITE('amount of Last payment'); READLN(LASTPAYMENT); END; 'M':BEGIN WRITE('Minumum payment ? '); READLN(MINPAYMENT); END; 'P':BEGIN WRITE('Percent monthly carry charge ? '); READLN(CARRYCHARGE); END; 'C':BEGIN WRITE('Cost per month ? '); READLN(MONTHLYCOST); END; 'T':BEGIN WRITE('Total carry charge to date ? '); READLN(TOTALCARRY); END; 'Q':; END; {CASE} UNTIL WHAT='Q'; CLRTO(FIRSTLINE); END {IF} ELSE BEGIN GOTOXY(6,1); WRITE('THAT NUMBER IS NOT IN THE RECORDS'); END; {ELSE} END; {CORRECT} PROCEDURE SERVE; BEGIN CASE REPLY OF 'D':GETTODAY; 'G':GLOBALS; 'P':PAY; 'C':CORRECT; 'A':ADD; 'L':LATE; 'E':EXPAND; 'F':FIGUREMIN; 'R':REMOVE1; 'T':TOTALALL; 'Q':QUIT; END; {CASE} END; {SERVE} BEGIN {MAIN PROG} INIT; REPEAT SHOWMENU; CHOOSE; SERVE; UNTIL DONE END. ======================================================================================== DOCUMENT :usus Folder:VOL03:othell1.text ======================================================================================== FUNCTION flipof(*oldcolor: color): color*); BEGIN IF oldcolor = white THEN flipof := black ELSE flipof := white; END; (*flipof*) PROCEDURE updatecrt(*VAR oldstatus,newstatus: gamestatus*); VAR x,y: coordinate; direc: direction; square: squareloc; PROCEDURE showpiece(square: squareloc); PROCEDURE changecrtsq(square: squareloc); CONST bell = 7; VAR s: PACKED ARRAY[1..3] OF CHAR; c: CHAR; crtline,crtcol: INTEGER; h,l: INTEGER; now: REAL; BEGIN WITH square DO BEGIN IF newstatus.boardstatus[row,col].occupier = white THEN c := CHR(whiteascii) ELSE c := CHR(blackascii); FILLCHAR(s,3,c); crtline := (3*row) - 3; crtcol := 26 + (6*col); END; REPEAT TIME(h,l); now := l; IF now < 0.0 THEN now := now + 65536.0; now := (h*65536.0) + now; UNTIL (now - lastchange) > minticks; GOTOXY(crtcol,crtline); WRITE(s); GOTOXY(crtcol,crtline+1); WRITE(s,CHR(bell)); lastchange := now; END; (*changecrtsq*) BEGIN (*showpiece*) WITH square DO IF newstatus.boardstatus[row,col].occupied THEN IF NOT oldstatus.boardstatus[row,col].occupied THEN changecrtsq(square) ELSE IF oldstatus.boardstatus[row,col].occupier <> newstatus.boardstatus[row,col].occupier THEN changecrtsq(square); END; (*showpiece*) BEGIN (*updatecrt*) WITH newstatus DO BEGIN showpiece(lastmoveloc); FOR direc := north to nw DO BEGIN square := lastmoveloc; WHILE boardstatus[square.row,square.col].occupied AND board[square.row,square.col].adjacentsq[direc].onboard DO BEGIN square := board[square.row,square.col].adjacentsq[direc]; showpiece(square); END; (*WHILE...*) END; (*FOR direc...*) GOTOXY(9,2); WRITE(score[white]:2); GOTOXY(9,3); write(score[black]:2); END; (*WITH newstatus...*) GOTOXY(0,0); END; (*updatecrt*) PROCEDURE findlegalmoves(VAR status: gamestatus; VAR legallist: movelist); VAR x,y: coordinate; sq: squareloc; flips,direcflips: INTEGER; borderflips: INTEGER; stopdirec: BOOLEAN; oppcolor: color; direc: direction; trydirs,gooddirs: SET OF direction; possible: BOOLEAN; sqstatus: squarestatus; BEGIN WITH status, legallist DO BEGIN oppcolor := flipof(nextmover); movecount := 0; FOR x := 1 TO 8 DO FOR y := 1 TO 8 DO BEGIN possible := FALSE; WITH boardstatus[x,y] DO IF NOT occupied THEN IF adjacentpieces[oppcolor] <> [] THEN BEGIN possible := TRUE; trydirs := adjacentpieces[oppcolor]; END; IF possible THEN BEGIN gooddirs := []; flips := 0; borderflips := 0; FOR direc := north TO nw DO IF direc IN trydirs THEN BEGIN sq := board[x,y].adjacentsq[direc]; sq := board[sq.row,sq.col].adjacentsq[direc]; IF sq.onboard THEN BEGIN direcflips := 1; stopdirec := FALSE; REPEAT sqstatus := boardstatus[sq.row,sq.col]; IF sqstatus.occupied THEN IF sqstatus.occupier = oppcolor THEN BEGIN direcflips := direcflips + 1; sq := board[sq.row,sq.col].adjacentsq[direc]; END ELSE stopdirec := TRUE ELSE BEGIN direcflips := 0; stopdirec := TRUE; END; UNTIL ( stopdirec OR (NOT sq.onboard) ); IF (stopdirec AND (direcflips>0)) THEN BEGIN flips := flips + direcflips; gooddirs := gooddirs + [direc]; IF board[x,y].border AND board[sq.row,sq.col].border THEN borderflips := borderflips + direcflips; END; END; (*IF sq.onboard...*) END; (*IF direc IN...*) IF flips > 0 THEN BEGIN movecount := movecount + 1; WITH okmove[movecount] DO BEGIN moveloc.onboard := TRUE; moveloc.row := x; moveloc.col := y; points := flips; dirsflipped := gooddirs; bordrsqsflipped := borderflips; END; END; END; (*IF possible...*) END; (*FOR x :=...FOR y :=...*) END; (*WITH status, legallist...*) END; (*findlegalmoves*) PROCEDURE inputmove(mover: color; legallist: movelist; VAR move: movedesc); VAR x,y: coordinate; xch,ych: CHAR; i,listindex: INTEGER; c: CHAR; BEGIN listindex := 0; REPEAT REPEAT GOTOXY(0,23); WRITE('Enter move for ',colorword[mover],': '); GOTOXY(22,23); READ(xch,ych); IF ych IN ['1'..'8'] THEN BEGIN (*Want xy but we'll accept yx*) c := ych; ych := xch; xch := c; END; IF ych IN ['a'..'h'] THEN ych := CHR(ORD(ych)-32); UNTIL ((xch IN ['1'..'8']) AND (ych IN ['A'..'H'])); x := ORD(xch) - ORD('1') + 1; y := ORD(ych) - ORD('A') + 1; i := 1; REPEAT IF legallist.okmove[i].moveloc.row = x THEN IF legallist.okmove[i].moveloc.col = y THEN listindex := i; i := i+1; UNTIL ((i>legallist.movecount) OR (listindex <> 0)); UNTIL listindex <> 0; move := legallist.okmove[listindex]; END; (*inputmove*) PROCEDURE makemove(*VAR status: gamestatus; VAR move: movedesc; updateadjacent: BOOLEAN*); VAR direc,direc2: direction; sq,sq2: squareloc; oppcolor: color; flips: INTEGER; emptyneighbors: SET of direction; BEGIN WITH status, move DO BEGIN lastmoveloc := moveloc; WITH boardstatus[moveloc.row,moveloc.col] DO BEGIN emptyneighbors := [north..nw] - adjacentpieces[white] - adjacentpieces[black]; occupied := TRUE; occupier := nextmover; END; oppcolor := flipof(nextmover); flips := 0; FOR direc := north TO nw DO IF direc IN dirsflipped THEN BEGIN sq := board[moveloc.row,moveloc.col].adjacentsq[direc]; REPEAT IF updateadjacent THEN FOR direc2 := north TO nw DO IF NOT (direc2 IN [direc,opposdir[direc]]) THEN BEGIN sq2 := board[sq.row,sq.col].adjacentsq[direc2]; IF sq2.onboard THEN WITH boardstatus[sq2.row,sq2.col] DO IF NOT occupied THEN BEGIN adjacentpieces[nextmover]:=adjacentpieces[nextmover] + [opposdir[direc2]]; adjacentpieces[oppcolor]:=adjacentpieces[oppcolor] - [opposdir[direc2]]; END; END; boardstatus[sq.row,sq.col].occupier := nextmover; flips := flips + 1; sq := board[sq.row,sq.col].adjacentsq[direc]; UNTIL boardstatus[sq.row,sq.col].occupier = nextmover; END ELSE IF updateadjacent THEN IF direc IN emptyneighbors THEN BEGIN sq := board[moveloc.row,moveloc.col].adjacentsq[direc]; IF sq.onboard THEN WITH boardstatus[sq.row,sq.col] DO adjacentpieces[nextmover] := adjacentpieces[nextmover] + [opposdir[direc]]; END; score[nextmover] := score[nextmover] + flips + 1; score[oppcolor] := score[oppcolor] - flips; nextmover := oppcolor; END; END; (*makemove*) ======================================================================================== DOCUMENT :usus Folder:VOL03:othell2.text ======================================================================================== PROCEDURE calcmove( mover: color; VAR status: gamestatus; VAR legallist: movelist; VAR bestmove: movedesc); TYPE movearray = ARRAY[1..30] OF movedesc; VAR bestsofar,cornmoves,m,respcornmoves: INTEGER; move,movetemp: movedesc; aftermove: gamestatus; responses: movelist; PROCEDURE checkposition(VAR legallist: movelist; VAR cornmoves: INTEGER); VAR m,bestm,bestyet: INTEGER; BEGIN bestyet := -MAXINT; cornmoves := 0; FOR m := 1 TO legallist.movecount DO WITH legallist.okmove[m], board[moveloc.row,moveloc.col] DO BEGIN bordnoncorn := FALSE; IF incenter4by4 THEN points := points + 10 ELSE BEGIN IF corner THEN BEGIN points := points + 60; cornmoves := cornmoves + 1; END ELSE IF border THEN BEGIN bordnoncorn := TRUE; points := points + 25; END ELSE IF diagnexttocorner THEN points := points - 50; END; IF points > bestyet THEN BEGIN bestyet := points; bestm := m; end; END; (*FOR m := 1 TO legallist.movecount...*) movetemp := legallist.okmove[1]; legallist.okmove[1] := legallist.okmove[bestm]; legallist.okmove[bestm] := movetemp; END; (*checkposition*) PROCEDURE sortmoves(VAR okmove: movearray; l,r: INTEGER) (*into descending order by points*) ; VAR i,j,baseval: INTEGER; BEGIN i := l; j := r; baseval := okmove[(i+j) DIV 2].points; REPEAT WHILE okmove[i].points > baseval DO i := i+1; WHILE okmove[j].points < baseval DO j := j-1; IF i <= j THEN BEGIN movetemp := okmove[i]; okmove[i] := okmove[j]; okmove[j] := movetemp; i := i+1; j := j-1; END; UNTIL i > j; IF l < j THEN sortmoves(okmove, l, j ); IF i < r THEN sortmoves(okmove, i, r ) END (* sortmoves *) ; PROCEDURE checkresponses(mover: color; VAR move: movedesc; VAR responses: movelist; bestsofar: INTEGER); (*$G+*) LABEL 0; VAR contingent,c,r: INTEGER; x,y: coordinate; sq: squareloc; direc: direction; oppcolor: color; afterresp: gamestatus; cornercounter: BOOLEAN; respondmove: movedesc; counterresp: movelist; BEGIN oppcolor := flipof(mover); WITH move DO BEGIN contingent := 0; r := 1; REPEAT respondmove := responses.okmove[r]; IF NOT board[moveloc.row,moveloc.col].incenter4by4 THEN FOR direc := north TO nw DO WITH respondmove DO IF direc IN dirsflipped THEN WITH moveloc DO IF board[row,col].adjacentsq[direc] = move.moveloc THEN BEGIN move.points := move.points - 5; IF move.points <= bestsofar THEN EXIT(checkresponses); END; afterresp := aftermove; makemove(afterresp,respondmove,FALSE); IF bordnoncorn THEN WITH moveloc DO IF afterresp.boardstatus[row,col].occupier = oppcolor THEN BEGIN bordnoncorn := FALSE; points := points - 65; (*40, plus the 25 given in checkposition*) IF points <= bestsofar THEN EXIT(checkresponses); END ELSE contingent := contingent + 8*respondmove.bordrsqsflipped; WITH respondmove.moveloc DO IF board[row,col].corner THEN BEGIN points := points - 55; IF cornmoves > 1 THEN IF board[moveloc.row,moveloc.col].corner THEN points := points -20; IF points <= bestsofar THEN EXIT(checkresponses); END; FOR x:=1 TO 8 DO FOR y:=1 TO 8 DO WITH afterresp.boardstatus[x,y] DO IF occupied THEN IF occupier = mover THEN FOR direc := north TO nw DO WITH afterresp DO BEGIN sq.row := x; sq.col := y; REPEAT sq := board[sq.row,sq.col].adjacentsq[direc]; IF NOT sq.onboard THEN GOTO 0; IF NOT boardstatus[sq.row,sq.col].occupied THEN GOTO 0 UNTIL boardstatus[sq.row,sq.col].occupier = oppcolor; END; makemove(afterresp,respondmove,TRUE); findlegalmoves(afterresp,counterresp); cornercounter := FALSE; c := 1; WITH counterresp DO WHILE ( (c <= movecount) AND (NOT cornercounter) ) DO BEGIN WITH okmove[c].moveloc DO IF board[row,col].corner THEN cornercounter := TRUE; c := c + 1; END; IF NOT cornercounter THEN BEGIN points := points -190; IF points <= bestsofar THEN EXIT(checkresponses); END; 0: IF afterresp.score[mover] = 0 THEN BEGIN points := -MAXINT+1; (*might be our only choice, so +1*) EXIT(checkresponses); END; r := r + 1; UNTIL r > responses.movecount; IF bordnoncorn THEN BEGIN points := points - contingent; WITH board[moveloc.row,moveloc.col] DO IF specialbordersq THEN WITH otherofpair, status.boardstatus[row,col] DO IF occupied THEN IF occupier = mover THEN WITH status.boardstatus[between.row,between.col] DO IF NOT occupied THEN points := points - 90; END; END; (*WITH move...*) END; (*checkresponses*) BEGIN (*calcmove*) GOTOXY(0,23); WRITE('Calculating move for ',colorword[mover],'...'); checkposition(legallist,cornmoves); IF legallist.movecount > 2 THEN sortmoves(legallist.okmove,2,legallist.movecount); bestsofar := -MAXINT; FOR m := 1 TO legallist.movecount DO BEGIN move := legallist.okmove[m]; aftermove := status; makemove(aftermove,move,TRUE); findlegalmoves(aftermove,responses); WITH move DO BEGIN IF responses.movecount = 0 THEN points := points + 100 ELSE IF points > bestsofar THEN BEGIN checkposition(responses,respcornmoves); checkresponses(mover,move,responses,bestsofar); END; IF points > bestsofar THEN BEGIN bestsofar := points; bestmove := move; END; END; (*WITH move...*) END; (*FOR m := 1 TO legallist.movecount...*) END; (*calcmove*) PROCEDURE play(mover: color); BEGIN GOTOXY(0,20+ORD(mover)); IF legalmoves[mover] > 0 THEN BEGIN WRITE(spaces); IF mover = usercolor THEN inputmove(mover,legallist,move) ELSE calcmove(mover,status,legallist,move); makemove(status,move,TRUE); updatecrt(crtstatus,status); crtstatus := status; END ELSE BEGIN WRITE('(No legal moves for ',colorword[mover],')'); status.nextmover := flipof(mover); END; END; (*play*) FUNCTION userquits: BOOLEAN; VAR playagain: CHAR; BEGIN GOTOXY(0,20); WRITELN(spaces); WRITELN(spaces); WRITELN; WRITE(spaces); GOTOXY(0,23); WRITE('Start a new game? (y/n): '); READ(playagain); userquits := NOT (playagain IN ['Y','y']); END; (*userquits*) ======================================================================================== DOCUMENT :usus Folder:VOL03:othellinit.text ======================================================================================== (* COPYRIGHT (C) 1979 Software Supply. All rights reserved. *) (* included file for OTHELLO *) PROCEDURE updatecrt(VAR oldstatus,newstatus: gamestatus); FORWARD; FUNCTION flipof(oldcolor: color): color; FORWARD; PROCEDURE makemove(VAR status: gamestatus; VAR move: movedesc; updateadjacent: BOOLEAN); FORWARD; SEGMENT PROCEDURE initgame; CONST backspace = 8; VAR x,y: coordinate; direc: direction; answer: CHAR; h,l,h0,l0: INTEGER; (*for testing whether clock is on*) PROCEDURE defineboard; BEGIN FOR x := 1 TO 8 DO FOR y := 1 TO 8 DO WITH board[x,y] DO BEGIN border := (x IN [1,8]) OR (y IN [1,8]); corner := (x IN [1,8]) AND (y IN [1,8]); incenter4by4 := (x IN [3..6]) AND (y IN [3..6]); diagnexttocorner := (x IN [2,7]) AND (y IN [2,7]); FOR direc := north TO nw DO WITH adjacentsq[direc] DO BEGIN CASE direc OF north: onboard := x>1; ne: onboard := (x>1) AND (y<8); east: onboard := y<8; se: onboard := (x<8) AND (y<8); south: onboard := x<8; sw: onboard := (x<8) AND (y>1); west: onboard := y>1; nw: onboard := (x>1) AND (y>1); END; (*CASE*) IF onboard THEN BEGIN CASE direc OF north,ne,nw: row := x-1; east,west: row := x; south,se,sw: row := x+1; END; CASE direc OF nw,west,sw: col := y-1; north,south: col := y; ne,east,se: col := y+1; END; END; END; (*FOR direc...WITH adjacentsq...*) specialbordersq := border AND (NOT corner) AND ( (x IN [2,4,5,7]) OR (y IN [2,4,5,7]) ); IF specialbordersq THEN BEGIN otherofpair.onboard := TRUE; between.onboard := TRUE; IF x IN [1,8] THEN BEGIN otherofpair.row := x; between.row := x; IF y IN [2,5] THEN BEGIN otherofpair.col := y+2; between.col := y+1; END ELSE BEGIN otherofpair.col := y-2; between.col := y-1; END; END ELSE BEGIN otherofpair.col := y; between.col := y; IF x IN [2,5] THEN BEGIN otherofpair.row := x+2; between.row := x+1; END ELSE BEGIN otherofpair.row := x-2; between.row := x-1; END; END; END; (*IF specialbordersq...*) END; (*FOR x:= ... FOR y:= ... WITH board[x,y]...*) END; (*defineboard*) PROCEDURE showemptyboard; CONST vertdivs = '| | | | | | | | |'; horzdivs = '|-----|-----|-----|-----|-----|-----|-----|-----|'; colnames = ' A B C D E F G H '; blanks = ' '; VAR gamerow : coordinate; BEGIN GOTOXY(0,0); FOR gamerow := 1 TO 8 DO BEGIN IF gamerow>1 THEN (* "IF" because no room for topmost border line *) writeln(blanks,horzdivs); writeln(blanks:29,gamerow,vertdivs); writeln(blanks,vertdivs); END; write(blanks,colnames); GOTOXY(4,0); WRITELN('Score'); WRITELN('-----------'); WRITELN(CHR(whiteascii),'/White:'); WRITELN(CHR(blackascii),'/Black:'); END; (*showemptyboard*) PROCEDURE instructions; VAR i: INTEGER; PROCEDURE page1; BEGIN WRITELN('A move consists of placing '); WRITELN('one of your pieces on an '); WRITELN('unoccupied square which is '); WRITELN('adjacent (vertically, hori- '); WRITELN('zontally, or diagonally) to '); WRITELN('a square occupied by your '); WRITELN('opponent so that a straight '); WRITELN('line starting at your piece '); WRITELN('and continuing in the direc-'); WRITELN('tion of the adjacent oppon- '); WRITELN('ent hits one of your other '); WRITELN('pieces before hitting an un-'); WRITELN('occupied square. All of the'); WRITELN('opponent''s pieces which that'); WRITELN('line crosses are converted '); WRITELN('to become your pieces. Thus'); WRITELN('each move "flips" at least '); WRITELN('one opposing piece. '); WRITE (' (Tap space bar for more...)'); END; (*page1*) PROCEDURE page2; BEGIN WRITELN('Example: a legal move for '); WRITELN('white on the first play '); WRITELN('would be 3E, 4F, 6D, or 5C. '); WRITELN('To make a move at, e.g., 3E '); WRITELN('you may type any of: 3E, 3e,'); WRITELN('E3, or e3. '); WRITELN('If you have no legal move, '); WRITELN('you must pass. The object '); WRITELN('of the game is to end up '); WRITELN('occupying more squares than '); WRITELN('does your opponent. '); WRITELN('Hints on strategy: Usually '); WRITELN('the board position of a move'); WRITELN('is more important than the '); WRITELN('number of pieces it "flips".'); WRITELN('Try to occupy the borders '); WRITELN('(especially corners!) and '); WRITELN('avoid giving them to your '); WRITE ('opponent. (Tap space bar...)'); END; (*page2*) BEGIN (*instructions*) GOTOXY(0,5); WRITE('Want instructions? (y/n): '); READ(answer); IF NOT (answer IN ['N','n']) THEN BEGIN GOTOXY(0,5); page1; READ(answer); GOTOXY(0,5); page2; READ(answer); GOTOXY(0,5); FOR i := 5 TO 22 DO WRITELN(spaces); WRITE(spaces); END ELSE BEGIN GOTOXY(0,5); WRITE(spaces); END; END; (*instructions*) BEGIN (*initgame*) lastchange := 0; TIME(h0,l0); defineboard; FOR direc := north TO NW DO IF odd(ORD(direc)) THEN opposdir[direc] := pred(direc) ELSE opposdir[direc] := succ(direc); TIME(h,l); IF (h=h0) AND (l=l0) THEN BEGIN GOTOXY(20,11); WRITE('Please turn on the clock.'); WHILE l=l0 DO TIME(h,l); END; showemptyboard; WITH status DO BEGIN score[white] := 0; score[black] := 0; FOR x := 1 TO 8 DO FOR y := 1 TO 8 DO WITH boardstatus[x,y] DO BEGIN occupied := FALSE; adjacentpieces[white] := []; adjacentpieces[black] := []; END; END; crtstatus := status; move.dirsflipped := []; move.points := 0; WITH status DO BEGIN FOR x := 4 TO 5 DO FOR y := 4 TO 5 DO BEGIN move.moveloc.row := x; move.moveloc.col := y; IF x=y THEN nextmover := white ELSE nextmover := black; makemove(status,move,TRUE); updatecrt(crtstatus,status); crtstatus := status; END; (*FOR...FOR...*) nextmover := white; END; (*WITH status...*) instructions; GOTOXY(0,6); WRITELN('White goes first -- Which'); WRITELN('color do you want to play:'); REPEAT GOTOXY(3,8); WRITE('W)hite or B)lack? ',CHR(backspace)); READ(answer); UNTIL answer IN ['W','w','B','b']; IF answer IN ['W','w'] THEN usercolor := white ELSE usercolor := black; GOTOXY (0,6); WRITELN(spaces); WRITELN(spaces); WRITELN(spaces); colorword[white] := 'white'; colorword[black] := 'black'; END; (*initgame*) ======================================================================================== DOCUMENT :usus Folder:VOL03:othello.text ======================================================================================== (* COPYRIGHT (C) 1979 Software Supply. All rights reserved. *) (*$S+*) (* UCSD Pascal *) PROGRAM OTHELLO; (* Steve Brecher 16-Jun-79 *) (* The position evaluation weights were derived from a FORTRAN program *) (* headed "from Creative Computing/Klaus E Liebold/4-26-78". *) (* This program provides playing instructions to the user on request. *) CONST (* The game pieces are shown on the screen as 2 rows of 3 characters, e.g. *) (* OOO *) (* OOO *) (* If your crt has a "block" character (like the cursor on some crts), that*) (* is good for the white piece, and capital letter O is good for black, *) (* especially if it has a rectangular shape. Otherwise, choose characters *) (* that are centered within the character dot matrix; try to maximize the *) (* difference in intensity between the black and white pieces while maxi- *) (* mizing the absolute intensity of the black piece. Avoid characters with*) (* semantic content, e.g. "W" and "B" are not so good. *) whiteascii = 96; (*ascii value of char making up piece of first mover*) blackascii = 79; (* " " " " " " " " 2nd " *) minticks = 22.0; (*min # clock ticks between crt square updates *) (*--should be long enough for a distinct, separate *) (*terminal bell sound on each square updated *) spaces = ' '; TYPE coordinate = 1..8; color = (white,black); squareloc = RECORD CASE onboard: BOOLEAN OF TRUE: (row,col: coordinate); END; direction = (north,south,east,west,sw,ne,se,nw); (*pairs of opposites*) squarestatus = RECORD CASE occupied: BOOLEAN OF TRUE: (occupier: color ); FALSE: (adjacentpieces: ARRAY[color] OF SET of direction); END; gamestatus = RECORD boardstatus: ARRAY[coordinate,coordinate] OF squarestatus; nextmover: color; lastmoveloc: squareloc; score: ARRAY[color] OF INTEGER; END; movedesc = RECORD moveloc: squareloc; points: INTEGER; dirsflipped: SET OF direction; bordrsqsflipped: INTEGER; bordnoncorn: BOOLEAN; END; movelist = RECORD movecount: INTEGER; okmove: ARRAY[1..30] OF movedesc; END; position = RECORD border: BOOLEAN; corner: BOOLEAN; diagnexttocorner: BOOLEAN; incenter4by4: BOOLEAN; adjacentsq: ARRAY[direction] OF squareloc; (* "special" border squares are those border squares *) (* adjacent to a corner or adjacent to board midline; there *) (* are 2 pairs of such squares on each border. Sample pair: *) (* (1,2) and (1,4); for each we want a pointer to the other *) (* and to the border square between them (1,3). *) CASE specialbordersq: BOOLEAN OF TRUE: (otherofpair,between: squareloc); END; VAR board: ARRAY[coordinate,coordinate] OF position; status,crtstatus: gamestatus; square: squareloc; legallist: movelist; move: movedesc; opposdir: ARRAY[direction] OF direction; legalmoves: ARRAY[color] OF INTEGER; colorword: ARRAY[color] OF STRING[5]; usercolor: color; lastchange: REAL; (*time of last square change on crt*) (*$I OTHELLINIT*) (*$I OTHELL1*) (*$I OTHELL2*) BEGIN (*PROGRAM OTHELLO*) REPEAT initgame; findlegalmoves(status,legallist); legalmoves[white] := legallist.movecount; REPEAT play(white); findlegalmoves(status,legallist); legalmoves[black] := legallist.movecount; play(black); findlegalmoves(status,legallist); legalmoves[white] := legallist.movecount; UNTIL (legalmoves[white]=0) and (legalmoves[black]=0); UNTIL userquits; END. ======================================================================================== DOCUMENT :usus Folder:VOL03:policy.doc.text ======================================================================================== INTERIM POLICY OF THE UCSD PASCAL USERS' GROUP LIBRARY Obtaining Library Software. Floppy disks full of donated Pascal programs are available from the Library as follows: 8-inch, single-sided, single-density UCSD- or CP/M-format disks are $10 each postpaid (California residents MUST add 6% sales tax; Canadian and Mexican recipients should add $3 per order for the extra hassle involved; other out-of-country sales must add $8 for the first disk of an order and $1.50 per each additional disk to cover air mail) from Jim Gagne, Datamed Research, 1433 Roscomare Road, Los Angeles CA 90024. Both UCSD Pascal and CP/M- compatible Pascals are supported, though UCSD programs will require modification to run under other systems. 5-1/4 inch diskettes of UCSD software (2 or 3 are required to hold an 8- inch volume) are available from Bruce Sherman, SofTech Microsystems, 9494 Black Mountain Road, San Diego CA 92126. Pricing is not yet established, but will probably exceed $20 per volume due to order processing costs. (We are looking for volunteers to distribute the various 5-1/4 inch formats so we can offer them at lower cost.) Software of interest only to users of certain systems will as a rule not be distributed to incompatible systems. Contact Bruce for further information. Western Digital has indicated an interest in distributing Users' Group software on 8-inch disks compatible with the Microengine (these are NOT UCSD compatible because of differences in disk sectoring). In addition, they can provide Microengine users with software that will enable them to convert UCSD standard disks on their machines. Contact them directly for more information. You can obtain a free disk volume of your choice by donating software to the group if the software is accepted (see below). Any user may copy Users' Group software and give it away to others FREE for nothing. This includes OEM's and retailers. However, if any charge whatsoever is made to the recipient of the software, then: 1) the maximum charge is limited to a $5 fee per volume plus the retail cost of each floppy disk and 2) the Users' Group must be reimbursed $2 per disk volume sold. (A disk volume is the contents of one 8-inch, single-sided, single-density diskette.) These charges apply no matter how indirectly the seller obtains Users' Group software. These editing fees should be paid to Datamed Research at the above address, within a month's time of the sale. All software is furnished with the understanding that no one may sell it for profit without the written consent of the author. In addition, the software MAY NOT be copied without continuing to carry whatever statements of authorship it may now contain. Finally, despite hard work to maintain the highest standards possible, we of course cannot guarantee in any way that programs obtained from the Users' Group Library will be suitable for your intended purpose. Submitting Software. We are interested in receiving software from anyone who may wish to contribute. Every type of program is welcomed, and we are particularly eager to receive donations of software tools: those procedures and programs you have developed to make your programming simpler and more productive, and which may be of broad interest to the Pascal community. Such items as double- precision integer packages, business math routines, generic input/output processing, program timers and debuggers, system utilities, and reports of specific techniques to speed UCSD programs are particularly desired. It is clear that if we can all develop the habit of donating particularly useful tools to the Users' Group, a broad base of software support will quickly develop which will benefit us all enormously. To be accepted, software must: 1) be in source form, 2) be relatively free of bugs, 3) be reasonably clearly written and documented so that it may be easily modified, 4) come with sufficient instructions so that we can use it, 5) be capable of being placed in the public domain, and 6) not have been received previously from someone else. If you have an especially long program or one that is for some reason tricky to compile, you may wish to submit object code as well as source. Certain items may be submitted in object form only: if you have a quality program undergoing development that you eventually wish to sell, we would be willing to pilot it for you if it is of sufficient interest to the group at large and works moderately well. I am certain many members would enjoy writing you with their comments, and you should wind up with a product of much higher quality in a much shorter time than is the rule. We are also interested in reports of bugs in the system or user software (preferably with fixes or kludges to get around them) and documentation of the more obscure aspects of UCSD Pascal. Editors. Many people have written to UCSD and SofTech wishing to assist in the organization of a users group library. We think this is grand. Because it makes little sense for the collection and distribution of programs to be scattered all around the country, we plan to set up the following structure for now and see how it works: Anyone who wishes to collect a disk full of software may submit it to the Users' Group (send them to Datamed Research; 8- inch diskettes preferred). Fundamentally, the requirements for the acceptance for the software are those stated previously; in addition, the disk editor must have checked out the programs and organized them in some way. You should have a catalog of the files on the disk, and a separate file containing: 1) descriptions of each program, 2) what you think of it, and 3) any remaining documentation required for use. Note that we are specifically committed to full and complete documentation ON THE DISK whenever possible. Programs should be of general interest, although it is all right to include hardware-specific programs if they solve a pressing need. (I would prefer to put most of the hardware-specific material on a special disk, which users can ignore if they wish.) If you submit a disk that is reasonably well put together, you will: 1) be listed as editor of that volume, 2) receive $1 for each disk SOLD (remember, many will be given to friends), and 3) be placed on the official UCSD Pascal Users' Group Library Roster of Editors, and receive all past and future volumes of the Users' Group library, so we can coordinate our efforts. (I reserve the right not to send you ALL the Users' Group volumes if this thing gets too big and you haven't contributed for a while.) A word of warning: most of the Pascal disks now floating around have much less work put into them than we feel is required for them to be generally useful. I, in particular, am a FANATIC about making our products helpful and/or fun to programmers of various persuasions. So the $1 payment per disk is intended to reimburse you in part for the very real effort required to create a disk with truly useful contents. ======================================================================================== DOCUMENT :usus Folder:VOL03:requests.text ======================================================================================== SOME REQUESTS FOR PASCAL SOFTWARE FOR THE USERS' GROUP LIBRARY As a programmer, what I like most is a challange that requires careful thought to carry off, yet is of manageable size and will make a definite contribution to the efforts of others. So I thought I'd offer you some programming challenges: A. A directory program that would be called up from the Command level (not in the filer), and display the contents of a disk in two or three alphabetized columns in one screenful. The size of each file would be included, and perhaps the date. Following the named files, one would list the unutilized areas of a disk individually, by block range and size. For example, an unused area might be indicated in the following manner: "<400-450 empty> 51", where the "51" would line up with the blocks per file column. A summary line at the bottom would list the total number of files and the vacant space on the disk. To save time, you would invoke the directory of a given disk simply by typing the unit number desired. For example, typing "X(ecute) 4 " would produce the directory of the main disk drive. B. We need a library of procedures to BLOCKREAD and BLOCKWRITE untyped files, then CREAD (or whatever name you want) a character, LNREAD a line, and CWRITE and LNWRITE respectively. Not only would this markedly expedite textfile handling in the present P-code Pascals that support untyped files, but these procedures are the ONLY way to access files with the present native- code compilers that run on micros. C. We need a good double-precision integer package written in Standard Pascal to augment the present inadequate limitations of MAXINT. D. We need a package of input/output procedures for money (usually represented as integer cents), so the user can type a decimal point and not confuse the computer. A nice touch is to have the cursor stay put at the dollar units position of the number to be entered, and have the number of dollars grow to the left as it is typed in. Then, when the decimal point is typed, the cursor steps to the right one character at a time as the user fills in the cents value. E. Someone interested in mathematics should tackle a complex-number package. F. A simple "data base system" consisting of: 1) a means to define the names of a number of fields, 2) a way of entering/correcting data within each field, 3) successive or random access to records, 4) a disk sort by a single field (if you wanted multiple fields in order you'd do multiple sorts), and 5) a key extraction program, where one would make a subfile consisting of all the records in the main file that had one field equal to a certain value or falling within a certain range. As an alternative to sorting the records themselves, one could use an ISAM approach. Because Pascal saves textfiles as lines with dynamic length terminated by an end-of-line character, the easiest and most space-saving way to represent the data would be as ASCII strings. The program could be very general if the zeroth record in a data file defined the data: first line: Number of elements per record (in ASCII) (call it "n"). second line: Name of first element, and perhaps an ASCII code of data type. . . . . . . nth line: Name and type code of n-1th element. n+1th line: Name and type code of nth element. Then, each successive record might begin with an ASCII record number and the actual data of each record element, all of dynamic length. So you'd never have to specify field width; you would simply be limited by the maximum length of the character array or string when the data was in memory. ======================================================================================== DOCUMENT :usus Folder:VOL03:snoopy.text ======================================================================================== 1 - - XXXX X XX X *** X XXXXX X ***** X XXX XX XXXX ******* XXX XXXX XX XX X ****** XXXXXXXXX XX XXX XX X **** X X** X X XX XX X X***X X //XXXX X XXXX X // X XX X // X XXXXXXXXXXXXXXXXXX/ X XXX// X X X X X X X X X X X X X X X X X XX X X X X X XXX XX X XXX X X X X X X X X X XX X XXXX X X XXXXXXXX\ XX XX X XX XX X X X XX XX XXXX XXXXXX/ X XXXX XXX XX*** X X XXXXXXXXXXXXX * * X X *---* X X X *-* * XXX X X *- * XXX X *- *X XXX *- *X X XXX *- *X X XX *- *XX X X * *X* X X X * *X * X X X * * X** X XXXX X * * X** XX X X * ** X** X XX X * ** X* XXX X X * ** XX XXXX XXX * * * XXXX X X * * * X X X =======******* * * X X XXXXXXXX\ * * * /XXXXX XXXXXXXX\ ) =====********** * X ) \ ) ====* * X \ \ )XXXXX =========********** XXXXXXXXXXXXXXXXXXXXXX Happy New Year, Red Baron! JANUARY FEBRUARY MARCH 1 2 3 4 5 1 2 1 6 7 8 9 10 11 12 3 4 5 6 7 8 9 2 3 4 5 6 7 8 13 14 15 16 17 18 19 10 11 12 13 14 15 16 9 10 11 12 13 14 15 20 21 22 23 24 25 26 17 18 19 20 21 22 23 16 17 18 19 20 21 22 27 28 29 30 31 24 25 26 27 28 29 23 24 25 26 27 28 29 30 31 APRIL MAY JUNE 1 2 3 4 5 1 2 3 1 2 3 4 5 6 7 6 7 8 9 10 11 12 4 5 6 7 8 9 10 8 9 10 11 12 13 14 13 14 15 16 17 18 19 11 12 13 14 15 16 17 15 16 17 18 19 20 21 20 21 22 23 24 25 26 18 19 20 21 22 23 24 22 23 24 25 26 27 28 27 28 29 30 25 26 27 28 29 30 31 29 30 JULY AUGUST SEPTEMBER 1 2 3 4 5 1 2 1 2 3 4 5 6 6 7 8 9 10 11 12 3 4 5 6 7 8 9 7 8 9 10 11 12 13 13 14 15 16 17 18 19 10 11 12 13 14 15 16 14 15 16 17 18 19 20 20 21 22 23 24 25 26 17 18 19 20 21 22 23 21 22 23 24 25 26 27 27 28 29 30 31 24 25 26 27 28 29 30 28 29 30 31 OCTOBER NOVEMBER DECEMBER 1 2 3 4 1 1 2 3 4 5 6 5 6 7 8 9 10 11 2 3 4 5 6 7 8 7 8 9 10 11 12 13 12 13 14 15 16 17 18 9 10 11 12 13 14 15 14 15 16 17 18 19 20 19 20 21 22 23 24 25 16 17 18 19 20 21 22 21 22 23 24 25 26 27 26 27 28 29 30 31 23 24 25 26 27 28 29 28 29 30 31 ======================================================================================== DOCUMENT :usus Folder:VOL03:store.data ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL03:universal.text ======================================================================================== A SUGGESTION FOR A UNIVERSAL I/O UNIT Most of the UCSD Pascal programs that I have seen have a monotonous beginning consisting of hardware-specific procedures like CLEARSCREEN, EraseToEndOfLine, EraseToEndOfScreen, etc., required for any application that manipulates data on the CRT screen. It means you always have to diddle with a new program before you can use it. Although this information should be readily available in SYSCOM, where the system functions have access to it, the implementors of UCSD Pascal did not see fit to allow us to get at it easily. Direct reference to the SYSCOM variables requires you to compile in the variable declarations in GLOBALS.TEXT, then switch to the (*$U-*) compiler option, so the compiler knows what SYSCOM^ refers to. This is clumsy, and it is not easy to debug software with all the checking turned off (the U- option disables i/o checking and rangechecking). There are alternate ways to get at the information in SYSCOM, such as the routine recently published in Dr. Dobb's to read in the SYSTEM.MISCINFO file. Programmers writing proprietary software will have to do something like this during initialization if their productions are to use the CRT efficiently. But there is additional problem: many programs rely on hardware-specific functions not implemented in SYSCOM. For example, quite a number of authors have included routines to test if a console key has been pressed without having to READ a character and thus hang up a program until someone types something. This allows optional user interaction with an ongoing program. Other programs, such as modem controllers, read and write data to specific hardware ports. Finally, it would be nice to have a random-number seed available directly from the hardware, so we don't always have to "Type a number" to begin a game. It seems elementary for the UCSD Pascal user community to agree on a minimal series of functions, which we would all include in our SYSTEM.LIBRARY. You would be free to add more, but at least you would be able to link the standard functions into your applications programs without having to fiddle with source code. If we all implemented a UNIT UNIVERSAL_IO, all your application program would have to say is "USES UNIVERSAL_IO", and you've included all the necessary functions. Here is a partial example of the way someone may implement such a UNIT: UNIT UNIVERSAL_IO; INTERFACE TYPE BYTE = 0..255; FUNCTION KeyPress: BOOLEAN; FUNCTION InPort (PORTNO: BYTE): CHAR; PROCEDURE OutPort (PORTNO: BYTE; CH: CHAR); PROCEDURE ClearScreen; PROCEDURE ClrToScreenEnd; PROCEDURE ClrToLineEnd; IMPLEMENTATION FUNCTION READY: BOOLEAN; EXTERNAL; {an assembly language routine that returns a "1" if a console key has been pressed} FUNCTION GetPort (PORTNO: BYTE): CHAR; EXTERNAL; {this assy-language routine reads a character from a specific port} PROCEDURE SendPort (PORTNO: BYTE; CH: CHAR); EXTERNAL; {this assy-language routine puts out a chararacter to a specific port} FUNCTION KeyPress; BEGIN KeyPress := READY; END; FUNCTION InPort; BEGIN InPort := GetPort (PORTNO); END; PROCEDURE OutPort; BEGIN SendPort (PORTNO, CH); END; PROCEDURE ClearScreen; VAR Chrbuf: PACKED ARRAY [0..1] OF CHAR; BEGIN Chrbuf [0] := CHR (12); UNITWRITE (1, Chrbuf, 1) END; PROCEDURE ClrToScreenEnd; BEGIN . . . END; PROCEDURE ClrToLineEnd; BEGIN . . . END; END. Of course, the implementation would vary from system to system. And this would be one more thing that you would have to write and debug before you could use UCSD Pascal Library software. But you have to alter the procedures other authors have included in their programs already!! In addition to the procedures and functions listed above, we should include FUNCTION RandomByte, which would return a random value from 0 to 255 (e.g., the contents of the Z-80 R register; the lowest byte of the system clock if you don't reset it every time you do something; or the contents of an address in RAM that is not used by the system but is different every time you turn on your machine). I specifically do NOT want to implement PEEK and POKE, since we do not need them to pass parameters to assembly language routines or anything else. Let me know what you think.... Sincerely, Jim Gagne, DATAMED RESEARCH. ======================================================================================== DOCUMENT :usus Folder:VOL04:catalog.4.text ======================================================================================== UCSD PASCAL USERS' LIBRARY -**- VOLUME 4 CATALOG The long-awaited Bowles Database seed, plus other utilities. Also info on the new UCSD System Users' Society. Name Blocks Description DBBUILDER.TEXT 38 Part of K. Bowles' database seed. DBUNIT.TEXT 4 The major data accessing routines, allowing records of variable size and user-defined linkage & nesting. DBUNIT.1.TEXT 18 Subfile of DBUNIT DBUNIT.2.TEXT 32 " " " DBUNIT.3.TEXT 34 " " " DBUNIT.4.TEXT 30 " " " KB.DATABASE.DOC 74 A detailed class manual to show you how to use it. KB.DBDEMO.TEXT 4 Demo program to further document the system. KB.SCUNIT.TEXT 16 Screen control unit with some very nice screen i/o. KB.STARTER.TEXT 30 Help set up the data structures. KB.TESTDB 32 A test database data file, used by DBDEMO. COMPARE.TEXT 34 From the Pascal News No. 12; prints out textfile diff's. COMPRESS.TEXT 8 Compress leading/strip trailing blanks; shrink files. INDEX.TEXT 24 Expanded index to Jensen & Wirth--now you can find it. USUS.NEWS.TEXT 20 Learn all about the UCSD System Users' Society. VOLUME.4.TEXT 14 Commentary on the files on this disk. WUMPUS.TEXT 28 The game of Wumpus, elegantly implemented. TEACH.WUMPUS 10 Documentation on the wunders of Wumpus. WUMP.CAVE0.TEXT 4 One of several cave configurations you can select from WUMP.CAVE1.TEXT 4 within the game; if you get bored with one, try WUMP.CAVE2.TEXT 4 another. WUMP.CAVE3.TEXT 4 . . . WUMP.CAVE4.TEXT 4 . . . This one's hard. WUMP.CAVE5.TEXT 4 . . . This one's hard, too. Please note: all software is for noncommercial use only. It may NOT be sold without the author's written permission. Do not remove statements of origin/authorship from program listings. ======================================================================================== DOCUMENT :usus Folder:VOL04:compare.text ======================================================================================== {* COMPARE - Compare two text files and report their differences. * * Copyright (C) 1977, 1978 * James F. Miner * Social Science Research Facilities Center * University of Minnesota * * General permission to make fair use in non-profit activities * of all or part of this material is granted provided that * this notice is given. To obtain permission for other uses * and/or machine readable copies write to: * * The Director * Social Science Research Facilities Center * 25 Blegen Hall * 269 19th Ave. So. * University of Minnesota * Minneapolis, Minnesota 55455 * U S A } {* Compare is used to display on "Output" the differences * between two similar texts ("Filea" and "Fileb"). Notable * characteristics are: * * - Compare is line oriented. The smallest unit of comparison * is the text line (ignoring trailing blanks). The present * implementation has a fixed maximum line length. * * - By manipulating a program parameter, the user can affect * Compare's sensitivity to the "locality" of differences. * More specifically this parameter, "Minlinesformatch", * specifies the number of consecutive lines on each file * which must match in order that they be considered as * terminating the prior mismatch. A large value of * "Minlinesformatch" tends to produce fewer but larger * mismatches than does a small value. The value six appears * to give good results on Pascal source files but may be * inappropriate for other applications. * * If compare is to be used as a general utility program, * "Minlinesformatch" should be treated as a program * parameter of some sort. It is declared as a constant here * for portability's sake. * * Another program parameter (constant), "Markunequalcolumns", * specifies that when unequal lines are found, each line from * filea is printed next to its corresponding line from fileb, * and unequal columns are marked. This option is particularly * useful for fixed-format data files. Notes: Line pairing is * not attempted if the mismatching sections are not the same * number of lines on each file. It is not currently very smart * about ASCII control characters like tab. (W.Kempton, Nov 78) * * - Compare employs a simple backtracking search algorithm to * isolate mismatches from their surrounding matches. This * requires (heap) storage roughly proportional to the size * of the largest mismatch, and time roughly proportional to * the square of the size of the mismatch for each mismatch. * For this reason it may not be feasible to use Compare on * files with very long mismatches. * * - To the best of the author's knowledge, Compare utilizes * only features of Standard Pascal. * * Modified for UCSD Pascal by T.S. Beck - 9 Jun 80. } program compare; const version = '1.3 (7 Nov 78)'; linelength = 120; { MAXIMUM SIGNIFICANT INPUT LINE LENGTH } minlinesformatch = 3; { NUMBER OF CONSECUTIVE EQUIVALENT } { LINES TO END A MIS-MATCH } markunequalcolumns = true; { IF UNEQUAL LINES ARE TO BE PAIRED, } { AND UNEQUAL COLUMNS MARKED } type linepointer = ^line; line = { SINGLE LINE BUFFER } packed record nextline : linepointer; length : 0..linelength; image : packed array [1..linelength] of char end; stream = { BOOKKEEPING FOR EACH INPUT FILE } record name : char; cursor, head, tail : linepointer; cursorlineno, headlineno, taillineno : integer; endfile : boolean end; var filea, fileb : text; out : interactive; filename : string[24]; a, b : stream; match : boolean; endfile : boolean; { SET IF END OF STREAM A OR B } templine : { USED BY READLINE } record length : integer; image : array [0..linelength] of char end; freelines : linepointer; { FREE LIST OF LINE BUFFERS } same : boolean; { FALSE IF NO MIS-MATCHES OCCUR } linestoolong : boolean; { FLAG IF SOME LINES NOT COMPLETELY CHECKED } procedure comparefiles; 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. } var p : linepointer; begin { MARK } with x do if head <> nil then begin while head <> cursor do { RECLAIM BUFFER } begin with head^ do begin p := nextline; nextline := freelines; freelines := head end; head := p end; headlineno := cursorlineno; if cursor = nil then begin tail := nil; taillineno := 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 IS ENCOUNTERED ON EITHER STREAM. } procedure readline; var newline : linepointer; c, c2 : 0..linelength; begin { READLINE } if not x.endfile then begin c := 0; while not eoln(filex) and (c < linelength) do begin c := c + 1; templine.image[c] := filex^; get(filex) end; if not eoln(filex) then linestoolong := true; readln(filex); while templine.image[c] = ' ' do c := c - 1; if c < templine.length then for c2 := c+1 to templine.length do templine.image[c2] := ' '; templine.length := c; newline := freelines; if newline = nil then new(newline) else freelines := freelines^.nextline; for c2 := 1 to linelength do newline^.image[c2] := templine.image[c2]; newline^.length := c; 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 X TO BECOME THAT } { OF THE LAST MARK OPERATION. I.E., THE CURRENT LINE } { WHEN THE STREAM WAS MARKED LAST BECOMES THE NEW CURSOR. } { XLINES IS SET TO THE NUMBER OF LINES FROM THE NEW CURSOR } { TO THE OLD CURSOR, INCLUSIVE. } begin { BACKTRACK } xlines := x.cursorlineno + 1 - x.headlineno; x.cursor := x.head; x.cursorlineno := x.headlineno; endfile := endstream(a) or endstream(b) end; { BACKTRACE } 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 begin match := (a.cursor^.length = b.cursor^.length); if match then match := (a.cursor^.image = b.cursor^.image) end 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 advanceb : boolean; { TOGGLE ONE-LINE LOOKAHEAD BETWEEN STREAMS } 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 writeoneline(name : char; l : integer; p : linepointer); begin { WRITEONELINE } write(out,' ', name, l:5,' '); if p^.length = 0 then writeln(out) else writeln(out,p^.image : p^.length); end; { WRITEONELINE } procedure writetext(var x : stream); { WRITE FROM X.HEAD TO ONE LINE BEFORE X.CURSOR } var p, q : linepointer; lineno : integer; begin { WRITETEXT } p:=x.head; q:=x.cursor; lineno:=x.headlineno; while (p <> nil) and (p <> q) do begin writeoneline( x.name, lineno, p); p := p^.nextline; lineno := lineno + 1; end; if p = nil then writeln(out,' *** eof ***'); writeln(out) end; { WRITETEXT } procedure writepairs( pa, pb : linepointer; la, lb : integer); { THIS WRITES FORM THE HEAD TO THE CURSOR, LIKE PROCEDURE } { WRITETEXT. UNLIKE PROCEDURE WRITETEXT, THIS WRITES FROM } { BOTH FILES AT ONCE, COMPARES COLUMNS WITHIN LINES, AND MARKS } { UNEQUAL COLUMNS. } var tempa, tempb : array [1..linelength] of char; col, maxcol : integer; begin { WRITEPAIRS } repeat writeoneline('a', la, pa); writeoneline('b', lb, pb); for col := 1 to linelength do begin tempa[col] := pa^.image[col]; tempb[col] := pb^.image[col] end; if pa^.length > pb^.length then maxcol := pa^.length else maxcol := pb^.length; write(out,' ': 11); { 11 spaces used for file name and line number } for col := 1 to maxcol do if tempa[col] = tempb[col] then write(out,' ') else write(out,'^'); writeln(out); writeln(out); pa := pa^.nextline; la := la + 1; pb := pb^.nextline; lb := lb + 1; until (pa = a.cursor) or (pa = nil); end; { WRITEPAIRS } procedure writelineno(var x : stream); var f, l : integer; begin { WRITELINENO } f := x.headlineno; l := x.cursorlineno - 1; write(out,'line'); if f = l then write(out,' ', f:1) else write(out,'s ', f:1, ' thru ', l:1); if x.cursor = nil then write(out,' (before eof)'); end; { WRITELINENO } procedure printextratext(var x , y : stream); begin { PRINTEXTRATEXT } write(out,' extra text: on file', x.name, ', '); if y.head = nil then writeln(out,' before eof on file', y.name) else writeln(out,' between lines ', y.headlineno-1:1, ' and ', y.headlineno:1, ' of file', y.name); writeln(out); writetext(x) end; { PRINTEXTRATEXT } begin { PRINTMISMATCH } writeln(out,' ':11, '**********************************'); emptya := (a.head = a.cursor); emptyb := (b.head = b.cursor); if emptya or emptyb then if emptya then printextratext(b, a) else printextratext(a, b) else begin write(out,' mismatch: '); write(out,' filea, '); writelineno(a); write(out,' not equal to '); write(out,' fileb, '); writelineno(b); writeln(out,':'); writeln(out); if markunequalcolumns and ((a.cursorlineno - a.headlineno) = (b.cursorlineno - b.headlineno)) then writepairs(a.head, b.head, a.headlineno, b.headlineno) else begin writetext(a); writetext(b) end end end; { PRINTMISMATCH } begin { FINDMATCH } { NOT MATCH } advanceb := true; repeat if not endfile then advanceb := not advanceb else advanceb := endstream(a); if advanceb then search(a, filea, b, fileb) else search(b, fileb, a, filea) until match; printmismatch; end; { FINDMATCH } begin { COMPAREFILES } match := true; { I.E., BEGINNINGS-OF-FILES MATCH } 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; { COMPAREFILES } procedure initialize; procedure initstream(fid : char; var x : stream; var filex : text); var count, i : integer; begin { INITSTREAM } with x do begin cursor := nil; head := nil; tail := nil; cursorlineno := 0; headlineno := 0; taillineno := 0 end; repeat write('Type name of file ',fid,': '); readln(filename); count := length(filename); if count = 0 then exit(compare); for i := 1 to count do if filename[i] in ['a'..'z'] then filename[i] := chr(ord(filename[i]) - 32); if (pos('.TEXT',filename) = 0) and (filename[count] <> '.') and (count < 19) then filename := concat(filename,'.TEXT'); {$i-} reset(filex,filename) {$i+} until ioresult = 0; writeln(out,' file',fid,': ',filename); x.endfile := eof(filex); end; { INITSTREAM } begin { INITIALIZE } initstream('a',a, filea); initstream('b',b, fileb); writeln(out); endfile := a.endfile or b.endfile; a.name := 'a'; b.name := 'b'; linestoolong := false; freelines := nil; templine.length := linelength; templine.image[0] := 'x'; { SENTINEL } end; {INITIALIZE} begin {COMPARE} repeat write('Type output file name: '); readln(filename); if length(filename) = 0 then exit(compare); {$i-} reset(out,filename) {$i+} until ioresult = 0; if (filename = '#8:') or (filename = 'REMOTE:') then write(out,chr(27),'u',chr(24)); { set H14 printer to 96 char. } writeln(out,' compare. version ', version); writeln(out); writeln(out,' match criterion = ', minlinesformatch:1, ' lines.'); writeln(out); initialize; if a.endfile then writeln(out,' filea is empty.'); if b.endfile then writeln(out,' fileb is empty.'); if not endfile then begin same := true; comparefiles; if same then writeln(out,' no differences.'); if linestoolong then begin writeln(out); writeln(out,' WARNING: some lines were longer than ', linelength:1, ' characters.'); writeln(out,' they were not compared past that point.'); end; end end. { COMPARE } ======================================================================================== DOCUMENT :usus Folder:VOL04:compress.text ======================================================================================== program compress; { This program will compress a text file by removing all trailing blanks and recomputing the indent codes - T. S. Beck - 8/Jun/80 } const CR = 13; DLE = 16; forever = false; NUL = 0; pagemax = 1023; type name = string[24]; var i, count, dummy, first, index, last : integer; inname, outname : name; line : string[255]; page : packed array[0..pagemax] of char; infile, outfile : file; intext : text; procedure writepage; VAR i: integer; ch: char; begin ch := CHR (NUL); for i := index to pagemax do page [i] := ch; dummy := blockwrite (outfile,page,2); write('.'); index := 0 end; { writepage } procedure forceuppercase(var filename : name); var i : integer; begin for i := 1 to count do if filename[i] in ['a'..'z'] then filename[i] := chr(ord(filename[i]) - 32) end; { forceuppercase } begin { compress } writeln('Type to quit.'); repeat repeat write('Input file? '); readln(inname); count := length(inname); if count = 0 then exit(compress); forceuppercase(inname); if (pos('.TEXT',inname) = 0) and (inname[count] <> '.') and (count < 19) then inname := concat(inname,'.TEXT'); {$i-} reset(infile,inname) {$i+} until ioresult = 0; repeat write('Output file? '); readln(outname); count := length(outname); if count = 0 then exit(compress); if (count = 1) and (outname[1] = '$') then outname := inname; forceuppercase(outname); if (pos('.TEXT',outname) = 0) and (outname[count] <> '.') and (count < 19) then outname := concat(outname,'.TEXT'); {$i-} rewrite(outfile,outname) {$i+} until ioresult = 0; dummy := blockread(infile,page,2); dummy := blockwrite(outfile,page,2); close(infile); reset(intext,inname); index := 0; repeat readln(intext,line); count := length(line); if count > 0 then begin first := scan(count,<> ' ',line[1]) + 1; if first > 223 then first := 223; last := count + scan(-count,<> ' ',line[count]); if first > last then count := 0 else if first <= 2 then count := last else count := last - first + 3 end; if (index + count) >= pagemax then writepage; { if count > 0 then if first <= 2 then moveleft(line[1],page[index],count) else begin page[index] := chr(DLE); page[index + 1] := chr(first + 31); moveleft(line[first],page[index + 2],count - 2) end; } if count > 0 then if first <= 2 then for i := 1 to count do page [index + i-1] := line[i] else begin page[index] := chr(DLE); page[index + 1] := chr(first + 31); for i := 0 to count - 3 do page [index + i + 2] := line [i + first]; end; index := index + count; page[index] := chr(CR); index := index + 1 until eof(intext); writepage; close(intext); close(outfile,lock); writeln until forever end. ======================================================================================== DOCUMENT :usus Folder:VOL04:dbbuilder.text ======================================================================================== (*$S+*) PROGRAM DESCRIPTORBUILDER; (*version 0.0 - 2 Feb 1980*) (*Copyright 1980 Kenneth L. Bowles. All rights reserved. Permission is hereby granted to use this material for any non-commerical purpose*) USES DBUNIT; CONST WA0 = 0; FDNAMEOFFSET = 12; LASTFIELDDESCRIPTOR = 255; TYPE CHSET=SET OF CHAR; REFLIST=ARRAY[0..0] OF INTEGER; (*index range checking off*) (*fixed layout parts of descriptors*) GRPDESCRIPTOR= PACKED RECORD OVERLINK:BYTE; (*descriptor longer than 240 bytes not allowed*) SWITCHES:BYTE; (*packed array gets allocated in whole words*) (*bit 0 = tagged; bit 1 = linked *) RECLINK:BYTE; FILLER:BYTE; RECNUM:REFLIST; (*expand here with additional recnum's*) END; GRPDESPTR=^GRPDESCRIPTOR; RECDESCRIPTOR= PACKED RECORD OVERLINK:BYTE; SWITCHES:BYTE; (*bit 0 = tagged; bit 1 = fixed width; bit 2 = sparse *) SIZE:INTEGER; FIRSTLITEMNUM:BYTE; USECOUNT:BYTE; LAYOUT:BYTE; (*on a large system this could be declared TAG*) LASTFLDLINK:BYTE; (*points to name field*) FLDREF:ARRAY [0..0] OF PACKED RECORD FDNUM: 0..LASTFIELDDESCRIPTOR; FLDOFFSET:BYTE; (*for fixed size fields; =0 for linked*) END; (*expand here with additional fldref's*) END; RECDESPTR=^RECDESCRIPTOR; FDTYPE= PACKED RECORD CASE BOOLEAN OF TRUE: (S:STRING); FALSE: (R:FLDDESCRIPTOR) END; RDTYPE= PACKED RECORD CASE BOOLEAN OF TRUE: (S:STRING); FALSE: (R:RECDESCRIPTOR) END; GDTYPE= PACKED RECORD CASE BOOLEAN OF TRUE: (S:STRING); FALSE: (R:GRPDESCRIPTOR) END; STRINGPTR = ^STRING; TRIXPTR= RECORD CASE DBLEVELTYPE OF FIELDT: (F:FLDDESPTR); RECORDT:(R:RECDESPTR); GROUPT: (G:GRPDESPTR); NONET: (S:STRINGPTR) END (*TRIXPTR*); VAR DONE:BOOLEAN; ITEMLEVEL:DBLEVELTYPE; REMFILE:BOOLEAN; FOUT:INTERACTIVE; FUNCTION GETCOMMAND(S:STRING; OKSET:CHSET):CHAR; VAR CH:CHAR; BEGIN REPEAT WRITELN; WRITE(S); READ(CH); IF CH IN ['a'..'z'] THEN CH:=CHR(ORD(CH)-32); IF NOT (CH IN OKSET) THEN WRITE(' ORD(CH)=',ORD(CH)); UNTIL CH IN OKSET; WRITELN; GETCOMMAND:=CH; END (*GETCOMMAND*); PROCEDURE LOCATOR(GROUPNUM,RECNUM:INTEGER); VAR I:INTEGER; BEGIN DBSHOWERR('LOC#1', DBHOME(WA0)); DBSHOWERR('LOC#2', DBSEEK(WA0, GROUPNUM)); DBSHOWERR('LOC#3', DBDESCEND(WA0)); DBSHOWERR('LOC#4', DBSEEK(WA0, RECNUM)); END (*LOCATOR*); FUNCTION READI(S:STRING; X:INTEGER): INTEGER; VAR I:INTEGER; BEGIN WRITE(S,X, ' >'); READLN(I); IF EOF THEN BEGIN RESET(INPUT); READI:=X; WRITELN; END ELSE READI:=I; END (*READI*); PROCEDURE SHOWFLDTYPE(FLDTYPE:DBFIELDTYPES); BEGIN WRITE('FLD TYPE:'); IF NOT (FLDTYPE IN [BYTEF, GROUPF, INTEGERF, LONGINTF, STRINGF, SETF, PICF]) THEN WRITELN('***** ILLEGAL ****') ELSE CASE FLDTYPE OF BYTEF: WRITELN('BYTEF'); GROUPF: WRITELN('GROUPF'); INTEGERF: WRITELN('INTEGERF'); LONGINTF: WRITELN('LONGINTF'); SETF: WRITELN('SETF'); PICF: WRITELN('PICF'); TEXTF: WRITELN('TEXTF'); STRINGF: WRITELN('STRINGF') END (*CASE*); END (*SHOWFLDTYPE*); PROCEDURE SHOWFD(PS:STRING); VAR FD:FDTYPE; BEGIN FD.S:=PS; WITH FD.R DO BEGIN (*note: link value is one more than correct string length*) WRITELN('FIELD DESCRIPTOR:',NAME:(LENGTH(NAME)-1)); WRITELN('SWITCHES:', SWITCHES); WRITELN('MAX WIDTH:', MAXWIDTH); WRITELN('USECOUNT:', USECOUNT); SHOWFLDTYPE(FLDTYPE); WRITELN('FLDREF:', FLDREF); IF FLDREF = 0 THEN BEGIN WRITELN('ROW:', ROW); WRITELN('DATACOL:', DATACOL); WRITELN('LABELCOL:', LABELCOL); WRITELN('CONTROLBITS:', CONTROLBITS); END; END (*WITH*); END (*SHOWFD*); PROCEDURE BUILDFD; VAR NS:STRING; I,FLDNUM:INTEGER; CH:CHAR; FD:FDTYPE; BEGIN DBTYPECHECK:=FALSE; WRITELN; WRITE('FIELD NUMBER:'); READLN(FLDNUM); LOCATOR(3(*FD'S*), FLDNUM); CASE GETCOMMAND('BUILDFD: C(hange old field or N(ew field?', ['C','c','N','n']) OF 'C','c': BEGIN DBSHOWERR('BUILDFD-GET', DBGET(WA0)); FD.S:=DBMAIL.STRG; END; 'N','n': FILLCHAR(FD.S, 82, CHR(0)) END (*CASE*); WITH FD.R DO BEGIN WRITE('FIELD NAME:', NAME:LENGTH(NAME)-1, ' >'); READLN(NS); IF LENGTH(NS) > 0 THEN (*$R-*) BEGIN MOVELEFT(NS,NAME,LENGTH(NS)+1); NAME[0]:=CHR(LENGTH(NS)+1); OVERLINK:=LENGTH(NS)+SIZEOF(FLDDESCRIPTOR)-1; END ELSE WRITELN; (*$R+*) SWITCHES:=READI('SWITCH BYTE:',SWITCHES); MAXWIDTH:=READI('MAXIMUM WIDTH:', MAXWIDTH); USECOUNT:=0; SHOWFLDTYPE(FLDTYPE); WRITE(' G(ROUP R(EC S(TRING B(YTE I(NTEGER >'); REPEAT READ(CH); UNTIL (CH IN ['G', 'S', 'B', 'I']) OR EOF; WRITELN; IF EOF THEN RESET(INPUT) ELSE CASE CH OF 'B': FLDTYPE:=BYTEF; 'G': FLDTYPE:=GROUPF; 'I': FLDTYPE:=INTEGERF; 'S': FLDTYPE:=STRINGF END (*CASE*); IF FLDTYPE = GROUPF THEN FLDREF:=READI('DESCRIPTOR NUMBER:',FLDREF) ELSE FLDREF:=READI('Displayable (=0) or not (=1):', FLDREF); IF FLDTYPE <> GROUPF THEN BEGIN WRITE('Set Display Params? (Y/N)'); READ(CH); WRITELN; IF CH IN ['Y', 'y'] THEN BEGIN ROW:=READI('ROW:',ROW); DATACOL:=READI('DATACOL:', DATACOL); LABELCOL:=READI('LABELCOL:',LABELCOL); CONTROLBITS:=READI('CONTROLBITS:',CONTROLBITS); END; END; END (*WITH FD.R*); WRITELN; WRITE(' ACCEPTS; TRY AGAIN'); READ(KEYBOARD,CH); IF CH = CHR(3(*ETX*)) THEN WITH DBMAIL DO BEGIN STRG:=FD.S; DBMAILTYPE:=STRINGF; DBSHOWERR('BUILDFD', DBPUT(WA0)); END; END (*BUILDFD*); PROCEDURE SHOWRD(PS:STRING); VAR I,J,N:INTEGER; NS:STRING; RD:RDTYPE; BEGIN RD.S:=PS; NS:=RD.S; DELETE(NS,1,(RD.R.LASTFLDLINK+SIZEOF(RECDESCRIPTOR)-3)); WRITELN('RECORD DESCRIPTOR:',NS); WITH RD.R DO BEGIN WRITELN('SWITCHES:', SWITCHES); WRITELN('SIZE:', SIZE); WRITELN('FIRSTLINK - ITEM# ', FIRSTLITEMNUM); WRITELN('USECOUNT:', USECOUNT); WRITELN('LAYOUT:', LAYOUT); WRITELN('LASTFLDLINK:', LASTFLDLINK); END (*WITH*); I:=0; N:=0; J:=RD.R.LASTFLDLINK - 2; WHILE I < J DO BEGIN (*$R-*) WITH RD.R.FLDREF[N] DO WRITELN(' FLDREF(', N, ') - FDNUM:', FDNUM, ' OFFSET:', FLDOFFSET); I:=I+2; N:=N+1; (*$R+*) END; END (*SHOWRD*); PROCEDURE BUILDRD; VAR I,J,N,X,RECNUM:INTEGER; NAME:STRING; CH:CHAR; RD:RDTYPE; BEGIN REPEAT FILLCHAR(RD.S, 82, CHR(0)); WRITELN; WRITE('RECORD DEF NUMBER:'); READLN(RECNUM); LOCATOR(2(*RD'S*), RECNUM); WRITE('RECDEF NAME:'); READLN(NAME); WRITE('SWITCH BYTES:'); WITH RD.R DO BEGIN READLN(I); SWITCHES:=I; WRITE('SIZE:'); READLN(SIZE); WRITE('FIRSTLITEMNUM:'); READLN(I); FIRSTLITEMNUM:=I; USECOUNT:=0; WRITE('LAYOUT#:'); READLN(I); LAYOUT:=I; END (*WITH*); I:=8; J:=3; REPEAT N:=(I-8) DIV 2; WRITE('FLDREF #', N, ':'); READ(X); IF X >= 0 THEN (*$R-*) WITH RD.R.FLDREF[N] DO BEGIN FDNUM:=X; WRITE(' OFFSET #', N, ':'); READLN(X); FLDOFFSET:=X; (*$R+*) J:=J+2; I:=I+2; END; UNTIL X < 0; RD.R.OVERLINK:=2+I; RD.R.LASTFLDLINK:=J; (*leave 2 empty bytes*) RD.S:=CONCAT(RD.S,NAME); RD.S[2+I]:=CHR(LENGTH(NAME)+1); WRITELN; SHOWRD(RD.S); WRITE(' ACCEPTS; TRY AGAIN'); READ(KEYBOARD,CH); UNTIL CH = CHR(3(*ETX*)); WITH DBMAIL DO BEGIN STRG:=RD.S; DBMAILTYPE:=STRINGF; END; READ(CH); (*flush buffered char left by READ(X) of '-1'*) WRITELN; END (*BUILDRD*); PROCEDURE SHOWGD(PS:STRING); VAR I,J,N:INTEGER; A: ARRAY[0..0] OF INTEGER; NS:STRING; GD:GDTYPE; BEGIN GD.S:=PS; NS:=GD.S; DELETE(NS,1,(GD.R.RECLINK+SIZEOF(GRPDESCRIPTOR)-4)); WRITELN('GROUP DESCRIPTOR:',NS); WITH GD.R DO BEGIN WRITELN('SWITCHES:', SWITCHES); WRITELN('RECLINK:', RECLINK); END (*WITH*); I:=0; N:=0; J:=GD.R.RECLINK-2; WHILE I < J DO BEGIN (*$R-*) WRITELN(' RECNUM(', N, '):', GD.R.RECNUM[N]); (*$R+*) N:=N+1; I:=I+2; END; END (*SHOWGD*); PROCEDURE BUILDGD; VAR I,J,N,X,GRPNUM:INTEGER; NAME:STRING; CH:CHAR; GD:GDTYPE; BEGIN FILLCHAR(GD.S, 82, CHR(0)); REPEAT WRITELN; WRITE('GROUP DEF NUMBER:'); READLN(GRPNUM); LOCATOR(1(*GD'S*), GRPNUM); WRITE('GRPDEF NAME:'); READLN(NAME); WRITE('SWITCH BYTES:'); READLN(I); GD.R.SWITCHES:=I; I:=4; REPEAT N:=(I-4) DIV 2; WRITE('RECNUM #', N, ':'); READLN(X); IF X >= 0 THEN BEGIN (*$R-*) GD.R.RECNUM[N]:=X; (*$R+*) I:=I+2; END; UNTIL X < 0; GD.R.OVERLINK:=2+I; GD.R.RECLINK:=I; GD.S:=CONCAT(GD.S,NAME); GD.S[2+I]:=CHR(LENGTH(NAME)+1); WRITELN; SHOWGD(GD.S); WRITE(' ACCEPTS; TRY AGAIN'); READ(KEYBOARD,CH); UNTIL CH = CHR(3(*ETX*)); WITH DBMAIL DO BEGIN STRG:=GD.S; DBMAILTYPE:=STRINGF; END; END (*BUILDGD*); PROCEDURE BUILDLITERAL; VAR I:INTEGER; S:STRING; BEGIN CASE GETCOMMAND('LITERAL: I(NTEGER S(TRING ', ['I','S']) OF 'I': BEGIN WRITE('I>'); READLN(I); WITH DBMAIL DO BEGIN INT:=I; DBMAILTYPE:=INTEGERF; END; END; 'S': BEGIN WRITE('S>'); READLN(S); WITH DBMAIL DO BEGIN STRG:=S; DBMAILTYPE:=STRINGF; END; END END (*CASES*); END (*BUILDLITERAL*); PROCEDURE SHOWLITERAL; BEGIN WRITELN; CASE DBMAIL.DBMAILTYPE OF STRINGF: WRITELN('STRG: ', DBMAIL.STRG); INTEGERF: WRITELN('INT: ', DBMAIL.INT) (*LONGINTF: WRITELN('LINT: ', DBMAIL.LINT) *) END (*CASES*); END (*SHOWLITERAL*); PROCEDURE SHOWDATASTRUCTURE; VAR TP:TRIXPTR; GN:INTEGER; PROCEDURE GDOUT(TP:TRIXPTR; LEVEL,GN:INTEGER); FORWARD; PROCEDURE FDOUT(TP:TRIXPTR; LEVEL,FN:INTEGER); VAR NS:STRING; GP:TRIXPTR; BEGIN WITH TP.F^ DO BEGIN NS:=NAME; DELETE(NS,LENGTH(NS),1); (*note: link value is one more than correct string length*) WRITE(FOUT,'FLD(':(4+LEVEL), FN, '):',NS, ' ':17-LENGTH(NS)); WRITE(FOUT,' SW:', SWITCHES); WRITE(FOUT,' W:', MAXWIDTH); WRITE(FOUT,' T:'); IF NOT (FLDTYPE IN [BYTEF, GROUPF, INTEGERF, LONGINTF, STRINGF, SETF, PICF]) THEN WRITE(FOUT,'***** ILLEGAL ****') ELSE BEGIN CASE FLDTYPE OF BYTEF: WRITE(FOUT,'BYT'); GROUPF: WRITE(FOUT,'GRP'); INTEGERF: WRITE(FOUT,'INT'); LONGINTF: WRITE(FOUT,'LNI'); SETF: WRITE(FOUT,'SET'); PICF: WRITE(FOUT,'PIC'); TEXTF: WRITE(FOUT,'TXT'); STRINGF: WRITE(FOUT,'STR') END (*CASE*); IF FLDTYPE = GROUPF THEN BEGIN WRITELN(FOUT); DBGETDESCRIPTORNUM(GROUPT, FLDREF, GP.F); IF GP.F <> NIL THEN GDOUT(GP, LEVEL+2, FLDREF); END ELSE BEGIN IF FLDREF = 0 THEN WRITE(FOUT, ' ROW=', ROW, ' LCOL=', LABELCOL, ' DCOL=', DATACOL); WRITELN(FOUT); END; END (*FLDTYPE OK*); END (*WITH TP.F^*); END (*FDOUT*); PROCEDURE RDOUT(TP:TRIXPTR; LEVEL,RN:INTEGER); VAR I,J,N:INTEGER; NS:STRING; FP:TRIXPTR; BEGIN NS:=TP.S^; DELETE(NS,1,(TP.R^.LASTFLDLINK+SIZEOF(RECDESCRIPTOR)-3)); (*correct for link to string length*) DELETE(NS, LENGTH(NS),1); WRITE(FOUT,'REC(':(4+LEVEL), RN, '):',NS, ' ':18-LENGTH(NS)); WITH TP.R^ DO BEGIN WRITE(FOUT,' SW:', SWITCHES); WRITELN(FOUT,' SIZE:', SIZE); END (*WITH*); I:=0; N:=0; J:=TP.R^.LASTFLDLINK - 4; WHILE I < J DO BEGIN (*$R-*) WITH TP.R^.FLDREF[N] DO BEGIN DBGETDESCRIPTOR(FIELDT, FDNUM, FP.F); (*$R+*) IF FP.F <> NIL THEN FDOUT(FP, LEVEL+2, FDNUM); END; I:=I+2; N:=N+1; END; END (*RDOUT*); PROCEDURE GDOUT(*TP:TRIXPTR; LEVEL,GN:INTEGER*); VAR I,J,N:INTEGER; NS:STRING; RP:TRIXPTR; BEGIN NS:=TP.S^; DELETE(NS,1,(TP.G^.RECLINK+SIZEOF(GRPDESCRIPTOR)-4)); (*correct for link to string length*) DELETE(NS, LENGTH(NS),1); WRITE(FOUT,'GRP(':(4+LEVEL), GN, '):',NS, ' ':18-LENGTH(NS)); WITH TP.G^ DO BEGIN WRITELN(FOUT,' SW:', SWITCHES); I:=0; N:=0; J:=RECLINK-4; WHILE I < J DO BEGIN (*$R-*) DBGETDESCRIPTOR(RECORDT, RECNUM[N], RP.F); (*$R+*) IF RP.F <> NIL THEN RDOUT(RP,LEVEL+2, RECNUM[N]); N:=N+1; I:=I+2; END; END (*WITH TP.G^*); END (*GDOUT*); BEGIN (*SHOWDATASTRUCTURE*) WRITELN(FOUT); GN:=0; DBGETDESCRIPTOR(GROUPT, GN, TP.F); WHILE TP.F <> NIL DO BEGIN GDOUT(TP,0, GN); WRITELN(FOUT); GN:=GN+1; DBGETDESCRIPTOR(GROUPT, GN, TP.F); END; END (*SHOWDATASTRUCTURE*); PROCEDURE SHOWITEMINFO; VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER; NAME:STRING; BEGIN WRITELN; DBITEMINFO(WA0,ITEMLEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NAME); WRITE('LEVEL='); CASE ITEMLEVEL OF GROUPT: WRITE('GROUPT'); RECORDT:WRITE('RECORDT'); FIELDT: WRITE('FIELDT'); NONET: WRITE('NONET') END (*CASES*); WRITELN(' ITEM#', ITEMNUM, ' OFFSET=', OFFSET, ' DESCRIP#', DESCRIPTORNUM, ' NAME=', NAME); END (*SHOWITEMINFO*); PROCEDURE NEWEMPTY; VAR CH:CHAR; TAG:INTEGER; BEGIN SHOWITEMINFO; WRITE('Make new item? (Y/N)'); READ(CH); WRITELN; IF CH IN ['Y','y'] THEN BEGIN CASE ITEMLEVEL OF GROUPT: CASE GETCOMMAND('new embedded R(ecord or new G(roup?', ['G','R']) OF 'G': BEGIN WRITE('TAG VALUE:'); READLN(TAG); DBSHOWERR('NEWEMPTY-GROUPT', DBEMPTYITEM(WA0,GROUPT,TAG)); END; 'R': DBSHOWERR('NEWEMPTY-REC', DBEMPTYITEM(WA0,RECORDT,TAG)) END (*CASE GROUPT*); RECORDT,FIELDT: DBSHOWERR('NEWEMPTY', DBEMPTYITEM(WA0,ITEMLEVEL,TAG)); NONET: BEGIN (*do nothing*) END END (*CASE ITEMLEVEL*); END (*IF CH*); END (*NEWEMPTY*); PROCEDURE TRANSFERPRIMITIVES; BEGIN CASE GETCOMMAND('XFER: E(MPTY G(ET P(UT R(EMOUT T(YPECHECK Q(UIT ', ['E', 'G', 'P', 'R', 'T', 'Q']) OF 'E': NEWEMPTY; 'P': DBSHOWERR('XFER-PUT', DBPUT(WA0)); 'G': DBSHOWERR('XFER-GET', DBGET(WA0)); 'R': BEGIN REMFILE:=NOT REMFILE; CLOSE(FOUT); IF REMFILE THEN BEGIN RESET(FOUT, 'CONSOLE:'); WRITELN('Output now to CONSOLE:'); END ELSE BEGIN RESET(FOUT, 'REMOUT:'); WRITELN('Output now to REMOUT:'); END; END; 'T': BEGIN DBTYPECHECK:=NOT DBTYPECHECK; WRITE('DBTYPECHECK NOW '); IF DBTYPECHECK THEN WRITELN('TRUE') ELSE WRITELN('FALSE'); END; 'Q': BEGIN (*do nothing*) END END (*CASES*); END (*TRANSFERPRIMITIVES*); PROCEDURE FILEHANDLER; CONST FNUM=0; PGZERO=0; EMPTYSTRING=''; VAR TITLE:STRING; CH:CHAR; DUMMY:INTEGER; PROCEDURE GETTITLE; BEGIN WRITE('FILE TITLE:'); READLN(TITLE); END (*GETTITLE*); BEGIN (*FILEHANDLER*) CASE GETCOMMAND( 'FILE: N(EWFILE O(PEN I(NIT-GROUPS C(LOSE R(EMOVE G(ET P(UT Q(UIT', ['C','G','I','N','O','P','R','Q']) OF 'C': DBSHOWERR('FILE(C)', DBFCLOSE(FNUM)); 'G': DBSHOWERR('FILE(G)', DBGETPAGE(FNUM,WA0,PGZERO)); 'I': DBSHOWERR('FILE(I)', DBGROUPINIT(FNUM,DUMMY,'ALL')); 'N': BEGIN WRITE('NEW '); GETTITLE; DBSHOWERR('FILE(N)', DBFCREATE(FNUM,WA0,EMPTYSTRING,TITLE)); END; 'O': BEGIN WRITE('OLD '); GETTITLE; DBSHOWERR('FILE(O)', DBFOPEN(FNUM, TITLE)); END; 'P': DBSHOWERR('FILE(P)', DBPUTPAGE(FNUM, WA0, PGZERO)); 'R': BEGIN WRITE('REMOVE OLD FILE (Y/N)?'); READ(CH); IF CH = 'Y' THEN DBSHOWERR('FILE(R)', DBFREMOVE(FNUM)); END; 'Q': BEGIN (*DO NOTHING*); END END (*CASE*); END (*FILEHANDLER*); PROCEDURE TESTFINDREC; VAR FN,RN:INTEGER; FOUND:BOOLEAN; KEY:STRING; BEGIN WRITELN('TEST DBFINDREC PROCEDURE'); WRITE('FIELDNUM:'); READLN(FN); WRITE('KEY(STRING):'); READLN(KEY); DBSHOWERR('TESTFINDREC', DBFINDREC(WA0, ASCENDING, FN, KEY, RN, FOUND)); IF FOUND THEN WRITE(' FOUND RECORD') ELSE WRITE(' COULDN''T FIND KEY'); WRITELN(' RECNUM=', RN); WRITELN; END (*TESTFINDREC*); PROCEDURE MOVER; VAR N,G,R:INTEGER; BEGIN CASE GETCOMMAND( 'MOVE: B(EGIN-LEVEL F(IND H(OME N(EXT T(AIL S(EEK D(ESCEND L(OCATE Q(UIT', ['B','F','H','N','S','T','D','L','Q']) OF 'B': DBSHOWERR('MOVE-HEAD', DBHEAD(WA0)); 'F': TESTFINDREC; 'H': DBSHOWERR('MOVE-HOME', DBHOME(WA0)); 'N': DBSHOWERR('MOVE-NEXT', DBNEXT(WA0)); 'T': DBSHOWERR('MOVE-TAIL', DBTAIL(WA0)); 'S': BEGIN WRITELN; WRITE('ITEM NUMBER:'); READLN(N); DBSHOWERR('MOVE-SEEK', DBSEEK(WA0, N)); END; 'D': DBSHOWERR('MOVE-DESCEND', DBDESCEND(WA0)); 'L': BEGIN WRITELN; WRITE('GROUP:'); READLN(G); WRITE(' RECORD:'); READLN(R); LOCATOR(G,R); END; 'Q': BEGIN (*DO NOTHING*) END END (*CASES*); END (*MOVER*); PROCEDURE SETTRACESITES; VAR I:INTEGER; BEGIN WRITELN('ENTER TRACE SITE NUMBERS ( Terminates input list)'); REPEAT WRITE('>'); READLN(I); IF NOT EOF THEN IF (I>=0) AND (I <= 100) THEN DBTRACESET := DBTRACESET + [I]; UNTIL EOF; RESET(INPUT); END (*SETTRACESITES*); PROCEDURE INIT; VAR I:INTEGER; BEGIN DBINITIALIZE; WRITELN('DESCRIPTOR BUILDER INITIALIZING'); DBTYPECHECK:=FALSE; SETTRACESITES; (*put 5 empty groups in wa0*) FOR I:=0 TO 4 DO DBSHOWERR('INIT#2', DBEMPTYITEM(WA0,GROUPT,0)); (*put one empty linked record in each group, thus permitting traversal operations to function*) FOR I:=1 TO 4 DO BEGIN DBSHOWERR('INIT-HOME',DBHOME(WA0)); DBSHOWERR('INIT-SEEK',DBSEEK(WA0,I)); DBSHOWERR('INIT#4', DBEMPTYITEM(WA0, RECORDT,0)); END; DONE:=FALSE; REMFILE:=FALSE; RESET(FOUT, 'CONSOLE:'); END (*INIT*); BEGIN (*MAIN PROGRAM*) INIT; REPEAT CASE GETCOMMAND( 'B(UILD X(FER D(ISPLAY F(ILE M(OVE S(TRUCT W(RITE Q(UIT', ['B','X','D','F','M','S','T','W','Q']) OF 'B': CASE GETCOMMAND('BUILD: G(ROUP R(ECORD F(IELD L(ITERAL', ['G','R','F','L']) OF 'F': BUILDFD; 'G': BUILDGD; 'L': BUILDLITERAL; 'R': BUILDRD END (*CASE*); 'X': TRANSFERPRIMITIVES; 'D': CASE GETCOMMAND('DISPLAY: G(ROUP R(ECORD F(IELD L(ITERAL', ['G','R','F','L']) OF 'F': SHOWFD(DBMAIL.STRG); 'G': SHOWGD(DBMAIL.STRG); 'L': SHOWLITERAL; 'R': SHOWRD(DBMAIL.STRG) END (*CASE*); 'F': FILEHANDLER; 'M': MOVER; 'S': SHOWDATASTRUCTURE; 'T': SETTRACESITES; 'W': DBSHOWERR('WRITEFIELD', DBWRITEFIELD(OUTPUT,WA0)); 'Q': DONE:=TRUE END (*CASE*); UNTIL DONE; END. ======================================================================================== DOCUMENT :usus Folder:VOL04:dbunit.1.text ======================================================================================== (* L #5:DBUNIT.LST.TEXT*) {make sure you leave plenty of room for the listing} (*$S+*) UNIT DBUNIT; (*version 1.2 - 5 Feb, 1980*) (*Copyright 1980 Kenneth L. Bowles. All rights reserved. Permission is hereby granted to use this material for any non-commercial purpose*) INTERFACE CONST LASTWRKINDEX=20; LONGINTSIZE=14; SETSIZE=47; NAMESTRSIZE=30; LASTFILENUM=4; TYPE BYTE=0..255; DBWRKINDEX=0..LASTWRKINDEX; DBERRTYPE=0..100; (*not a scalar to conserve symbols*) DBFILENUM=0..LASTFILENUM; DBFIELDTYPES=(GROUPF, STRINGF, BYTEF, INTEGERF, LONGINTF, ADDRCOUPLEF, SETF, PICF, TEXTF); DBLEVELTYPE=(NONET, GROUPT, RECORDT, FIELDT); DBFINDRULE=(ASCENDING, DESCENDING, RANDOM); FILETYPE=FILE; (*compiler won't acccept 'file' as parameter type*) FLDDESCRIPTOR= PACKED RECORD OVERLINK:BYTE; SWITCHES:BYTE; (*bit 0 = tagged; bit 1 = fixedwidth *) MAXWIDTH:INTEGER; USECOUNT:BYTE; FLDTYPE:DBFIELDTYPES; FLDREF:INTEGER; (*points to descriptor of FLDTYPE; =0 IF NOT GROUPF*) (*following may get moved to Layout later*) ROW:BYTE; DATACOL:BYTE; LABELCOL:BYTE; CONTROLBITS:BYTE; NAME:STRING[1] (*generally will be expanded out of rangechecking*) END; FLDDESPTR=^FLDDESCRIPTOR; VAR DBTYPECHECK:BOOLEAN; (*if false can't use fixed length records*) DEBUGGING:BOOLEAN; F0,F1,F2,F3,F4:FILETYPE; DBMAIL: RECORD CASE DBMAILTYPE: DBFIELDTYPES OF GROUPF: ( ); (*TO BE DEFINED*) STRINGF: (STRG:STRING[255]); BYTEF: (BYT:BYTE); INTEGERF: (INT:INTEGER); LONGINTF: (LINT:INTEGER[LONGINTSIZE]); ADDRCOUPLE:(PGE:INTEGER; GRP:INTEGER; REC:INTEGER); SETF: (SETT:PACKED ARRAY[0..SETSIZE] OF BOOLEAN); PICF: ( ); (* PICTURES TO BE DEFINED *) TEXTF: (TXT: PACKED ARRAY[0..255] OF CHAR) END (*DBMAIL*); DBIORESULT:INTEGER; DBTRACESET:SET OF DBERRTYPE; (*TRAVERSAL PRIMITIVES*) FUNCTION DBHOME(WI:DBWRKINDEX):DBERRTYPE; FUNCTION DBHEAD(WI:DBWRKINDEX):DBERRTYPE; FUNCTION DBNEXT(WI:DBWRKINDEX):DBERRTYPE; FUNCTION DBTAIL(WI:DBWRKINDEX):DBERRTYPE; FUNCTION DBSEEK(WI:DBWRKINDEX; WHICHITEM:INTEGER):DBERRTYPE; FUNCTION DBDESCEND(WI:DBWRKINDEX):DBERRTYPE; FUNCTION DBASCEND(WI:DBWRKINDEX):DBERRTYPE; FUNCTION DBFINDREC(WI:DBWRKINDEX; RULE:DBFINDRULE; FIELDNUM:INTEGER; KEY:STRING; VAR RECNUM:INTEGER; VAR FOUND:BOOLEAN):DBERRTYPE; (*DATA TRANSFER PRIMITIVES*) FUNCTION DBCOPY(SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE; FUNCTION DBEMPTYITEM(DESTINATION:DBWRKINDEX; LVL:DBLEVELTYPE; TAG:INTEGER):DBERRTYPE; FUNCTION DBDELETE(DESTINATION:DBWRKINDEX):DBERRTYPE; FUNCTION DBBLANK(DESTINATION:DBWRKINDEX):DBERRTYPE; FUNCTION DBREPLACE(SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE; FUNCTION DBRESERVE(DESTINATION:DBWRKINDEX):DBERRTYPE; FUNCTION DBGET(SOURCE:DBWRKINDEX):DBERRTYPE; FUNCTION DBPUT(DESTINATION:DBWRKINDEX):DBERRTYPE; (*SUPPORT PRIMITIVES*) FUNCTION DBWRITEFIELD(VAR FID:TEXT; SOURCE:DBWRKINDEX):DBERRTYPE; PROCEDURE DBGETDESCRIPTOR(LEVEL:DBLEVELTYPE; DESCRIPTORNUM:INTEGER; VAR PTR:FLDDESPTR); FUNCTION DBTAG(NAME:STRING; SOURCE:DBWRKINDEX; VAR ITEMNUM:INTEGER):DBERRTYPE; (*WORKAREA PRIMITIVES*) FUNCTION DBWRKOPEN(WI:DBWRKINDEX; SIZE:INTEGER):DBERRTYPE; FUNCTION DBWRKCLOSE(WI:DBWRKINDEX):DBERRTYPE; PROCEDURE ZEROWORKAREA(WI:DBWRKINDEX); (*FILE PRIMITIVES*) FUNCTION DBFOPEN(FNUM:DBFILENUM; TITLE:STRING):DBERRTYPE; FUNCTION DBFCLOSE(FNUM:DBFILENUM):DBERRTYPE; FUNCTION DBFCREATE(FNUM:DBFILENUM; WASCRATCH:DBWRKINDEX; SPEXTITLE,NEWTITLE:STRING):DBERRTYPE; FUNCTION DBFREMOVE(FNUM:DBFILENUM):DBERRTYPE; FUNCTION DBGETPAGE(FNUM:DBFILENUM; DESTINATION:DBWRKINDEX; PAGENUM:INTEGER):DBERRTYPE; FUNCTION DBPUTPAGE(FNUM:DBFILENUM; SOURCE:DBWRKINDEX; PAGENUM:INTEGER):DBERRTYPE; (*DESCRIPTOR INITIALIZING PRIMITIVES*) FUNCTION DBGROUPINIT(FNUM:DBFILENUM; VAR GROUPNUM:INTEGER; GROUPNAME:STRING):DBERRTYPE; FUNCTION DBGROUPRELEASE(GROUPNUM:INTEGER):DBERRTYPE; (*INITIALIZATION*) PROCEDURE DBINITIALIZE; (*ORDERLY TERMINATION*) FUNCTION DBCLOSEDOWN:DBERRTYPE; (*ERROR REPORTING AND DIAGNOSTICS*) PROCEDURE DBSHOWERROR(S:STRING; ERRNUM:DBERRTYPE); PROCEDURE DBITEMINFO(WI:DBWRKINDEX; VAR LEVEL:DBLEVELTYPE; VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER; VAR NAME:STRING); (**************************************************************) IMPLEMENTATION CONST PAGELASTBYTE=4095; LASTSPECIALGROUP=6; LASTWRKSTACKSLOT=9; LASTGROUPDESCRIPTOR=255; LASTRECDESCRIPTOR=255; LASTFIELDDESCRIPTOR=255; LINKESCAPE=240; DBNUL=0; ONEITEMRECLINK=6; TYPE PAGEPTR=0..PAGELASTBYTE; PAGETYPE=PACKED ARRAY[PAGEPTR] OF BYTE; (*work area information block - WIB *) WIBENTRY= RECORD OFFSET:PAGEPTR; LEVEL:DBLEVELTYPE; DESCRIPTORNUM:INTEGER; ITEMNUM:INTEGER; END; TOSRANGE=0..LASTWRKSTACKSLOT; WIBTYPE=ARRAY[TOSRANGE] OF WIBENTRY; WIBPTR=^WIBTYPE; (*following are dummy types used for heap allocation of workareas*) WATYPE=PACKED ARRAY[0..63] OF BYTE; (* WA will be multiple of these*) WAPTR=^WATYPE; ONEWORDPTR=^INTEGER; REFLIST=ARRAY[0..0] OF INTEGER; (*index with range checking off*) (*fixed layout parts of descriptors*) GRPDESCRIPTOR= PACKED RECORD OVERLINK:BYTE; (*descriptor longer than 240 bytes not allowed*) SWITCHES:BYTE; (*packed array gets allocated in whole words*) (*bit 0 = tagged; bit 1 = linked *) RECLINK:BYTE; FILLER:BYTE; RECNUM:REFLIST; (*expand here with additional recnum's*) END; GRPDESPTR=^GRPDESCRIPTOR; RECDESCRIPTOR= PACKED RECORD OVERLINK:BYTE; SWITCHES:BYTE; (*bit 0 = tagged; bit 1 = fixed width; bit 2 = sparse *) SIZE:INTEGER; FIRSTLITEMNUM:BYTE; (*set to 1 more than last fixed itemnumber if there are only fixed fields in the record*) USECOUNT:BYTE; LAYOUT:BYTE; (*on a large system this could be declared TAG*) LASTFLDLINK:BYTE; (*points to name field, indirect upper bound of FLDREF array*) FLDREF:ARRAY [0..0] OF PACKED RECORD FDNUM: 0..LASTFIELDDESCRIPTOR; FLDOFFSET:BYTE; (*for fixed size fields; =0 for linked*) END; (*expand here with additional fldref's*) END; RECDESPTR=^RECDESCRIPTOR; CRACKSWTYPE= (*for accessing individual switch control bits*) PACKED RECORD CASE BOOLEAN OF TRUE:(BL:BYTE; BH:BYTE); FALSE:(A:PACKED ARRAY[0..15] OF BOOLEAN); END (*CRACKSWTYPE*); VAR HEAPMARKER:ONEWORDPTR; OPENFILES: PACKED ARRAY[0..LASTFILENUM] OF BOOLEAN; (*page numbers of fixed numbered groups at beginning of file*) SPECIALGROUPPAGE: ARRAY[0..LASTSPECIALGROUP] OF INTEGER; (*all access to workareas flows via WRKTABLE*) WRKTABLE: ARRAY[DBWRKINDEX] OF RECORD TOS: TOSRANGE; (*top of stack*) WIB: WIBPTR; (*points to stack of offsets in WIB; NIL if none allocated*) WSIZE: INTEGER; (*size of Workarea in bytes*) SPACEINUSE: INTEGER; (*initially 0*) WA: WAPTR (*the workarea itself*) END; (*all access to on-line descriptors is via these arrays*) ACTIVEGROUPS: ARRAY[0..LASTGROUPDESCRIPTOR] OF GRPDESPTR; ACTIVERECORDS: ARRAY[0..LASTRECDESCRIPTOR] OF RECDESPTR; ACTIVEFIELDS: ARRAY[0..LASTFIELDDESCRIPTOR] OF FLDDESPTR; (*Lower and Upper bound for tracing*) TRACELB,TRACEUB:INTEGER; ======================================================================================== DOCUMENT :usus Folder:VOL04:dbunit.2.text ======================================================================================== PROCEDURE SETTRACESITES; CONST RET=13; VAR I:INTEGER; CH:CHAR; BEGIN WRITELN; WRITELN('Enter trace site numbers (-1 terminates)'); REPEAT WRITE('>'); READLN(I); IF (I>=0) AND (I<=100) THEN BEGIN IF I IN DBTRACESET THEN WRITE(' ON') ELSE WRITE(' OFF'); WRITE(' S(et or R(eset ?'); REPEAT READ(CH); UNTIL CH IN ['R','S']; IF CH='S' THEN DBTRACESET:=DBTRACESET+[I] ELSE DBTRACESET:=DBTRACESET-[I]; END; WRITELN; UNTIL I<0; REPEAT WRITE('L(ower Bound=', TRACELB, ' U(pper Bound=', TRACEUB, ' '); READ(CH); IF EOLN THEN CH:=CHR(RET) ELSE WRITELN; IF CH = 'L' THEN BEGIN WRITE(' LB:'); READLN(TRACELB); END ELSE IF CH = 'U' THEN BEGIN WRITE(' UB:'); READLN(TRACEUB); END; UNTIL CH = CHR(RET); END (*SETTRACESITES*); PROCEDURE TRACEWA(TRACENUM:INTEGER; WI:DBWRKINDEX); VAR I,L,P:INTEGER; DONE:BOOLEAN; S:STRING[10]; BEGIN DONE:=FALSE; WHILE (TRACENUM IN DBTRACESET) AND (NOT DONE) DO BEGIN WRITELN; WITH WRKTABLE[WI] DO BEGIN WRITELN('TRACE # ', TRACENUM, ' WA:', WI, ' TOS:', TOS, ' WSIZE:', WSIZE, ' SPACEINUSE:', SPACEINUSE); IF WIB = NIL THEN WRITELN(' WIB = NIL ****') ELSE FOR L:=0 TO TOS DO WITH WIB^[L] DO BEGIN WRITE(' L:', L, ': OFFSET:', OFFSET, ' LEVEL:'); CASE LEVEL OF GROUPT: WRITE('GROUP'); RECORDT: WRITE('RECORD'); FIELDT: WRITE('FIELD'); NONET: WRITE('NONE') END (*CASE*); WRITELN(' DESCR#:', DESCRIPTORNUM); (*$L #5:DBUXXX.LST.TEXT*) END (*WITH WIB*); P:=TRACELB; IF WA = NIL THEN WRITELN(' WA = NIL') ELSE WHILE P <= TRACEUB DO BEGIN WRITE(' ', P:3, ':'); FOR I:=0 TO 9 DO BEGIN (*$R-*) WRITE(WA^[P]:4); (*$R+*) P:=P+1; END; WRITELN; END; WRITELN(' CONTINUES; "D" TOGGLES DEBUGGING'); WRITE(' "T" TO CHANGE TRACE SITES:'); READLN(S); DONE:=TRUE; IF LENGTH(S) > 0 THEN IF S[1] = 'T' THEN BEGIN SETTRACESITES; WRITE(' CONTINUES; R RE-DISPLAYS'); READLN(S); IF LENGTH(S) > 0 THEN DONE:=(S[1] <> 'R'); END ELSE IF S[1] = 'D' THEN DEBUGGING:=NOT DEBUGGING; END (*WITH WRKTABLE*); END (*DEBUGGING*); END (*TRACEWA*); PROCEDURE DBSHOWERROR(*S:STRING; ERRNUM: DBERRTYPE*); CONST RET=13; CAN=24; ESC=27; VAR CH:CHAR; BEGIN IF (ERRNUM<>0) OR DEBUGGING THEN (*temporary substitute for display of actual message*) BEGIN WRITELN; WRITELN('DBERROR # ', ERRNUM, ' IN ', S); WRITELN(' CONTINUES, ABORTS, TERMINATES'); WRITELN(' "T" TO CHANGE TRACE SITES'); REPEAT READ(CH); IF EOLN THEN CH:=CHR(RET); UNTIL CH IN [CHR(RET), CHR(CAN), CHR(ESC), 'T']; IF CH = CHR(CAN) THEN EXIT(PROGRAM); IF CH = CHR(ESC) THEN HALT; IF CH = 'T' THEN SETTRACESITES; END; END (*DBSHOWERROR*); PROCEDURE DBITEMINFO(*WI:DBWRKINDEX; VAR LEVEL:DBLEVELTYPE; VAR ITEMNUM,OFFSET,DESCRIPTORNUM:INTEGER; VAR NAME:STRING*); TYPE TRICKPTR = RECORD CASE BOOLEAN OF TRUE: (R:RECDESPTR); FALSE:(G:GRPDESPTR) END; VAR FP:FLDDESPTR; TP:TRICKPTR; NILMSG:STRING[25]; DPTR:INTEGER; PAB:PACKED ARRAY[0..255] OF BYTE; PROCEDURE EXTRACTNAME(TP:TRICKPTR; DPTR:INTEGER); BEGIN (*get the name field length into PAB[DPTR]*) MOVELEFT(TP.R^, PAB, DPTR+1); (*this time transfer the name*) MOVELEFT(TP.R^, PAB, DPTR+PAB[DPTR]); MOVELEFT(PAB[DPTR], NAME, PAB[DPTR]); (*convert to string*) DELETE(NAME, LENGTH(NAME), 1); END (*EXTRACTNAME*); BEGIN (*DBITEMINFO*) WITH WRKTABLE[WI] DO BEGIN LEVEL:=WIB^[TOS].LEVEL; ITEMNUM:=WIB^[TOS].ITEMNUM; OFFSET:=WIB^[TOS].OFFSET; DESCRIPTORNUM:=WIB^[TOS].DESCRIPTORNUM; NILMSG:='NIL Descriptor Pointer'; WITH WIB^[TOS] DO BEGIN IF (DESCRIPTORNUM < 0) THEN NAME:='Uninitialized Descriptor Number' ELSE CASE LEVEL OF FIELDT: BEGIN FP:=ACTIVEFIELDS[DESCRIPTORNUM]; IF FP=NIL THEN NAME:=NILMSG ELSE NAME:=FP^.NAME; END (*FIELDT:*); RECORDT: BEGIN TP.R:=ACTIVERECORDS[DESCRIPTORNUM]; IF TP.R = NIL THEN NAME:=NILMSG ELSE BEGIN DPTR:=7 + TP.R^.LASTFLDLINK; EXTRACTNAME(TP,DPTR); END; END (*RECORDT:*); GROUPT: BEGIN TP.G:=ACTIVEGROUPS[DESCRIPTORNUM]; IF TP.G = NIL THEN NAME:=NILMSG ELSE BEGIN DPTR:=2 + TP.G^.RECLINK; EXTRACTNAME(TP,DPTR); END; END (*GROUPT:*) END (*CASES*); END (*WITH WIB^*); END (*WITH*); END (*DBITEMINFO*); (*$L-*) FUNCTION CHECKHEAP(SIZE:INTEGER):BOOLEAN; VAR MA:INTEGER; BEGIN MA:=MEMAVAIL + MEMAVAIL; CHECKHEAP:=(MA<0) (* i.e. more than 32767 *) OR (MA>SIZE); END (*CHECKHEAP*); FUNCTION MAX(X,Y:INTEGER):INTEGER; BEGIN IF X>Y THEN MAX:=X ELSE MAX:=Y; END; FUNCTION CHECKWORKAREA(WI:DBWRKINDEX; SIZE:INTEGER):DBERRTYPE; BEGIN WITH WRKTABLE[WI] DO IF (WA=NIL) OR (WIB=NIL) THEN CHECKWORKAREA:=8 (*workarea not open*) ELSE IF WSIZE<>SIZE THEN CHECKWORKAREA:=2 ELSE CHECKWORKAREA:=0; END (*CHECKWORKAREA*); FUNCTION HEAPALLOCATE(SIZE:PAGEPTR):DBERRTYPE; VAR P1:ONEWORDPTR; P64:WAPTR; BEGIN IF CHECKHEAP(SIZE) THEN BEGIN WHILE SIZE >= 64 DO BEGIN NEW(P64); SIZE:=SIZE-64; END; IF ODD(SIZE) THEN SIZE:=SIZE+1; WHILE SIZE>0 DO BEGIN NEW(P1); SIZE:=SIZE-2; END; HEAPALLOCATE:=0; END ELSE HEAPALLOCATE:=1; (*insufficient memory*) END (*HEAPALLOCATE*); PROCEDURE ZEROWORKAREA(*WI:DBWRKINDEX*); (*unprotected -- call checkworkarea if in doubt*) VAR I:INTEGER; BEGIN WITH WRKTABLE[WI] DO BEGIN FILLCHAR(WA^,WSIZE,CHR(0)); FOR I:=0 TO LASTWRKSTACKSLOT DO WITH WIB^[I] DO BEGIN OFFSET:=0; LEVEL:=NONET; DESCRIPTORNUM:=-1; ITEMNUM:=-1; END; WITH WIB^[0] DO BEGIN LEVEL:=GROUPT; OFFSET:=0; ITEMNUM:=0; END; SPACEINUSE:=0; TOS:=0; END (*WITH*); END (*ZEROWORKAREA*); FUNCTION NEXTLEVEL(LVL:DBLEVELTYPE):DBLEVELTYPE; BEGIN IF LVL=NONET THEN NEXTLEVEL:=NONET ELSE IF LVL=FIELDT THEN NEXTLEVEL:=GROUPT ELSE NEXTLEVEL:=SUCC(LVL); END (*NEXTLEVEL*); FUNCTION MOVETAIL(DESTINATION:DBWRKINDEX; DELTA:INTEGER; OFFSET:PAGEPTR):DBERRTYPE; (*service routine for data transfer functions. shifts tail of workarea after checking whether requested shift is legal *) BEGIN MOVETAIL:=0; WITH WRKTABLE[DESTINATION] DO BEGIN TRACEWA(2,DESTINATION); IF (SPACEINUSE+DELTA) >= WSIZE THEN MOVETAIL:=14 (*insufficient space*) ELSE IF (OFFSET+DELTA) < 0 THEN MOVETAIL:=17 (*attempted negative offset*) ELSE BEGIN (*$R-*) IF DELTA > 0 THEN BEGIN MOVERIGHT(WA^[OFFSET], WA^[OFFSET+DELTA], SPACEINUSE-OFFSET); FILLCHAR(WA^[OFFSET],DELTA,CHR(0)); END ELSE IF DELTA < 0 THEN MOVELEFT(WA^[OFFSET], WA^[OFFSET+DELTA], SPACEINUSE-OFFSET); SPACEINUSE:=SPACEINUSE+DELTA; IF DELTA < 0 THEN FILLCHAR(WA^[SPACEINUSE], -DELTA, CHR(0)); (*$R+*) END; TRACEWA(3,DESTINATION); END (*WITH*); END (*MOVETAIL*); FUNCTION LINKVALUE(WA:WAPTR; OFFSET: PAGEPTR):PAGEPTR; VAR B1:BYTE; BEGIN (*$R-*) B1:=WA^[OFFSET]; IF B1 < LINKESCAPE THEN LINKVALUE:=B1 ELSE LINKVALUE:=(B1-LINKESCAPE+1)*LINKESCAPE+WA^[OFFSET+1]; (*$R+*) END (*LINKVALUE*); PROCEDURE SAVEBIGLINK(DESTINATION:DBWRKINDEX; NEWLINK:INTEGER; OFFSET:PAGEPTR); BEGIN WITH WRKTABLE[DESTINATION] DO BEGIN (*$R-*) IF NEWLINK < LINKESCAPE THEN WA^[OFFSET]:=NEWLINK ELSE BEGIN WA^[OFFSET]:=(NEWLINK DIV LINKESCAPE)+(LINKESCAPE-1); WA^[OFFSET+1]:=(NEWLINK MOD LINKESCAPE); END; (*$R+*) END; END (*SAVEBIGLINK*); FUNCTION LINKDELTA(DESTINATION:DBWRKINDEX; DELTA:INTEGER; OFFSET:PAGEPTR):DBERRTYPE; (*add delta to the link at offset*) VAR B1,OLDLINK,NEWLINK:INTEGER; CHOP: PACKED RECORD CASE BOOLEAN OF TRUE: (INT:INTEGER); FALSE: (LB:BYTE; HB:BYTE) END; BEGIN LINKDELTA:=0; TRACEWA(4,DESTINATION); WITH WRKTABLE[DESTINATION] DO BEGIN OLDLINK:=LINKVALUE(WA,OFFSET); IF ((OFFSET+OLDLINK+DELTA) >= WSIZE) OR ((OLDLINK+DELTA) < 0) THEN LINKDELTA:=16 (*out of range*) ELSE BEGIN NEWLINK:=OLDLINK+DELTA; IF NEWLINK > 4079 (* (256-LINKESCAPE)*256+(LINKESCAPE-1) *) THEN LINKDELTA:=18 (* too large to be expressed as a link *) ELSE IF OLDLINK < LINKESCAPE THEN (* one byte *) BEGIN IF NEWLINK < LINKESCAPE THEN (*also one byte*) (*$R-*) WA^[OFFSET]:=NEWLINK ELSE BEGIN NEWLINK:=NEWLINK+1; (* one more byte for 2-byte link *) DBSHOWERR('LINKDELTA#1', MOVETAIL(DESTINATION,1,OFFSET)); SAVEBIGLINK(DESTINATION,NEWLINK,OFFSET); END; END (*OLDLINK < LINKESCAPE*) ELSE BEGIN (*OLDLINK >= LINKESCAPE i.e. 2 bytes*) IF (NEWLINK < LINKESCAPE) THEN BEGIN IF NEWLINK > 1 THEN NEWLINK:=NEWLINK-1; (*newlink 1-byte, oldlink was 2*) (*however, cannot go < 1*) DBSHOWERR('LINKDELTA#2', MOVETAIL(DESTINATION,-1, OFFSET + 1(*avoid tromping on previous data*))); WA^[OFFSET]:=NEWLINK; (*$R+*) END ELSE (*both old and new are 2 bytes*) SAVEBIGLINK(DESTINATION,NEWLINK,OFFSET); END (*OLDLINK >= LINKESCAPE*); END (* (OFFSET+DELTA) < WSIZE *); END (*WITH WRKTABLE*); TRACEWA(5,DESTINATION); END (*LINKDELTA*); PROCEDURE FIXLINKS(DESTINATION:DBWRKINDEX; STACKCELL:TOSRANGE; DELTA:INTEGER); (*following a change in item contents, all enclosing levels must have links corrected*) VAR ISTACK:INTEGER; BEGIN WITH WRKTABLE[DESTINATION] DO FOR ISTACK:=STACKCELL DOWNTO 0 DO WITH WIB^[ISTACK] DO DBSHOWERR('FIXLINKS', LINKDELTA(DESTINATION,DELTA,OFFSET)); TRACEWA(16,DESTINATION); END (*FIXLINKS*); FUNCTION LINKSIZE(LINKV:INTEGER):INTEGER; BEGIN IF LINKV >= LINKESCAPE THEN LINKSIZE:=2 ELSE LINKSIZE:=1; END (*LINKSIZE*); PROCEDURE STEPLINK(WI:DBWRKINDEX); (*advance offset at current level to step over a link-like item (either link or tag*) BEGIN WITH WRKTABLE[WI] DO WITH WIB^[TOS] DO OFFSET:=OFFSET+1+ORD(LINKVALUE(WA,OFFSET) >= LINKESCAPE); END (*STEPLINK*); PROCEDURE NEXTLINK(WA:WAPTR; VAR OFFSET:PAGEPTR; VAR ITEMNUM:INTEGER); (*advance offset to next location on list*) VAR LINKV:INTEGER; BEGIN LINKV:=LINKVALUE(WA,OFFSET); (*combine this guy and linkvalue call into one external proc*) IF LINKV > 0 THEN BEGIN OFFSET:=OFFSET+LINKV; ITEMNUM:=ITEMNUM+1; END; END (*NEXTLINK*); PROCEDURE SETDESCRIPTORNUM(WI:DBWRKINDEX); (*gets descriptor number for field # ITEMNUM from list in record descriptor*) (* group descriptor from enclosing field or tag*) (* record descriptor from group*) VAR RP:RECDESPTR; GP:GRPDESPTR; FP:FLDDESPTR; LINKV:INTEGER; BEGIN WITH WRKTABLE[WI] DO CASE WIB^[TOS].LEVEL OF FIELDT: BEGIN (*refer to record's list of descriptor pointers*) RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM]; WITH RP^ DO IF (((LASTFLDLINK-1) DIV SIZEOF(FLDREF))-2) < WIB^[TOS].ITEMNUM THEN (*Note: one item only (i.e. itemnum=0) goes with LASTFLDLINK = 5 if FLDREF is 2 bytes; end of list is one FLDREF entry with value of zero as stopper*) WIB^[TOS].DESCRIPTORNUM:=-1 (*no such field*) ELSE (*$R-*) WITH WIB^[TOS] DO DESCRIPTORNUM:=RP^.FLDREF[ITEMNUM].FDNUM; (*$R-*) END; GROUPT: (*all groups are tagged*) (*descriptor number is tag value at page level*) IF TOS=0 THEN WITH WIB^[TOS] DO BEGIN LINKV:=LINKVALUE(WA,OFFSET); DESCRIPTORNUM:=LINKVALUE(WA,(OFFSET+LINKSIZE(LINKV))); END ELSE BEGIN (*get from parent field descriptor*) FP:=ACTIVEFIELDS[WIB^[TOS-1].DESCRIPTORNUM]; WITH WIB^[TOS] DO DESCRIPTORNUM:=FP^.FLDREF; END; RECORDT: BEGIN (*record is tagged if group specifies mixed records*) GP:=ACTIVEGROUPS[WIB^[TOS-1].DESCRIPTORNUM]; WITH WIB^[TOS] DO WITH GP^ DO IF RECLINK > ONEITEMRECLINK THEN (*mixed*) BEGIN LINKV:=LINKVALUE(WA,OFFSET); (*get the tag*) DESCRIPTORNUM:=LINKVALUE(WA,OFFSET+LINKSIZE(LINKV)); END ELSE DESCRIPTORNUM:=RECNUM[0]; END (*RECORDT:*); END (*CASES*); END (*SETDESCRIPTORNUM*); (*TRAVERSAL PRIMITIVES*) FUNCTION DBHOME(*WI:DBWRKINDEX):DBERRTYPE*); (*zero out workstack for the workarea, except for its initial location*) VAR I:INTEGER; BEGIN WITH WRKTABLE[WI] DO BEGIN IF WA=NIL THEN DBHOME:=8 (* workarea not open *) ELSE BEGIN FOR I:=1 TO TOS DO WITH WIB^[I] DO BEGIN OFFSET:=0; LEVEL:=NONET; DESCRIPTORNUM:=-1; ITEMNUM:=-1; END; WITH WIB^[0] DO BEGIN OFFSET:=0; ITEMNUM:=0; IF DBTYPECHECK THEN SETDESCRIPTORNUM(WI); END; TOS:=0; END (* WA <> NIL *); END (*WITH WRKTABLE*); TRACEWA(6,WI); END (*DBHOME*); FUNCTION DBNEXT(*WI:DBWRKINDEX):DBERRTYPE*); (*move to head of next linked item*) VAR RP:RECDESPTR; BEFOREITEM,DUMMY:INTEGER; BEGIN DBNEXT:=0; TRACEWA(7,WI); WITH WRKTABLE[WI] DO WITH WIB^[TOS] DO BEGIN BEFOREITEM:=ITEMNUM; IF LEVEL = FIELDT THEN BEGIN RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM]; IF RP = NIL THEN DBNEXT:=32 ELSE WITH RP^ DO BEGIN IF ITEMNUM < FIRSTLITEMNUM THEN BEGIN ITEMNUM:=ITEMNUM+1; IF ITEMNUM = FIRSTLITEMNUM THEN (*transition from fixed to variable fields*) NEXTLINK(WA,OFFSET,DUMMY); END ELSE NEXTLINK(WA,OFFSET,ITEMNUM); END (*WITH RP^*); END (*LEVEL=FIELDT*) ELSE (*all items assumed to be linked & all lists stopped with nul*) NEXTLINK(WA,OFFSET,ITEMNUM); IF BEFOREITEM = ITEMNUM THEN DBNEXT:=27 (*can't find any more*) ELSE IF DBTYPECHECK THEN SETDESCRIPTORNUM(WI); END; TRACEWA(8,WI); END (*DBNEXT*); FUNCTION DBHEAD(*WI:DBWRKINDEX):DBERRTYPE*); (*move to head of list at current level*) VAR LINKV:INTEGER; RP:RECDESPTR; PARENTOFFSET:PAGEPTR; BEGIN WITH WRKTABLE[WI] DO BEGIN IF TOS > 0 THEN BEGIN PARENTOFFSET:=WIB^[TOS-1].OFFSET; LINKV:=LINKVALUE(WA,PARENTOFFSET); WITH WIB^[TOS] DO BEGIN OFFSET:=PARENTOFFSET+LINKSIZE(LINKV); IF LEVEL = RECORDT THEN (*step over parent group's tag*) STEPLINK(WI); END; END ELSE (*global group level - point to head of page*) WIB^[TOS].OFFSET:=0; WIB^[TOS].ITEMNUM:=0; IF DBTYPECHECK THEN SETDESCRIPTORNUM(WI); END (*WITH WRKTABLE*); TRACEWA(30,WI); END (*DBHEAD*); FUNCTION DBTAIL(*WI:DBWRKINDEX):DBERRTYPE*); (*point to link position following last non-nul item at current level*) VAR RP:RECDESPTR; BEFOREITEMNUM:INTEGER; BEGIN WITH WRKTABLE[WI] DO WITH WIB^[TOS] DO BEGIN BEFOREITEMNUM:=ITEMNUM; REPEAT NEXTLINK(WA,OFFSET,ITEMNUM); UNTIL LINKVALUE(WA,OFFSET)=0; IF LEVEL = FIELDT THEN BEGIN RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM]; IF RP = NIL THEN DBTAIL:=32 ELSE WITH RP^ DO IF BEFOREITEMNUM < FIRSTLITEMNUM THEN ITEMNUM:=ITEMNUM + (FIRSTLITEMNUM-BEFOREITEMNUM-1); END (*LEVEL=FIELDT*); SETDESCRIPTORNUM(WI); END (*WITH WIB*); TRACEWA(29,WI); END (*DBTAIL*); ======================================================================================== DOCUMENT :usus Folder:VOL04:dbunit.3.text ======================================================================================== FUNCTION DBSEEK(*WI:DBWRKINDEX; WHICHITEM:INTEGER):DBERRTYPE*); (*move pointer to item # itemnum in current level*) VAR NEWOFFSET,I,LINKV:INTEGER; CRACKSW:CRACKSWTYPE; RP:RECDESPTR; PROCEDURE FOLLOWLINKS(NEWOFFSET:PAGEPTR; COUNT:INTEGER); VAR I:INTEGER; BEGIN (*all items assumed to be linked & all lists stopped with nul*) WITH WRKTABLE[WI] DO WITH WIB^[TOS] DO BEGIN LINKV:=LINKVALUE(WA,NEWOFFSET); (*following should be in external procedure for speed*) I:=0; WHILE (LINKV > 0 ) AND (I < COUNT) DO BEGIN NEWOFFSET:=NEWOFFSET+LINKV; LINKV:=LINKVALUE(WA,NEWOFFSET); I:=I+1; END; (*end of external proc*) IF (LINKV = 0) AND (I < COUNT) THEN DBSEEK:=27 (*cannot find requested item*) ELSE BEGIN OFFSET:=NEWOFFSET; ITEMNUM:=ITEMNUM+COUNT; END; END (*WITH WIB*); END (*FOLLOWLINKS*); BEGIN (*DBSEEK*) DBSEEK:=0; TRACEWA(9,WI); WITH WRKTABLE[WI] DO WITH WIB^[TOS] DO BEGIN DBSHOWERR('SEEK#1',DBHEAD(WI)); IF DBTYPECHECK THEN BEGIN (*assume that we are at head of this level!*) CASE LEVEL OF GROUPT,RECORDT: BEGIN (*all groups and records are linked*) IF WHICHITEM > 0 THEN BEGIN (*item #0 in a record may contain several fixed fields*) FOLLOWLINKS(OFFSET,WHICHITEM); SETDESCRIPTORNUM(WI); END; END (*GROUPT*); FIELDT: BEGIN IF WHICHITEM > 0 THEN BEGIN (*now get offset of field within the record*) RP:=ACTIVERECORDS[WIB^[TOS-1].DESCRIPTORNUM]; IF RP = NIL THEN DBSEEK:=32 ELSE WITH RP^ DO BEGIN IF WHICHITEM < FIRSTLITEMNUM THEN ITEMNUM:=WHICHITEM ELSE BEGIN (*linked field*) ITEMNUM:=FIRSTLITEMNUM-1; FOLLOWLINKS(OFFSET,(WHICHITEM - FIRSTLITEMNUM + ORD(FIRSTLITEMNUM > 0))); END (*linked field*); END (*WITH RP^*); SETDESCRIPTORNUM(WI); END; END (*FIELDT*) END (*CASE*); END (*IF DBTYPECHECK*) ELSE FOLLOWLINKS(OFFSET,WHICHITEM); END (*WITH*); TRACEWA(10,WI); END (*DBSEEK*); FUNCTION DBDESCEND(*WI:DBWRKINDEX):DBERRTYPE*); VAR LINKV:PAGEPTR; OLDLVL:DBLEVELTYPE; LINKED:BOOLEAN; GP:GRPDESPTR; RP:RECDESPTR; FP:FLDDESPTR; CRACKSW:CRACKSWTYPE; PROCEDURE DOWNLINK; (*move down to head of enclosed level*) VAR PARENTOFFSET:PAGEPTR; BEGIN WITH WRKTABLE[WI] DO BEGIN WITH WIB^[TOS] DO BEGIN LINKV:=LINKVALUE(WA,OFFSET); PARENTOFFSET:=OFFSET; END; IF LINKV = 0 THEN DBDESCEND:=19 (*at end of list, can't descend*) ELSE BEGIN OLDLVL:=WIB^[TOS].LEVEL; IF OLDLVL=NONET THEN DBDESCEND:=20 (*can't continue from nonet*) ELSE BEGIN TOS:=TOS+1; WITH WIB^[TOS] DO BEGIN OFFSET:=PARENTOFFSET+LINKSIZE(LINKV); IF OLDLVL = GROUPT THEN (*step over group's tag*) STEPLINK(WI); LEVEL:=NEXTLEVEL(OLDLVL); ITEMNUM:=0; END (*WITH*); END (*LEVEL<>NONET*); END (*LINKV<>0*); END (*WITH WRKTABLE*); END (*DOWNLINK*); BEGIN (*DBDESCEND*) DBDESCEND:=0; TRACEWA(11,WI); IF DBTYPECHECK THEN WITH WRKTABLE[WI] DO BEGIN CASE WIB^[TOS].LEVEL OF GROUPT: BEGIN (*point to first record in group*) GP:=ACTIVEGROUPS[WIB^[TOS].DESCRIPTORNUM]; IF GP=NIL THEN DBDESCEND:=33 ELSE BEGIN DOWNLINK; SETDESCRIPTORNUM(WI); END; END (*GROUPT*); RECORDT: BEGIN (*point to first field in record*) RP:=ACTIVERECORDS[WIB^[TOS].DESCRIPTORNUM]; IF RP=NIL THEN DBDESCEND:=32 ELSE BEGIN DOWNLINK; SETDESCRIPTORNUM(WI); END (*RP<>NIL*); END (*RECORDT*); FIELDT: BEGIN (*if the field is structured, point to the contained group*) FP:=ACTIVEFIELDS[WIB^[TOS].DESCRIPTORNUM]; IF FP=NIL THEN DBDESCEND:=31 ELSE WITH FP^ DO IF FLDTYPE <> GROUPF THEN DBDESCEND:=34 (*can't descend into a simple field*) ELSE BEGIN DOWNLINK; SETDESCRIPTORNUM(WI); END; END (*FIELDT*) END (*CASES*); END (*WITH WRKTABLE*) ELSE (*assume that next level, if any, is linked*) DOWNLINK; TRACEWA(12,WI); END (*DBDESCEND*); FUNCTION DBASCEND(*WI:DBWRKINDEX):DBERRTYPE*); (*return to enclosing level*) BEGIN WITH WRKTABLE[WI] DO BEGIN IF TOS > 0 THEN BEGIN WITH WIB^[TOS] DO BEGIN OFFSET:=0; LEVEL:=NONET; DESCRIPTORNUM:=-1; ITEMNUM:=-1; END; TOS:=TOS-1; END (*TOS> 0*); END (*WITH WRKTABLE*); TRACEWA(31,WI); END (*DBASCEND*); FUNCTION DBFINDREC(*WI:DBWRKINDEX; RULE:DBFINDRULE; FIELDNUM:INTEGER; KEY:STRING; VAR RECNUM:INTEGER; VAR FOUND:BOOLEAN):DBERRTYPE*); (*locate a record whose FIELDNUM field matches the KEY according to the comparison RULE (ascending,descending, or random equals) *) (*$G+*) LABEL 1; VAR FLINKNUM,FN,RN,RLINKV,FOFFSET,DUMMY:INTEGER; RP:RECDESPTR; DONE:BOOLEAN; S:STRING; BEGIN TRACEWA(27,WI); (*on entry we should be at RECORDT level, with ITEMNUM=0. First find out if field is variable and set FLINKNUM*) WITH WRKTABLE[WI] DO WITH WIB^[TOS] DO BEGIN IF LEVEL <> RECORDT THEN DBFINDREC:=39 (*must be at record level*) ELSE BEGIN IF ITEMNUM <> 0 THEN DUMMY:=DBHEAD(WI); RP:=ACTIVERECORDS[DESCRIPTORNUM]; IF RP = NIL THEN DBFINDREC:=32 ELSE WITH RP^ DO BEGIN IF (SWITCHES <> 0) OR (FIELDNUM < FIRSTLITEMNUM) THEN DBFINDREC:=40 (*must be untagged record and untagged string field*) ELSE BEGIN FLINKNUM:=FIELDNUM - FIRSTLITEMNUM + ORD(FIRSTLITEMNUM > 0); DONE:=FALSE; FOUND:=FALSE; RN:=0; RLINKV:=LINKVALUE(WA,OFFSET); (*speed-up possibilities: native code; assume all links are single bytes & eliminate proc calls to linksize & linkvalue*) WHILE RLINKV <> 0 DO BEGIN FN:=0; FOFFSET:=OFFSET + LINKSIZE(RLINKV); (*all in-field links assumed 1 byte ! *) (*move to field pointer now*) (*$R-*) WHILE (FN < FLINKNUM) DO BEGIN FOFFSET:=FOFFSET+WA^[FOFFSET]; FN:=FN+1; END; MOVELEFT(WA^[FOFFSET],S,WA^[FOFFSET]); (*$R+*) DELETE(S,LENGTH(S),1); (*correct link to length*) CASE RULE OF ASCENDING: DONE:= (KEY <= S); DESCENDING:DONE:= (KEY >= S); RANDOM: DONE:= (KEY = S) END (*CASES*); IF DONE THEN BEGIN FOUND:= (KEY = S); GOTO 1; (*for efficiency*) END ELSE BEGIN (*jump to next record*) OFFSET:=OFFSET+RLINKV; RLINKV:=LINKVALUE(WA,OFFSET); RN:=RN+1; END (*NOT DONE*); END (*WHILE RLINKV*); 1: RECNUM:=RN; ITEMNUM:=RN; END (*untagged ok*); END (*WITH RP^*); END (*LEVEL = RECORDT*); END (*WITH WIB^*); TRACEWA(28,WI); END (*DBFINDREC*); (*DATA TRANSFER PRIMITIVES*) FUNCTION DBCOPY(*SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE*); (*zero out the destination workarea. copy source record or group into destination. initialize pointers. *) VAR SLEVEL:DBLEVELTYPE; SINUSE,SDNUM,SOFFSET,SLINKV,STOS:INTEGER; BEGIN TRACEWA(24,SOURCE); TRACEWA(25,DESTINATION); ZEROWORKAREA(DESTINATION); WITH WRKTABLE[SOURCE] DO WITH WIB^[TOS] DO BEGIN SINUSE:=SPACEINUSE; SLEVEL:=LEVEL; SOFFSET:=OFFSET; SLINKV:=LINKVALUE(WA,OFFSET); STOS:=TOS; SDNUM:=DESCRIPTORNUM; END; IF (SLEVEL <> GROUPT) OR (STOS <> 0) THEN DBCOPY:=12 (*can''t yet handle anything but outer level group*) ELSE WITH WRKTABLE[DESTINATION] DO WITH WIB^[TOS] DO IF SLINKV > WSIZE THEN DBCOPY:=1 (*insufficient space*) ELSE BEGIN SPACEINUSE:=SINUSE; LEVEL:=GROUPT; OFFSET:=0; DESCRIPTORNUM:=SDNUM; ITEMNUM:=0; (*$R-*) MOVELEFT(WRKTABLE[SOURCE].WA^[SOFFSET], WA^[OFFSET], SLINKV); (*$R+*) END; TRACEWA(26,DESTINATION); END (*DBCOPY*); FUNCTION DBEMPTYITEM(*DESTINATION:DBWRKINDEX; LVL:DBLEVELTYPE; TAG:INTEGER):DBERRTYPE*); (*creates a new empty item at level LVL and sets its tag if required*) VAR NEWOFFSET,LINKV:PAGEPTR; TAGBYTES,ISTACK:INTEGER; PROCEDURE NEWLINKITEM(WIDTH:INTEGER; NEWOFFSET:PAGEPTR); (*insert an empty linked item WIDTH bytes wide*) VAR I:INTEGER; BEGIN IF TAG >= LINKESCAPE THEN WIDTH:=WIDTH+1; WITH WRKTABLE[DESTINATION] DO BEGIN DBSHOWERR('NEWLINKITEM', MOVETAIL(DESTINATION,WIDTH,NEWOFFSET)); (*$R-*) WA^[NEWOFFSET]:=WIDTH; IF LVL = GROUPT THEN SAVEBIGLINK(DESTINATION,TAG,NEWOFFSET+1); (*$R+*) IF LVL = WIB^[TOS].LEVEL THEN BEGIN IF TOS > 0 THEN FIXLINKS(DESTINATION, (TOS-1), WIDTH); END ELSE FIXLINKS(DESTINATION, TOS, WIDTH); END (*WITH*); END (*NEWLINKITEM*); PROCEDURE BLANKRECORD; (*lay out empty fields in a blank record*) VAR RP:RECDESPTR; FP:FLDDESPTR; FN,MAXFN,FIXWIDTH,VARWIDTH:INTEGER; SW:CRACKSWTYPE; FIRSTLINKOFFSET:PAGEPTR; BEGIN WITH WRKTABLE[DESTINATION] DO WITH WIB^[TOS] DO BEGIN RP:=ACTIVERECORDS[DESCRIPTORNUM]; WITH RP^ DO BEGIN FN:=0; SW.BL:=SWITCHES; FIRSTLINKOFFSET:=OFFSET+1; IF SW.A[0] THEN (*tagged*) FIXWIDTH:=1 ELSE FIXWIDTH:=0; MAXFN:=LASTFLDLINK DIV 2 - 1; (*fixed fields first*) WHILE (FN < FIRSTLITEMNUM) AND (FN < MAXFN) DO BEGIN (*$R-*) WITH FLDREF[FN] DO (*$R+*) BEGIN FP:=ACTIVEFIELDS[FDNUM]; FIXWIDTH:=FIXWIDTH+FP^.MAXWIDTH; END; FN:=FN+1; END (*WHILE*); IF FN > 0 THEN BEGIN (*one link over all fixed fields*) FIXWIDTH:=FIXWIDTH+1; NEWLINKITEM(FIXWIDTH, FIRSTLINKOFFSET); END; (*if there are fixed fields, FIXWIDTH now includes the link*) NEWOFFSET:=FIRSTLINKOFFSET+FIXWIDTH; (*now put links of 1 for each variable size field*) VARWIDTH:=MAXFN-FN+1; DBEMPTYITEM:=MOVETAIL(DESTINATION, VARWIDTH, NEWOFFSET); WHILE FN < MAXFN DO BEGIN (*$R-*) WA^[NEWOFFSET]:=1; (*$R+*) NEWOFFSET:=NEWOFFSET+1; FN:=FN+1; END; END (*WITH RP^*); (*still have to set overlink of record itself*) IF (VARWIDTH+FIXWIDTH) >= LINKESCAPE THEN BEGIN VARWIDTH:=VARWIDTH+1; DBEMPTYITEM:=MOVETAIL(DESTINATION,1,OFFSET); END; SAVEBIGLINK(DESTINATION, (VARWIDTH+FIXWIDTH+1(*original link assumed small*)), OFFSET); (* and also the enclosing links*) FIXLINKS(DESTINATION, (TOS-1), VARWIDTH); END (*WITH WIB^[TOS]*); END (*BLANKRECORD*); BEGIN (*DBEMPTYITEM*) DBEMPTYITEM:=0; WITH WRKTABLE[DESTINATION] DO BEGIN TRACEWA(0,DESTINATION); WITH WIB^[TOS] DO IF LVL=LEVEL THEN CASE LEVEL OF NONET: DBEMPTYITEM:=13; (*undefined level*) RECORDT: (*insert a single byte link with value of 2, with nul stopper*) BEGIN NEWLINKITEM(1,OFFSET); IF DBTYPECHECK THEN BLANKRECORD; END; GROUPT: BEGIN NEWLINKITEM(3,OFFSET); (*leave byte for required tag*) DESCRIPTORNUM:=TAG; END; FIELDT:NEWLINKITEM(2,OFFSET) END (*CASE LEVEL*) ELSE BEGIN (*LVL<>LEVEL*) IF LVL<>NEXTLEVEL(LEVEL) THEN DBEMPTYITEM:=15 (*improper data level*) ELSE (*new embedded level, probably have to update earlier link*) BEGIN (*create blank linked item, descend to it, make blank record if needed*) IF LVL = GROUPT THEN TAGBYTES:=2 ELSE TAGBYTES:=0; NEWOFFSET:=OFFSET+1+ORD(LINKVALUE(WA,OFFSET) >= LINKESCAPE); IF LEVEL = GROUPT THEN (*step over the tag*) NEWOFFSET:=NEWOFFSET+1 +ORD(LINKVALUE(WA,NEWOFFSET) >= LINKESCAPE); NEWLINKITEM(1+TAGBYTES,NEWOFFSET); DBEMPTYITEM:=DBDESCEND(DESTINATION); IF DBTYPECHECK AND (LVL = RECORDT) THEN BLANKRECORD; END (*LVL = NEXTLEVEL*); END (*LVL<>LEVEL*); END (*WITH WRKTABLE*); TRACEWA(1,DESTINATION); END (*DBEMPTYITEM*); FUNCTION DBDELETE(*DESTINATION:DBWRKINDEX):DBERRTYPE*); (*eliminate the destination item (group or record only) entirely*) VAR LINKV:INTEGER; BEGIN TRACEWA(17,DESTINATION); DBDELETE:=0; WITH WRKTABLE[DESTINATION] DO WITH WIB^[TOS] DO BEGIN IF NOT (LEVEL IN [GROUPT,RECORDT]) THEN DBDELETE:=41 ELSE BEGIN LINKV:=LINKVALUE(WA,OFFSET); IF LINKV <> 0 THEN DBDELETE:=MOVETAIL(DESTINATION, -LINKV, OFFSET+LINKV); IF TOS > 0 THEN FIXLINKS(DESTINATION, TOS-1, -LINKV); END (*LEVEL OK*); END (*WITH WIB^*); TRACEWA(18,DESTINATION); END (*DBDELETE*); FUNCTION DBBLANK(*DESTINATION:DBWRKINDEX):DBERRTYPE*); (*replace the destination group or record with an empty item*) VAR RSLT,DELTA:INTEGER; BEGIN TRACEWA(19,DESTINATION); RSLT:=DBDELETE(DESTINATION); IF RSLT <> 0 THEN DBBLANK:=RSLT ELSE WITH WRKTABLE[DESTINATION] DO WITH WIB^[TOS] DO BEGIN IF LEVEL = GROUPT THEN DELTA:=3 ELSE DELTA:=2; RSLT:=MOVETAIL(DESTINATION, DELTA, OFFSET); IF RSLT <> 0 THEN DBBLANK:=RSLT ELSE BEGIN WA^[OFFSET]:=DELTA; IF TOS > 0 THEN FIXLINKS(DESTINATION, TOS-1, DELTA); END; DESCRIPTORNUM:=-1; END (*WITH WIB^*); TRACEWA(20,DESTINATION); END (*DBBLANK*); FUNCTION DBREPLACE(*SOURCE,DESTINATION:DBWRKINDEX):DBERRTYPE*); (*the source item replaces the destination item. must be record or group*) VAR SLINKV,SOFFSET,STOS,DOFFSET,DTOS,RSLT:INTEGER; SLEVEL,DLEVEL:DBLEVELTYPE; BEGIN TRACEWA(21,SOURCE); TRACEWA(22,DESTINATION); RSLT:=DBDELETE(DESTINATION); IF RSLT <> 0 THEN DBREPLACE:=RSLT ELSE BEGIN WITH WRKTABLE[SOURCE] DO WITH WIB^[TOS] DO BEGIN SLEVEL:=LEVEL; SOFFSET:=OFFSET; SLINKV:=LINKVALUE(WA,OFFSET); STOS:=TOS; END; WITH WRKTABLE[DESTINATION] DO WITH WIB^[TOS] DO BEGIN DLEVEL:=LEVEL; DOFFSET:=OFFSET; DTOS:=TOS; END; IF DLEVEL <> SLEVEL THEN DBREPLACE:=42 (*mismatch*) ELSE IF NOT (DLEVEL IN [GROUPT,RECORDT]) THEN DBREPLACE:=41 ELSE BEGIN (*open space up to receive source copy*) RSLT:=MOVETAIL(DESTINATION,SLINKV,DOFFSET); IF RSLT <> 0 THEN DBREPLACE:=RSLT ELSE (*$R-*) BEGIN MOVELEFT(WRKTABLE[SOURCE].WA^[SOFFSET], WRKTABLE[DESTINATION].WA^[DOFFSET], SLINKV); (*$R+*) IF DTOS > 0 THEN FIXLINKS(DESTINATION, DTOS-1, SLINKV); END; WRKTABLE[DESTINATION].WIB^[DTOS].DESCRIPTORNUM := WRKTABLE[SOURCE].WIB^[STOS].DESCRIPTORNUM; END (*levels ok*); END (*DELETE worked ok*); TRACEWA(23,DESTINATION); END (*DBREPLACE*); FUNCTION DBRESERVE(*DESTINATION:DBWRKINDEX):DBERRTYPE*); (*reserve empty space at the end of destination group*) BEGIN TRACEWA(32,DESTINATION); TRACEWA(33,DESTINATION); END (*DBRESERVE*); FUNCTION GETFOFFSET(WI:DBWRKINDEX):PAGEPTR; (*returns the offset (in record) of a fixed width field based on its ITEMNUM*) VAR RP:RECDESPTR; DN:INTEGER; BEGIN WITH WRKTABLE[WI] DO BEGIN DN:=WIB^[TOS-1].DESCRIPTORNUM; IF (DN >= 0) AND (DN <= LASTRECDESCRIPTOR) THEN BEGIN RP:=ACTIVERECORDS[DN]; IF RP = NIL THEN DBSHOWERR('GETOFFSET - Record not active', 100) ELSE (*$R-*) GETFOFFSET:=RP^.FLDREF[WIB^[TOS].ITEMNUM].FLDOFFSET; (*$R+*) END ELSE DBSHOWERR('GETOFFSET - DESCRIPTORNUM not initialized',100); END; END (*GETFOFFSET*); FUNCTION DBGET(*SOURCE:DBWRKINDEX):DBERRTYPE*); (*extract item value from workarea and place it in DBMAIL for pickup by caller*) CONST FIXEDWIDTH = 1; VAR LINKV: INTEGER; FP:FLDDESPTR; RP:RECDESPTR; SW:CRACKSWTYPE; FOFFSET:INTEGER; PROCEDURE GETLINKF(FLDTYPE:DBFIELDTYPES); BEGIN WITH WRKTABLE[SOURCE] DO WITH WIB^[TOS] DO BEGIN LINKV:=LINKVALUE(WA,OFFSET); IF LINKV >= LINKESCAPE THEN DBGET:=21 (*string too long to assign*) ELSE BEGIN (*$R-*) MOVELEFT(WA^[OFFSET],DBMAIL.TXT,LINKV); (*$R+*) DBMAIL.TXT[0]:=CHR(LINKV-1); DBMAIL.DBMAILTYPE:=FLDTYPE; END (*LINKV < LINKESCAPE*); END (*WITH WIB*); END (*GETLINKF*); BEGIN (*DBGET*) DBGET:=0; TRACEWA(13,SOURCE); IF DBTYPECHECK THEN WITH WRKTABLE[SOURCE] DO WITH WIB^[TOS] DO BEGIN IF LEVEL = GROUPT THEN GETLINKF(GROUPF) ELSE IF LEVEL <> FIELDT THEN DBGET:=38 (*must be a field*) ELSE IF (DESCRIPTORNUM >= 0) AND (DESCRIPTORNUM <= LASTFIELDDESCRIPTOR) THEN BEGIN FP:=ACTIVEFIELDS[DESCRIPTORNUM]; IF FP = NIL THEN DBGET:=31 (*no such field exists*) ELSE WITH FP^ DO BEGIN SW.BL:=SWITCHES; IF SW.A[FIXEDWIDTH] THEN WITH DBMAIL DO BEGIN (*$R-*) MOVELEFT(WA^[OFFSET +GETFOFFSET(SOURCE)], TXT, MAXWIDTH); (*$R+*) DBMAILTYPE:=FLDTYPE; END ELSE GETLINKF(FLDTYPE); END (*WITH FP^*); END (*DESCRIPTORNUM OK*) ELSE DBGET:=31; (*no such field exists*) END (*WITH WIB^[TOS]*) ELSE (*no type checking - assume it's linked*) GETLINKF(STRINGF); END (*DBGET*); ======================================================================================== DOCUMENT :usus Folder:VOL04:dbunit.4.text ======================================================================================== FUNCTION DBPUT(*DESTINATION:DBWRKINDEX):DBERRTYPE*); (*replace current item in workarea with the contents of DBMAIL*) VAR DELTA,OLDLINKV,NEWLINKV,ISTACK:INTEGER; FP:FLDDESPTR; PROCEDURE PUTLINKF; (*replace current linked item with the item in DBMAIL*) BEGIN WITH WRKTABLE[DESTINATION] DO BEGIN (*replace the linked item*) WITH WIB^[TOS] DO BEGIN OLDLINKV:=LINKVALUE(WA,OFFSET); NEWLINKV:=ORD(DBMAIL.TXT[0]); IF DBMAIL.DBMAILTYPE = STRINGF THEN NEWLINKV:=NEWLINKV+1; (*link is 1 greater than string length*) DELTA:=NEWLINKV-OLDLINKV; IF DELTA > 0 THEN DBSHOWERR('DBPUT#1',MOVETAIL(DESTINATION,DELTA,OFFSET)) ELSE DBSHOWERR('DBPUT#2',MOVETAIL(DESTINATION,DELTA,OFFSET-DELTA)); (*$R-*) MOVELEFT(DBMAIL.TXT,WA^[OFFSET],NEWLINKV); WA^[OFFSET]:=NEWLINKV; (*$R+*) END (*WITH WIB*); (*now correct enclosing links also*) IF TOS > 0 THEN FIXLINKS(DESTINATION,(TOS-1),DELTA); END (*WITH WRKTABLE*); END (*PUTLINKF*); PROCEDURE PUTFIXEDF(FP:FLDDESPTR); (*replace a fixed width item in a record assumed already present*) CONST FIXEDWIDTH = 1; VAR SW:CRACKSWTYPE; FOFFSET:INTEGER; BEGIN WITH WRKTABLE[DESTINATION] DO WITH WIB^[TOS] DO WITH FP^ DO BEGIN SW.BL:=SWITCHES; IF NOT SW.A[FIXEDWIDTH] THEN DBPUT:=37 (*fixed width item expected*) ELSE (*$R-*) WITH DBMAIL DO MOVELEFT(TXT, WA^[OFFSET+GETFOFFSET(DESTINATION)], MAXWIDTH); (*$R+*) END (*WITH FP^*); END (*PUTFIXEDF*); BEGIN (*DBPUT*) DBPUT:=0; TRACEWA(14,DESTINATION); IF DBTYPECHECK THEN WITH WRKTABLE[DESTINATION] DO WITH WIB^[TOS] DO WITH DBMAIL DO BEGIN IF DBMAILTYPE = GROUPF THEN BEGIN IF LEVEL <> GROUPT THEN DBPUT:=36 ELSE PUTLINKF; END ELSE IF LEVEL <> FIELDT THEN DBPUT:=38 ELSE IF (DESCRIPTORNUM >= 0) AND (DESCRIPTORNUM <= LASTFIELDDESCRIPTOR) THEN BEGIN (*it's a simple field*) FP:=ACTIVEFIELDS[DESCRIPTORNUM]; IF FP = NIL THEN DBPUT:=31 (*no such field initialized*) ELSE WITH FP^ DO IF FLDTYPE <> DBMAILTYPE THEN DBPUT:=36 (*mismatch*) ELSE IF DBMAILTYPE IN [STRINGF,INTEGERF,LONGINTF] THEN CASE DBMAILTYPE OF STRINGF: PUTLINKF; LONGINTF,INTEGERF: PUTFIXEDF(FP) END (*CASES*) ELSE DBPUT:=12; (*not yet implemented*) END (*simple field*) ELSE DBPUT:=31 (*no such field exists*); END (*WITH DBMAIL*) ELSE (*item assumed to be linked string*) PUTLINKF; TRACEWA(15,DESTINATION); END (*DBPUT*); (*SUPPORT PRIMITIVES*) FUNCTION DBWRITEFIELD(*FID:TEXT; SOURCE:DBWRKINDEX):DBERRTYPE*); (*access to Pascal's WRITE referring to the item currently pointed to in the source workarea; output is to file FID*) VAR FP:FLDDESPTR; S:STRING[255]; IA:REFLIST; BEGIN DBWRITEFIELD:=0; WITH WRKTABLE[SOURCE] DO WITH WIB^[TOS] DO BEGIN IF LEVEL <> FIELDT THEN DBWRITEFIELD:=28 (*can't write out a whole group*) ELSE BEGIN FP:=ACTIVEFIELDS[DESCRIPTORNUM]; IF FP=NIL THEN DBWRITEFIELD:=29 ELSE WITH FP^ DO CASE FLDTYPE OF GROUPF: DBWRITEFIELD:=28; STRINGF: BEGIN (*$R-*) MOVELEFT(WA^[OFFSET],S,LINKVALUE(WA,OFFSET)); (*$R+*) DELETE(S,LENGTH(S),1); (*correct for link*) WRITE(FID,S); END; INTEGERF: BEGIN (*$R-*) MOVELEFT(WA^[OFFSET+GETFOFFSET(SOURCE)],IA[0],2); (*$R+*) WRITE(FID,IA[0]); END; BYTEF,LONGINTF,TEXTF: DBWRITEFIELD:=12; (*not implemented*) ADDRCOUPLEF,SETF: DBWRITEFIELD:=30 END (*CASE*); END (*LEVEL=FIELDT*); END (*WITH WIB*); END (*DBWRITEFIELD*); PROCEDURE DBGETDESCRIPTOR(*LEVEL:DBLEVELTYPE; DESCRIPTORNUM:INTEGER; VAR PTR:FLDDESPTR)*); (*used to pass descriptors to external programs. to avoid excessive interface symbol table, TRIX record is used to pass pointer as FLDDESPTR. external program is expected to declare its own records corresponding to RECORDT and GROUPT since they are not in the interface part*) TYPE TRIXPTR= RECORD CASE DBLEVELTYPE OF FIELDT: (F:FLDDESPTR); RECORDT:(R:RECDESPTR); GROUPT: (G:GRPDESPTR) END; VAR TP:TRIXPTR; BEGIN IF DESCRIPTORNUM < 0 THEN TP.F := NIL ELSE CASE LEVEL OF FIELDT: TP.F:=ACTIVEFIELDS[DESCRIPTORNUM]; RECORDT: TP.R:=ACTIVERECORDS[DESCRIPTORNUM]; GROUPT: TP.G:=ACTIVEGROUPS[DESCRIPTORNUM] END (*CASES*); PTR:=TP.F; END (*DBGETDESCRIPTOR*); FUNCTION DBTAG(*NAME:STRING; SOURCE:DBWRKINDEX; VAR ITEMNUM:INTEGER):DBERRTYPE*); (*search the current level for a descriptor corresponding to NAME*) BEGIN END (*DBTAG*); (**WORKAREA PRIMITIVES*) FUNCTION DBWRKOPEN(*WI:DBWRKINDEX; SIZE:INTEGER):DBERRTYPE*); CONST WADELTA=64; (*open a workarea for business*) VAR I:INTEGER; P:WAPTR; BEGIN DBWRKOPEN:=0; WITH WRKTABLE[WI] DO IF (SIZE <= 0) OR (SIZE > (PAGELASTBYTE+1)) THEN DBWRKOPEN:=2 (*size out of range*) ELSE IF (WA <> NIL) OR (WIB<>NIL) THEN DBWRKOPEN:=3 (*workarea already open*) ELSE IF NOT CHECKHEAP(SIZE+SIZEOF(WIBTYPE)) THEN DBWRKOPEN:=1 (*insufficient memory*) ELSE BEGIN (*should be safe - do it*) NEW(WIB); NEW(WA); (*allocates WADELTA bytes - minimum wa size*) IF SIZE > WADELTA THEN I:=HEAPALLOCATE(SIZE-WADELTA); (*already checked for error*) WSIZE:=MAX(WADELTA,SIZE); ZEROWORKAREA(WI); END; END (*DBWRKOPEN*); FUNCTION DBWRKCLOSE(*WI:DBWRKINDEX):DBERRTYPE*); BEGIN END (*DBWRKCLOSE*); (**FILE PRIMITIVES*) FUNCTION DBFOPEN(*FNUM:DBFILENUM; TITLE:STRING):DBERRTYPE*); BEGIN DBFOPEN:=0; (*$I-*) CASE FNUM OF 0: RESET(F0,TITLE); 1: RESET(F1,TITLE); 2: RESET(F2,TITLE); 3: RESET(F3,TITLE); 4: RESET(F4,TITLE) END (*CASE*); DBIORESULT:=IORESULT; IF DBIORESULT <> 0 THEN DBFOPEN:=23 (*unable to open file*) ELSE OPENFILES[FNUM]:=TRUE; (*$I+*) END (*DBFOPEN*); FUNCTION DBFCLOSE(*FNUM:DBFILENUM):DBERRTYPE*); BEGIN DBFCLOSE:=0; (*$I-*) CASE FNUM OF 0: CLOSE(F0); 1: CLOSE(F1); 2: CLOSE(F2); 3: CLOSE(F3); 4: CLOSE(F4) END (*CASE*); IF IORESULT <> 0 THEN DBFCLOSE:=26; (*unable to close file*) (*$I+*) END (*DBFCLOSE*); FUNCTION DBFCREATE(*FNUM:DBFILENUM; WASCRATCH:DBWRKINDEX; SPEXTITLE,NEWTITLE:STRING):DBERRTYPE*); (*open a new database file; lock it into directory; if there is a non-empty specification file fitle, copy the spex into the new file. uses wascratch to initialize the file. assumes wascratch will be associated with fnum file*) VAR RSLT:INTEGER; PROCEDURE BLANKZEROPAGE(VAR F:FILETYPE); VAR BLOCKCOUNT:INTEGER; BEGIN BLOCKCOUNT:=(PAGELASTBYTE+1) DIV 512; RSLT:=BLOCKWRITE(F,WRKTABLE[WASCRATCH].WA^,BLOCKCOUNT,0); DBFCREATE:=0; IF RSLT <> BLOCKCOUNT THEN DBFCREATE:=9 ELSE (*$I-*) BEGIN CLOSE(F,LOCK); IF IORESULT <> 0 THEN DBFCREATE:=10 (*unable to lock file*) ELSE BEGIN RESET(F,NEWTITLE); IF IORESULT <> 0 THEN DBFCREATE:=11 (*unable to re-open the file*) ELSE OPENFILES[FNUM]:=TRUE; END; END (*RSLT = BLOCKCOUNT*); END (*BLANKZEROPAGE*); BEGIN (*DBFCREATE*) RSLT:=CHECKWORKAREA(WASCRATCH,(PAGELASTBYTE+1)); IF RSLT<>0 THEN DBFCREATE:=RSLT (*pass on error from checkworkarea*) ELSE IF OPENFILES[FNUM] THEN DBFCREATE:=5 (*file already open and in use*) ELSE IF LENGTH(NEWTITLE) = 0 THEN DBFCREATE:=6 (*requires non-nul title string*) ELSE (*$I-*) BEGIN CASE FNUM OF 0: RESET(F0,NEWTITLE); 1: RESET(F1,NEWTITLE); 2: RESET(F2,NEWTITLE); 3: RESET(F3,NEWTITLE); 4: RESET(F4,NEWTITLE) END (*CASE*); RSLT:=IORESULT; (*$I+*) IF RSLT=0 THEN (*file already on disk*) DBFCREATE:=4 ELSE IF RSLT = 12 THEN (*file already open, but not caught above*) DBFCREATE:=99 (*system error*) ELSE BEGIN (*$I-*) CASE FNUM OF 0: REWRITE(F0,NEWTITLE); 1: REWRITE(F1,NEWTITLE); 2: REWRITE(F2,NEWTITLE); 3: REWRITE(F3,NEWTITLE); 4: REWRITE(F4,NEWTITLE) END (*CASE*); RSLT:=IORESULT; (*$I+*) IF RSLT <> 0 THEN DBFCREATE:=7 (*rewrite failure*) ELSE IF LENGTH(SPEXTITLE) = 0 THEN BEGIN (*ok to create the file now*) ZEROWORKAREA(WASCRATCH); CASE FNUM OF 0: BLANKZEROPAGE(F0); 1: BLANKZEROPAGE(F1); 2: BLANKZEROPAGE(F2); 3: BLANKZEROPAGE(F3); 4: BLANKZEROPAGE(F4) END (*CASE*); END (*LENGTH(SPEXTITLE) = 0*) ELSE DBFCREATE:=12; (*spexfile transfer not yet implemented*) END (*RSLT <> 12*); END (*LENGTH(NEWTITLE) <> 0*); END (*DBFCREATE*); FUNCTION DBFREMOVE(*FNUM:DBFILENUM):DBERRTYPE*); BEGIN DBFREMOVE:=0; (*$I-*) CASE FNUM OF 0: CLOSE(F0,PURGE); 1: CLOSE(F1,PURGE); 2: CLOSE(F2,PURGE); 3: CLOSE(F3,PURGE); 4: CLOSE(F4,PURGE) END (*CASE*); IF IORESULT <> 0 THEN DBFREMOVE:=22 ELSE OPENFILES[FNUM]:=FALSE; (*$I+*) END (*DBFREMOVE*); FUNCTION DBGETPAGE(*FNUM:DBFILENUM; DESTINATION:DBWRKINDEX; PAGENUM:INTEGER):DBERRTYPE*); VAR BLOCKSMOVED,BLOCKSINPAGE,LINKV,LX,DUMMY:INTEGER; PROCEDURE MOVEWA(VAR F:FILETYPE); BEGIN BLOCKSMOVED:=BLOCKREAD(F,WRKTABLE[DESTINATION].WA^, BLOCKSINPAGE, (PAGENUM*BLOCKSINPAGE)); END; BEGIN DBGETPAGE:=DBHOME(DESTINATION); BLOCKSINPAGE:=(PAGELASTBYTE+1) DIV 512; WITH WRKTABLE[DESTINATION] DO CASE FNUM OF 0: MOVEWA(F0); 1: MOVEWA(F1); 2: MOVEWA(F2); 3: MOVEWA(F3); 4: MOVEWA(F4) END (*CASE*); IF BLOCKSMOVED <> BLOCKSINPAGE THEN DBGETPAGE:=25 ELSE WITH WRKTABLE[DESTINATION] DO BEGIN (*get SPACEINUSE by following links to end*) LX:=0; LINKV:=LINKVALUE(WA,0); WHILE LINKV<>0 DO BEGIN LX:=LX+LINKV; LINKV:=LINKVALUE(WA,LX); END; SPACEINUSE:=LX+1; WITH WIB^[0] DO BEGIN LINKV:=LINKVALUE(WA,0); DESCRIPTORNUM:=LINKVALUE(WA,LINKSIZE(LINKV)); (*tag*) END; END (*WITH WRKTABLE*); END (*DBGETPAGE*); FUNCTION DBPUTPAGE(*FNUM:DBFILENUM; SOURCE:DBWRKINDEX; PAGENUM:INTEGER):DBERRTYPE*); VAR BLOCKSMOVED,BLOCKSINPAGE:INTEGER; PROCEDURE MOVEWA(VAR F:FILETYPE); BEGIN BLOCKSMOVED:=BLOCKWRITE(F,WRKTABLE[SOURCE].WA^, BLOCKSINPAGE, (PAGENUM*BLOCKSINPAGE)); END; BEGIN DBPUTPAGE:=0; BLOCKSINPAGE:=(PAGELASTBYTE+1) DIV 512; WITH WRKTABLE[SOURCE] DO CASE FNUM OF 0: MOVEWA(F0); 1: MOVEWA(F1); 2: MOVEWA(F2); 3: MOVEWA(F3); 4: MOVEWA(F4) END (*CASE*); IF BLOCKSMOVED <> BLOCKSINPAGE THEN DBPUTPAGE:=24; END (*DBPUTPAGE*); (**DESCRIPTOR INITIALIZING PRIMITIVES*) FUNCTION DBGROUPINIT(*FNUM:DBFILENUM; VAR GROUPNUM:INTEGER; GROUPNAME:STRING):DBERRTYPE*); (*load the descriptor lists from groups 1,2,3 of the database using workarea 0 as temporary store. note: these groups may extend over more than one page*) CONST WA0=0; (*work area #0*) VAR GN,LINKV,PAGENUM,DUMMY:INTEGER; PROCEDURE LOADDESCRIPTORS(LVL:DBLEVELTYPE); VAR GPTR:GRPDESPTR; RPTR:RECDESPTR; FPTR:FLDDESPTR; BEGIN WITH WRKTABLE[WA0] DO WITH WIB^[TOS] DO BEGIN GN:=0; LINKV:=LINKVALUE(WA,OFFSET); WHILE LINKV > 2 (*ignore empty dummy records*) DO BEGIN CASE LVL OF GROUPT: BEGIN NEW(GPTR); DBSHOWERR('GROUPINIT(G)', HEAPALLOCATE(LINKV-SIZEOF(GRPDESCRIPTOR))); (*$R-*) MOVELEFT(WA^[OFFSET],GPTR^,LINKV); (*$R+*) ACTIVEGROUPS[GN]:=GPTR; END (*GROUPT*); RECORDT: BEGIN NEW(RPTR); DBSHOWERR('GROUPINIT(R)', HEAPALLOCATE(LINKV-SIZEOF(RECDESCRIPTOR))); (*$R-*) MOVELEFT(WA^[OFFSET],RPTR^,LINKV); (*$R+*) ACTIVERECORDS[GN]:=RPTR; END (*RECORDT*); FIELDT: BEGIN NEW(FPTR); DBSHOWERR('GROUPINIT(F)', HEAPALLOCATE(LINKV-SIZEOF(FLDDESCRIPTOR))); (*$R-*) MOVELEFT(WA^[OFFSET],FPTR^,LINKV); (*$R+*) ACTIVEFIELDS[GN]:=FPTR; END (*FIELDT*) END (*CASE*); DUMMY:=DBNEXT(WA0); LINKV:=LINKVALUE(WA,OFFSET); IF LINKV <> 0 THEN GN:=GN+1; END (*WHILE*); END (*WITH*); END (*LOADDESCRIPTORS*); PROCEDURE NEWPAGE; BEGIN PAGENUM:=PAGENUM+1; DBSHOWERR('GROUPINIT#2',DBGETPAGE(FNUM,WA0,PAGENUM)); END (*NEWPAGE*); BEGIN (*DBGROUPINIT*) DBGROUPINIT:=0; (*initially load all descriptors - selection to be added later*) IF GROUPNAME <> 'ALL' THEN DBGROUPINIT:=12; (*loads descriptor groups into WA0*) PAGENUM:=-1; NEWPAGE; SPECIALGROUPPAGE[1]:=PAGENUM; DUMMY:=DBHOME(WA0); DUMMY:=DBNEXT(WA0); (*go to head of group descriptor list*) DUMMY:=DBDESCEND(WA0); (*head of 1st record*) WITH WRKTABLE[WA0] DO WITH WIB^[TOS] DO BEGIN LOADDESCRIPTORS(GROUPT); GROUPNUM:=GN; (*now load record descriptors*) DUMMY:=DBHOME(WA0); IF DBSEEK(WA0,2(*RD'S*)) <> 0 THEN NEWPAGE; SPECIALGROUPPAGE[2]:=PAGENUM; DUMMY:=DBDESCEND(WA0); LOADDESCRIPTORS(RECORDT); (*now fields*) DUMMY:=DBHOME(WA0); IF DBSEEK(WA0,3(*FD'S*)) <> 0 THEN NEWPAGE; SPECIALGROUPPAGE[3]:=PAGENUM; DUMMY:=DBDESCEND(WA0); LOADDESCRIPTORS(FIELDT); END (*WITH WIB*); END (*DBGROUPINIT*); FUNCTION DBGROUPRELEASE(*GROUPNUM:INTEGER):DBERRTYPE*); (*de-allocate storage for the designated group descriptors, and their dependent record and field descriptors*) BEGIN END (*DBGROUPRELEASE*); (**INITIALIZATION*) PROCEDURE DBINITIALIZE; VAR WI:INTEGER; BEGIN FOR WI:=0 TO LASTFILENUM DO OPENFILES[WI]:=FALSE; FOR WI:=0 TO LASTWRKINDEX DO WITH WRKTABLE[WI] DO BEGIN TOS:=0; WIB:=NIL; WSIZE:=0; SPACEINUSE:=0; WA:=NIL; END; FOR WI:=0 TO LASTSPECIALGROUP DO SPECIALGROUPPAGE[WI]:=0; FOR WI:=0 TO LASTGROUPDESCRIPTOR DO ACTIVEGROUPS[WI]:=NIL; FOR WI:=0 TO LASTRECDESCRIPTOR DO ACTIVERECORDS[WI]:=NIL; FOR WI:=0 TO LASTFIELDDESCRIPTOR DO ACTIVEFIELDS[WI]:=NIL; MARK(HEAPMARKER); WI:=DBWRKOPEN(0,(PAGELASTBYTE+1)); (*open wa # 0 for full page*) DBTYPECHECK:=TRUE; (*following lines are for debugging*) DEBUGGING:=FALSE; DBTRACESET:=[ ]; TRACELB:=0; TRACEUB:=99; END (*DBINITIALIZE*); (**ORDERLY TERMINATION*) FUNCTION DBCLOSEDOWN(*:DBERRTYPE*); BEGIN END (*DBCLOSEDOWN*); END. (*END OF DBUNIT*) ======================================================================================== DOCUMENT :usus Folder:VOL04:dbunit.text ======================================================================================== {Professor Ken Bowles' database seed. Please see the statement at the start of the actual file, DBUNIT.1.TEXT, for his copyright notice This is a dummy file that contains the I)nclude compiler directives allowing the source to be broken up into parts that will fit into the E6 editor's wholly memory-resident buffer.} {$IDBUNIT1.TEXT} {$IDBUNIT.2.TEXT} {$IDBUNIT.3.TEXT} {$IDBUNIT.4.TEXT} ======================================================================================== DOCUMENT :usus Folder:VOL04:index.text ======================================================================================== Index to Pascal Report(2nd. ed.) by Niklaus Wirth ABS 11.1.1 actual parameter 9.1.2 adding operator 8.1.3 AND 8.1.2 ARRAY 6.2.1 array type 6.2.1 array variable 7.2.1 ARCTAN 11.1.1 assignment statement 9.1.1 base type 6.2.3/14.3 BEGIN 9.2.1 blank 14.4/14.6 block 10. BOOLEAN 6.1.2 buffer variable 7./7.2.3 CASE 6.2.2/9.2.2.2 case label 6.2.2 case label list 6.2.2/9.2.2.2 case list element 9.2.2.2 case statement 9.2.2.2 CHAR 6.1.2 CHR 11.1.3 component type 6.2.1 component variable 7.2 compound statement 9.2.1 conditional statement 9.2.2 CONST 10. constant 5. constant definition 5. constant definition part 10. constant identifier 5. control variable 9.2.3.3 COS 11.1.1 digit 3. digit sequence 4. DISPOSE 10.1.2 DIV 8.1.2 DO 9.2.3.1/9.2.3.3/9.2.4 DOWNTO 9.2.3.3 E 4. element 8. element list 8. ELSE 9.2.2.1 empty ??? empty statement 9.1 END 6.2.2/9.2.1/9.2.2.2 entire variable 7.1 EOF 11.1.2 EOLN 11.1.2 EXP 11.1.1 expression 8. external 13. factor 8. FALSE 6.1.2 field designator 7.2.2 field identifier 7.2.2 field list 6.2.2 FILE 6.2.4 file buffer 7.2.3 file type 6.2.4 file variable 7.2.3 final value 9.2.3.3 fixed part 6.2.2 FOR 9.2.3.3 for list 9.2.3.3 for statement 9.2.3.3 formal parameter section 10. FUNCTION 10./11. function declaration 11. function designator 8.2 function heading 11. function identifier 8.2 GET 10.1.1 GOTO 9.1.3 goto statement 9.1.3 identifier 4./14.1 IF 9.2.2.1 if statement 9.2.2.1 IN 8.1.4 index type 6.2.1 indexed variable 7.2.1 initial value 9.2.3.3 INPUT 12./13. INTEGER 6.1.2 LABEL 10. label 9./14.4 label declaration part 10. letter 3. letter or digit 4. LN 11.1.1 MAXINT ??? MOD 8.1.2 multiplying operator 8.1.2 NEW 10.1.2 NIL 6.3/8. NOT 8.1.1 ODD 11.1.2 OF 6.2.1/6.2.2/6.2.3/6.2.4/9.2.2.2 operator precedence 8. OR 8.1.3 ORD 11.1.3 OUTPUT 12./13. PACK 10.1.3 PACKED 6.2 PAGE 12.5 parameter group 10. pointer type 6.3 pointer variable 7.3 PRED 11.1.4 printer control character 14.4 PROCEDURE 10. procedure and function declaration part 10. procedure declaration 10. procedure heading 10. procedure identifier 9.1.2 procedure or function declaration 10. procedure statement 9.1.2 PROGRAM 13. program 13. program heading 13. program parameters 13. PUT 10.1.1 READ 12.1 READLN 12.2 REAL 6.1.2 RECORD 6.2.2 record section 6.2.2 record type 6.2.2 record variable 7.2.2 record variable list 9.2.4 recursive 10. referenced variable 7.3 relational operator 8.1.4 REPEAT 9.2.3.2 repeat statement 9.2.3.2 repetitive statement 9.2.3 RESET 10.1.1 REWRITE 10.1.1 result type 11. ROUND 11.1.3 scalar type 6.1.1 scale factor 4. scope 10. separator 14.6/14.7 SET 6.2.3 set 8. set type 6.2.3 sign 4. simple expression 8. simple statement 9.1 simple type 6.1 SIN 11.1.1 special symbol 3. space 14.4/14.6 SQR 11.1.1 SQRT 11.1.1 standard functions 11.1 standard procedures 10.1 statement 9. statement part 10. string 4. structured statement 9.2 structured type 6.2 subrange type 6.1.3 SUCC 11.1.4 tag field 6.2.2 term 8. TEXT 6.2.4 THEN 9.2.2.1 TO 9.2.3.3 TRUE 6.1.2 TRUNC 11.1.3 TYPE 10. type 6. type definition 6. type definition part 10. type identifier 6.1 unlabelled statement 9. UNPACK 10.1.3 unpacked structured type 6.2 unsigned constant 8. unsigned integer 4. unsigned number 4. unsigned real 4. UNTIL 9.2.3.2 VAR 10. varible 7. variable declaration 7. variable declaration part 10. variable identifier 7.1 variant 6.2.2 variant part 6.2.2 WHILE 9.2.3.1 while statement 9.2.3.1 WITH 9.2.4 with statement 9.2.4 WRITE 12.3 WRITELN 12.4 ' (single quote) 4. ( 6.1.1/6.2.2/8./8.2/9.1.2/13. (* 3. ) 6.1.1/6.2.2/8./8.2/9.1.2/13. * 8.1.2 *) 3. + 4./8.1.3/14.4 , (comma) 6.1.1/6.2.1/6.2.2/7./7.2.1/8./ 8.2/9.1.2/9.2.2.2/9.2.4/10./13. - (minus sign) 4./8.1.3 . (period) 4./7.2.2/13. .. 6.1.3./8. / 8.1.2 0 14.4 1 14.4 : (colon) 9./9.2.2.2/11. := 9.1.1/9.2.3.3 ; (semicolon) 6.2.2/9.2.1/9.2.2.2/9.2.3.2/10./11. < 8.1.4 <= 8.1.4 <> 8.1.4 = 8.1.4 > 8.1.4 >= 8.1.4 [ 6.2.1/8. ] 6.2.1/8. ^ (up arrow) 6.3/7./7.2.3/7.3 { (left brace) 3. } (right brace) 3. ======================================================================================== DOCUMENT :usus Folder:VOL04:kb.dbdemo.text ======================================================================================== (*$S+*) PROGRAM DBTEST; USES DBUNIT,SCUNIT,STARTER; BEGIN (*DBDEMO PROGRAM*) STINITIALIZE; REPEAT GOTOXY(0,0); BLANKTOPLINE; CASE GETCOMMAND('DBDEMO: C(hangerec F(indrec G(etrec N(ewrec Q(uit T(race', ['C', 'F', 'G', 'N', 'Q', 'T']) OF 'C': IF CHANGEREC(WA1) THEN SAVEREC; 'F': FINDREC; 'G': GETREC; 'N': NEWREC; 'T': BEGIN DEBUGGING:=TRUE; DBSHOWERR('Halt request from keyboard - allows trace change',100); DEBUGGING:=FALSE; END; 'Q': DONE:=TRUE END (*CASE*); UNTIL DONE; END. ======================================================================================== DOCUMENT :usus Folder:VOL04:kb.scunit.text ======================================================================================== (*$L #5:SCUNIT.LST.TEXT*) (*$S+*) UNIT SCUNIT; (*Copyright 1980 Kenneth L. Bowles, All rights reserved. Permission is hereby granted to use this material for any non-commercial purpose*) (*This version includes specific constants for Terak 8510A*) INTERFACE TYPE SCCHSET = SET OF CHAR; SCKEYCOMMAND = (BACKSPACEKEY,ETXKEY,ESCKEY,DELKEY,UPKEY,DOWNKEY, LEFTKEY,RIGHTKEY,NOTLEGAL); VAR SCCH:CHAR; PROCEDURE SCINITIALIZE; PROCEDURE SCLEFT; PROCEDURE SCRIGHT; PROCEDURE SCUP; PROCEDURE SCDOWN; PROCEDURE SCGETCCH(VAR CH:CHAR; OKSET:SCCHSET); FUNCTION SCMAPCRTCOMMAND(KCH: CHAR): SCKEYCOMMAND; PROCEDURE SCREADSTRG(VAR S:STRING; WIDTH:INTEGER; CCHSET:SCCHSET; ROW,COL:INTEGER); PROCEDURE SCREADINT(VAR X: INTEGER; WIDTH:INTEGER; ROW,COL:INTEGER); IMPLEMENTATION CONST SCEOL=13; BELL=7; UNDERLINE='_'; VAR TRANSLATE: PACKED ARRAY[CHAR] OF SCKEYCOMMAND; KEYBRD: PACKED ARRAY[SCKEYCOMMAND] OF CHAR; PROCEDURE SCINITIALIZE; VAR I:INTEGER; BEGIN FOR I:=0 TO 255 DO TRANSLATE[CHR(I)]:=NOTLEGAL; TRANSLATE[CHR(8)]:=BACKSPACEKEY; KEYBRD[BACKSPACEKEY]:=CHR(8); TRANSLATE[CHR(3)]:=ETXKEY; KEYBRD[ETXKEY]:=CHR(3); TRANSLATE[CHR(26)]:=UPKEY; KEYBRD[UPKEY]:=CHR(26); TRANSLATE[CHR(12)]:=DOWNKEY; KEYBRD[DOWNKEY]:=CHR(12); TRANSLATE[CHR(23)]:=LEFTKEY; KEYBRD[LEFTKEY]:=CHR(23); TRANSLATE[CHR(11)]:=RIGHTKEY; KEYBRD[RIGHTKEY]:=CHR(11); KEYBRD[ESCKEY]:=CHR(27); KEYBRD[DELKEY]:=CHR(127); END (*INITIALIZE*); FUNCTION SCMAPCRTCOMMAND(*(VAR KCH:CHAR): SCKEYCOMMAND*); BEGIN SCMAPCRTCOMMAND:=TRANSLATE[KCH] END; PROCEDURE SCLEFT; BEGIN WRITE(CHR(8)); END (*SCLEFT*); PROCEDURE SCRIGHT; BEGIN WRITE(CHR(28)); END (*SCRIGHT*); PROCEDURE SCUP; BEGIN WRITE(CHR(31)); END (*SCUP*); PROCEDURE SCDOWN; BEGIN WRITE(CHR(10)); END (*SCDOWN*); PROCEDURE SQUAWK; BEGIN WRITE(CHR(BELL)); END; PROCEDURE SCGETCCH(*VAR CH: CHAR; OKSET: SCCHSET*); BEGIN REPEAT (*If user wants a character then get one that's LEGAL*) READ(KEYBOARD,CH); IF EOLN(KEYBOARD) THEN CH:=CHR(SCEOL); IF NOT (CH IN OKSET) THEN SQUAWK; UNTIL (CH IN OKSET); END; PROCEDURE UCLC(VAR CH:CHAR); BEGIN IF CH IN ['a'..'z'] THEN CH:=CHR(ORD(CH)-32); END (*UCLC*); PROCEDURE FILLFIELD(CH:CHAR; WIDTH:INTEGER); (*fill a field on screen with CH by fastest method (in practice) *) VAR A:PACKED ARRAY[0..79] OF CHAR; BEGIN FILLCHAR(A[0], WIDTH, CH); WRITE(A:WIDTH); END (*FILLFIELD*); PROCEDURE TRUNCSTRING(WIDTH:INTEGER; INSTRG:STRING; VAR OUTSTRG: STRING); BEGIN IF LENGTH(INSTRG)<=WIDTH THEN OUTSTRG:=INSTRG ELSE OUTSTRG:=COPY(INSTRG,1,WIDTH); END (*TRUNCSTRG*); (*$G+*) PROCEDURE SCREADSTRG(*VAR S:STRING; WIDTH:INTEGER; CCHSET:SCCHSET; ROW,COL:INTEGER*); (*this is (hopefully) a reasonably friendly string read to replace the standard routine in the system*) (*display S, with underlining to fill out remainder of WIDTH columns. allow editing within the displayed field. See embedded comments regarding edit commands.*) LABEL 2; VAR CH:CHAR; X:STRING[1]; CURSINX,CHCNT:INTEGER; CHOK:SCCHSET; TS,TAILS:STRING; BEGIN X:=' '; TS:=S; CHCNT:=LENGTH(TS); GOTOXY(COL,ROW); IF LENGTH(TS) > WIDTH THEN DELETE(TS,WIDTH+1, (WIDTH-LENGTH(TS))); WRITE(TS); IF LENGTH(TS) < WIDTH THEN FILLFIELD(UNDERLINE, WIDTH - LENGTH(TS)); GOTOXY(COL,ROW); CURSINX:=1; CHOK:=CCHSET + [CHR(SCEOL), KEYBRD[ESCKEY], KEYBRD[RIGHTKEY], KEYBRD[LEFTKEY], KEYBRD[BACKSPACEKEY], KEYBRD[DELKEY] ]; REPEAT SCGETCCH(CH,CHOK); IF CH=KEYBRD[ESCKEY] THEN BEGIN (*restore previous string to screen & bail out*) GOTOXY(COL,ROW); FILLFIELD(' ',WIDTH); GOTOXY(COL,ROW); WRITE(S); GOTO 2; END; IF CH IN [KEYBRD[BACKSPACEKEY], KEYBRD[LEFTKEY] ] THEN BEGIN (*move cursor left one position*) IF CURSINX > 1 THEN BEGIN SCLEFT; CURSINX:=CURSINX-1; END; END ELSE IF CH=KEYBRD[RIGHTKEY] THEN BEGIN (*move cursor right one position*) IF (CURSINX < (CHCNT+1)) AND (CURSINX < WIDTH) THEN BEGIN SCRIGHT; CURSINX:=CURSINX+1; END; END ELSE IF CH=KEYBRD[DELKEY] THEN BEGIN (*delete one character, redisplay the tail*) IF CHCNT > 0 THEN BEGIN DELETE(TS,CURSINX,1); CHCNT:=CHCNT-1; TAILS:=TS; IF CURSINX > 1 THEN DELETE(TAILS,1,CURSINX-1); WRITE(TAILS); WRITE(UNDERLINE); GOTOXY((COL+CURSINX-1),ROW); END; END ELSE IF CH <> CHR(SCEOL) THEN (*insert the character and redisplay the tail*) IF CHCNT < WIDTH THEN BEGIN X[1]:=CH; INSERT(X,TS,CURSINX); CHCNT:=CHCNT+1; TAILS:=TS; DELETE(TAILS,1,CURSINX-1); WRITE(TAILS); (*only the tail needs to be rewritten*) IF CURSINX < WIDTH THEN CURSINX:=CURSINX+1; GOTOXY((COL+CURSINX-1),ROW); END; UNTIL (CH = CHR(SCEOL)); S:=TS; 2: END (*SCREADSTRG*); PROCEDURE SCREADINT(*VAR X: INTEGER; WIDTH:INTEGER; ROW,COL:INTEGER*); (*read integers in as friendly a way as possible - without blowing up*) (*This is for reading 16 bit integers - not long integers*) LABEL 1,2; CONST BADINT= -32767; VAR NUM,PCH,PWRTEN,DIGIT:INTEGER; CH:CHAR; NEGATIVE,DONE:BOOLEAN; S:STRING[7]; BEGIN GOTO 2; (*Jump over error handling*) 1: GOTOXY(COL,ROW); FOR PCH:=1 TO WIDTH DO WRITE('*'); SQUAWK; 2: S:=''; SCREADSTRG(S,WIDTH,[' ','-','+','0'..'9'],ROW,COL); NUM:=0; PWRTEN:=1; PCH:=1; NEGATIVE:=FALSE; DONE:=FALSE; X:=BADINT; (*Strip off leading blanks*) WHILE (LENGTH(S)>0) AND (NOT DONE) DO IF S[1]=' ' THEN DELETE(S,1,1) ELSE DONE:=TRUE; IF LENGTH(S)>0 THEN BEGIN IF S[1] IN ['+','-'] THEN BEGIN NEGATIVE:=(S[1]='-'); DELETE(S,1,1); END; PCH:=LENGTH(S); WHILE (PCH>=1) AND (NUM<10000) DO BEGIN IF S[PCH] IN [' ','+','-'] THEN GOTO 1 ELSE DIGIT:=ORD(S[PCH])-ORD('0'); IF NUM>1000 THEN CASE S[PCH] OF '0','1','2': NUM:=NUM+DIGIT*PWRTEN; '3': IF NUM<=2767 THEN NUM:=NUM+30000 ELSE GOTO 1; '4','5','6','7','8','9': GOTO 1 END (*CASES*) ELSE NUM:=NUM+DIGIT*PWRTEN; PWRTEN:=PWRTEN*10; PCH:=PCH-1; END (*WHILE*); IF NEGATIVE THEN X:=-NUM ELSE X:=NUM; END (*LENGTH(S)>0*); END (*READINT*); END. ======================================================================================== DOCUMENT :usus Folder:VOL04:kb.starter.text ======================================================================================== (*$S+*) UNIT STARTER; INTERFACE USES DBUNIT,SCUNIT; CONST WA0=0; WA1=1; WA2=2; FNUM=0; PAGEZERO=0; EOL=13; ESC=27; ETX=3; LASTSELCH='Z'; PAGELASTBYTE=4095; MINRECSPACE=250; PEOPLEGROUP=0; PERSONREC=0; INDEXGROUP=1; INDEXREC=1; KEYFIELD=4; TYPE STRINGPTR = ^STRING; TRIXPTR = RECORD CASE DBLEVELTYPE OF FIELDT: (F:FLDDESPTR); RECORDT:( (*R:RECDESPTR*) ); GROUPT: ( (*G:GRPDESPTR*) ); NONET: (S:STRINGPTR) END; SELECTITEM = RECORD SFP: FLDDESPTR; SITEMNUM: INTEGER; SDESCRIPTORNUM: INTEGER; END; VAR PAGENUM,GROUPNUM, RECNUM:INTEGER; INDEXPAGE, (*temporarily - fixed index page; later - coarse index*) FIRSTAVAILPAGE, (*page into which next person record should be placed*) DUMMY:INTEGER; DONE:BOOLEAN; CHOK:SCCHSET; MAXSELCH:CHAR; SELECT: ARRAY['A'..LASTSELCH] OF SELECTITEM; INDEXITEMS: STRING[20]; PAGEINWA: ARRAY[DBWRKINDEX] OF INTEGER; PROCEDURE BLANKTOPLINE; FUNCTION GETCOMMAND(S:STRING; OKSET:SCCHSET):CHAR; PROCEDURE CHECKPAGE(WI:DBWRKINDEX; PAGENUM:INTEGER); PROCEDURE STINITIALIZE; PROCEDURE SHOWREC(WI:DBWRKINDEX); FUNCTION CHANGEREC(WI:DBWRKINDEX):BOOLEAN; PROCEDURE SAVEINDEXITEM(SELCH:CHAR); PROCEDURE SAVEREC; PROCEDURE FETCHREC; PROCEDURE FINDREC; PROCEDURE NEWREC; PROCEDURE GETREC; IMPLEMENTATION PROCEDURE BLANKTOPLINE; BEGIN GOTOXY(0,0); WRITE( ' '); GOTOXY(0,0); END (*BLANKTOPLINE*); FUNCTION GETCOMMAND(*S:STRING; OKSET:SCCHSET):CHAR*); VAR CH:CHAR; BEGIN REPEAT BLANKTOPLINE; WRITE(S); READ(KEYBOARD,CH); IF EOLN(KEYBOARD) THEN CH:=CHR(EOL); IF CH IN ['a'..'z'] THEN CH:=CHR(ORD(CH)-32); UNTIL CH IN OKSET; GETCOMMAND:=CH; END (*GETCOMMAND*); PROCEDURE CHECKPAGE(*WI:DBWRKINDEX; PAGENUM:INTEGER*); VAR DUMMY:INTEGER; BEGIN IF PAGEINWA[WI] <> PAGENUM THEN BEGIN DUMMY:=DBGETPAGE(FNUM, WI, PAGENUM); PAGEINWA[WI]:=PAGENUM; END; DUMMY:=DBHOME(WI); END (*CHECKPAGE*); PROCEDURE MOVETOFIRSTAVAILPAGE; VAR DUMMY:INTEGER; BEGIN CHECKPAGE(WA0, PAGEZERO); DUMMY:=DBHOME(WA0); DUMMY:=DBDESCEND(WA0); (*to record level*) DUMMY:=DBDESCEND(WA0); (*to field level*) DUMMY:=DBGET(WA0); END (*MOVETOFIRSTAVAILPAGE*); PROCEDURE GETFIRSTAVAIL; VAR DUMMY:INTEGER; BEGIN MOVETOFIRSTAVAILPAGE; FIRSTAVAILPAGE:=ORD(DBMAIL.STRG[2]); (*temporary kludge*) INDEXPAGE:=ORD(DBMAIL.STRG[1]); END (*GETFIRSTAVAIL*); PROCEDURE SAVEFIRSTAVAIL; VAR DUMMY:INTEGER; BEGIN MOVETOFIRSTAVAILPAGE; DBMAIL.STRG[2]:=CHR(FIRSTAVAILPAGE); (*temporary kludge*) DBMAIL.DBMAILTYPE:=STRINGF; DUMMY:=DBPUT(WA0); DUMMY:=DBPUTPAGE(FNUM,WA0,PAGEZERO); END (*SAVEFIRSTAVAIL*); PROCEDURE STINITIALIZE; VAR NWA,RSLT:INTEGER; TITLE:STRING; BEGIN DBINITIALIZE; SCINITIALIZE; REPEAT WRITE('Data Base File Title:'); READLN(TITLE); RSLT:=DBFOPEN(FNUM,TITLE); IF RSLT <> 0 THEN WRITELN('Can''t open the file'); UNTIL RSLT = 0; DBSHOWERR('Init-Getpage', DBGETPAGE(FNUM, WA0, PAGEZERO)); PAGEINWA[WA0]:=PAGEZERO; DBTYPECHECK:=FALSE; DBSHOWERR('Init-descriptors', DBGROUPINIT(FNUM,RSLT,'ALL')); DBTYPECHECK:=TRUE; DONE:=FALSE; DBSHOWERR('Init-open(WA1)', DBWRKOPEN(WA1,(PAGELASTBYTE+1))); DBSHOWERR('Init-open(WA2)', DBWRKOPEN(WA2, MINRECSPACE)); FOR NWA:=1 TO LASTWRKINDEX DO PAGEINWA[NWA]:=-1; GETFIRSTAVAIL; WRITELN; WRITELN('First available page is # ', FIRSTAVAILPAGE); WRITELN('Index page is # ', INDEXPAGE); INDEXITEMS:='DE'; (*Name, Company fields - could be chosen from keyboard if we wanted slightly fancier program*) END (*STINITIALIZE*); PROCEDURE LOCATOR(WI:DBWRKINDEX; GROUPNUM,RECNUM:INTEGER); VAR I:INTEGER; BEGIN DBSHOWERR('LOC#1', DBHOME(WI)); DBSHOWERR('LOC#2', DBSEEK(WI, GROUPNUM)); DBSHOWERR('LOC#3', DBDESCEND(WI)); (*to record level*) DBSHOWERR('LOC#4', DBSEEK(WI, RECNUM)); END (*LOCATOR*); PROCEDURE SHOWREC(*WI:DBWRKINDEX*); (*show the content of a data record within its labelled form*) VAR FP:FLDDESPTR; TP:TRIXPTR; OFFSET,ITEMNUM,DESCRIPTORNUM,RSLT:INTEGER; LEVEL:DBLEVELTYPE; SELCH:CHAR; NS:STRING; BEGIN PAGE(OUTPUT); DBITEMINFO(WI,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS); IF LEVEL = RECORDT THEN BEGIN RSLT:=DBDESCEND(WI); (*to field level*) DBITEMINFO(WI,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS); DBGETDESCRIPTOR(FIELDT,DESCRIPTORNUM,FP); SELCH:='A'; MAXSELCH:=SELCH; CHOK:= []; WHILE (RSLT = 0) AND (FP <> NIL) DO WITH FP^ DO BEGIN IF FLDTYPE IN [STRINGF,INTEGERF] THEN BEGIN GOTOXY(LABELCOL, ROW); (*note link value is one more than correct string length*) WRITE(SELCH,'>'); WRITE(NAME:(LENGTH(NAME)-1)); GOTOXY(DATACOL, ROW); DBSHOWERR('Showrec-Data', DBWRITEFIELD(OUTPUT, WI)); CHOK:=CHOK+[SELCH]; WITH SELECT[SELCH] DO BEGIN SFP:=FP; SITEMNUM:=ITEMNUM; SDESCRIPTORNUM:=DESCRIPTORNUM; END; MAXSELCH:=SELCH; SELCH:=CHR(ORD(SELCH)+1); END (*FLDTYPE <> GROUPF*); RSLT:=DBNEXT(WI); IF RSLT = 0 THEN BEGIN (*get the descriptor number, then with that FP*) DBITEMINFO(WI,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS); DBGETDESCRIPTOR(FIELDT,DESCRIPTORNUM,FP); END; END (*WITH FP^*); END ELSE BEGIN WRITELN; WRITELN('ERROR - Call SHOWREC when pointing at a record'); END; GOTOXY(0,0); END (*SHOWREC*); FUNCTION CHANGEREC(*WI:DBWRKINDEX):BOOLEAN*); (*after record is shown on screen in its form by SHOWREC, this routine allows editing any or all fields in the form*) VAR SELCH,CH:CHAR; SELCHSET:SCCHSET; DUMMY:INTEGER; MSG:STRING; BEGIN BLANKTOPLINE; SELCHSET:=CHOK+[CHR(EOL), CHR(ETX), CHR(ESC)]; MSG:= 'Pick item by lead char; next item; accept rec; abort'; WRITE(MSG); REPEAT SCGETCCH(CH,SELCHSET); IF CH=CHR(EOL) THEN BEGIN IF SELCH < MAXSELCH THEN SELCH:=CHR(ORD(SELCH)+1); CH:=SELCH; END; IF CH IN CHOK THEN WITH SELECT[CH] DO BEGIN DUMMY:=DBSEEK(WI,SITEMNUM); DBSHOWERR('CHANGEREC-DBGET', DBGET(WI)); WITH SFP^ DO IF FLDTYPE IN [STRINGF,INTEGERF] THEN BEGIN SELCH:=CH; CASE FLDTYPE OF STRINGF: SCREADSTRG(DBMAIL.STRG, MAXWIDTH, [' '..'~'], ROW, DATACOL); INTEGERF:SCREADINT(DBMAIL.INT, 6, ROW, DATACOL) END (*CASE*); DBMAIL.DBMAILTYPE:=FLDTYPE; DBSHOWERR('CHANGEREC-DBPUT', DBPUT(WI)); END (*IF FLDTYPE*); BLANKTOPLINE; WRITE(MSG); (*flash top line, leave cursor at end*) END (*WITH SELECT*) ELSE BEGIN (*do nothing*) END; UNTIL CH IN [CHR(ETX),CHR(ESC)]; CHANGEREC:= (CH = CHR(ETX)); DUMMY:=DBASCEND(WI); (*leave pointing at parent record*) END (*CHANGEREC*); PROCEDURE SAVEINDEXITEM(*SELCH:CHAR*); (*called once for each item to be indexed. data record is in WA1 with pointer at field level*) VAR ITEMNUM, TAGVALUE, RSLT, NREC, DUMMY:INTEGER; FOUND:BOOLEAN; PROCEDURE PUTNEXT(I:INTEGER); BEGIN DBMAIL.INT:=I; DUMMY:=DBPUT(WA2); DUMMY:=DBNEXT(WA2); END (*PUTNEXT*); BEGIN (*SAVEINDEXITEM*) WITH SELECT[SELCH] DO BEGIN ITEMNUM:=SITEMNUM; TAGVALUE:=SDESCRIPTORNUM; END; (*build index record in WA2*) ZEROWORKAREA(WA2); DUMMY:=DBEMPTYITEM(WA2, GROUPT, INDEXGROUP); DUMMY:=DBEMPTYITEM(WA2, RECORDT, INDEXREC); DUMMY:=DBHOME(WA2); DUMMY:=DBDESCEND(WA2); (*to record level*) DUMMY:=DBDESCEND(WA2); (*to field level*) DBMAIL.DBMAILTYPE:=INTEGERF; PUTNEXT(PAGEINWA[WA1]); (*page#*) PUTNEXT(GROUPNUM); PUTNEXT(RECNUM); PUTNEXT(TAGVALUE); (*WA1 assumed in field level on entry to this routine*) DUMMY:=DBSEEK(WA1,ITEMNUM); (*point to field to be indexed*) (*pick up the key value from data record in WA1, insert in WA2*) DUMMY:=DBGET(WA1); (*KEY to mailbox*) DUMMY:=DBPUT(WA2); (*prepare to insert in index in WA0*) CHECKPAGE(WA0, INDEXPAGE); RSLT:=DBDESCEND(WA0); (*to index rec*) IF RSLT = 19 (*reached end of list error, WA0 is empty*) THEN BEGIN (*use WA2 to start new WA0*) DUMMY:=DBHOME(WA2); DBSHOWERR('SAVEINDEXITEM - copy WA2 to WA0', DBCOPY(WA2,WA0)); END ELSE IF RSLT <> 0 THEN DBSHOWERR('SAVEINDEXITEM - cant''t descend in WA0', 100) ELSE BEGIN (*point to location where the new item is to be placed in index*) DBSHOWERR('SAVEINDEXITEM - findrec', DBFINDREC(WA0, ASCENDING, KEYFIELD, DBMAIL.STRG, (*KEY*) NREC, FOUND)); IF FOUND THEN (*KEY matches exactly*) BEGIN (*code to eliminate only those duplicates with same page, group, and record numbers might go here*) END ELSE BEGIN (*insert the new index record into index in WA0*) DBSHOWERR('SAVEINDEXITEM - emptyitem', DBEMPTYITEM(WA0, RECORDT, INDEXREC)); DUMMY:=DBASCEND(WA2); (*to record level*) DBSHOWERR('SAVEINDEXITEM - replace WA0', DBREPLACE(WA2,WA0)); END; END (*RSLT OK*); END (*SAVEINDEXITEM*); PROCEDURE SAVEREC; (*save both the new or changed record, and updated index, in file*) VAR I,DUMMY:INTEGER; BEGIN DBSHOWERR('SAVEREC - People Group', DBPUTPAGE(FNUM,WA1,PAGEINWA[WA1])); (*enter with WA1 in Record level*) DUMMY:=DBDESCEND(WA1); (*to field level*) FOR I:=1 TO LENGTH(INDEXITEMS) DO SAVEINDEXITEM(INDEXITEMS[I]); DBSHOWERR('SAVEREC - INDEX', DBPUTPAGE(FNUM, WA0, INDEXPAGE)); END (*SAVEREC*); PROCEDURE FETCHREC; (*get the required page into WA1, if not already there. then display the record in GROUPNUM, RECNUM*) BEGIN IF PAGEINWA[WA1] <> PAGENUM THEN BEGIN DBSHOWERR('GETREC', DBGETPAGE(FNUM, WA1, PAGENUM)); PAGEINWA[WA1]:=PAGENUM; END; LOCATOR(WA1,GROUPNUM,RECNUM); SHOWREC(WA1); END (*FETCHREC*); PROCEDURE FINDREC; CONST FIRSTLINE = 5; VAR RN,RSLT,DUMMY:INTEGER; CH,SELCH:CHAR; FOUND:BOOLEAN; KEY:STRING; OFFSET,ITEMNUM,DESCRIPTORNUM:INTEGER; LEVEL:DBLEVELTYPE; NS:STRING; PROCEDURE PICKNEXT(VAR I:INTEGER); VAR DUMMY:INTEGER; BEGIN DUMMY:=DBGET(WA0); I:=DBMAIL.INT; DUMMY:=DBNEXT(WA0); END (*PICKNEXT*); BEGIN CHECKPAGE(WA0, INDEXPAGE); PAGE(OUTPUT); WRITE('Search Key:'); READLN(KEY); DUMMY:=DBDESCEND(WA0); (*to record level*) DBSHOWERR('FINDREC #1', DBFINDREC(WA0, ASCENDING, KEYFIELD, KEY, RECNUM, FOUND)); (*establish beginning of range of keys to be displayed*) IF RECNUM > 5 THEN RN:=RECNUM-5 ELSE RN:=0; DUMMY:=DBSEEK(WA0,RN); SELCH:='A'; RSLT:=0; (*display up to 10 keys, identified by letters for user selection*) WHILE (SELCH < 'J') AND (RSLT = 0) DO BEGIN RSLT:=DBDESCEND(WA0); (*to field level*) (* descend should fail on nul record at tail of list *) IF RSLT = 0 THEN (*descend ok*) BEGIN RSLT:=DBSEEK(WA0, KEYFIELD); (*should also fail at tail*) IF RSLT = 0 THEN BEGIN GOTOXY(0,(FIRSTLINE+ORD(SELCH)-ORD('A'))); WRITE(SELCH, '>'); DUMMY:=DBWRITEFIELD(OUTPUT, WA0); SELCH:=CHR(ORD(SELCH)+1); DUMMY:=DBASCEND(WA0); (*back to record level*) RSLT:=DBNEXT(WA0); END (* SEEK RSLT OK*); END (*DESCEND RSLT OK*); END (*WHILE*); (*now check to make sure we are still at the record level - debugging*) DBITEMINFO(WA0,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS); IF LEVEL <> RECORDT THEN DBSHOWERR('FINDREC - not at record level!', 100) ELSE BEGIN (*ask user which entry to pick*) GOTOXY(0,1); WRITE('Pick item by initial char; to escape'); SCGETCCH(CH, ['A'..CHR(ORD(SELCH)-1), CHR(ESC)]); IF CH <> CHR(ESC) THEN BEGIN RN:=RN+ORD(CH)-ORD('A'); DUMMY:=DBSEEK(WA0,RN); DUMMY:=DBDESCEND(WA0); (*to field level*) (*Pick up page, group, record numbers from index record*) PICKNEXT(PAGENUM); PICKNEXT(GROUPNUM); PICKNEXT(RECNUM); (*get the data record and display it*) FETCHREC; END (*CH <> ESC*); END (*RECORD level ok*); END (*FINDREC*); PROCEDURE NEWREC; (*display a blank form, create a blank record, and collect data content for it from keyboard. save the new record if requested*) VAR DUMMY,RSLT:INTEGER; OFFSET,ITEMNUM,DESCRIPTORNUM:INTEGER; LEVEL:DBLEVELTYPE; NS:STRING; BEGIN (*Assume page PAGENUM has one group only, of People_group*) ZEROWORKAREA(WA2); DUMMY:=DBEMPTYITEM(WA2, GROUPT, PEOPLEGROUP); DUMMY:=DBEMPTYITEM(WA2, RECORDT, PERSONREC); SHOWREC(WA2); (*display the empty form with labels*) DUMMY:=DBHEAD(WA2); IF CHANGEREC(WA2) THEN (*should save it*) BEGIN DUMMY:=DBHOME(WA1); DUMMY:=DBDESCEND(WA1); DUMMY:=DBTAIL(WA1); RSLT:=DBREPLACE(WA2,WA1); IF RSLT <> 0 THEN (*insufficient room in WA1*) BEGIN (*blank out WA1, put in new record, prepare to save in a new page*) ZEROWORKAREA(WA1); DUMMY:=DBEMPTYITEM(WA1, GROUPT, PEOPLEGROUP); DUMMY:=DBEMPTYITEM(WA1, RECORDT, PERSONREC); DUMMY:=DBHOME(WA1); DUMMY:=DBDESCEND(WA1); RSLT:=DBREPLACE(WA2,WA1); FIRSTAVAILPAGE:=FIRSTAVAILPAGE+1; PAGEINWA[WA1]:=FIRSTAVAILPAGE; END (*REPLACE failed*); IF RSLT = 0 THEN BEGIN (*save the newly assigned record # in RECNUM, then save the record*) DBITEMINFO(WA1,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS); RECNUM:=ITEMNUM; SAVEREC; END (*RSLT OK*); END (*changerec succeeded*); END (*NEWREC*); PROCEDURE GETREC; (*display the content of a specific record in selected page and group*) BEGIN PAGE(OUTPUT); WRITELN; (*put index search calls here in place of following explicit setting of PAGENUM, RECNUM. Assume GROUPNUM is 0 by default*) WRITE('PAGE#:'); READLN(PAGENUM); WRITE('GROUP#:'); READLN(GROUPNUM); WRITE('RECORD#:'); READLN(RECNUM); FETCHREC; END (*GETREC*); END. ======================================================================================== DOCUMENT :usus Folder:VOL04:kb.testdb ======================================================================================== Y People_Group Index_Group TransGroupAvail_Pages_Group+È Person_Rec6    Index_Rec    Transref2Avail_Pages_Recð}A4 CategoryA4 Last_DateA4Access##Name#Company# Street/Box#CityState/CountryA4 Zip Code>4Phone TransactionsPage#Group#Rec#Tag(Key Avail_Pages_Fldgds{James W. BandyTexas Instruments12860 Hillcrest, MS 370DallasTexas75230(214)980-6107ó; Bandy, James W.  Byte Books Byte Magazine, !Computer Power of Australia Pty.$ Daneva Control Pty. Ltd.(  Electronic Engineering Times& Fenwick Software Pty. Ltd. Forsyth, Dr.Daniel, !Helmers, Carl T. Jr. - Edit Dir.. #Hunt, Helen - Principal Programmer- "Integrated Computer Systems, Inc..  #Israel, Marvin - Computer Sci. Ed.%  Japan Automation Co. Ltd..  #Japan Business Automation Co. Ltd."  Kojima, Jun - Director+  Liffick, Blaise W. - Sr. Editor*  Missler, Charles W. - Chairman$ Mote, Michael - Director* Ortex Computer Sales & Service$ Sale, Prof. Arthur H. J.&  Springer Verlag Publishers/ $Tasmania, Univ of - Inf. Sci. Dept." Texas Instruments Inc.  Trewin, Bob' Wadham, Ian D. - Tech. Mgr.*  Werner, Jerry - Western Editor!  Western Digital Corp.õ›ˆ#Hunt, Helen - Principal ProgrammerFenwick Software Pty. Ltd.140 William St. MelbourneVictoria 3000, Australia300067-9265r Trewin, BobOrtex Computer Sales & Service37 Townshend St.PhillipA.C.T. 2606, Australia260682-4995jBandy, James W.Texas Instruments Inc.12860 Hillcrest, MS 370DallasTexas75230(214)980-6107„Sale, Prof. Arthur H. J.$Tasmania, Univ of - Inf. Sci. Dept.Box 252C G.P.O.HobartTasmania, Australia7001 (002)23-0561•€Wadham, Ian D. - Tech. Mgr.!Computer Power of Australia Pty.244 Canterbury RoadSurrey Hills, MelbourneVictoria, Australia3127 690-3288…Mote, Michael - DirectorDaneva Control Pty. Ltd. 70 Bay RoadSandringham, MelbourneVictoria, Australia3191 (03)598-5622{Forsyth, Dr.Daniel"Integrated Computer Systems, Inc.3304 Pico Blvd. Santa Monica California90405(213)450-2060t!Helmers, Carl T. Jr. - Edit Dir.Byte Magazine 70 Main St. PeterboroughNew Hampshire03458(603)924-7217p Liffick, Blaise W. - Sr. Editor Byte Books 70 Main St. PeterboroughNew Hampshire03458(603)924-7217} #Israel, Marvin - Computer Sci. Ed.Springer Verlag Publishers175 Fifth Ave. New York New York10010(212)477-8200‰ Missler, Charles W. - ChairmanWestern Digital Corp.3128 Red Hill Ave, Box 2180Newport Beach California92663(714)557-3550 Werner, Jerry - Western EditorElectronic Engineering Times4500 Campus Drive, Suite 112Newport Beach California92660(714)631-3322@Kojima, Jun - DirectorJapan Automation Co. Ltd.FSET,ITEMNUM,DESCRIPTORNUM:INTEGER; "LEVEL:DBLEVELTYPE; "NS:STRING;  BEGIN "(*Assume page PAGENUM has one group only, of People_group*) "ZEROWORKAREA(WA2); "DUMMY:=DBEMPTYITEM(WA2, GROUPT, PEOPLEGROUP); "DUMMY:=DBEMPTYITEM(WA2, RECORDT, PERSONREC); "SHOWREC(WA2); (*display the empty form with labels*) "DUMMY:=DBHEAD(WA2); "IF CHANGEREC(WA2) THEN (*should save it*) $BEGIN &DUMMY:=DBHOME(WA1); &DUMMY:=DBDESCEND(WA1); &DUMMY:=DBTAIL(WA1); &RSLT:=DBREPLACE(WA2,WA1); &IF RSLT <> 0 THEN (*insufficient room in WA1*) (BEGIN *(*blank out WA1, put in new record, prepare to save in a ,new page*) *ZEROWORKAREA(WA1); *DUMMY:=DBEMPTYITEM(WA1, GROUPT, PEOPLEGROUP); *DUMMY:=DBEMPTYITEM(WA1, RECORDT, PERSONREC); *DUMMY:=DBHOME(WA1); *DUMMY:=DBDESCEND(WA1); *RSLT:=DBREPLACE(WA2,WA1); *FIRSTAVAILPAGE:=FIRSTAVAILPAGE+1; *PAGEINWA[WA1]:=FIRSTAVAILPAGE; (END (*REPLACE failed*); &IF RSLT = 0 THEN (BEGIN (*save the newly assigned record # in RECNUM, then *save the record*) *DBITEMINFO(WA1,LEVEL,ITEMNUM,OFFSET,DESCRIPTORNUM,NS); *RECNUM:=ITEMNUM; *SAVEREC; $ END (*RSLT OK*); $END (*changerec succeeded*);  END (*NEWREC*);   PROCEDURE GETREC;  (*display the content of a specific record in selected page and group*)  BEGIN "PAGE(OUTPUT); "WRITELN; "(*put index search calls here in place of following explicit setting $of PAGENUM, RECNUM. Assume GROUPNUM is 0 by default*) "WRITE('PAGE#:'); "READLN(PAGENUM); "WRITE('GROUP#:'); "READLN(GROUPNUM); "WRITE('RECORD#:'); "READLN(RECNUM); "FETCHREC;  END (*GETREC*);   BEGIN (*DBDEMO PROGRAM*) "INIT; "REPEAT $GOTOXY(0,0); $BLANKTOPLINE; $CASE GETCOMMAND('DBDEMO: C(hangerec F(indrec G(etrec N(ewrec Q(uit T(race', @['C', 'F', 'G', 'N', 'Q', 'T']) OF &'C': IF CHANGEREC(WA1) THEN SAVEREC; &'F': FINDREC; &'G': GETREC; &'N': NEWREC; &'T': BEGIN -DEBUGGING:=TRUE; -DBSHOWERR('Halt request from keyboard - allows trace change',100); -DEBUGGING:=FALSE; +END; &'Q': DONE:=TRUE $END (*CASE*); "UNTIL DONE;  END.  "IF PAGEINWA[WA1] <> PAGENUM THEN $BEGIN &DBSHOWERR('GETREC', DBGETPAGE(FNUM, WA1, PAGENUM)); &PAGEINWA[WA1]:=PAGENUM; " END; "LOCATOR(WA1,GROUPNUM,RECNUM); "SHOWREC(WA1);  END (*FETCHREC*);   PROCEDURE FINDREC;  CONST FIRSTLINE = 5;  VAR "RN,RSLT,DUMMY:INTEGER; "CH,SELCH:CHAR; "FOUND:BOOLEAN; "KEY:STRING;  "PROCEDURE PICKNEXT(VAR I:INTEGER); "VAR DUMMY:INTEGER; "BEGIN " DUMMY:=DBGET(WA0); $I:=DBMAIL.INT; $DUMMY:=DBNEXT(WA0); "END (*PICKNEXT*);   BEGIN "CHECKPAGE(WA0, INDEXPAGE); "PAGE(OUTPUT); "WRITE('Search Key:'); "READLN(KEY); "DUMMY:=DBDESCEND(WA0); (*to record level*) "DBSHOWERR('FINDREC #1', DBFINDREC(WA0, ASCENDING, KEYFIELD, KEY, DRECNUM, FOUND)); "(*establish beginning of range of keys to be displayed*) "IF RECNUM > 5 THEN $RN:=RECNUM-5 "ELSE $RN:=0;  DUMMY:=DBSEEK(WA0,RN); "SELCH:='A'; "RSLT:=0; " "(*display up to 10 keys, identified by letters for user selection*) "WHILE (SELCH < 'J') AND (RSLT = 0) DO $BEGIN &GOTOXY(0,FIRSTLINE); 1 !E^¢žÒ  ======================================================================================== DOCUMENT :usus Folder:VOL04:teach.wumpus ======================================================================================== Welcome to 'Hunt the Wumpus' The Wumpus lives in a cave of 20 rooms. Each room has 3 tunnels leading to other rooms. There are several caves that you can play in. With only a small change in the program, you can even invent you own cave! Hazards: Bottomless Pits - Two rooms have bottomless pits in them. If you go there, you fall into the pit and lose! Super Bats - Two rooms have super bats. If you go there, a bat grabs you and takes to some other room at random. (which mignt be troublesome) Wumpus: The Wumpus is not bothered by the hazards (he has sucker feet and is too big for a super bat to lift). Usually he is asleep. Two things wake him up: your entering his room or your shooting an arrow. If the Wumpus wakes he moves (p=.75) one room or stays still (p=.25). After that, if he is where you are, he eats you up and you lose! $pause You: Each turn you can move or shoot a crooked arrow. Moving: you can go one room (thru one tunnel). Arrows: you have 5 arrow. You lose when you run out. Each arrow can go from 1 to 5 rooms. You aim by telling the computer the room numbers you want the arrow to go to. If the arrow can't go that way (ie. no tunnel) it moves at random to the next room. If the arrow hits the Wumpus, you win. If the arrow hits you, you lose. Warnings: When you are one room away from the Wumpus or a hazard, the cumputer says: Wumpus - 'I smell a Wumpus' Bat - 'Bats nearby' Pit - 'I feel a draft' Caves: All caves have have 20 rooms and 3 tunnels leading from one room to other rooms. The caves are: $pause 0 - Dodecahedron The rooms of this cave are on a 12-sided object, each forming a pentagon. The rooms are at the corners of the pentagons. Each room has tunnels that lead to 3 other rooms. 1 - Mobius Strip This cave is two rooms wide and 10 rooms around (like a belt). You will notice that there is a half twist somewhere. 2 - String of Beads Five beads in a circle. Each bead is a diamond with a virtical cross- bar. The right and left corners lead to neighboring beads. (This one is difficult to play) 3 - Toroidal Hex Network Imagine a hex tile floor. Take a rectangle with 20 points (inter- sections) inside (4 X 4). Join right and left sides to make a cylinder. Then join top and bottom to form a torus (doughnut). Have fun imagining this one! $pause Caves 0-3 are regular in the sense that each room goes to three other rooms and each tunnel allows two-way traffic. Caves 4 and 5 do not have these properties. 4 - Dendrite with Degeneracies Pull a plant from the ground. The roots and branches form a Dendrite. There are no looping paths. Degeneracy means that some rooms connect to themselves and some rooms have more than one tunnel to the same other room. 5 - One Way Latice Here all tunnels go one way only. To return to the room you just left, you must go all the way around the cave (only 5 moves). GOOD LUCK - HAPPY WUMPUS HUNTING! $pause ======================================================================================== DOCUMENT :usus Folder:VOL04:usus.news.text ======================================================================================== 22 July 1980 TO USERS OF THE UCSD PASCAL USERS' LIBRARY Here's some news from the UCSD Pascal front lines (I am reporting according to the way I saw it, so don't be surprised if others also present interpreted events differently): The UCSD System Users Society (USUS) was formed last month at San Diego. It is a vigorous, alive, and independent organization that right now is oriented to those who plan to make their living using the UCSD system, primarily the Pascal language. It is possible that hobbiest users may play more of a role in the future. SofTech Microsystems organized the meeting and was extremely careful to clearly give it away to the users. The users in turn made no bones about their needs and gripes with SofTech, particularly the importance to them of SofTech's releasing Version 4.0 in the NEAR future. For months the word has been that it's been only a few weeks away from being marketed. The purpose of 4.0 is twofold, I gathered: 1) to clean up the "warts" and weird system dependencies of the UCSD system and to finally remove it from the realm of a highly advanced student project, plus 2) to restore total object-code machine independence, where programs will run unaltered on multiple machines. Most of the users agreed that even more than implementing Pascal on a micro, what they liked most about the UCSD system was its uniformity across multiple systems. TI and Boeing, for instance, chose the UCSD system for these reasons, though the man from Boeing noted that alterations were required for total machine transparency. The delays in releasing 4.0 apparently stem from the intention at SofTech that it be fully compatible with 2.1 (the Apple system) and 3.0 (the Microengine), despite less than optimal cooperation from the manufacturers involved. The things that will be cleaned up include the UNITS system (allowing linkage at runtime, plus a greatly expanded number of available segments), subtle compiler bugs, and a few fixes in the editor and operating system. The minimal facilities for concurrancy present in the Microengine system will apparantly be extended to all. Despite the fact that many people would like to expand the operating system beyond the present single-user development system model, these features won't be changed a great deal at present. The future holds a number of tantalizing possibilities and promises. A major emphasis will be the extension of addressing beyond the present maximum of 64K, requiring (of course) more than 16-bit integer arithmetic as a standard, something I feel is a limitation of the present system anyway. No one has talked about how this will be done and yet retain compatibility with present systems. We need improved error handling that does not all to be done by the user program, so commercial applications programs do not bomb out to the operating system (although there are some tricky, kludgy ways involving a fake SYSTEM.DEBUGGER program that EXITS back to the user program; I know no more). We need a more flexible front end (GETCOMMAND, the main command processor), so writers of business systems can disguise the operating system from the user. There was considerable interest in a UNIX-like operating system with concurrancy, multi-user and multi-tasking capabilities, and shells and pipes. More than likely, this is a good way into the future; first, we've got to get an expanded system going on the new 16-bit micros. Ideas like the ones above aroused considerable interest at the meeting, and the Advanced Planning Special Interest Group was among the best attended. For further information, contact the chairperson, Randy Bush, at 503/572- 5391. It is clear that one of the most important things we users can offer SofTech is a coherent feedback mechanism with courage and clout; this was already very much in evidence in San Diego. Al Irvin of SofTech made an impassioned plea that anyone who has developed new capabilities of the UCSD system contact him for a mutually satisfying discussion concerning SofTech's licensing the new development. I am chairperson of the software library, which will announce offerings in the newsletter and will sell disks in much the same way that I am now, except that there will be: a) multiple distribution centers, b) several software reviewers, each concentrating on a specific area, and c) the requirement that purchasers of the software either be members ($20 per year) or pay a $20 premium per order. Only UCSD-compatible software will be offered, and all policy is being set by a policy board of interested users. Realistically, we will not be shipping USUS software before 1 September. Because of my announcements of software available from me without such restrictions, the group agreed that I should continue as before, although eventually I will continue my operations through the USUS exclusively. Dr. Ken Bowles will be on sabbatical leave next year, and he is making no secret of his next project: to get an Ada compiler going on the UCSD system (P-machine compatible only, I imagine). Because it is no more expensive to have the more distant members of his group work at home and communicate via modem, he plans to implement a full-fledged Telenet host with a hard-disk- based microcomputer. Enough time will be left over on the system to devote to an innovative project: interested users will be invited to subscribe to a users' bulletin board and software supermarket, where users' group software can be downloaded at cost and proprietary programs purchased, all via the phone. The bulletin board would include any comments on the proprietary software users cared to leave, which should (with luck) stimulate the rapid development of reliable, quality UCSD-compatible products. Further, and more important, this concept will help overcome the insane proliferation of incompatible floppy disk formats. One interesting note: the Pascal Transfer Program from Vol. 2A has turned out to be excellent, and has been selected for the "official" modem transfer routine by the group, a step approved by its author, Mark Gang. Thus we can all talk with each other. The protocol used is the PCNET "standard" (Mark indicated that not all aspects of the protocol had been formalized), so that we can talk with non-UCSD processors as well. The program lets you transfer files to another user in both directions at once, while simultaneously conversing on your terminals. The only problem is that program overhead is high and the data rate low; you can expect about 16 char/sec if your line is not too noisy. Mark promised a new version, somewhat incompatible with the old, that involves much more system handshaking to set modem speed and select binary vs Radix-41 (PCNET standard) transmission. We'll probably stick to the old version, since it should run on ANY UCSD system, even on personal computers. I also volunteered to be chairperson of the Medical Special Interest Group, and we dreamed up a project to adapt to the UCSD System whatever we could of the expanse of public-domain clinical applications software, developed under grant. Contact Porter Welbourne, M.D., of Patient Care Data Systems, 418 North Main St., Penn Yan, NY 14527, who volunteered to head up this effort. In addition, we are looking for volunteers to transcribe the programs to UCSD-compatible floppies from 9-track tapes. Other special interest groups include the Newsletter (direct all articles to Keith Shillington, c/o SofTech Microsystems), European, Computer Aided Instruction, Standards, Word Processing, Real-Time Applications, Industrial, and Compatibility and Communications. To join the UCSD System User Society, send a self-addressed envelope to Chip Chapin, Secretary, c/o SofTech Microsystems, 9494 Black Mountain Road, San Diego CA 92126, or use the membership form I sent out with the disks. The next general meeting will be in San Francisco (same time as another, general computer conference) on October 16 to 18, 1980. Tentative cost is $25. Keep in touch. Jim Gagne. ======================================================================================== DOCUMENT :usus Folder:VOL04:volume.4.text ======================================================================================== DOCUMENTATION FOR THE FILES ON THE UCSD PASCAL USERS' LIBRARY VOLUME 4 1. PROF. KEN BOWLES' DATABASE SEED The major portion of the disk is taken up by Prof. Ken Bowles' database seed, which he donated to the users' library as a tutorial on how to build a data structure with records of variable size. Originally, it functioned as the starting point for student homework projects within a course at UCSD. It is not intended as a commercial product, nor as a foundation for one, and is available to users explicitly for noncommercial purposes only. This is not a database system; rather, it is a collection of routines to represent and access data structured in various ways. To get a real database management system, you would have to add a means of logically grouping and structuring your data, as well as a representation-independent user interface. Many of the required utilities are suggested in the documentation as student projects. The file KB.DATABASE.DOC is taken from the handout given to the students. The handout also contained listings of the routines of the data system itself, all of which are present on the disk in source form. Program listing page numbers referenced in the handout are not available, but program line numbers are also given; you should be able to figure out which portions of the programs are being referred to by Dr. Bowles. Missing from the disk are three figures diagramming the heirarchical nature of the data structure, showing that fields and records can be declared recursively and referenced by links of pointers, all within a fixed, 4-kilobyte frame. I have not personally tried out any of the routines, except to run the demo program DBDEMO.TEXT, which must be given the database name "TESTDB" when it asks for the name of the database file. It is complex and fancy. However, I found the comments within the handout illuminating, and I suspect that the many projects suggested by Prof. Bowles within the handout would make fascinating exercises for experienced programmers seeking to learn more about Pascal. I doubt that the database holds more than an example of good programming for beginners, although if you're good at learning on your own and stick with it, you may get quite a bit out of it. Note that the screen control unit KB.SCUNIT.TEXT must be reconfigured for your CRT terminal and then compiled before the rest of the programs will work properly. I have taken care of breaking up DBUNIT.TEXT into smaller chunks that will fit in memory for the E6 editor; remember to compensate for the $I compiler directives when calculating line numbers on the listing. I made no other changes. 2. OTHER ITEMS ON THE DISK INDEX.TEXT is a greatly expanded index (by section, alas not by page) to Jensen and Wirth's PASCAL USER MANUAL AND REPORT. It greatly aids looking up those syntactical queries. COMPARE.TEXT is from the Pascal User Group's PASCAL NEWS No. 12, pp. 20- 23, June, 1978, and was written by James F. Miner, who retains copyright but has released the program for non-profit use. It does a very good job of comparing similar textfiles and pointing out differences. Notably, it is good at discovering chunks of text that are present in one file but not in the other, and then discovering where the files are the same again. The printout is pretty; the runtime is long. It ran well on my system. It is documented further within the source text. COMPRESS.TEXT was written and donated by Ted Beck. It compresses spaces at the beginning of a line of text (changing them to the UCSD blank compression code, 16 [control P or DLE], followed by a byte representing the number of spaces plus 31) and removes blanks at the end of each line. It is intended to shrink files transferred from other operating systems. I found a curious bug when I tried to compile Ted's original program: my 2.0 compiler would die when it confronted a FILLCHAR, MOVELEFT, or MOVERIGHT intrinsic-- everything just stopped. So I altered the program to use more standard Pascal syntax, and it runs well. DISK_COPY.TEXT is Ted Beck's version of MAPPER, the routine available from Western Digital to translate the "standard" RT-11-like UCSD 8-inch disk format to that used by the Microengine. Unlike other versions I have heard about, it will run ONLY on a Microengine, not on other systems (even if recompiled). Since Microengine users can't read this disk without a functioning mapper program, the chief value of this program is that it is available in source form. Because I don't have a Microengine, I have not tried out the program. USUS.NEWS.TEXT tells you all about the new UCSD System Users' Society. WUMPUS hardly needs documentation, and what is required is provided by the program. I thought the author implemented it well. I removed the requirement for asynchronous i/o in order to initialize the random number generator (which ran until a key was pressed), without apparant difficulty. ======================================================================================== DOCUMENT :usus Folder:VOL04:wump.cave0.text ======================================================================================== a Dodecahedron 02 05 08 01 03 10 02 04 12 03 05 14 01 04 06 05 07 15 06 08 17 01 07 09 08 10 18 02 09 11 10 12 19 03 11 13 12 14 20 04 13 15 06 14 16 15 17 20 07 16 18 09 17 19 11 18 20 13 16 19 ======================================================================================== DOCUMENT :usus Folder:VOL04:wump.cave1.text ======================================================================================== a Mobius Strip 20 02 03 19 01 04 01 04 05 02 03 06 03 06 07 04 05 08 05 08 09 06 07 10 07 10 11 08 09 12 09 12 13 10 11 14 11 14 15 12 13 16 12 16 17 14 15 18 15 18 19 16 17 20 02 17 20 01 18 19 ======================================================================================== DOCUMENT :usus Folder:VOL04:wump.cave2.text ======================================================================================== a String of Beads 02 03 20 01 03 04 01 02 04 02 03 05 04 06 07 05 07 08 05 06 08 06 07 09 08 10 11 09 11 12 09 10 12 10 11 13 12 14 15 13 15 16 13 14 16 14 15 17 16 18 19 17 19 20 17 18 20 01 18 19 ======================================================================================== DOCUMENT :usus Folder:VOL04:wump.cave3.text ======================================================================================== a Toroidal Hex Net 19 02 03 20 01 04 01 08 05 02 19 06 03 06 07 04 05 08 05 12 09 06 03 10 07 10 11 08 09 12 09 16 13 10 07 14 11 14 15 12 13 16 13 20 17 14 11 18 15 18 19 16 17 20 17 04 01 18 15 02 ======================================================================================== DOCUMENT :usus Folder:VOL04:wump.cave4.text ======================================================================================== a Dendrite with Degeneracies 01 01 05 02 02 05 03 03 06 04 04 06 01 02 07 03 04 07 05 06 10 08 09 09 08 08 10 07 09 11 10 13 14 12 13 13 11 12 12 11 15 16 14 17 18 14 19 20 15 17 17 15 18 18 16 19 19 16 20 20 ======================================================================================== DOCUMENT :usus Folder:VOL04:wump.cave5.text ======================================================================================== a One Way Lattice 02 16 17 03 17 18 04 18 19 05 19 20 01 20 16 07 01 02 08 02 03 09 03 04 10 04 05 06 05 01 12 06 07 13 07 08 14 08 09 15 09 10 11 10 06 17 11 12 18 12 13 19 13 14 20 14 15 16 15 11 ======================================================================================== DOCUMENT :usus Folder:VOL04:wumpus.text ======================================================================================== program wumpus; { This program was written by Paul J. Gilliam from the basic programs "wumpus 1" and "wumpus 2" in "More BASIC Computer Games", edited by David H. Ahl. The original games were written by Gregory Yob. This game will teach you how to play it. Happy wumpus hunting! (c) 1980 Palouse Software NOTICE: This program was the product of: Palouse Software P.O. Box 2202 Pullman, WA 99163 Permission is hereby given to copy, modify, distribute, and in any other way use this program, provided that this notice is not removed from it. } type room = 1 .. 20; tunnel = 1 .. 3; var cave : array[room, tunnel] of room; initlocate : array[1..6] of room; seed : integer; needhelp : boolean; i, j, arrowcount : integer; {* * The following strings can be used for control of the system console. * The procedure "terminit" must be invoked before any of these are * used. *} cursorhome, cursorup, cursordown, cursorleft, cursorright, clearscreen, clearline, beep : string[2]; procedure terminit; {* * This routine initializes the terminal control strings *} var esc : string[1]; begin {* initialize for TVI-920c *} esc := ' '; esc[1] := chr(27); cursorhome := ' '; cursorhome[1] := chr(26); cursorup := ' '; cursorup[1] := chr(23);; cursordown := ' '; cursordown[1] := chr(10); cursorleft := ' '; cursorleft[1] := chr(8); cursorright := ' '; cursorright[1] := chr(20); clearscreen := ' '; clearscreen[1] := chr(12); clearline := ' '; clearline[1] := chr(21); beep := ' '; beep[1] := chr(7) end { terminit }; FUNCTION RANDOM (VAR SEED : INTEGER) : REAL; {* * This is Algorithm A-1 from Pascal News #12 *} CONST PSHIFT = 1024; { 2 ^ 10 } PMOD = 32; { 2 ^ 5 } QSHIFT = 16; { 2 ^ 4 } VAR A, B : RECORD CASE BOOLEAN OF TRUE : (I : INTEGER); FALSE : (S : PACKED SET OF 0..15); END; BEGIN { EXCLUSIVE OR NUMBER AND NUMBER SHIFTED 4 PLACES } A.I := ABS(SEED); B.I := A.I DIV QSHIFT; { RIGHT SHIFT 4 } A.S := (A.S - B.S) + (B.S - A.S); { XOR } { EXCLUSIVE OR NUMBER AND NUMBER SHIFTED 10 PLACES LEFT } B.I := A.I MOD PMOD * PSHIFT + A.I DIV PMOD; { CIRCULAR LEFT SHIFT 10 } A.S := (A.S - B.S) + (B.S - A.S); { CONVERT TO REAL RESULT } SEED := A.I; RANDOM := A.I / (1.0 + MAXINT) END { RANDOM }; function randomize : char; {* * This routine will step thru random numbers until a key is pressed * on the system console. *} { The next version should work on your system, but I don't know. } (* Paul Gilliam feels that this routine will work on most systems, but in fact only a few UCSD implementations support asynchronous i/o. Apple users and others who have implemented KEYPRESS (a machine-language function true if a console key has been pressed) can use version B; on systems like mine, we'll have to make do with version C, which is the only one not commented out. By the way, if you use version A or B, you can initialize seed with a constant. Jim Gagne *) (* VERSION A: ORIGINAL:*) (*var junk : real; ch : char; begin { randomize } unitread(1{console}, ch, 1,,1{asynch}); while unitbusy(1) do junk := random(seed); randomize := ch end { randomize }; *) (*VERSION B: USING KEYPRESS *) (* VAR junk: real; ch: char; BEGIN {randomize} WHILE NOT Keypress DO junk := random (seed); Read (ch); randomize := ch; END; *) (*VERSION C: SYNCHRONOUS *) VAR junk : real; ch: char; BEGIN junk := random (seed); Read (ch); randomize := ch; END; function randroom : room; begin randroom := trunc(random(seed) * 20) + 1 end { randroom }; function randtunnel : tunnel; begin randtunnel := trunc(random(seed) * 3) + 1 end { randtunnel }; function wumpmove : integer; var i : integer; begin i := trunc(random(seed) * 4) + 1; if i > 3 then wumpmove := -1 else wumpmove := i; end { wumpmove }; function instruct(filename : string) : boolean; {* * This function uses the input from a file to teach the player * how to play the game. When the string "$pause" starts in the * first position of a line in the file, 'instruct' will pause in * its listing of the file until the player hits the space bar. *} var line : string; ifile : text; ch : char; begin { instruct } gotoxy(0,0); write(clearline); write('Do you want instructions on how to play? '); ch := randomize; writeln; instruct := false; if (ch <> 'y') and (ch <> 'Y') then exit(instruct); {$I- } { turn off i/o checking } reset(ifile,filename); {$I+ } { turn on i/o checking } if ioresult <> 0 then begin writeln; writeln('Sorry, instructions not availiable yet.'); exit(instruct) end; instruct := true; gotoxy(0,1); write(clearscreen); while not eof(ifile) do begin; readln(ifile,line); if (line = '$pause') or (line = '$PAUSE') then begin gotoxy(0,0); write(clearline); write('Hit to continue.'); repeat read(keyboard,ch) until ch = ' '; gotoxy(0,23); writeln end else writeln(line) end; end { instruct }; procedure getacave; var i : room; j : tunnel; k : integer; cavename : string; cavein : text; ch : char; begin cavename := 'wump.cave'; k := length(cavename) + 1; cavename := concat(cavename, '$', '.text'); writeln; repeat write('cave #(0-5) '); read(ch); writeln; until ch in ['0'..'5']; cavename[k] := ch; reset(cavein,cavename); writeln('reading ',cavename,' '); readln(cavein, cavename); write('.'); for i := 1 to 20 do begin write('.'); for j := 1 to 3 do read(cavein,cave[i,j]) end; writeln; writeln('you are in ',cavename); writeln; end { getacave }; procedure initsetup; var locatesunique : boolean; i, j : integer; begin repeat for i := 1 to 6 do initlocate[i] := randroom; locatesunique := true; i := 1; while locatesunique and (i <= 6) do begin j := 1; while locatesunique and (j <= 6) do begin if (initlocate[i] = initlocate[j]) and (j <> i) then begin locatesunique := false end else begin j := j + 1 end end; i := i + 1 end; until locatesunique; end { initsetup }; procedure HuntTheWumpus; type long = integer[35]; var i : integer; game : (inprogress, youlost, youwon); locate : array[1..6] of room; escape : char; procedure warnings; var location, i, j: integer; begin writeln; location := locate[1]; for i := 2 to 6 do begin for j := 1 to 3 do begin if cave[location,j] = locate[i] then begin case i of 2 : writeln('I smell a Wumpus!'); 3, 4: writeln('I feel a draft!'); 5, 6: writeln('Bats nearby!'); end end end end; writeln('You are in Room ',location:2); write('Tunnels lead to'); for i := 1 to 3 do write(cave[location,i]:3); writeln; end { warnings }; function wanttoshoot : boolean; var ch : char; begin repeat write('Shoot or move (s-m) '); read(keyboard,ch); writeln; if ch = escape then begin game := youlost; exit(HuntTheWumpus) end; if ch = 'l' then begin write('you = ',locate[1]); write(' wumpus = ',locate[2]); write(' pits = ',locate[3],',',locate[4]); write(' bats = ',locate[5],',',locate[6]); writeln end; until ch in ['m', 'M', 's', 'S']; wanttoshoot := ch in ['S', 's']; end { wanttoshoot }; procedure movewumpus; var i : integer; begin i := wumpmove; if i > 0 then locate[2] := cave[locate[2],i]; if locate[1] = locate[2] then begin writeln('Tsk Tsk Tsk - Wumpus got you!'); game := youlost end; end { movewumpus }; function lint(s : string; var l : long) : integer; var i, j : integer; negitive : boolean; ch : char; begin j := 0; l := 0; lint := -1; negitive := false; for i := 1 to length(s) do begin ch := s[i]; if ch in ['0'..'9'] then begin j := j + 1; if j > 36 then begin lint := -2; exit(lint) end; l := l * 10 + (ord(ch) - ord('0')) end else if ch = '-' then begin if negitive then exit(lint) end else exit(lint); end; if l > maxint then lint := j else lint := 0; if negitive then l := -l; end; procedure doshot; var path : array[1..5] of integer; rooms, i, j, arrow : integer; roomok, targethit : boolean; l : long; ans : string; begin { program the arrow } repeat write('No. of rooms (1-5) '); readln(ans); i := lint(ans, l); rooms := trunc(l); until (i = 0) and (rooms >= 1) and (rooms <= 5); for i := 1 to rooms do begin repeat roomok := true; write('Room # '); readln(ans); j := lint(ans, l); roomok := (j = 0) and (l > 0) and (l < 21); path[i] := trunc(l); if i > 2 then begin if path[i] = path[i-2] then begin writeln('Arrows aren''t that crooked - try another room'); roomok := false end end; if not roomok then write(beep); until roomok; end; { shoot the arrow } arrowcount := arrowcount - 1; I := 1; arrow := locate[1]; repeat roomok := false; for j := 1 to 3 do begin if cave[arrow,j] = path[i] then roomok := true end; if roomok then begin arrow := path[i] end else begin arrow := randroom end; if arrow = locate[1] then begin writeln('OUCH! Arrow got YOU!'); game := youlost end else if arrow = locate[2] then begin writeln('Aha! You got the Wumpus!'); game := youwon end; i := i + 1; until (i > rooms) or (game <> inprogress); if (game = inprogress) and (arrowcount = 0) then begin writeln('Out of arrows!!'); game := youlost end; if game = inprogress then writeln('missed'); movewumpus; end { doshot }; procedure domove; var room, i, location : integer; roomok, movefinished : boolean; l : long; ans : string; begin location := locate[1]; repeat write('Where to? '); readln(ans); roomok := false; i := lint(ans, l); room := trunc(l); if i = 0 then begin for i := 1 to 3 do begin if room = cave[location,i] then roomok := true end; if room = location then roomok := true end; if not roomok then begin writeln('Not possible') end until roomok; location := room; repeat locate[1] := location; movefinished := true; if location = locate[2] then begin writeln('... OOPS! Bumped a Wumpus'); movewumpus end; if game = inprogress then begin if (location = locate[3]) or (location = locate[4]) then begin writeln('YYYIIEEEE . . . Fell in a pit!'); game := youlost end else if (location = locate[5]) or (location = locate[6]) then begin writeln('ZAP -- Super bat snatch! Elsewhereville for you!'); movefinished := false; location := randroom end end until movefinished; end { do move }; begin { huntthewumpus } escape := chr(27); arrowcount := 5; for i := 1 to 6 do locate[i] := initlocate[i]; game := inprogress; writeln; writeln('Hunt the Wumpus'); writeln; while game = inprogress do begin warnings; if wanttoshoot then doshot else domove; end; if game = youwon then writeln('Hee Hee Hee - The Wumpus''ll getcha next time.') else writeln('Ha Ha Ha - You lose!'); end { huntthewumpus }; function newsetup : boolean; var ch : char; begin writeln; repeat write('Same set-up (y-n) '); read(ch); writeln; until ch in ['y', 'Y', 'n', 'N']; newsetup := ch in ['n', 'N']; end { newsetup }; function newcave : boolean; var ch : char; begin writeln; repeat write('Same cave (y-n) '); read(ch); writeln until ch in ['y', 'Y', 'n', 'N']; newcave := ch in ['n', 'N']; end { newcave }; function alldone : boolean; var ch : char; begin writeln; repeat write('Play again (y-n) '); read(keyboard,ch); writeln; until ch in ['y', 'Y', 'n', 'N']; alldone := ch in ['n', 'N']; end { alldone }; begin Write ('Type a four-digit number --> '); Readln (seed); terminit; needhelp := instruct('teach.wumpus'); repeat getacave; repeat initsetup; repeat huntthewumpus; until newsetup until newcave until alldone end { wumpus }. ======================================================================================== DOCUMENT :usus Folder:VOL05:addrs.doc.text ======================================================================================== Monaco's Address Programs Version 2.0 These address programs (STRUCT, UPDATE AND GETSORT) are designed to manage a database of up to 1000 records consisting of "arbitrary records". An "arbitrary" record is simply defined as five strings of text, each string up to 80 characters long, and the fifth string being the "key" by which the records are sorted and accessed. The routines will build the database, allow dynamic updates, and sort the entire database for a printable output file. The selected application presented here is for maintaining an address file, but the source can be easily changed to reflect any application. Use "STRUCT" to convert a standard ascii file (built in the editor called #5:adds.text) to the diskfile #5:address.text. The file #5:adds.text must look like this: Nameline Streetline CitystateZipline Phoneline Keyline Nextnameline etc... Note that no blank intervening lines are permitted, and that no completely blank fields are allowed. Also, the keyline should contain the collating sequence key you want the record accessed by (keys must be, on the whole, unique). Use #5:update.code to update/modify or print mailing labels from the database, and use #5:getsort.code to build a sorted, full copy of #5:address.text called #5:printf.text. You can spool #5:printf.text; do not attempt to use #5:address.text for anything (editor, line printer, etc) as it is a structured file! HINTS: you only have to use #5:struct.code once; #5:update.code and #5:getsort.code do everything for you automatically once you have the structured file #5:address.text. Both #5:update.code and #5:getsort.code will build files of keys (these will magically appear on #5:); do not mess with these phantom files! The user should only ensure that a few free blocks appear right after #5:address.text to allow dynamic file increase. The user should modify the global variables for terminal control in #5:update.text (since I built it for a Hazeltine 1510); see the main program for documentation for what the global terminal variables handle. When #5:update.code prompts for a key, the first record in address.text having the string typed after the prompt will be retrieved; the entire key need not be typed! Also, if the key is not found, update will prompt for another try. Update understands "stop" and "print" as reserved keys with obvious meanings. Last, when adding new records with new keys, bracket the key field with "*" as "*keyfield*". Notice that character cases are important in keys! The user will find the program #5:getsort.text extremely instructional in tech- niques of sorting large files with little memory... Please address comments to: Cpt Francis J. Monaco Department of Geography and Computer Science The United States Military Academy West Point, New York 10996 ======================================================================================== DOCUMENT :usus Folder:VOL05:catalog.5.text ======================================================================================== VOLUME 5 CATALOG UCSD PASCAL USERS' LIBRARY Many software tools written by Frank Monaco and me, plus a few odds and ends ADDRS.DOC.TEXT 10 Doc for STRUCT, UPDATE, and GETSORT address database. CRTINPUT.TEXT 20 A tuned-up string, boolean & textfile input package. DIR.TEXT 16 See the directory, double-column & alphabetized, with file date & size, plus a list of unused areas. DISKREAD.TEXT 26 Similar to UCSD's PATCH, lets you alter disks directly. FMT.1.5.CODE 27 Frank's text formatter program -- tell him how you FMT.2.0.CODE 26 like it -- code for UCSD versions I.5 & 2.0. FMT.EXAMP.TEXT 16 Sample text for FMT - "before" version of READ.DISKR. GETNUMBER.TEXT 30 Fancy, sophisticated integer & decimal input routines. GETSORT.TEXT 12 Part of the mailing list "database" system. HEXDECOCT.TEXT 18 Convert integers any way you want: HEX, DECimal, OCTal. ID2ID.TEXT 36 From the PASCAL NEWS No. 15, converted by Frank. Lets you change one or more identifiers in Pascal source to others of your choice. MAKEMASKS.TEXT 18 Allows you to edit SUPER CRT masks, put them on disk. MONACO.DOC.TEXT 14 Documentation for some of the files on this disk. PEEK.POKE.TEXT 8 Thought you couldn't PEEK or POKE? Shows you how. QUICKSORT.TEXT 4 Example of fast disk sorting algorithm. READ.DISKR.TEXT 24 Documentation for DISKREAD and example of FMT at work. READ.FMT.TEXT 82 Documentation for FMT.x.x.CODE and example of output. SCREENCNTL.TEXT 4 Example of SEPARATE UNITS, with some nice routines. SOFT.TOOLS.DOC 18 Doc for CRTINPUT, GETNUMBER, MAKEMASKS, & SCREENCNTL. SP.TEXT 14 Allows your line printer to follow FORTRAN conventions. STRUCT.TEXT 8 Part of the mailing address "database" system. UNIT.GOOD.TEXT 22 Should be called WONDERSTUFF; solves those nagging terminal dependencies for good, plus allows you to read the directory from any disk, get date, etc. UPDATE.TEXT 22 Part of the mailing address "database" system. NOTE: The UCSD Pascal Users' Library material may be used only in accordance with policy outlined elsewhere. No commercial use may be made of these routines without the written permission of the authors. ======================================================================================== DOCUMENT :usus Folder:VOL05:crtinput.text ======================================================================================== UNIT CRTINPUT; {Special procedures for controlled CRT input of string, textfile, and boolean variables. COPYRIGHT (c) 1980, James Gagne, President DATAMED RESEARCH 1433 Roscomare Road Los Angeles, CA 90024 213/472-8825 ALL RIGHTS RESERVED. These routines may be used for nonprofit, non- commercial purposes only, unless written consent of the author is obtained.} INTERFACE TYPE FileAction = (GetOld, Create) {equivalent to Reset/Rewrite}; FNameString = string [30]; chset = set OF char; PROCEDURE AllCaps (VAR s:string); {convert string to all capital letters} FUNCTION GetLetter (y: integer; s: string; cset: chset): char; { Writes S at line Y; reads w/o echo, converting alpha to upper case, until char is in CSET, then returns this char after erasing line Y. The cursor is not moved if Y < 0 or > 23.} PROCEDURE GetString (MaxLength: integer; VAR Typed: string); {See description in IMPLEMENTATION section.} FUNCTION OpenTextFile (Prompt: string {your request for the filename}; VAR FileName: FNameString{filename string}; Action: FileAction {"GetOld" or "Create"}; Startline: integer {linenumber on which to start dialogue}; VAR F: text {file to be opened}) : boolean {true = file opened; false = user aborted}; PROCEDURE GetBoolean (x, y: integer; VAR DesiredValue: boolean); IMPLEMENTATION CONST {ASCII characters} etx = 3; bel = 7; bs = 8; htab = 9; esc = 27; del = 127; RCurs = 18 {Control R ==> move cursor right}; ErrorLine = 23 {last line on screen is for error messages}; VAR Response, ch, EscapeCh: char; PROCEDURE GoAndClearLine (y: integer); EXTERNAL; FUNCTION Yes (prompt: string) : boolean; EXTERNAL; PROCEDURE OptionalGotoxy (x,y: integer); {Leave the cursor where it is if x or y is < 0} BEGIN IF (x >= 0) AND (y >= 0) THEN Gotoxy (x,y); END; PROCEDURE AllCaps {(VAR s:string)}; VAR i, LittletoBig : integer; BEGIN LittletoBig := ORD ('A') - ORD ('a'); FOR i := 1 TO Length (s) DO IF s[i] IN ['a'..'z'] THEN s[i] := CHR (Ord (s[i]) + LittletoBig); END; FUNCTION GetLetter {(y: integer; s: string; cset: chset): char}; VAR ch: char; BEGIN IF (y>=0) AND (y<24) THEN GoAndClearLine(y); Write(s); REPEAT Read(keyboard, ch); IF (ch IN ['a'..'z']) THEN ch := CHR( ORD(ch) + ORD('A') - ORD('a') ) UNTIL ch IN cset; IF (y >= 0) AND (y < 24) THEN GoAndClearLine (y) ELSE writeln(ch); GetLetter := ch END; {GETSTRING does the following: This routine first types the original string (Typed), followed by dots to the maximum string length. If any char is typed but ETX or ESCAPE, the original string is replaced by a row of dots to the maximum length of the string as passed by the calling routine. GetString then reads characters until terminated by a typed return or escape or at the point that the string is filled by the maximum allowed characters. Typing a control R at any point will fill that character with one from the original string; a horizontal tab will either fill in text, or add spaces, depending on whether the end of the original string has been reached. If at any time escape is typed, the original string (TYPED) is restored and the procedure terminated. Otherwise, either a return or a full string are taken as end-of-string. Backspace and Delete work per the usual UCSD standard.} PROCEDURE GetString {(MaxLength: integer; VAR Typed: string[255])}; CONST MaxString = 250; FillChar = '.'; VAR j, k, MaxL, StringLength: integer; ReadCh: boolean; HTabCh, backsp, DeleteCh: char; Newstring: String[MaxString]; Didtype: PACKED ARRAY [1..MaxString] OF char; BEGIN IF MaxLength > MaxString THEN MaxL := MaxString ELSE MaxL := MaxLength; IF MaxLength = 0 THEN BEGIN Typed := ''; Exit (GetString); END; backsp := CHR (bs); HTabCh := CHR (Htab); EscapeCh := CHR (esc); DeleteCh := CHR (del); REPEAT {loop repeated only if DELETE typed} StringLength := LENGTH (typed); IF StringLength > MaxL THEN BEGIN Delete (Typed, MaxL+1, StringLength-MaxL); StringLength := LENGTH (typed); END; Write (typed); FOR j := StringLength+1 TO maxlength DO Write (FillChar); FOR j := 1 TO Maxlength DO write (backsp); Read (Keyboard, ch); IF ch = EscapeCh THEN BEGIN Write (typed, ' ': MaxL - StringLength); EXIT (GetString) END ELSE BEGIN IF ch = CHR (etx) THEN ReadCh := true ELSE BEGIN {If the 1st char <> control C,} ReadCh := false; {then erase original string. } FOR j := 1 TO StringLength DO Write (FillChar); FOR j := 1 TO StringLength DO Write (backsp); END; j := 1; REPEAT IF ReadCh THEN Read (keyboard, ch); ReadCh := true; IF (ch = CHR (RCurs)) AND (j <= StringLength) THEN BEGIN {The Right-cursor character will keep one } ch := Typed [j]; {character at a time from the original string.} Write (ch); Didtype[j] := ch; j := j + 1 END ELSE IF (ch >= ' ') AND (ch < DeleteCh) THEN BEGIN Write (ch); Didtype[j] := ch; j := j + 1 END ELSE IF ch = HTabCh THEN REPEAT IF j <= StringLength THEN ch := Typed [j] ELSE ch := ' '; Write (ch); Didtype [j] := ch; j := j + 1 UNTIL (j MOD 8 = 1) OR (j > MaxL) ELSE IF (ch = backsp) AND (j > 1) THEN BEGIN Write (backsp, FillChar, backsp); j := j - 1; END UNTIL (j > MaxL) OR (ch IN [EscapeCh, DeleteCh]) OR EOLN (keyboard); k := j - 1; IF EOLN (keyboard) AND (k = 1) THEN k := 0; FOR j := 1 TO k DO Write (backsp); END UNTIL ch < DeleteCh; IF ch <> EscapeCh THEN BEGIN NewString := ''; FOR j := 1 TO k DO BEGIN NewString := CONCAT (NewString, ' '); NewString [j] := Didtype [j] END; Typed := NewString END; {else typed is left alone} Write (typed, ' ':(maxlength - Length (typed))); END (*GetString*); PROCEDURE WriteErr (Message: string); BEGIN Gotoxy (0, ErrorLine); Write (CHR (bel), '-** ERROR **- ', Message, '. Tap to continue...'); REPEAT Read (keyboard, ch) UNTIL ch = ' '; GoAndClearLine (ErrorLine) END; {OPENTEXTFILE will open a textfile, prompting at lines STARTLINE to STARTLINE+3 --except for the error message, which is always at the bottom of the screen. It returns the filename and the opened file. ".TEXT" is added to any filename that needs it. It returns false if the user quit.} FUNCTION OpenTextFile {(Prompt: string; VAR FileName: FNameString; Action: FileAction; Startline: integer; VAR F: text) : boolean}; VAR gotfn: boolean; Typed: string [255]; BEGIN REPEAT GoAndClearLine (StartLine); GoAndClearLine (StartLine+1); GoAndClearLine (StartLine+2); GoAndClearLine (StartLine+3); Gotoxy (5,StartLine); Write (Prompt); Gotoxy (15,StartLine+1); Write ('--> '); Gotoxy (8,StartLine+2); Write (' (Or just press the key if you wish to quit.)'); Typed := ''; Gotoxy (20, StartLine+1); GetString (23, Typed); IF (typed = ' ') OR (typed = '') THEN BEGIN GoAndClearLine (StartLine+3); Gotoxy (11,StartLine+3); IF Yes ('Would you prefer to skip this file') THEN BEGIN OpenTextFile := false; EXIT (OpenTextFile); END; GoAndClearLine (StartLine+3); END ELSE BEGIN FileName := Typed; AllCaps (FileName); (*$I-*) IF Action = getold THEN BEGIN Reset (F, typed); IF IORESULT > 0 THEN Reset (F, CONCAT (typed, '.TEXT')) END ELSE BEGIN IF (POS ('.TEXT', typed) = 0) THEN typed := CONCAT (typed, '.TEXT'); Rewrite (F, typed); END; (*$I+*) Gotfn := IORESULT = 0; IF NOT Gotfn THEN CASE IORESULT OF 1, 4: WriteErr ('Please check your disk--hardware problem'); 2: WriteErr ('Unit number is incorrect'); 5, 9: WriteErr ('Unit or Volume is off line at present'); 6, 10: WriteErr ('Can''t find this file on this disk'); 7: WriteErr ('Illegal file name...probably too long'); 8: WriteErr ('No room on this disk for this file'); END; END(*else*) UNTIL Gotfn; OpenTextFile := true END; {GETBOOLEAN is a routine to read in a boolean variable; gotoxy is optional as before. If you don't want GOTOXY, consider also 'YES' from SCREENCONTROL.} PROCEDURE GetBoolean {(x, y: integer; VAR DesiredValue: boolean)}; VAR ch: char; DontGotoxy: boolean; BEGIN DontGotoxy := (x<0) OR (y<0); Escapech := CHR (esc); IF NOT DontGotoxy THEN BEGIN GoAndClearLine (22); Write (' Type "Y" for yes, or "N" for no.'); Gotoxy (x,y); END; REPEAT Read (keyboard, ch) UNTIL (ch IN ['Y', 'y', 'T', 't', 'N', 'n', 'F', 'f', EscapeCh]); CASE ch OF 'Y', 'y', 'T', 't': BEGIN Write ('YES'); DesiredValue := true END; 'N', 'n', 'F', 'f': BEGIN Write (' no'); DesiredValue := false END END; IF NOT DontGotoxy THEN GoAndClearLine (22) END; END. ======================================================================================== DOCUMENT :usus Folder:VOL05:dir.text ======================================================================================== PROGRAM DIR; { This program was originally written by Frank Monaco, I believe, and appears in its original form as part of UNIT.GOOD. I've been hankering after a decent directory lister for a while; so I took over and basically rewrote the program, though chunks of Frank's code are scattered here and there. Now I like it. You may feel the screen is too cluttered and want to remove the last column of the directory list, the first block no., but I find this useful. Meagre attempts were made to format the display properly for terminals with less than 80-column lines, though you will have to pay attention to that if you have a narrow screen. It should work OK for terminals of any number of lines if you correct the constant LastLine. The constant UserPicksUnit gives you the option (at compile time) to fix the unit # of the directory to be displayed, or to ask for it at run time. This program is for NONcommercial use only, without written permission from the authors. Jim Gagne, Datamed Research, 1433 Roscomare Road, Los Angeles, California 90024.} CONST ScreenWidth = 80; LastLine = 23; {last line no. on screen, starting from line 0.} MaxDirEnt = 77; Testing = true; UserPicksUnit = true; {if false, name the program by the unit number and just type, for example, "X)ecute 4" to see the directory of Unit 4} FixedUnitNum = 4; {used only if UserPicksUnit = false; choose whichever unit you want to display} TYPE DATEREC = PACKED RECORD MONTH: 0..12; DAY: 0..31; YEAR: 0..100 END; DIRRANGE = 0..MaxDirEnt; VID = STRING[7]; TID = STRING[15]; FILEKIND = (UNTYPED,XDISK,CODE,TEXT, INFO,DATA,GRAF,FOTO,SECUREDIR); DIRENTRY = RECORD DFIRSTBLK: INTEGER; DLASTBLK: INTEGER; CASE DFKIND:FILEKIND OF SECUREDIR,UNTYPED: (DVID:VID; DEOVBLK, DLOADTIME, DBLOCKS:INTEGER; DLASTBOOT:DATEREC); XDISK,CODE,TEXT,INFO,DATA, GRAF,FOTO: (DTID:TID; DLASTBYTE:1..512; DACCESS:DATEREC) END; DIRP = ^DIRECTORY; DIRECTORY = ARRAY[DIRRANGE] OF DIRENTRY; VAR UNITNUM, I, J, RoomLeft, TotlBlocks, SCount, FCount, DirLinesThatFit: INTEGER; CHBUF : char; IdxArry: ARRAY [DIRRANGE] OF Integer; BUFR: PACKED ARRAY[0..2048] OF CHAR; DIRX: DIRECTORY; PROCEDURE AlphabetizeDirectory; VAR i, j, k, temp: integer; Done: boolean; BEGIN Write (i, j); {I don't know why I need this statement, but without it I get a value range error, because the assignment statements for i & j do not appear to execute.} i := 1; j := Dirx[0].DLOADTIME; REPEAT IF Length (DIRX[i].DTID) > 0 THEN IdxArry[i] := i ELSE IdxArry[i] := 0; i := i + 1 UNTIL i > j; FOR i := 2 TO DIRX[0].DLOADTIME DO IF IdxArry[i] > 0 THEN BEGIN j := i; k := j; REPEAT k := k - 1 UNTIL (IdxArry [k] > 0) OR (k = 0); Done := false; REPEAT IF (k > 0) AND (j > 1) THEN IF (DIRX [IdxArry [j]].DTID < DIRX [IdxArry [k]].DTID) THEN BEGIN temp := IdxArry[k]; IdxArry[k] := IdxArry[j]; IdxArry[j] := temp; j := j - 1; k := j; REPEAT k := k-1 UNTIL (IdxArry[k] > 0) OR (k = 0); END ELSE Done := true ELSE Done := true UNTIL Done; END {then}; END {AlphabetizeDirectory}; PROCEDURE WriteDate (Date: DateRec); BEGIN WITH Date DO BEGIN WRITE(DAY:3,'-'); CASE MONTH OF 1: WRITE('Jan'); 2: WRITE('Feb'); 3: WRITE('Mar'); 4: WRITE('Apr'); 5: WRITE('May'); 6: WRITE('Jun'); 7: WRITE('Jul'); 8: WRITE('Aug'); 9: WRITE('Sep'); 10: WRITE('Oct'); 11: WRITE('Nov'); 12: WRITE('Dec'); END {case}; WRITE('-',YEAR:2); END {with}; END; PROCEDURE ListUnusedBlocks; VAR i, j, Next: integer; BEGIN i := 1; WHILE (Length (DIRX[0].DTID) = 0) AND (i < TotlBlocks) DO i := i + 1; Next := DIRX[i].DLASTBLK; Write ('Unused blocks = '); FOR i := i + 1 TO DIRX[0].DLOADTIME DO WITH DIRX[i] DO IF Length (DTID) > 0 THEN BEGIN IF DFIRSTBLK > Next THEN Write (Next, '-', DFIRSTBLK - 1, '=', DFIRSTBLK - Next, ', '); Next := DLASTBLK; END; IF Next < TotlBlocks THEN Write (Next, '-', TotlBlocks - 1, '=', TotlBlocks - Next) END; BEGIN IF UserPicksUnit THEN BEGIN {note: extend the prompt if you really do have units 9 & 10 on line} WRITE ('Enter the unit number (4 or 5) for the directory you wish --> '); REPEAT Read (keyboard, chbuf) UNTIL (chbuf IN ['4', '5', '9', '1']); Unitnum := ORD (chbuf) - ORD ('0'); IF Unitnum = 1 then Unitnum := 10; Writeln (Unitnum); END ELSE Unitnum := FixedUnitNum; {$I-} UNITREAD(UNITNUM,DIRX[0],2048,2); {$I+} IF IORESULT <> 0 THEN BEGIN WRITELN('Unit No. ', Unitnum, 'is not on line.'); EXIT(DIR); END; AlphabetizeDirectory; Gotoxy (0,LastLine); Writeln; Writeln; Writeln; {clear screen} Gotoxy ((ScreenWidth - 44) DIV 2, 1); WITH DIRX[0] DO BEGIN WRITELN ('Directory of Unit #', Unitnum, ' -**- Volume ', DVID,':'); RoomLeft := DBLOCKS; TotlBlocks := DBLOCKS; END; I := 1; WHILE (Length (DIRX[I].DTID) = 0) AND (I < DIRX[0].DLOADTIME) DO I := I + 1; RoomLeft := RoomLeft - DIRX[I].DFIRSTBLOCK; SCount := 0; FCount := 0; DirLinesThatFit := LastLine - 4; FOR I:=1 TO DIRX[0].DLOADTIME DO BEGIN IF IdxArry[I] > 0 THEN WITH DIRX[IdxArry[I]] DO BEGIN Gotoxy ((SCount DIV DirLinesThatFit) * 40, (SCount MOD DirLinesThatFit) + 3); SCount := SCount + 1; J := DLASTBLK-DFIRSTBLK; WRITE(DTID,' ':16-LENGTH(DTID), J: 3, ' '); RoomLeft := RoomLeft - J; WriteDate ( DACCESS ); Write (DFIRSTBLK:5); END {then}; if SCount mod (DirLinesThatFit * 2) = 0 then begin gotoxy ((ScreenWidth - 32) DIV 2, LastLine); write ('tap to continue '); SCount := 0; FCount := FCount + (DirLinesThatFit * 2); repeat read ( chbuf ) until chbuf = ' '; end; END {for}; Gotoxy ((ScreenWidth - 52) DIV 2, LastLine-1); SCount := SCount + FCount; Write (SCount); IF SCount = 1 THEN Write (' file; ') ELSE Write (' files; '); Writeln (TotlBlocks - RoomLeft, ' blocks used, ', RoomLeft, ' remaining, ', TotlBlocks, ' total.'); ListUnusedBlocks; END. ======================================================================================== DOCUMENT :usus Folder:VOL05:diskread.text ======================================================================================== PROGRAM DISKREAD; (*$I-,R-*) (*$C DISKREAD BY ROGER L. SOLES - GEORGIA INSTITUTE OF TECHNOLOGY *) CONST STATUS = 2; PROMPT = 4; MAXBLOCKS = 493; (* NUMBER OF BLOCKS ON DISK *) TYPE CRTCOMMAND = (ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT,LEADIN); VAR MODE: (ASCII, HEX); ST: STRING; CH,BELL: CHAR; UNITNUM,BLOCKNUM: INTEGER; I,J,K: INTEGER; BUF: PACKED ARRAY [0..511] OF 0..255; CRTINFO: PACKED ARRAY[CRTCOMMAND] OF CHAR; PREFIXED: ARRAY[CRTCOMMAND] OF BOOLEAN; PROCEDURE GETCRTINFO; (* READ SYSTEM.MISCINFO AND GET CRT CONTROL CHARACTER INFO *) VAR BUFFER: PACKED ARRAY[0..511] OF CHAR; BYTE: INTEGER; F: FILE; BEGIN RESET(F,'*SYSTEM.MISCINFO'); I := BLOCKREAD(F,BUFFER,1); CLOSE(F); BYTE := ORD(BUFFER[72]); (* PREFIX INFORMATION BYTE *) CRTINFO[LEADIN] := BUFFER[62]; PREFIXED[LEADIN] := FALSE; CRTINFO[ERASEOS] := BUFFER[64]; PREFIXED[ERASEOS] := ODD(BYTE DIV 8); CRTINFO[ERASEOL] := BUFFER[65]; PREFIXED[ERASEOL] := ODD(BYTE DIV 4); CRTINFO[RIGHT] := BUFFER[66]; PREFIXED[RIGHT] := ODD(BYTE DIV 2); CRTINFO[UP] := BUFFER[67]; PREFIXED[UP] := ODD(BYTE); CRTINFO[LEFT] := BUFFER[68]; PREFIXED[LEFT] := ODD(BYTE DIV 32); CRTINFO[DOWN] := CHR(10); PREFIXED[DOWN] := FALSE; END; (* GETCRTINFO *) PROCEDURE CRT(C: CRTCOMMAND); (* CRT COMMANDS ARE: ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT *) BEGIN IF PREFIXED[C] THEN UNITWRITE(1,CRTINFO[LEADIN],1,0,12); UNITWRITE(1,CRTINFO[C],1,0,12); END; (* CRT *) PROCEDURE PRINTBYTE(BYTE: INTEGER); (* PRINT A BYTE AS A HEXSTRING *) BEGIN IF BYTE > 255 THEN BEGIN PRINTBYTE(BYTE DIV 256); PRINTBYTE(BYTE MOD 256); END ELSE BEGIN IF (BYTE DIV 16) IN [0..9] THEN WRITE(CHR((BYTE DIV 16) + ORD('0'))) ELSE WRITE(CHR((BYTE DIV 16) - 10 + ORD('A'))); IF (BYTE MOD 16) IN [0..9] THEN WRITE(CHR((BYTE MOD 16) + ORD('0'))) ELSE WRITE(CHR((BYTE MOD 16) - 10 + ORD('A'))); END; END; (* PRINTBYTE *) FUNCTION CVI(ASCII:STRING): INTEGER; (* CONVERT AN INPUT STRING, EITHER DECIMAL OR HEX, TO AN INTEGER *) VAR BASE,MPY,X,RV: INTEGER; BEGIN BASE := 10; IF POS('$',ASCII) <> 0 THEN BASE := 16; MPY := 1; RV := 0; FOR X:=LENGTH(ASCII) DOWNTO 1 DO CASE BASE OF 10 : BEGIN IF ASCII[X] IN ['0'..'9'] THEN BEGIN RV := RV+(MPY*(ORD(ASCII[X])-ORD('0'))); MPY := MPY*10; END; END; 16 : BEGIN IF ASCII[X] IN ['0'..'9'] THEN BEGIN RV := RV+(MPY*(ORD(ASCII[X])-ORD('0'))); MPY := MPY*16; END; IF ASCII[X] IN ['A'..'F'] THEN BEGIN RV := RV+(MPY*(ORD(ASCII[X])-ORD('A')+10)); MPY := MPY*16; END; IF ASCII[X] IN ['a'..'f'] THEN BEGIN RV := RV+(MPY*(ORD(ASCII[X])-ORD('a')+10)); MPY := MPY*16; END; END; END; (* CASE OF *) CVI := RV; END; (* CVI *) PROCEDURE BASECALC (VAR X,Y,BYTE: INTEGER); (* CALCULATE THE SCREEN BASE ADDRESS FOR ANY BYTE OF THE BUFFER *) VAR TEMP: INTEGER; BEGIN Y := (BYTE DIV 32) + 7; TEMP := (BYTE MOD 32) DIV 8; CASE TEMP OF 0: X := (BYTE MOD 8) * 2 + 6; 1: X := (BYTE MOD 8) * 2 + 25; 2: X := (BYTE MOD 8) * 2 + 44; 3: X := (BYTE MOD 8) * 2 + 63; END; (* CASE OF *) END; (* BASECALC *) PROCEDURE DISHEX; (* DISPLAY THE BUFFER IN HEX *) VAR X,Y,I: INTEGER; BEGIN I := 0; REPEAT BASECALC(X,Y,I); GOTOXY(X,Y); FOR J:=0 TO 7 DO PRINTBYTE(BUF[I+J]); I := I+8; UNTIL I >= 511; END; (* DISHEX *) PROCEDURE DISASCII; (* DISPLAY THE BUFFER IN ASCII - ONLY VALID ASCII CODES ARE DISPLAYED *) VAR CH: CHAR; X,Y,I: INTEGER; BEGIN I := 0; REPEAT BASECALC(X,Y,I); GOTOXY(X,Y); FOR J:=0 TO 7 DO BEGIN CH := CHR(BUF[I+J]); IF NOT( CH IN [' '..'}']) THEN CH := ' '; WRITE(CH:2); END; I := I+8; UNTIL I >= 511; END; (* DISASCII *) PROCEDURE DISBLOCK; (* DISPLAY CURRENT BLOCK NUMBER IN DECIMAL AND HEX *) BEGIN GOTOXY(8,STATUS); WRITE(BLOCKNUM:3,' $'); PRINTBYTE(BLOCKNUM DIV 256); PRINTBYTE(BLOCKNUM MOD 256); END; (* DISBLOCK *) PROCEDURE DISUNIT; (* DISPLAY CURRENT UNIT NUMBER IN DECIMAL AND HEX *) BEGIN GOTOXY(71,STATUS); WRITE(UNITNUM:2,' $'); PRINTBYTE(UNITNUM); END; (* DISUNIT *) PROCEDURE DISMODE; (* DISPLAY CURRENT DISPLAY MODE *) BEGIN GOTOXY(37,STATUS); CASE MODE OF ASCII: WRITE('ASCII'); HEX: WRITE(' HEX '); END; (* CASE OF *) END; (* DISMODE *) PROCEDURE DISPLAY(I: INTEGER); (* DISPLAY A BYTE IN THE BUFFER IN THE CURRENT DISPLAY MODE *) VAR X,Y: INTEGER; BEGIN BASECALC(X,Y,I); GOTOXY(X,Y); CASE MODE OF ASCII: BEGIN CH := CHR(BUF[I]); IF NOT(CH IN [' '..'}']) THEN CH := ' '; WRITE(CH:2); END; HEX : PRINTBYTE(BUF[I]); END; (* CASE OF *) END; (* DISPLAY *) PROCEDURE CHANGE; (* CHANGE VALUE OF A BYTE IN THE BUFFER - INPUT HEX OR DECIMAL *) VAR DONE: BOOLEAN; BEGIN WRITE('ADDRESS: '); READLN(ST); I := CVI(ST); DONE := FALSE; REPEAT GOTOXY(0,PROMPT); CRT(ERASEOL); WRITE('('); PRINTBYTE(I); WRITE(') = '); PRINTBYTE(BUF[I]); WRITE(': '); READLN(ST); IF LENGTH(ST) = 0 THEN DONE := TRUE ELSE BEGIN K := CVI(ST) MOD 256; BUF[I] := K; DISPLAY(I); END; I := I+1; IF I > 511 THEN DONE := TRUE; UNTIL DONE; END; (* CHANGE *) PROCEDURE STRINGCHANGE; (* CHANGE BYTES IN THE BUFFER - INPUT ASCII STRING *) BEGIN WRITE('ADDRESS: '); READLN(ST); I := CVI(ST) MOD 512; GOTOXY(0,PROMPT); CRT(ERASEOL); WRITE('('); PRINTBYTE(I); WRITE('): '); READLN(ST); IF LENGTH(ST) <> 0 THEN FOR J:=0 TO LENGTH(ST)-1 DO BEGIN K := I+J; BUF[K] := ORD(ST[J+1]); DISPLAY(K); END; END; (* STRINGCHANGE *) PROCEDURE MEMORYUPDATE; (* CHANGE A BLOCK OF VALUES IN THE BUFFER - INPUT HEX OR DECIMAL *) VAR VALUE: INTEGER; BEGIN WRITE('STARTING ADDRESS: '); READLN(ST); I := CVI(ST) MOD 512; GOTOXY(0,PROMPT); CRT(ERASEOL); WRITE('ENDING ADDRESS: '); READLN(ST); J := CVI(ST) MOD 512; IF I > J THEN EXIT(MEMORYUPDATE); GOTOXY(0,PROMPT); CRT(ERASEOL); WRITE('BYTE: '); READLN(ST); VALUE := CVI(ST) MOD 256; FOR K:=I TO J DO BEGIN BUF[K] := VALUE; DISPLAY(K); END; END; (* MEMORYUPDATE *) PROCEDURE INIT; (* INITIALIZE THE SCREEN, THIS NEED NO BE DONE AGAIN! *) BEGIN BELL := CHR(7); BLOCKNUM := 0; UNITNUM := 4; MODE := HEX; GOTOXY(0,0); CRT(ERASEOS); WRITELN('Roger L. Soles Disk Block Read/Write/Modify':61); GOTOXY(0,STATUS); WRITE('BLOCK:'); GOTOXY(64,STATUS); WRITE('UNIT:'); GOTOXY( 5,5); WRITE('00'); GOTOXY(21,5); WRITE('07'); GOTOXY(24,5); WRITE('08'); GOTOXY(40,5); WRITE('0F'); GOTOXY(43,5); WRITE('10'); GOTOXY(59,5); WRITE('17'); GOTOXY(62,5); WRITE('18'); GOTOXY(78,5); WRITE('1F'); GOTOXY(5,6); FOR I:=5 TO 80 DO WRITE('_'); FOR I:=0 TO 15 DO BEGIN GOTOXY(0,I+7); PRINTBYTE(I*2); WRITE('0 |'); END; DISBLOCK; DISUNIT; DISMODE; FOR I:=0 TO 511 DO BUF[I] := 0; END; (* INIT *) PROCEDURE COMMAND; (* GET AND PROCESS A COMMAND - ADD MORE HERE *) VAR DONE: BOOLEAN; BEGIN DONE := FALSE; REPEAT GOTOXY(0,PROMPT); CRT(ERASEOL); READ(CH); CRT(LEFT); CASE CH OF 'A','a' : BEGIN (* DISPLAY BUFFER IN ASCII *) IF MODE <> ASCII THEN BEGIN MODE := ASCII; DISMODE; DISASCII; END; END; 'H','h' : BEGIN (* DISPLAY BUFFER IN HEX *) IF MODE <> HEX THEN BEGIN MODE := HEX; DISMODE; DISHEX; END; END; 'R','r' : BEGIN (* READ CURRENT UNIT/BLOCK *) UNITREAD(UNITNUM,BUF,512,BLOCKNUM); IF IORESULT = 0 THEN BEGIN CASE MODE OF ASCII: DISASCII; (* DISPLAY ASCII *) HEX: DISHEX; (* DISPLAY HEX *) END; (* CASE OF *) END ELSE BEGIN GOTOXY(0,PROMPT); CRT(ERASEOL); WRITE(BELL,'I/O ERROR: Please check unit status'); READLN; END; END; 'W','w' : BEGIN (* WRITE CURRENT UNIT/BLOCK *) WRITE('Update disk block ? '); READ(CH); IF CH IN ['Y','y'] THEN BEGIN UNITWRITE(UNITNUM,BUF,512,BLOCKNUM); IF IORESULT <> 0 THEN BEGIN GOTOXY(0,PROMPT); CRT(ERASEOL); WRITE(BELL,'I/O ERROR: Please check unit status' ); READLN; END; END; END; ';','+' : BEGIN (* INCREASE BLOCK *) BLOCKNUM := BLOCKNUM + 1; IF BLOCKNUM > MAXBLOCKS THEN BLOCKNUM := 0; DISBLOCK; END; '=','-' : BEGIN (* DECREASE BLOCK *) BLOCKNUM := BLOCKNUM - 1; IF BLOCKNUM < 0 THEN BLOCKNUM := MAXBLOCKS; DISBLOCK; END; 'B','b' : BEGIN (* SET BLOCK NUMBER *) WRITE('BLOCK: '); READLN(ST); BLOCKNUM := CVI(ST); IF BLOCKNUM > MAXBLOCKS THEN BLOCKNUM := MAXBLOCKS; IF BLOCKNUM < 0 THEN BLOCKNUM := 0; DISBLOCK; END; 'U','u' : BEGIN (* SET UNIT NUMBER *) WRITE('UNIT: '); READLN(ST); UNITNUM := CVI(ST); IF NOT(UNITNUM IN [4,5,9..12]) THEN UNITNUM := 4; DISUNIT; END; 'C','c' : CHANGE; (* BLOCK CHANGE *) 'S','s' : STRINGCHANGE; (* STRING CHANGE *) 'M','m' : MEMORYUPDATE; (* MEMORY UPDATE *) 'Q','q' : BEGIN (* QUIT PROGRAM *) GOTOXY(0,0); CRT(ERASEOS); DONE := TRUE; END; END; (* CASE OF *) UNTIL DONE; END; (* COMMAND *) BEGIN (* MAIN PROGRAM *) GETCRTINFO; INIT; COMMAND; END. ======================================================================================== DOCUMENT :usus Folder:VOL05:fmt.1.5.code ======================================================================================== < binary file -- not listed > O^ ======================================================================================== DOCUMENT :usus Folder:VOL05:fmt.2.0.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL05:fmt.examp.text ======================================================================================== .lpt .sp+ 25 .tl Disk Block Read/Write/Modify .sp+ 2 .tl by .sp+ 2 .tl Roger L. Soles .sp+ 2 .tl Georgia Institute of Technology .tl Box 36177 .tl Atlanta, GA 30332 .pg .pn 1 .he 'Diskread' ' ^ ' .fo ' ' - # - ' ' .pp Disk Block Read/Write/Modify (afterwards referred to as "DISKREAD") is a system utility program designed to allow the knowledgable user a means through which he can read information from disk, modify that information, and place it back onto the disk. It's primary design purpose is to allow the user to make quick disk patches, either in his system files, or any other file. (Basically, a very smart DUMP facility with dynamic disk and RAM updating capability! - F. Monaco). .sp+ 2 .tl WARNING! .pp This program can totaly obliterate the information on the disk (and RAM), and therefore it must be considered as dangerous to the unfamiliar user - please acquaint yourself with it's operation before proceeding to utilize it. .pp The screen consists of several distinct fields: .pp 1) The upper part of the screen will have a field indicating the current block number and the current unit (or volume) number in both decimal and hex, as a rule quantities that "DISKREAD" displays will always be in hex. Between these is an indicator, either HEX or ASCII, this refers to the mode in which the data from the disk block is to be displayed. .pp 2) A command prompt line: all commands and user input quantities will be entered here. When the cursor is here, "DISKREAD" is waiting for a user input. .pp 3) The disk block buffer area. This area is bounded by a row and a column of numbers, the actual address of any byte in the buffer is the logical sum of the two quantities, and thus a little knowledge about hexidecimal addition is needed to utilize the displayed information efficiently. The contents of the buffer are displayed in the current mode. In ASCII mode, only legal ASCII characters are displayed; that is ' '..'}'; all other ASCII codes are displayed as blanks. .pp The commands of "DISKREAD" are: .sp+ 2 .tl 1) Set ASCII display mode : 'a' .pp This command will immediately display the contents of the disk block buffer in ASCII and set the mode indicator to show this. .sp+ 2 .tl 2) Set HEXIDECIMAL display mode : 'h' .pp This command will immediately display the contents of the disk block buffer in hex and set the mode indicator to show this. .sp+ 2 .tl 3) READ a disk block : 'r' .pp This command will cause "DISKREAD" to read in the disk block specified by the current blocknumber from the volume specified in the current unitnumber. If the I/O process is not complete, "DISKREAD" alerts the user and displays an error message, hit RETURN to continue. .sp+ 2 .tl 4) WRITE the buffer to disk : 'w' .pp This command will cause "DISKREAD" to write out the contents of the buffer to the block specified by the current block number on the volume specified by the current unit number. Before the process is completed, verification from the user is requested, typing anything except 'y' or 'Y' will abort the process. .sp+ 2 .tl WARNING! .pp This is the only dangerous command in "DISKREAD", once a buffer has been written to disk, the information that was prevously in the block on the disk is lost! .pp If the I/O process is not complete, "DISKREAD" alerts the user and displays an error message, hit RETURN to continue. .sp+ 2 .tl 5) INCREMENT disk block number : '+' .pp This command will increment the current blocknumber by one each time it is pressed. If the blocknumber exceeds the MAXBLOCKS on the disk, the number wraps around to zero. For convenience the ';' may also be used so that the user does not have to hit the shift key. .sp+ 2 .tl 6) DECREMENT disk block number : '-' .pp This command will decrement the current blocknumber by one each time it is pressed. If the blocknumber goes below zero, then number wraps around to the MAXBLOCKS. For convenience, if the keyboard is shift locked, the '=' may also be used. .sp+ 2 .tl 7) Set the BLOCK NUMBER : 'b' .pp This command allows the user to enter the absolute block address directly in either hexidecimal or decimal, default is decimal, but a '$' anywhere in the input field will cause the number to be processed as a hex number (this is true of all numeric input). Special Note: users with mini-floppies or hard disks will have to change the constant in the beginning of "DISKREAD" to reflect the correct number of blocks! .sp+ 2 .tl 8) Set the UNIT NUMBER : 'u' .pp This command allows the user to enter the volume number on which further operations are to take place, if the number entered is not a vailide block device then the default value of four is substituted - no error message is given! .sp+ 2 .tl 9) CHANGE buffer byte by byte : 'c' .pp This command allows the user to change the buffer contents byte by byte. The user is first ask for a starting address at which the changes are to begin, then he enter each change. The displayed numbers are the current address, and the value of the buffer at that address. To terminate the change mode, simply type return with no other entry. .sp+ 2 .tl 10) STRING CHANGES : 's' .pp This command allows the user to chage the buffer contents to values which are equivalent to an input string. The user is ask to supply a starting address for the string and the string, the change takes up as many bytes as are needed for the string, trailing blanks are significant! .sp+ 2 .tl 11) MEMORY UPDATE : 'm' .pp This command allows the user to change large amounts of the buffer with a single command. The starting address, the ending address, and the value to update the buffer to must be supplied when requested, if the starting address is larger than the ending addres the proccess is aborted. .sp+ 2 .tl 12) QUIT : 'q' .pp This command terminates "DISKREAD", the buffer is not saved automatically! .sp+ 2 .tl Some General Suggestions .pp Numeric inputs may be either hex or decimal, generally error messages are not given, "DISKREAD" assumes the user is very familar with this program, and that he simply made a typing error, any quantity may be corrected before the return key is hit by simply back spacing, and either upper of lower case characters can be used for commands and hex digits. .sp+ 2 .ne 10 .ce Please send comments and suggestions to: .sp+ 2 .ce Roger L. Soles .ce Georgia Institute of Technology .ce Atlanta, GA 30332 .sp+ 2 .sp+ 2 .tl NOTICE: .sp+ 2 .pp This program is for free distribution ONLY, and the copyright notice and author name may not be removed! ======================================================================================== DOCUMENT :usus Folder:VOL05:getnumber.text ======================================================================================== UNIT GetNumber; {Special procedures for controlled CRT input of integers in three flavors. COPYRIGHT (c) 1980, James Gagne, President DATAMED RESEARCH 1433 Roscomare Road Los Angeles, CA 90024 213/472-8825 ALL RIGHTS RESERVED. These routines may be used for nonprofit, non- commercial purposes only, unless written consent of the author is obtained.} INTERFACE CONST {The first 4 are standard ASCII control characters.} bell = 7; backspace = 8; escape = 27; delete = 127; ErrorLine = 23 {Standard line on the CRT for error messages}; PROCEDURE GetInteger (x, y, {desired x/y displacements for START of integer} {If either x or y is < 0, no X-Y movement done.} LowerLimit, UpperLimit: integer; {bounds of WantedNo values } {If LowerLimit > UpperLimit, then LowerLimit is} { taken as the WIDTH of the field, and limits are} { calculated by width alone within the procedure.} RJustify: boolean; {do you want it justified R or L?} VAR WantedNo: integer); {the number returned: unchanged if} { typed during entry. } PROCEDURE GetDecimal (x, y, {same as GetInteger} LowerLimit, UpperLimit, {same as GetInteger; work on WHOLE no. } MaxPlaces: integer; {boundary for decimal = max # of places} VAR WholePart, FractnPart: integer); {returned values; the fractional value is NORMALIZED to the no. of places, i.e., it = number of 1/(10 EXP MaxPlaces)} IMPLEMENTATION PROCEDURE GoAndClearLine (y: integer); EXTERNAL; PROCEDURE QuietRead (VAR ch: char); {this is implemented separately in case you wish to modify it.} BEGIN Read (keyboard, ch) END; FUNCTION LengthOf (int: integer): integer; VAR i, j:integer; BEGIN j := int; IF j < 0 THEN BEGIN i := 1 (*leave room for "-" sign*); j := -j END ELSE i := 0; REPEAT i := i + 1; j := j DIV 10; UNTIL j = 0; LengthOf := i END; FUNCTION FigureWidth (x, y: integer): integer; {returns the number of characters of whichever integer is larger} VAR i, j: integer; BEGIN i := LengthOf (x); j := LengthOf (y); IF j > i THEN FigureWidth := j ELSE FigureWidth := i; END; PROCEDURE BackUp (distance: integer); VAR i: integer; bs: char; BEGIN bs := CHR (backspace); FOR i := 1 TO distance DO Write (bs, ' ', bs) END; PROCEDURE GetSpace (XYEnabled: boolean); {for getting attention and then cleaning up the error message} VAR ch: char; BEGIN Write (CHR (Bell), '. Type to continue...'); REPEAT Read (ch) UNTIL ch = ' '; IF XYEnabled THEN GoAndClearLine (errorline) ELSE Writeln; END; FUNCTION IntInProgress (VAR LastCh: char; VAR wanted: integer): boolean; {This function reads a character quietly, accepting only appropriate ones, updates LASTCH (last char typed) and the integer WANTED appropriately, and returns an approximate boolean value of whether we're done. Used by all input routines.} VAR ch: char; ValidChar: boolean; BEGIN ValidChar := false; REPEAT QuietRead (ch) UNTIL (ch IN ['0'..'9', ' ', '+', '-', '.', CHR (delete), CHR (backspace), CHR (escape)]); IF (ch IN ['0'..'9']) AND (ABS (wanted) < MAXINT DIV 10) THEN BEGIN IF wanted >= 0 THEN Wanted := wanted * 10 + ORD (ch) - ORD ('0') ELSE Wanted := wanted * 10 - ORD (ch) + ORD ('0'); ValidChar := true; END ELSE IF ch = CHR (backspace) THEN BEGIN IF Wanted < 0 THEN Wanted := -( (-wanted) DIV 10) ELSE Wanted := wanted DIV 10; ValidChar := true END ELSE IF ch = CHR (delete) THEN BEGIN Wanted := 0; ValidChar := true END ELSE IF ch = '+' THEN BEGIN IF wanted < 0 THEN wanted := - wanted; ValidChar := true END ELSE IF ch = '-' THEN BEGIN IF wanted > 0 THEN wanted := - wanted; ValidChar := true END; LastCh := ch; IntInProgress := ValidChar END; PROCEDURE WriteRFlushInteger (int, width: integer; LastChWasMinus: boolean); VAR i:integer; BEGIN FOR i := LengthOf (int) TO width - 1 DO Write ('.'); IF int = 0 THEN IF LastChWasMinus THEN Write ('-') ELSE Write ('.') ELSE Write (int); END; PROCEDURE WriteLFlushInteger (int, width: integer; LastChWasMinus: boolean); VAR i, j, k: integer; BEGIN j := width - LengthOf (int); k := j; IF int = 0 THEN IF LastChWasMinus THEN Write ('-') ELSE BEGIN k := k + 1; Write ('.') END ELSE Write (int); FOR i := 1 TO j DO Write ('.'); FOR i := 1 TO k DO Write (CHR (backspace)); END; FUNCTION ValidInteger (LowerLimit, UpperLimit, width: integer; RJustify: boolean; VAR LastChTyped: char; VAR Wanted: integer): boolean; {Get an integer, justifying the number appropriately as you do so. Quit if escape or carriage return or period or space typed or the number is as large as it can get within the limits. Return a boolean variable attesting to the validity of the number.} VAR PrevLength: integer; Done, UnderTopLimit, NumberWasWritten, StillShort, WriteAMinus, NegativeOnly, PositiveOnly: boolean; BEGIN IF (Wanted < LowerLimit) OR (Wanted > UpperLimit) THEN Wanted := 0; NumberWasWritten := Wanted <> 0; PrevLength := LengthOf (Wanted); IF RJustify THEN WriteRFlushInteger (Wanted, width, false) ELSE WriteLFlushInteger (Wanted, width, false); Done := false; StillShort := true; UnderTopLimit := true; WriteAMinus := false; NegativeOnly := UpperLimit <= 0; PositiveOnly := LowerLimit >= 0; WHILE UnderTopLimit AND StillShort AND NOT Done DO IF IntInProgress (LastChTyped, Wanted) THEN BEGIN IF PositiveOnly AND (Wanted < 0) THEN Wanted := -Wanted; IF NegativeOnly AND (Wanted > 0) THEN Wanted := -Wanted; UnderTopLimit := Wanted <= UpperLimit; IF UnderTopLimit THEN BEGIN IF RJustify THEN BackUp (width) ELSE IF NumberWasWritten THEN Backup (PrevLength); WriteAMinus := (LastChTyped = '-') AND NOT PositiveOnly; IF RJustify THEN WriteRFlushInteger (Wanted, width, WriteAMinus) ELSE WriteLFlushInteger (Wanted, width, WriteAMinus); NumberWasWritten := (Wanted <> 0) OR WriteAMinus; PrevLength := LengthOf (Wanted); StillShort := (PrevLength < width) AND (UpperLimit >= Wanted * 10) END; END ELSE Done := true; ValidInteger := (LastChTyped IN [' ', '.', '0'..'9']) AND (Wanted >= LowerLimit) AND UnderTopLimit END; PROCEDURE GetInteger {(x, y, LowerLimit, UpperLimit: integer; RJustify: boolean; VAR WantedNo: integer)}; {Main procedure that is used; X & y refer to the START of the field. Field size is inferred from the maximum number of digits in the two limits. Plus or minus signs typed at any time invert the sign if appropriate. An escape typed any time before auto-termination (by a number approaching UpperLimit) will restore the original value of WantedNo. Nice number movement.} VAR TempInt, width, WorkingUpperLimit, WorkingLowerLimit, i, j: integer; XYEnabled, OK, Abort: boolean; Lastch: char; s: string; BEGIN IF LowerLimit > UpperLimit THEN BEGIN width := LowerLimit MOD 20 {just in case, reasonable limit on width}; i := 1; FOR j := 1 TO width DO i := i * 10; WorkingUpperLimit := i - 1; WorkingLowerLimit := (i DIV 10) -1; {room for "-" sign} END ELSE BEGIN WorkingUpperLimit := UpperLimit; WorkingLowerLimit := LowerLimit; width := FigureWidth (UpperLimit, LowerLimit) END; XYEnabled := (X>=0) AND (Y>=0); REPEAT IF XYEnabled THEN Gotoxy (x,y); OK := ValidInteger (WorkingLowerLimit, WorkingUpperLimit, width, RJustify, Lastch, TempInt); IF OK THEN WantedNo := TempInt ELSE IF Lastch = CHR (escape) THEN Abort := true ELSE IF TempInt > WorkingUpperLimit THEN BEGIN IF XYEnabled THEN Gotoxy (0, errorline) ELSE Writeln; Write ('Please type a number less than ', WorkingUpperLimit + 1); GetSpace (XYEnabled); TempInt := WorkingUpperLimit END ELSE IF TempInt < WorkingLowerLimit THEN BEGIN IF XYEnabled THEN Gotoxy (0, errorline) ELSE Writeln; Write ('Please type a number greater than ', WorkingLowerLimit - 1); GetSpace (XYEnabled); TempInt := WorkingLowerLimit END UNTIL OK OR Abort; IF RJustify THEN i := width ELSE i := LengthOf (TempInt); IF XYEnabled THEN Gotoxy (x,y) ELSE Backup (i); IF RJustify THEN Write (WantedNo: width) ELSE Write (WantedNo) END; PROCEDURE WriteAFraction (fractn, decplaces, maxplaces: integer; includedots: boolean); VAR i, j, LeadingZeros: integer; BEGIN i := LengthOf (fractn); IF fractn = 0 THEN i := 0; LeadingZeros := DecPlaces - i; FOR j := 1 TO LeadingZeros DO Write ('0'); IF fractn > 0 THEN Write (fractn); IF IncludeDots THEN BEGIN i := maxplaces - decplaces; FOR j := 1 TO i DO Write ('.'); FOR j := 1 TO i DO Write (CHR(backspace)); END; END; FUNCTION GetValidFraction (Wholepart, MaxPlaces: integer; VAR LastChTyped: char; VAR fractn: integer): boolean; {Workhorse decimal fraction-getter; difficult because leading zeros are much more significant than trailing ones, which I allowed anyway because people like to type them.} VAR dummy, DumpFractn: boolean; i, j, DecPlaces: integer; BEGIN IF fractn < 0 THEN fractn := - fractn; DecPlaces := MaxPlaces; IF fractn = 0 THEN DecPlaces := 0 ELSE WHILE (fractn MOD 10 = 0) DO BEGIN fractn := fractn DIV 10; DecPlaces := DecPlaces - 1 END; IF LengthOf (fractn) > MaxPlaces THEN BEGIN fractn := 0; DecPlaces := 0; END; WriteAFraction (fractn, DecPlaces, MaxPlaces, true); REPEAT dummy := IntInProgress (LastChTyped, fractn); IF fractn < 0 THEN fractn := -fractn; DumpFractn := (LastChTyped IN [CHR (delete), CHR (escape)]) OR ((LastChTyped = '+') AND (WholePart < 0)) OR ((LastChTyped = '-') AND (WholePart > 0)); Backup (DecPlaces); IF (LastChTyped = CHR (backspace)) AND (DecPlaces > 0) THEN DecPlaces := DecPlaces -1; IF (DecPlaces >= MaxPlaces) AND (fractn = 0) THEN DecPlaces := DecPlaces - 1; IF LengthOf (fractn) > MaxPlaces THEN fractn := fractn DIV 10; IF (LastChTyped IN ['0'..'9']) AND (DecPlaces < MaxPlaces) THEN DecPlaces := DecPlaces + 1; WriteAFraction (fractn, DecPlaces, MaxPlaces, true); UNTIL DumpFraction OR (LastChTyped = ' ') OR (DecPlaces >= MaxPlaces); FOR i := DecPlaces TO MaxPlaces - 1 DO fractn := fractn * 10; GetValidFraction := NOT DumpFraction; END; PROCEDURE GetDecimal {(x, y, LowerLimit, UpperLimit, MaxPlaces: integer; VAR WholePart, FractnPart: integer)}; { Main decimal-getting procedure; returns two INTEGERS representing the whole and the fractional parts. The later number is by the maximum number of decimal places allowed (MaxPlaces), so that if you allow 4 decimal places, FractnPart represents integral 1/10,000th's; 2 decimal places returns hundredths. This procedure is the least well debugged of the sequence. I'm going to have to live with the features I provided here to see if I like them: 1) You work on the two parts of the number separately. If you finish the whole number with a period, you can work on the fractional part. If you finish the integral portion with a carriage return or space, the routine exits and the fractional portion is unaltered. Typing an at any time before termination aborts the procedure and returns the original values. 2) During the actual number entry, if the the original values of the integral and fractional portions are within the range set by the user, they are presented for the user's perusal and optional change; otherwise, they are set to zero. 3) It was simply too complicated to allow for omitting x & y parameters; I couldn't keep track of where I was without a GOTOXY.} VAR OK, Abort: boolean; LastCh: char; TempWhole, TempFrac, width, i, j, WorkingLowerLimit, WorkingUpperLimit: integer; BEGIN IF LowerLimit > UpperLimit THEN BEGIN width := LowerLimit MOD 20 {just in case, reasonable limit on width}; i := 1; FOR j := 1 TO width DO i := i * 10; WorkingUpperLimit := i - 1; WorkingLowerLimit := (i DIV 10) -1; {room for "-" sign} END ELSE BEGIN WorkingUpperLimit := UpperLimit; WorkingLowerLimit := LowerLimit; width := FigureWidth (UpperLimit, LowerLimit) END; TempWhole := WholePart; TempFrac := FractnPart; Abort := false; REPEAT Gotoxy (x,y); OK := ValidInteger (WorkingLowerLimit, WorkingUpperLimit, width, true, Lastch, TempWhole); IF NOT OK THEN IF Lastch = CHR (escape) THEN Abort := true ELSE IF TempWhole > WorkingUpperLimit THEN BEGIN Gotoxy (0, ErrorLine); Write ('Please type a number less than ', WorkingUpperLimit + 1); GetSpace (true); TempWhole := WorkingUpperLimit END ELSE IF TempWhole < WorkingLowerLimit THEN BEGIN Gotoxy (0, ErrorLine); Write ('Please type a number greater than ', WorkingLowerLimit - 1); GetSpace (true); TempWhole := WorkingLowerLimit END ELSE Write ('whoops! Forgot About This Error!') ELSE IF Lastch IN ['.', '0'..'9'] THEN BEGIN Write ('.'); OK := GetValidFraction (TempWhole, MaxPlaces, Lastch, TempFrac); IF NOT OK THEN IF LastCh = CHR (escape) THEN Abort := true ELSE IF LastCh IN ['-', '+'] THEN TempWhole := - TempWhole ELSE IF LastCh = CHR (delete) THEN BEGIN TempWhole := 0; TempFrac := 0 END ELSE Write ('whoops! Unforeseen fraction error.') END UNTIL Abort OR OK; IF OK THEN BEGIN WholePart := TempWhole; FractnPart := TempFrac; END; Gotoxy (x,y); Write (WholePart: width, '.'); WriteAFraction (FractnPart, MaxPlaces, MaxPlaces, false) END; END. ======================================================================================== DOCUMENT :usus Folder:VOL05:getsort.text ======================================================================================== PROGRAM GETSORTEDCOPY; (* uses #5;keyno.text, #5:address.text, to build #5:printf.text, a sorted printable version of the entire address file *) CONST MAXNUMKEYS = 1000; TYPE STRUCTURE = RECORD NAME: STRING; STREET: STRING; CITYSTATEZIP: STRING; PHONE: STRING; KEY : STRING END; KEYREC = RECORD KEY : STRING; RECNUM : 0 .. MAXNUMKEYS END; PREC = ^REC; REC = RECORD LEFT, RIGHT : PREC; THEKEY : KEYREC END; VAR FIN : FILE OF STRUCTURE; FOUT, KEYF : TEXT; KEYS : KEYREC; NEXT, BASE, TREE : PREC; MAXKEYS : 0 .. MAXNUMKEYS; ANSWER : CHAR; PROCEDURE PUTONTREE ( VAR PT, PN : PREC ); BEGIN IF PT = NIL THEN PT := PN ELSE IF PN^.THEKEY.KEY < PT^.THEKEY.KEY THEN PUTONTREE ( PT^.LEFT, PN ) ELSE PUTONTREE ( PT^.RIGHT, PN ); TREE := PT; WRITE ( '.'); END; PROCEDURE PRINTTREE ( PNT : PREC ); BEGIN IF PNT <> NIL THEN BEGIN PRINTTREE ( PNT^.LEFT ); WRITELN (KEYF, PNT^.THEKEY.KEY); WRITELN (KEYF, PNT^.THEKEY.RECNUM); WRITE ( '.'); PRINTTREE (PNT^.RIGHT); END; END; PROCEDURE BUILDKEYFILE; VAR THISRECNO : 0 .. MAXNUMKEYS; BEGIN RESET ( KEYF, '#5:KEYS.TEXT'); READLN ( KEYF, MAXKEYS ); MAXKEYS := PRED ( MAXKEYS ); CLOSE ( KEYF, NORMAL ); WRITELN('... Building the key file...' ); RESET ( FIN, '#5:ADDRESS.TEXT'); REWRITE ( KEYF, '#4:SORTK.TEXT'); THISRECNO := 0; WHILE ( (NOT EOF ( FIN ) ) AND (THISRECNO <= MAXKEYS)) DO BEGIN SEEK ( FIN, THISRECNO ); GET ( FIN ); WRITELN ( KEYF, FIN^.KEY ); WRITELN ( 'GOT ', FIN^.KEY); WRITELN ( KEYF, THISRECNO ); WRITELN ( ' ',THISRECNO:2); SEEK (FIN, THISRECNO); PUT ( FIN ); THISRECNO := SUCC ( THISRECNO ); END; CLOSE ( KEYF, LOCK ); END; PROCEDURE SORTKEYS; BEGIN RESET ( KEYF,'#4:SORTK.TEXT'); BASE := NIL; TREE := NIL; WRITELN ( '... Sorting keys ...'); WHILE NOT EOF ( KEYF ) DO BEGIN NEW ( NEXT ); READLN (KEYF, NEXT^.THEKEY.KEY); READLN (KEYF, NEXT^.THEKEY.RECNUM); NEXT^.LEFT := NIL; NEXT^.RIGHT := NIL; PUTONTREE ( BASE, NEXT ); END; CLOSE ( KEYF, PURGE ); REWRITE ( KEYF, '#5:SORTK.TEXT'); WRITELN; WRITELN ('... Traversing the tree ... '); PRINTTREE ( TREE ); CLOSE ( KEYF, LOCK ); END; PROCEDURE BUILDSORTEDFILE; VAR I, BUF1 : INTEGER; BEGIN WRITELN; WRITELN ('... Writing the sorted file ...'); I := 0; CLOSE ( FIN, NORMAL ); RESET ( KEYF, '#5:SORTK.TEXT'); RESET ( FIN, '#5:ADDRESS.TEXT'); REWRITE ( FOUT, '#5:PRINTF.TEXT'); WHILE ( (NOT EOF ( FIN ) ) AND ( I <= MAXKEYS ) ) DO BEGIN READLN ( KEYF); READLN ( KEYF, BUF1); SEEK ( FIN, BUF1); GET ( FIN ); WRITELN (FIN^.NAME); WRITELN (FIN^.STREET); WRITELN (FIN^.CITYSTATEZIP); WRITELN (FIN^.PHONE); WRITELN ('``````````````````````````````````````````````> ', FIN^.KEY); WRITELN ( FOUT ); WRITELN ( FOUT, FIN^.NAME); WRITELN ( FOUT, FIN^.STREET); WRITELN ( FOUT, FIN^.CITYSTATEZIP); WRITELN ( FOUT, FIN^.PHONE); WRITELN ( FOUT ); SEEK ( FIN, BUF1); PUT ( FIN ); I := SUCC ( I ); END; CLOSE (FOUT, LOCK); WRITELN; WRITELN (' ...Your sorted file, #5:PRINTF.TEXT, is ready ...'); CLOSE (KEYF, PURGE); END; PROCEDURE PRINTSORTEDCOPY; VAR F, LP : TEXT; BUFFER : STRING; LINENO, I : INTEGER; FF, CH : CHAR; BEGIN FF := CHR ( 12 ); WRITELN; WRITE(' Do You want a Hard Copy now? Y/N: '); READLN ( CH ); WRITELN; IF CH IN [ 'Y', 'y' ] THEN BEGIN RESET ( F, '#5:PRINTF.TEXT'); REWRITE ( LP, 'PRINTER:'); WHILE NOT EOF ( F ) DO BEGIN CH := FF; WRITE ( LP, CH ); LINENO := 0; WHILE (LINENO < 60 ) AND (NOT (EOF (F) )) DO BEGIN LINENO := SUCC ( LINENO ); READLN ( F, BUFFER ); WRITELN ( LP, BUFFER ); WRITELN ( BUFFER ); END; END; END; END; BEGIN WRITE (' Do You want to rebuild the print file? Y/N: '); READLN ( ANSWER ); IF ANSWER IN [ 'Y', 'y'] THEN BEGIN BUILDKEYFILE; SORTKEYS; BUILDSORTEDFILE; END; PRINTSORTEDCOPY; END. ======================================================================================== DOCUMENT :usus Folder:VOL05:hexdecoct.text ======================================================================================== {This program does number base conversion between hexidecimal, decimal, octal and binary numbers. Author is unknown} PROGRAM CONVERSION; TYPE OREC = PACKED RECORD E0:PACKED ARRAY[0..4] OF 0..7 END; HREC = PACKED RECORD H0:PACKED ARRAY[0..3] OF 0..15 END; BREC = PACKED RECORD B0:PACKED ARRAY[0..15] OF 0..1 END; LETSET = SET OF '0'..'F'; VAR R: RECORD CASE INTEGER OF 1:(INT:INTEGER); 2:(OCTREC:OREC); 3:(HEXREC:HREC); 4:(BINREC:BREC) END; CH:CHAR; OCTLET,BINLET,DECLET,HEXLET,TESTSET:LETSET; K,I,J:INTEGER; BOOLCHAR,VALID,BOOL:BOOLEAN; PROCEDURE DECTO; VAR NUM:STRING[6]; MINUS:BOOLEAN; BEGIN WITH R.HEXREC DO BEGIN WITH R.OCTREC DO BEGIN WITH R.BINREC DO BEGIN WRITE(' TO '); TESTSET:=['H','B','O']; BOOL:=FALSE; BOOLCHAR:=TRUE; REPEAT FOR I:=0 TO 3 DO H0[I]:=0; IF BOOL THEN WRITE('CONVERT DECIMAL TO '); IF BOOL THEN READLN(CH); IF BOOLCHAR THEN READ(CH); IF CH IN TESTSET THEN BEGIN BOOLCHAR:=TRUE; WRITELN; WRITE('DECIMAL NUMBER = '); READ(NUM); MINUS:=FALSE; IF NUM[1] = '-' THEN BEGIN MINUS:=TRUE; I:=2; END ELSE I:=1; VALID:=TRUE; R.INT:=0; WHILE (I<=LENGTH(NUM)) AND VALID DO BEGIN IF NUM[I] IN DECLET THEN R.INT:=(R.INT*10)+ORD(NUM[I])-ORD('0') ELSE VALID:=FALSE; I:=I+1; END; IF MINUS THEN R.INT:=R.INT*(-1); IF NOT VALID THEN WRITELN('INVALID DECIMAL NUMBER') ELSE BEGIN IF CH = 'H' THEN BEGIN WRITE('HEXADECIMAL NUMBER = '); FOR I:=3 DOWNTO 0 DO BEGIN IF H0[I] < 10 THEN WRITE(H0[I]) ELSE WRITE(CHR(H0[I]-10+ORD('A'))); END; END ELSE IF CH = 'O' THEN BEGIN WRITE('OCTAL INTEGER ='); WRITE(B0[15],E0[4],E0[3],E0[2],E0[1],E0[0]); END ELSE IF CH = 'B' THEN BEGIN WRITE('BINARY INTEGER ='); FOR I:=15 DOWNTO 0 DO WRITE(B0[I]); END; END; (*VALID*) END (*TESTSET*) ELSE IF CH <> 'S' THEN BEGIN WRITELN(' WRONG CHARACTER COMMAND.'); WRITELN('Press Return After Entering Correct Command.'); BOOLCHAR:=FALSE; END; WRITELN; BOOL:=TRUE; UNTIL CH = 'S'; END; (*BEGIN'S*) END; END; END; (*DECTO*) PROCEDURE HEXTO; VAR NUM:STRING[4]; BEGIN WITH R.HEXREC DO BEGIN WITH R.OCTREC DO BEGIN WITH R.BINREC DO BEGIN WRITE(' TO '); TESTSET:=['B','D','O']; BOOL:=FALSE; BOOLCHAR:=TRUE; REPEAT FOR I:=0 TO 3 DO H0[I]:=0; IF BOOL THEN WRITE('CONVERT HEXADECIMAL TO '); IF BOOL THEN READLN(CH); IF BOOLCHAR THEN READ (CH); IF CH IN TESTSET THEN BEGIN BOOLCHAR:=TRUE; WRITELN; WRITE('HEXADECIMAL INTEGER ='); READ (NUM); I:=0; VALID:=TRUE; J:=LENGTH(NUM); WHILE (J>=1) AND VALID DO BEGIN IF NUM[J] IN HEXLET THEN H0[I]:=ORD(NUM[J])-ORD('A')+10 ELSE IF NUM[J] IN DECLET THEN H0[I]:=ORD(NUM[J])-ORD('0') ELSE VALID:=FALSE; J:=J-1; I:=I+1; END; IF NOT VALID THEN WRITELN('INVALID HEXADECIMAL NUMBER') ELSE BEGIN IF CH = 'D' THEN WRITE('DECIMAL INTEGER = ',R.INT) ELSE IF CH = 'O' THEN WRITE('OCTAL INTEGER = ',B0[15],E0[4],E0[3],E0[2],E0[1],E0[0]) ELSE IF CH = 'B' THEN BEGIN WRITE('BINARY INTEGER ='); FOR I:=15 DOWNTO 0 DO WRITE(B0[I]); END; END; (*VALID*) END (*TESTSET*) ELSE IF CH <> 'S' THEN BEGIN WRITELN(' WRONG CHARACTER COMMAND.'); WRITELN('Press Return After Entering Correct Command.'); BOOLCHAR:=FALSE; END; WRITELN; BOOL:=TRUE UNTIL CH = 'S'; END; (*BEGIN'S*) END; END; END; (*HEXTO*) PROCEDURE OCTTO; VAR NUM:STRING[6]; BEGIN WITH R.HEXREC DO BEGIN WITH R.OCTREC DO BEGIN WITH R.BINREC DO BEGIN WRITE(' TO '); TESTSET:=['B','D','H']; BOOL:=FALSE; BOOLCHAR:=TRUE; REPEAT FOR I:=0 TO 3 DO H0[I]:=0; IF BOOL THEN WRITE('CONVERT OCTAL TO '); IF BOOL THEN READLN(CH); IF BOOLCHAR THEN READ(CH); IF CH IN TESTSET THEN BEGIN BOOLCHAR:=TRUE; WRITELN; WRITE('OCTAL INTEGER = '); READ(NUM); I:=1; VALID:=TRUE; R.INT:=0; WHILE (I<= LENGTH(NUM)) AND VALID DO BEGIN IF NUM[I] IN OCTLET THEN R.INT:=(R.INT*8)+ORD(NUM[I])-ORD('0') ELSE VALID:=FALSE; I:=I+1; END; IF NOT VALID THEN WRITELN('INVALID OCTAL NUMBER') ELSE BEGIN IF CH = 'D' THEN WRITE('DECIMAL INTEGER =',R.INT) ELSE IF CH = 'H' THEN BEGIN WRITE('HEXADECIMAL NUMBER = '); FOR I:=3 DOWNTO 0 DO BEGIN IF H0[I] < 10 THEN WRITE(H0[I]) ELSE WRITE(CHR(H0[I]-10+ORD('A'))); END; END ELSE IF CH = 'B' THEN BEGIN WRITE('BINARY INTEGER ='); FOR I:=15 DOWNTO 0 DO WRITE(B0[I]); END; END; (*VALID*) END (*TESTSET*) ELSE IF CH <> 'S' THEN BEGIN WRITELN(' WRONG CHARACTER COMMAND.'); WRITELN('Press Return After Entering Correct Command.'); BOOLCHAR:=FALSE; END; WRITELN; BOOL:=TRUE; UNTIL CH = 'S'; END; (*BEGIN'S*) END; END; END; (*OCTTO*) PROCEDURE BINTO; VAR NUM:STRING[16]; BEGIN WITH R.HEXREC DO BEGIN WITH R.OCTREC DO BEGIN WITH R.BINREC DO BEGIN WRITE(' TO '); TESTSET:=['D','H','O']; BOOL:=FALSE; BOOLCHAR:=TRUE; REPEAT FOR I:=0 TO 3 DO H0[I]:=0; IF BOOL THEN WRITE('CONVERT BINARY TO '); IF BOOL THEN READLN(CH); IF BOOLCHAR THEN READ(CH); IF CH IN TESTSET THEN BEGIN BOOLCHAR:=TRUE; WRITELN; WRITE('BINARY NUMBER = '); READ(NUM); I:=LENGTH(NUM); VALID:=TRUE; J:=0; WHILE (I>=1) AND VALID DO BEGIN IF NUM[I] IN BINLET THEN B0[J]:=ORD(NUM[I])-ORD('0') ELSE VALID:=FALSE; I:=I-1; J:=J+1; END; IF NOT VALID THEN WRITELN('INVALID BINARY NUMBER') ELSE BEGIN IF CH = 'D' THEN WRITE('DECIMAL INTEGER =',R.INT) ELSE IF CH = 'H' THEN BEGIN WRITE('HEXADECIMAL INTEGER = '); FOR I:=3 DOWNTO 0 DO BEGIN IF H0[I] < 10 THEN WRITE(H0[I]) ELSE WRITE(CHR(ORD(H0[I])-10+ORD('A'))); END; END ELSE IF CH = 'O' THEN BEGIN WRITE('OCTAL INTEGER = '); WRITE(B0[15],E0[4],E0[3],E0[2],E0[1],E0[0]); END; END; (*VALID*) END (*TESTSET*) ELSE IF CH <> 'S' THEN BEGIN WRITELN(' WRONG CHARACTER COMMAND.'); WRITELN('Press Return After Entering Correct Command.'); BOOLCHAR:=FALSE; END; WRITELN; BOOL:=TRUE; UNTIL CH = 'S'; END; (*BEGIN'S*) END; END; END; (*BINTO*) PROCEDURE COMMENTS; BEGIN WRITELN('THIS PROGRAM CONVERTS BETWEEN DECIMAL, OCTAL, AND '); WRITELN('HEXADECIMAL INTEGERS.'); WRITELN('THE LARGEST INTEGERS THIS PROGRAM WILL USE IS:'); WRITELN(' HEXADECIMAL: 7FFF FFFF'); WRITELN(' DECIMAL : 65535 -65535 '); WRITELN(' OCTAL : 077777 177777'); WRITELN(' BINARY : 16 BITS'); WRITELN; WRITELN('HEXADECIMAL,BINARY AND OCTAL INTEGERS ARE IN 16 BIT TWO''S'); WRITELN('COMPLEMENT REPRESENTATION. IF AN ENTERED DECIMAL INTEGER'); WRITELN('IS OUTSIDE THE RANGE 32767<= X <=-32768 THEN THE HEX, OCTAL'); WRITELN('AND BINARY NUMBERS WILL HAVE AN "UNDERSTOOD" SIGN BIT. WHEN '); WRITELN('HEX, OCTAL OR BINARY INTEGER IS ENTERED THE I6TH BIT (IF THERE '); WRITELN('IS ONE) WILL BE TAKEN AS A SIGN BIT'); WRITELN; WRITELN('FOR USE IN THIS PROGRAM TYPE:'); WRITELN(' ''H'' FOR HEXADECIMAL'); WRITELN(' ''D'' FOR DECIMAL'); WRITELN(' ''B'' FOR BINARY'); WRITELN(' ''O'' FOR OCTAL'); WRITELN(' ''C'' FOR GETTING THESE COMMENTS'); WRITELN(' ''S'' FOR STOPPING A PROCEDURE'); WRITE(' ''Q'' FOR QUITTING THE PROGRAM'); END; (*COMMENTS*) BEGIN (*MAIN PROGRAM*) COMMENTS; HEXLET:=['A'..'F']; DECLET:=['0'..'9']; OCTLET:=['0'..'7']; BINLET:=['0'..'1']; CH:='E'; REPEAT CASE CH OF 'H': HEXTO; 'O': OCTTO; 'B': BINTO; 'C': COMMENTS; 'D': DECTO END; WRITELN; WRITE('I WOULD LIKE TO CONVERT INTEGERS IN '); REPEAT READ (CH); UNTIL CH IN ['C','B','H','O','D','Q']; UNTIL CH = 'Q'; WRITELN('GOODBYE'); END. ======================================================================================== DOCUMENT :usus Folder:VOL05:id2id.text ======================================================================================== (*$S+, Modified by F. J. Monaco for UCSD PASCAL *) PROGRAM ID2D (INFILE,OUTFILE, IDPAIRS, SCREEN ); USES GOODSTUFF; CONST MAXLENGTH = 25; BLANKS = ' '; TYPE CHARS = 'A' .. 'z'; CHARSET = SET OF CHARS; IDLENGTH = 1 .. MAXLENGTH; IDTYPE = RECORD NAME : PACKED ARRAY [ IDLENGTH ] OF CHAR; LENGTH : IDLENGTH END; BALANCE = (HIGHERLEFT, EVEN, HIGHERRIGHT); NODEPTR = ^NODE; NODE = RECORD ID : IDTYPE; LEFT, RIGHT : NODEPTR; BAL : BALANCE; IDISNEW : BOOLEAN; CASE IDISOLD: BOOLEAN OF TRUE: (NEWPTR : NODEPTR); FALSE: (SEENININFILE : BOOLEAN) END; VAR IDTABLE : NODEPTR; INFILE, OUTFILE, IDPAIRS, SCREEN: TEXT; LETTERS, DIGITS, LETTERANDDIGITS : CHARSET; PROCEDURE INITIALIZE; VAR THISNAME : STRING[30]; BEGIN REWRITE(SCREEN, 'CONSOLE:'); GETCRTINFO; getdate ( thisname ); GOTOXY ( 0, 0 ); CRT ( ERASEOS ); writeln (' UCSD PASCAL version of PUG''s ID2D ... ',thisname, ' ...'); writeln (' modified by Frank Monaco '); writeln; WRITELN ( 'This Program replaces OLD IDENTIFIERS with NEW IDENTIFIERS '); WRITELN (' ...... in a PASCAL Program ... '); writeln; writeln (' You will be prompted for two INPUT files: '); writeln (' 1) The file containing "oldids, newids" '); writeln (' 2) The file containing the program to be changed '); writeln (' You will be next prompted for the new OUTPUT program file '); gotoxy ( 25, 12 ); write (' ... First, the IDPAIRS file .... '); getfile (idpairs, true ); GOTOXY ( 0, 0); CRT (ERASEOS ); gotoxy ( 25, 12 ); write (' ... Next, the PROGRAM file to be changed ...'); GETFILE (INFILE, TRUE ); gotoxy ( 0, 0); CRT (ERASEOS); gotoxy ( 25, 12 ); write (' ... Next, the NEW PROGRAM File name ...'); GETFILE (OUTFILE, FALSE); gotoxy ( 0, 0 ); crt ( eraseos ); LETTERS := [ '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']; DIGITS := [ '0' .. '9' ]; LETTERANDDIGITS := LETTERS + DIGITS; END; PROCEDURE READID(VAR INFILE : TEXT; VAR IDENT : IDTYPE); VAR CHCOUNT : 0 .. MAXLENGTH; BEGIN IDENT.NAME := BLANKS; CHCOUNT := 0; REPEAT CHCOUNT := SUCC (CHCOUNT); IDENT.NAME [ CHCOUNT ] := INFILE^; GET(INFILE) UNTIL NOT (INFILE^ IN LETTERANDDIGITS) OR (CHCOUNT = MAXLENGTH); IDENT.LENGTH := CHCOUNT END; PROCEDURE READIDPAIRSANDCREATESYMBOLTABLE; TYPE IDKIND = (OLDKIND, NEWKIND); VAR OLDID, NEWID: IDTYPE; LINK: NODEPTR; LINENUM: INTEGER; INCRHGT : BOOLEAN; PROCEDURE ERROR; BEGIN WRITELN(SCREEN,' ON LINE NUMBER ':29,LINENUM: 1, ' OF THE "IDPAIRS" FILE'); END; PROCEDURE ENTER (VAR IDENTIFIER: IDTYPE; KIND: IDKIND; VAR P : NODEPTR; VAR INCREASEDHEIGHT : BOOLEAN); VAR P1, P2 : NODEPTR; BEGIN IF P = NIL THEN BEGIN NEW(P); INCREASEDHEIGHT := TRUE; WITH P^ DO BEGIN ID := IDENTIFIER; IDISNEW := KIND = NEWKIND; IDISOLD := KIND = OLDKIND; LEFT := NIL; RIGHT := NIL; BAL := EVEN; IF IDISNEW THEN BEGIN LINK := P; SEENININFILE := FALSE; END ELSE NEWPTR := LINK END END ELSE IF IDENTIFIER.NAME < P^.ID.NAME THEN BEGIN ENTER (IDENTIFIER, KIND, P^.LEFT, INCREASEDHEIGHT); IF INCREASEDHEIGHT THEN CASE P^.BAL OF HIGHERRIGHT : BEGIN P^.BAL := EVEN; INCREASEDHEIGHT := FALSE END; EVEN: P^.BAL := HIGHERLEFT; HIGHERLEFT: BEGIN P1 := P^.LEFT; IF P1^.BAL = HIGHERLEFT THEN BEGIN P^.LEFT := P1^.RIGHT; P1^.RIGHT := P; P^.BAL := EVEN; P := P1 END ELSE BEGIN P2 := P1^.RIGHT; P1^.RIGHT := P2^.LEFT; P2^.LEFT := P1; P^.LEFT := P2^.RIGHT; P2^.RIGHT := P; IF P2^.BAL = HIGHERLEFT THEN P^.BAL := HIGHERRIGHT ELSE P^.BAL := EVEN; IF P2^.BAL = HIGHERRIGHT THEN P^.BAL := HIGHERLEFT ELSE P1^.BAL := EVEN; P := P2; END; P^.BAL := EVEN; INCREASEDHEIGHT := FALSE; END; END END ELSE IF IDENTIFIER.NAME > P^.ID.NAME THEN BEGIN ENTER(IDENTIFIER, KIND, P^.RIGHT, INCREASEDHEIGHT); IF INCREASEDHEIGHT THEN CASE P^.BAL OF HIGHERLEFT: BEGIN P^.BAL := EVEN; INCREASEDHEIGHT := FALSE; END; EVEN: P^.BAL := HIGHERRIGHT; HIGHERRIGHT: BEGIN P1 := P^.RIGHT; IF P1^.BAL = HIGHERRIGHT THEN BEGIN P^.RIGHT := P1^.LEFT; P1^.LEFT := P; P^.BAL := EVEN; P := P1 END ELSE BEGIN P2 := P1^.LEFT; P1^.LEFT := P2^.RIGHT; P2^.RIGHT := P1; P^.RIGHT := P2^.LEFT; P2^.LEFT := P; IF P2^.BAL = HIGHERRIGHT THEN P^.BAL := HIGHERLEFT ELSE P^.BAL := EVEN; IF P2^.BAL = HIGHERLEFT THEN P1^.BAL := HIGHERRIGHT ELSE P1^.BAL := EVEN; P := P2; END; P^.BAL := EVEN; INCREASEDHEIGHT := FALSE; END; END END ELSE BEGIN INCREASEDHEIGHT := FALSE; WITH P^ DO BEGIN IF IDISOLD THEN IF KIND = OLDKIND THEN BEGIN WRITELN(SCREEN, '***DUPLICATE OLD IDS ENCOUNTERED: ', IDENTIFIER.NAME); ERROR; EXIT ( PROGRAM ) END ELSE BEGIN IDISNEW := TRUE; LINK := P END ELSE IF KIND = NEWKIND THEN BEGIN WRITELN(SCREEN, '---WARNING: ', IDENTIFIER.NAME, ' HAS ALSO APPEARED AS ANOTHER NEWID'); ERROR; LINK := P END ELSE BEGIN IDISOLD := TRUE; NEWPTR := LINK END END END END; PROCEDURE TRUNCATION ( VAR IDENT: IDTYPE); BEGIN WRITELN(SCREEN, '---WARNING: TRUNCATION FOR IDENTIFIER: ', IDENT.NAME); WRITELN(SCREEN, '---EXTRA CHARACTERS IGNORED ': 39); ERROR; REPEAT GET (IDPAIRS) UNTIL NOT (IDPAIRS^ IN LETTERANDDIGITS); END; BEGIN IDTABLE := NIL; RESET (IDPAIRS); LINENUM := 1; INCRHGT := FALSE; WHILE NOT EOF(IDPAIRS) DO BEGIN WHILE (IDPAIRS^ = ' ') AND NOT EOLN(IDPAIRS) DO GET(IDPAIRS); IF IDPAIRS^ IN LETTERS THEN BEGIN READID(IDPAIRS,OLDID); IF IDPAIRS^ IN LETTERANDDIGITS THEN TRUNCATION(OLDID); WHILE (IDPAIRS^ IN [' ',',']) AND NOT EOLN(IDPAIRS) DO GET (IDPAIRS); IF IDPAIRS^ IN LETTERS THEN BEGIN READID(IDPAIRS,NEWID); IF IDPAIRS^ IN LETTERANDDIGITS THEN TRUNCATION(NEWID); ENTER(NEWID,NEWKIND, IDTABLE,INCRHGT); ENTER(OLDID, OLDKIND, IDTABLE, INCRHGT); END ELSE BEGIN WRITELN(SCREEN, '---WARNING: MALFORMED IDPAIR'); ERROR; END END ELSE BEGIN WRITELN(SCREEN, '---WARNING: MALFORMED IDPAIR'); ERROR; END; READLN(IDPAIRS); LINENUM := SUCC ( LINENUM); END; END; PROCEDURE EDITINFILETOOUTFILE; VAR INFILEID: IDTYPE; DIGITSE, IMPORTANTCHARS: CHARSET; PROCEDURE SUBSTITUTE (VAR IDENTIFIER: IDTYPE; P : NODEPTR); PROCEDURE WRITEINFILEID; BEGIN WITH INFILEID DO WRITE(OUTFILE, NAME: LENGTH); WHILE INFILE^ IN LETTERANDDIGITS DO BEGIN WRITE(OUTFILE, INFILE^); GET(INFILE); END END; BEGIN IF P = NIL THEN WRITEINFILEID ELSE IF IDENTIFIER.NAME < P^.ID.NAME THEN SUBSTITUTE(IDENTIFIER, P^.LEFT) ELSE IF IDENTIFIER.NAME > P^.ID.NAME THEN SUBSTITUTE(IDENTIFIER, P^.RIGHT) ELSE WITH P^ DO IF IDISOLD THEN BEGIN WITH NEWPTR^.ID DO WRITE(OUTFILE, NAME: LENGTH); WHILE INFILE^ IN LETTERANDDIGITS DO GET(INFILE) END ELSE BEGIN SEENININFILE := TRUE; WRITEINFILEID END END; BEGIN IMPORTANTCHARS := LETTERANDDIGITS + ['(', '_', '''']; DIGITSE := DIGITS + ['E', 'e']; WHILE NOT EOF(INFILE) DO BEGIN WHILE NOT EOLN(INFILE) DO IF INFILE^ IN IMPORTANTCHARS THEN CASE INFILE^ OF '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': BEGIN READID(INFILE, INFILEID ); SUBSTITUTE( INFILEID , IDTABLE ); END; '0','1','2','3','4','5','6','7','8','9': REPEAT WRITE(OUTFILE, INFILE^) ; GET(INFILE) UNTIL NOT (INFILE^ IN DIGITS); '''': BEGIN REPEAT WRITE(OUTFILE, INFILE^); GET(INFILE); UNTIL ( INFILE^ = '''') OR EOLN(INFILE); IF EOLN(INFILE) THEN WRITELN(SCREEN, 'UNCLOSED STRING FOUND'); WRITE(OUTFILE, INFILE^); GET(INFILE); END; '(' : BEGIN WRITE (OUTFILE, INFILE^); GET(INFILE); IF INFILE^ = '*' THEN BEGIN REPEAT WRITE(OUTFILE, INFILE^); GET(INFILE); WHILE INFILE^ <> '*' DO BEGIN IF EOLN (INFILE) THEN WRITELN (OUTFILE) ELSE WRITE(OUTFILE, INFILE^); GET(INFILE); END; WRITE(OUTFILE,INFILE^); GET(INFILE) UNTIL INFILE^ = ')'; WRITE(OUTFILE, INFILE^); GET(INFILE); END; END; END ELSE BEGIN WRITE(OUTFILE,INFILE^); GET(INFILE); END; READLN(INFILE); WRITELN(OUTFILE); END END; PROCEDURE CHECKSEENININFILE(P: NODEPTR); BEGIN IF P <> NIL THEN BEGIN CHECKSEENININFILE(P^.LEFT); WITH P^ DO IF IDISNEW AND NOT IDISOLD THEN IF SEENININFILE THEN BEGIN WRITELN(SCREEN,'---WARNING: ', ID.NAME: ID.LENGTH, ' WAS SPECIFIED AS A NEW IDENTIFIER '); WRITELN(SCREEN,'---AND WAS ALSO SEEN IN THE INFILE ': 46, ' PROGRAM UNCHANGED '); END; CHECKSEENININFILE(P^.RIGHT) END END; BEGIN INITIALIZE; READIDPAIRSANDCREATESYMBOLTABLE; EDITINFILETOOUTFILE; CHECKSEENININFILE(IDTABLE); CLOSE ( OUTFILE, LOCK ); END. ======================================================================================== DOCUMENT :usus Folder:VOL05:makemasks.text ======================================================================================== PROGRAM MakeCRTMasks; USES CRTInput, GetNumber; CONST MaxX = 79; MaxY = 23; MaxData = 50; DefaultMark = '^'; LengthChar = '*'; TESTING = FALSE; TYPE YLimits = 0..MaxY; XLimits = 0..MaxX; DataLimits = 1..MaxData; CRTLineArray = PACKED ARRAY [XLimits] OF char; DataRec = PACKED RECORD X: XLimits; Y: YLimits; Lngth, Decimal: XLimits; END; MaskRec = RECORD Line: ARRAY [YLimits] OF CRTLineArray; Data: ARRAY [DataLimits] OF DataRec; END; VAR i, j, ThisRecordNo, NoOfDataRecords: integer; ch, Datamark: char; NumberSet: SET OF DataLimits; InfileName, DFileName: string[30]; TextBuf: ARRAY [YLimits] OF string; Mask: MaskRec; Infile, List: text; DataFile: FILE OF MaskRec; PROCEDURE ClearScreen; EXTERNAL; FUNCTION Yes (prompt: string) : boolean; EXTERNAL; PROCEDURE OpenDataFile; VAR Newfile: boolean; BEGIN REPEAT NoOfDataRecords := 0; NewFile := false; Write ('What is the name of the CRT mask data file? '); DFileName := ''; GetString (23, DFileName); Writeln; IF (DFileName = '') OR (DFileName = ' ') THEN IF Yes ('Do you want to quit') THEN EXIT (program); {$I-} Allcaps (DFileName); Reset (DataFile, DFileName); IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#5:', DFileName)); {$I+} i := IORESULT; IF i = 10 THEN BEGIN IF Yes ('NEW FILE. Correct') THEN BEGIN Newfile := true; {$I-} Rewrite (DataFile, DFileName); {$I+} i := IORESULT; END END; UNTIL i = 0; IF NOT Newfile THEN BEGIN REPEAT Get (DataFile); NoOfDataRecords := NoOfDataRecords + 1; UNTIL eof (DataFile); Reset (DataFile) END; END; PROCEDURE TranslateCRTData (LineNo: YLimits); VAR L, FieldStart, FieldEnd, DataNumber: integer; DataDec, DataLength, TextLength: XLimits; HasData: boolean; PROCEDURE ScanField; VAR Done, HasDecimal: boolean; ChL: char; Dec: integer; BEGIN L := FieldStart; HasDecimal := false; Dec := 0; IF TESTING THEN BEGIN WRITE ('X = ', FIELDSTART:3, '; Y = ', I:3); IF DATANUMBER MOD 4 = 0 THEN WRITELN ELSE WRITE (' ') END; REPEAT L := L + 1; Done := (L > TextLength) OR (L > MaxX); IF NOT Done THEN BEGIN ChL := Mask.Line [LineNo,L]; Done := NOT (ChL IN ['0'..'9', '.', LengthChar]) END; IF NOT Done AND (ChL = '.') THEN IF HasDecimal THEN BEGIN {second period marks end of field. } Done := true; IF (Mask.Line [LineNo, L-1] = '.') {i.e., are we really at the start of} THEN BEGIN { a dotted line? Then dump ALL periods.} HasDecimal := false; Dec := 0; L := L-1; END END ELSE BEGIN HasDecimal := true; Dec := L END; UNTIL Done; DataLength := L - FieldStart; IF Dec = 0 THEN DataDec := 0 ELSE DataDec := L - (Dec +1); FieldEnd := L; END; PROCEDURE GetFieldNumber; PROCEDURE FigureOutNumber; VAR i: integer; BEGIN i := 0; REPEAT i := i + 1 UNTIL NOT (i IN NumberSet); IF i > MaxData THEN BEGIN Writeln (CHR (7), '** ERROR **':40); Writeln ('There is no room in the table for the data field starting at ', FieldStart, ', ', LineNo, '.'); i := 0; END; DataNumber := i END; BEGIN DataNumber := 0; L := FieldStart + 1; REPEAT IF Mask.Line [LineNo,L] IN ['0'..'9'] THEN DataNumber := DataNumber * 10 + ORD (Mask.Line [LineNo,L]) - ORD ('0'); L := L + 1; UNTIL L >= FieldEnd; IF (DataNumber > MaxData) OR (DataNumber = 0) OR (DataNumber IN Numberset) THEN FigureOutNumber; END; BEGIN TextLength := Length (TextBuf [LineNo]); FieldStart := -1; REPEAT REPEAT FieldStart := FieldStart + 1; HasData := Mask.Line [LineNo, FieldStart] = Datamark UNTIL HasData OR (FieldStart > TextLength) OR (FieldStart = MaxX); IF HasData THEN BEGIN ScanField; GetFieldNumber; IF DataNumber > 0 THEN WITH Mask.Data[DataNumber] DO BEGIN X := FieldStart; Y := LineNo; Lngth := DataLength; Decimal := DataDec END; FOR L := FieldStart TO FieldEnd - 1 DO Mask.Line [LineNo,L] := ' '; NumberSet := NumberSet + [DataNumber]; END UNTIL NOT HasData; END; FUNCTION GotInstructions: boolean; BEGIN ClearScreen; Writeln ( 'The current marker of the start of a CRT data field is a "', DataMark, '".'); IF Yes ('Do you wish to change this character') THEN BEGIN Write ('Please type the new field start character: '); Read (DataMark); END; IF NOT OpenTextFile ('What is the name of the file containing the desired mask?', InfileName, GetOld, 0, Infile) THEN GotInstructions := false ELSE BEGIN GotInstructions := true; Gotoxy (0,6); Writeln ( 'The file ', DFileName, ' now contains ', NoOfDataRecords, ' records.'); ch := '0'; {dummy character} IF NoOfDataRecords > 0 THEN BEGIN Writeln ('Where would you like to write this mask?'); Writeln (' N)ext new record in file.'); Writeln (' C)orrect previously existing record.'); REPEAT Read (ch) UNTIL (ch IN ['C', 'c', 'N', 'n']); Writeln; END; ThisRecordNo := NoOfDataRecords; {record no's start at 0, remember} IF (ch IN ['N', 'n']) OR (NoOfDataRecords = 0) THEN NoOfDataRecords := NoOfDataRecords + 1 ELSE BEGIN IF NoOfDataRecords = 1 THEN ThisRecordNo := 0 ELSE BEGIN Write ('Then what record number would you like ', 'to replace (0 TO ', NoOfDataRecords-1, ')? '); GetInteger (-1, -1, 0, NoOfDataRecords-1, true, ThisRecordNo); Writeln; END END; END END; PROCEDURE PrintMask; BEGIN Writeln (List, ' C R T M A S K G E N E R A T O R U T I L I T Y', ' (c) 1980 by DATAMED RESEARCH.'); Writeln (List, 'Source Textfile = ', InFileName, ' Mask File = ', DFileName, ' Mask Number = ', ThisRecordNo); Writeln (List); Writeln (List, ' Y X:0....5...10....5...20....5...30....5...40....5...50....5...60', '....5...70....5..79'); FOR i := 0 TO MaxY DO BEGIN Write (List, i:4, ' !', Mask.Line [i,0]); FOR j := 1 TO MaxX DO IF (Mask.Line [i,j] = ' ') AND (j MOD 10 = 0) AND (Mask.Line [i,j-1] = ' ') THEN Write (List, '!') ELSE Write (List, Mask.Line [i,j]); Writeln (List, '!'); END; Writeln (List, ' !:....,....:....,....:....,....:....,....:....,....:....,....:', '....,....:....,....!'); Writeln (List); Writeln (List, 'FIELD NUMBER ', 'X COORDINATE ':13, 'Y COORDINATE ':16, 'FIELD END':10, 'LENGTH':9, 'DECIMAL PLACES':20); FOR i := 1 TO MaxData DO WITH Mask.Data [i] DO IF Lngth > 0 THEN Writeln (List, i:6, X:16, Y:16, (X + Lngth -1):12, Lngth:10, Decimal:16); Page (List); END; PROCEDURE ProcessAMask; BEGIN IF TESTING THEN WRITELN ('CURRENT RECORD NO. = ', THISRECORDNO); Seek (DataFile, ThisRecordNo); NumberSet := []; FOR i := 0 TO MaxY DO FOR j := 0 TO MaxX DO Mask.Line [i,j] := ' '; FOR i := 1 TO MaxData DO WITH Mask.Data [i] DO BEGIN X := 0; Y := 0; Lngth := 0; Decimal := 0; END; i := 0; WHILE NOT eof (Infile) AND (i <= MaxY) DO BEGIN Readln (Infile, TextBuf[i]); FOR j := 1 TO Length (TextBuf [i]) DO Mask.Line [i,j-1] := TextBuf [i,j]; TranslateCRTData (i); i := i + 1; END; DataFile^ := Mask; Put (DataFile); IF Yes ('Would you like to print this mask ') THEN PrintMask; CLOSE (Infile); Write ('Process complete. '); END; BEGIN OpenDataFile; Rewrite (List, 'PRINTER:'); DataMark := DefaultMark; REPEAT IF GotInstructions THEN ProcessAMask UNTIL NOT Yes ('More masks to do'); CLOSE (DataFile, Lock); END. ======================================================================================== DOCUMENT :usus Folder:VOL05:monaco.doc.text ======================================================================================== Monaco's Fmt and Other Gems... edited by Francis J. Monaco Introduction to this Volume Hopefully, this volume contains something for everyone in the wonderful world of UCSD PASCAL! From an interactive textformatter to a really fine disk- memory-patch and dump routine, an attempt to include a wide variety of really useful stuff has been made. The source code is included in all cases except for the textformatter; interested personnel should contact the author for information on obtaining the source to "FMT"... Small Database System "ADDRS.DOC" contains instructions on how to use STRUCT, UPDATE, and GETSORT; basically, these programs allow ISAM updates, sorts, etc. on a large user defined "database". Because update uses the foreground and background intensity levels of display capabilities of the Hazeltine 1510 terminal, the user should get into the variable definitions at the start of the main program and redefine some values (all well documented). Other than a dual floppy system and a printer on line (the printer code can be easily removed), these programs require little else except compilation. Monaco's Interactive Formatter The file "READ.FMT" is a printable user manual for using the the code files "FMT.1.5.CODE" and "FMT.20.CODE". The user should look at "SP.TEXT" in the editor, and modify it to work with his/her printer; then try SP on "READ.FMT" (since it contains FORTRAN carriage controls which must be con- verted to ASCII: an extremely simple task). Once you have a copy of the READ.FMT in hand, print the input files "USER.IN2" and "USER.A2" and study the input to "FMT" along-side the output from "FMT". The author would appreciate feedback from users of "FMT", as it might one day become a saleable product. By the way, "FMT.EXAMP" is another example input file to "FMT". Fantastic Disk Patch Utility See "READ.DISKR" for instructions on this fine bit of programming. The compiliable version is "DISKREAD" and will work on any system, including knowledge of terminal control features (it reads SYSTEM.MISCINFO!). Change Crummy Identifiers to Nice Identifiers The file "ID2D" is a terminal-independent version of PUG's ID2D, a very clean balanced AVL tree implementation of a program to change all PASCAL identifiers in one program into new identifiers in a new program. Self prompting. Requires a file containing the old identifiers, new identifiers as: oldid1, newid1 oldid2, newid2 oldid3, newid3 as well as a file containing the program to be changed. Errors go to the screen. Very clean... Miscellaneous Good Stuff "DIR" reads a directory from the command level of the UCSD PASCAL system; "FAST.PG" solves the problem of an extremely fast program perusal using blockreads and unitwrites to the console; "UNIT.GOOD.TEXT" is a unit that con- tains very good stuff like: a procedure to get the system date; a procedure to read in a string without bombing; a procedure to open a file for reading or writing that will provide you with a directory if you forget the file name (under program control) and give you unlimited chances; and best of all, a set of two procedures that will read in "SYSTEM.MISCINFO" and allow the user to use procedure calls like: crt ( eraseol ) crt ( eraseos ) crt ( left ) crt ( right ) etc. anywhere in the program. This is not dependent on anything except the data in SYSTEM.MISCINFO; therefore, all terminals will respond correctly to these "crt" calls (as long as "getcrtinfo" has been invoked!) This unit was named "goodstuff" and when you see it, you'll know why! Added goodie for LSI- 11 interps: change the line "ALOCK:.BYTE0" to "ALOCK:.BYTE-1" in IOTRAP and rebuild the interpreter to preclude having to type control-r to get lower case! Please send comments and suggestions to: Francis J. Monaco Cpt, US ARMY Department of Geography and Computer Science The United States Military Academy West Point, New York 10996 ======================================================================================== DOCUMENT :usus Folder:VOL05:peek.poke.text ======================================================================================== {This program demonstrates how to bend the Pascal language into doing the BASIC equivalent of 'PEEK' and 'POKE' on a PDP-11. Program permits direct inspection and alteration of memory locations} PROGRAM PEEKANDPOKE; CONST BS=8; VAR P: RECORD CASE INTEGER OF 1: (I: INTEGER); 2: (P: ^INTEGER) END; A,V: INTEGER; I: INTERACTIVE; PROCEDURE READO(VAR N: INTEGER); VAR K: INTEGER; C: CHAR; BEGIN (* READO *) K := 0; N := 0; WHILE I^ IN ['0'..'7',CHR(BS)] DO BEGIN C := I^; IF C = CHR(BS) THEN BEGIN IF K > 0 THEN BEGIN WRITE(CHR(BS)); K := K - 1; N := N DIV 8 END END ELSE BEGIN WRITE(C); K := K + 1; N := N * 8 + ORD(C) - ORD('0') END; GET(I) END END (* READO *); PROCEDURE READB(VAR N: INTEGER); VAR K: INTEGER; C: CHAR; BEGIN (* READB *) K := 0; N := 0; WHILE I^ IN ['0'..'1',CHR(BS)] DO BEGIN C := I^; IF C = CHR(BS) THEN BEGIN IF K > 0 THEN BEGIN WRITE(CHR(BS)); K := K - 1; N := N DIV 2 END END ELSE BEGIN WRITE(C); K := K + 1; N := N * 2 + ORD(C) - ORD('0') END; GET(I) END END (* READB *); PROCEDURE WRITEO(N: INTEGER); VAR I: INTEGER; C: CHAR; BEGIN (* WRITEO *) IF N < 0 THEN BEGIN WRITE('1'); N := N + 32767 + 1 END ELSE WRITE('0'); I := 4096; REPEAT WRITE(CHR(N DIV I MOD 8 + ORD('0'))); I := I DIV 8 UNTIL I = 0 END (* WRITEO *); PROCEDURE WRITEB(N: INTEGER); VAR I: INTEGER; BEGIN (* WRITEB *) IF N < 0 THEN BEGIN WRITE('1'); N := N + 32767 + 1 END ELSE WRITE('0'); I := 16384; REPEAT WRITE(CHR(N DIV I MOD 2 + ORD('0'))); I := I DIV 2 UNTIL I = 0 END (* WRITEB *); BEGIN (* PEEK AND POKE *) RESET(I,'SYSTERM:'); P.I := 0; WRITEO(0); WHILE NOT EOF(I) DO BEGIN WRITE('='); WRITEB(P.P^); GET(I); IF I^ IN [' ','/','0','1','2','3','4','5','6','7','^'] THEN CASE I^ OF ' ': BEGIN IF EOLN(I) THEN WRITELN ELSE WRITE(' '); P.I := P.I + 1; WRITEO(P.I) END; '/': BEGIN WRITE('/'); GET(I); READB(V); IF I^ = ' ' THEN BEGIN P.P^ := V; IF EOLN(I) THEN WRITELN ELSE WRITE(' '); P.I := P.I + 1; WRITEO(P.I) END ELSE BEGIN WRITELN; WRITEO(P.I) END END; '0','1','2','3','4','5','6','7': BEGIN WRITE(' '); READO(A); IF I^ = ' ' THEN BEGIN P.I := A; IF EOLN(I) THEN BEGIN WRITELN; WRITEO(P.I) END END ELSE BEGIN WRITELN; WRITEO(P.I) END END; '^': BEGIN P.I := P.P^; WRITELN; WRITEO(P.I) END END ELSE BEGIN WRITELN; WRITEO(P.I) END END END (* PEEK AND POKE *). ======================================================================================== DOCUMENT :usus Folder:VOL05:quicksort.text ======================================================================================== {Benchmark program using the Quicksort algorithm. Does nothing useful here except chew up CPU cycles, but the algorithm is useful in lots of sorting applications.} (*$R+*) PROGRAM QUICKSORT; CONST N = 10000; VAR I,Z: INTEGER; A: ARRAY [1..N] OF INTEGER; PROCEDURE SORT( L,R: INTEGER ); VAR I,J,X,W: INTEGER; BEGIN I := L; J := R; X := A[(I+J) DIV 2]; REPEAT WHILE A[I] < X DO I := I+1; WHILE A[J] > X DO J := J-1; IF I <= J THEN BEGIN W := A[I]; A[I] := A[J]; A[J] := W; I := I+1; J := J-1 END UNTIL I > J; IF L < J THEN SORT( L, J ); IF I < R THEN SORT( I, R ) END (* SORT *) ; BEGIN (* MAIN *) Z := 113; FOR I := 1 TO N DO BEGIN Z := (131*Z+1) MOD 221; A[I] := Z END; WRITE('TYPE TO SORT...'); READLN; SORT( 1, N ); WRITELN( CHR(7), 'ALL DONE AGAIN.' ) END. ======================================================================================== DOCUMENT :usus Folder:VOL05:read.diskr.text ======================================================================================== Disk Block Read/Write/Modify by Roger L. Soles Georgia Institute of Technology Box 36177 Atlanta, GA 30332 1 Disk Block Read/Write/Modify (afterwards referred to as "DISKREAD") is a system utility program designed to allow the knowledgable user a means through which he can read in- formation from disk, modify that information, and place it back onto the disk. It's primary design purpose is to allow the user to make quick disk patches, either in his system files, or any other file. (Basically, a very smart DUMP facility with dynamic disk and RAM updating capability! - F. Monaco). WARNING! This program can totaly obliterate the information on the disk (and RAM), and therefore it must be considered as dangerous to the unfamiliar user - please acquaint yourself with it's operation before proceeding to utilize it. The screen consists of several distinct fields: 1) The upper part of the screen will have a field in- dicating the current block number and the current unit (or volume) number in both decimal and hex, as a rule quantities that "DISKREAD" displays will always be in hex. Between these is an indicator, either HEX or ASCII, this refers to the mode in which the data from the disk block is to be displayed. 2) A command prompt line: all commands and user input quantities will be entered here. When the cursor is here, "DISKREAD" is waiting for a user input. 3) The disk block buffer area. This area is bounded by a row and a column of numbers, the actual address of any byte in the buffer is the logical sum of the two quantities, and thus a little knowledge about hexidecimal addition is needed to utilize the displayed information efficiently. The contents of the buffer are displayed in the current mode. In ASCII mode, only legal ASCII characters are displayed; that is ' '..'}'; all other ASCII codes are displayed as blanks. The commands of "DISKREAD" are: 1) Set ASCII display mode : 'a' This command will immediately display the contents of the disk block buffer in ASCII and set the mode indicator to show this. - 1 - 1 Diskread 30 Apr 1980 2) Set HEXIDECIMAL display mode : 'h' This command will immediately display the contents of the disk block buffer in hex and set the mode indicator to show this. 3) READ a disk block : 'r' This command will cause "DISKREAD" to read in the disk block specified by the current blocknumber from the volume specified in the current unitnumber. If the I/O process is not complete, "DISKREAD" alerts the user and displays an error message, hit RETURN to continue. 4) WRITE the buffer to disk : 'w' This command will cause "DISKREAD" to write out the contents of the buffer to the block specified by the current block number on the volume specified by the current unit number. Before the process is completed, verification from the user is requested, typing anything except 'y' or 'Y' will abort the process. WARNING! This is the only dangerous command in "DISKREAD", once a buffer has been written to disk, the information that was prevously in the block on the disk is lost! If the I/O process is not complete, "DISKREAD" alerts the user and displays an error message, hit RETURN to continue. 5) INCREMENT disk block number : '+' This command will increment the current blocknumber by one each time it is pressed. If the blocknumber exceeds the MAXBLOCKS on the disk, the number wraps around to zero. For convenience the ';' may also be used so that the user does not have to hit the shift key. - 2 - 1 Diskread 30 Apr 1980 6) DECREMENT disk block number : '-' This command will decrement the current blocknumber by one each time it is pressed. If the blocknumber goes below zero, then number wraps around to the MAXBLOCKS. For convenience, if the keyboard is shift locked, the '=' may also be used. 7) Set the BLOCK NUMBER : 'b' This command allows the user to enter the absolute block address directly in either hexidecimal or decimal, default is decimal, but a '$' anywhere in the input field will cause the number to be processed as a hex number (this is true of all numeric input). Special Note: users with mini-floppies or hard disks will have to change the constant in the beginning of "DISKREAD" to reflect the correct number of blocks! 8) Set the UNIT NUMBER : 'u' This command allows the user to enter the volume number on which further operations are to take place, if the number entered is not a vailide block device then the default value of four is substituted - no error message is given! 9) CHANGE buffer byte by byte : 'c' This command allows the user to change the buffer con- tents byte by byte. The user is first ask for a starting address at which the changes are to begin, then he enter each change. The displayed numbers are the current address, and the value of the buffer at that address. To terminate the change mode, simply type return with no other entry. 10) STRING CHANGES : 's' This command allows the user to chage the buffer con- tents to values which are equivalent to an input string. The user is ask to supply a starting address for the string and the string, the change takes up as many bytes as are - 3 - 1 Diskread 30 Apr 1980 needed for the string, trailing blanks are significant! 11) MEMORY UPDATE : 'm' This command allows the user to change large amounts of the buffer with a single command. The starting address, the ending address, and the value to update the buffer to must be supplied when requested, if the starting address is larger than the ending addres the proccess is aborted. 12) QUIT : 'q' This command terminates "DISKREAD", the buffer is not saved automatically! Some General Suggestions Numeric inputs may be either hex or decimal, generally error messages are not given, "DISKREAD" assumes the user is very familar with this program, and that he simply made a typing error, any quantity may be corrected before the return key is hit by simply back spacing, and either upper of lower case characters can be used for commands and hex digits. Please send comments and suggestions to: Roger L. Soles Georgia Institute of Technology Atlanta, GA 30332 NOTICE: - 4 - 1 Diskread 30 Apr 1980 This program is for free distribution ONLY, and the copyright notice and author name may not be removed! ======================================================================================== DOCUMENT :usus Folder:VOL05:read.fmt.text ======================================================================================== UCSD PASCAL Textformatter User's Guide + UCSD PASCAL Textformatter User's Guide + UCSD PASCAL Textformatter User's Guide + UCSD PASCAL Textformatter User's Guide "Fmt" Version 2.1 by Francis J. Monaco + Francis J. Monaco + Francis J. Monaco + Francis J. Monaco 24 Apr 1980 1 Introduction + ____________ + ____________ + ____________ "Fmt" is a Pascal Program specifically written for the University of California at San Diego's PASCAL Operating System "USCD PASCAL." "Fmt" is designed to facilitate the preparation of neatly formatted documents, letters, reports, etc. "Fmt" allows the user to input a text file using the UCSD screen editor without concern of margins, centering, etc.; by interspersing a few "imbedded" commands in the input text file, the user is able to tell "fmt" what needs to be done to the text being processed. By studying the "in- put" to "fmt" alongside the "output" from "fmt", the user can easily modify the text to look exactly as he wants with a minimum effort. The "output" of "fmt" is a ".text" file containing FORTRAN carriage controls; this output can be funneled through a program like "sp" to convert FORTRAN carriage controls to Line Printer controls (more on this later). "Fmt" draws heavily from other textformatters; basically, it was designed to include almost all the good features found in other "word processing" systems while simultaneously keeping the program small, easy to maintain, and, above all, easy to modify. "Fmt" provides many impor- + easy to modify. + easy to modify. + easy to modify. tant features such as automatic margining, hyphenation, paragraphing, and pagination along with "headers" and "footers": basically, everything needed to ease the chore of text writing. In addition, "Fmt" enables the user to solicit input from multiple files as well as from the terminal's keyboard. The purpose of this guide is to demonstrate the use of "Fmt" to a UCSD PASCAL user. The reader of this guide need not be familiar with other text formatting tools; however, it is important that the reader be familiar with UCSD PASCAL at least at the novice level. Basics + ______ + ______ + ______ The file is the eXecutable file; at the com- mand level of the UCSD PASCAL system, the user should type X for eXecute + X for eXecute + X for eXecute + X for eXecute - 1 - 1 User Guide Fmt V2.1 24 Apr 1980 and when prompted for a file name, the response is :fmt + :fmt + :fmt + :fmt where is the UCSD PASCAL unit number containing the file . If all goes well, "Fmt" will respond: Enter title of text file to be formatted --> + Enter title of text file to be formatted --> + Enter title of text file to be formatted --> + Enter title of text file to be formatted --> to which the user should respond with the name of a text file containing imbedded "Fmt" commands like: <#5:user.in2>. Note that the ".text" must not be typed. If + not + not + not the file <#5:user.in2.text> exists, "Fmt" will next respond with: Enter the title of the formatted text or CR --> + Enter the title of the formatted text or CR --> + Enter the title of the formatted text or CR --> + Enter the title of the formatted text or CR --> to which the user must specify a disk file name like: <#5:user.out2>; again, note that the ".text" is omitted. Typing a carriage return will default to sending output to the CRT (this is good for initial viewing). Note: do not specify PRINTER: as the output file. Next, "Fmt" will respond with: ...Monaco's Fmt inititializing... ... + ...Monaco's Fmt inititializing... ... + ...Monaco's Fmt inititializing... ... + ...Monaco's Fmt inititializing... ... where is the date last typed in the Filer using the D(ate command. "Fmt" spends a few seconds with its segemented procedure initializations, and then begins reading the input file for commands and text, simultaneously writing to the output file or CRT. "Fmt" does not incorporate IO checking using the UCSD Function "IORESULT" and the Compiler option (*$I-*). Such code could be added in a later release; however, "Fmt" presently gives the user no second chances at interactive input. In addition, some of the commands described later in - 2 - 1 User Guide Fmt V2.1 24 Apr 1980 this guide require TYPED (in the strict PASCAL sense) arguments; failure to include required command arguments of the correct type will currently result in run-time errors. Commands and Text + _________________ + _________________ + _________________ "Fmt" defines a "word" as the contiguous grouping of characters between blanks or between end-of-line character and a blank. Thus "." is a word, as is "word", where the double quotes represent blanks. The basic unit returned by "Fmt's" input routine is a word. Words can be either com- + com- + com- + com- mands or text; Commands always begin with a period "." + mands or text; + mands or text; + mands or text; usually at the beginning of a line in the input text file; note that any word beginning with a period found anywhere in the input file will be treated as a command; thus "... " cannot be used! An example of a command follows: .tl @Some Title + .tl @Some Title + .tl @Some Title + .tl @Some Title where "tl" is the 'Command Name', "@Some Title" is the 'Command Argument', in this case, a string of characters of 'Argument Type' STRING. Note that nothing else may legally appear on the command line; "Fmt" does not require that com- mands be the first word on a line; however, it is a good idea to put commands on separate lines from surrounding text. Note also that some commands may 'bracket' text lines as: .bo This is text to be boldfaced. .bo where the command "bo" means boldface the text until the next occurence of the command. Some commands have 'defaults', either default values if a numeric argument is required, or default switches if a boolean value is appropriate. "Fmt" attempts, in its normal mode, to 'fill' as many text words between its left and right margins as possible. Some commands cause the current 'unfilled' line preceding the command to be forced to the output file; this is called 'breaking'. - 3 - 1 User Guide Fmt V2.1 24 Apr 1980 Command Description + ___________________ + ___________________ + ___________________ The following paragraphs in this User Guide describe all available commands in "Fmt" including: 1) COMMAND NAME + 1) COMMAND NAME + 1) COMMAND NAME + 1) COMMAND NAME 2) ARGUMENTS + 2) ARGUMENTS + 2) ARGUMENTS + 2) ARGUMENTS 3) DEFAULT + 3) DEFAULT + 3) DEFAULT + 3) DEFAULT 4) BREAK CAUSED + 4) BREAK CAUSED + 4) BREAK CAUSED + 4) BREAK CAUSED 5) ACTION OF COMMAND + 5) ACTION OF COMMAND + 5) ACTION OF COMMAND + 5) ACTION OF COMMAND By studying the command syntax along with a copy of the file , and this guide , the user should be able to easily capitalize on the available features of "Fmt". Command #1: .pp + Command #1: .pp + Command #1: .pp + Command #1: .pp COMMAND: Startnewparagraph ARGUMENTS: None required DEFAULT: N/A BREAK: Yes ACTION: Causes the current unfilled line to be forced to output, skipping LINESPACING line(s), and indenting the next line PDENT spaces. Command #2: .ce + Command #2: .ce + Command #2: .ce + Command #2: .ce COMMAND: Centeraline ARGUMENTS: STRING DEFAULT: N/A BREAK: Yes ACTION: Centers the argument if possible; recognizes the character "@" to mean boldface the argument or "_" to mean underline the argument if and only if the character appears as the first character in the argument string. The argument may appear on the same line or the line immediately fol- lowing the command. Command #3: .br + Command #3: .br + Command #3: .br + Command #3: .br COMMAND: Breakcurrentline ARGUMENTS: None DEFAULT: N/A BREAK: Yes ACTION: - 4 - 1 User Guide Fmt V2.1 24 Apr 1980 Forces the current unfilled text line to be written to the Output File. Note that a new line indentation is not automatically begun; thus the line after a ".br" will start in column 1 instead of in the leftmargin. The user should thus combine this command with another like ".pp". Command #4: .nf + Command #4: .nf + Command #4: .nf + Command #4: .nf COMMAND: Donotfilltext ARGUMENTS: String(s) of lines; DEFAULT: N/A BREAK: Yes ACTION: Causes input to be echoed to output without fill, but each line starting at the LEFTMARGIN. The user must insure that text will fit between the LEFTMARGIN and LINEWIDTH. Used for tables, etc. Note that this is a BRACKET command that is turned off by another occurence of the same command (MUST begin in Column One). Also, the line following the terminal ".nf" will begin in column one, not the leftmargin, unless the user provides an additional command like ".pp". Command #5: .sp + Command #5: .sp + Command #5: .sp + Command #5: .sp COMMAND: Skipline ARGUMENTS: None DEFAULT: N/A BREAK: Yes ACTION: Causes the current unfilled line of text to be written to the output file and the next line to be skipped. Each oc- curence of the command skips one line (See Command #28 for multiple skips). Command #6: .so + Command #6: .so + Command #6: .so + Command #6: .so COMMAND: Takeinputfromnewfile ARGUMENTS: STRING { '-', } DEFAULT: N/A BREAK: Yes ACTION: This command temporarily alters the input stream of "Fmt". It has two options: A) Interactive Input: when the argument string contains the character '-', "Fmt" will stop taking input from the original file and begin taking input from the terminal's keyboard (until either another ".so" command is seen or the user types ASCII ETX (Control C). "Fmt" will discard the last "word" typed before the ETX before returning to the main input file, so the user should include an extra word like " * " at the end of the last line - 5 - 1 User Guide Fmt V2.1 24 Apr 1980 of interactive input. In addition, the user should use a ".pr" command to prompt for input at the Console. Note that interactive input makes sense only when writing to a Disk File (and using CARRIAGECONTROL). An example of interactive input follows: .pr Please type in the name line: .so - { A ? will now appear on the screen. The user should type until finished, adding a "*" at the end, followed by a carriage-return, and last by a CONTROL-C as } ? This is the name line * { Control- C} { "Fmt" now returns to the original input file } B) Input from a New Disk File: when the string argument doesn't contain '-' , "Fmt" interprets the String as a Disk Text file (without the ".text") as: #5:new.input. "Fmt" then RESETS the new file and begins taking input from it, remem- bering how to return to the original input file when EOF occurs in the new file. Command #7: .lm + Command #7: .lm + Command #7: .lm + Command #7: .lm COMMAND: Setleftmargin ARGUMENTS: INTEGER in the range 1..40 DEFAULT: 9 BREAK: No ACTION: Alters the value of LEFTMARGIN. Command #8: .rm + Command #8: .rm + Command #8: .rm + Command #8: .rm COMMAND: Setrightmargin ARGUMENTS: INTEGER in the range 40..80 DEFAULT: 69 BREAK: No ACTION: Alters the value of LINEWIDTH (the number of columns between the LEFTMARGIN and RIGHTMARGIN. For all practical purposes, LINEWIDTH is the RIGHTMARGIN in the typewriter sense. Command #9: .hy+ + Command #9: .hy+ + Command #9: .hy+ + Command #9: .hy+ COMMAND: Onhyphen - 6 - 1 User Guide Fmt V2.1 24 Apr 1980 ARGUMENTS: None DEFAULT: True BREAK: No ACTION: Turns on automatic hyphenation (HYNATE := TRUE). Command #10: .hy- + Command #10: .hy- + Command #10: .hy- + Command #10: .hy- COMMAND: Offhyphen ARGUMENTS: None DEFAULT: False BREAK: No ACTION: Turns off automatic hyphenation (HYNATE := FALSE). Command #11: .lpt + Command #11: .lpt + Command #11: .lpt + Command #11: .lpt COMMAND: Lineprinter ARGUMENTS: None DEFAULT: False BREAK: No ACTION: Turns on generation of Fortran Carriage Controls '1' for ASCII FF, and '+' for CR without LF (CARRIAGECONTROL := TRUE). Note that the ".lpt" command must be selected in order to generate BOLDFACE or UNDERLINE. Command #12: .crt + Command #12: .crt + Command #12: .crt + Command #12: .crt COMMAND: Crt ARGUMENTS: None DEFAULT: True BREAK: No ACTION: Turns off generation of Fortran Carriage Controls (CARRIAGECONTROL := FALSE). Also stops BOLDFACE and UNDERLINE. Command #13: .tl + Command #13: .tl + Command #13: .tl + Command #13: .tl COMMAND: Title ARGUMENTS: {@STRING} , {_STRING}, {STRING} DEFAULT: N/A BREAK: Yes: one before and one after Title ACTION: Generates a blank line following by a centered title followed by a blank line. The characters "@" and "_" can only be used as the first character of the STRING argument, with "@" meaning BOLDFACE the STRING and "_" meaning UNDERLINE the STRING (as well as center). - 7 - 1 User Guide Fmt V2.1 24 Apr 1980 Command #14: .he + Command #14: .he + Command #14: .he + Command #14: .he COMMAND: Header ARGUMENTS: {' S1 '}, {' S1 ' S2 '}, {' S1 ' S2 ' S3 '} DEFAULT: N/A BREAK: No ACTION: The next time the HEADER line is encountered in the output file, this command will generate a one, two, or three part header. Do not use the Single Quotes (') for anything but delimiters of the STRING(s). If the characters "#" or "^" appear in S1, S2, or S3, they have special meaning: "#" denotes the CURRPAGE; "^" denotes THEDATE. The Header line appears M1 lines from the Top of the Page. There are M2 lines between the Header line and the first text line. If more than four single quotes appear in the argument, the header will be blank. Also, Headers can be changed anywhere in the text. Command #15: .fo + Command #15: .fo + Command #15: .fo + Command #15: .fo COMMAND: Footer ARGUMENTS: See Header, #14. DEFAULT: " BREAK: " ACTION: Same as Header, #14, except that the Footer line ap- pears M3 lines after the last text line on a page of output text. There are M4 lines after every Footer until the Top of next Page. Command #16: .m1 + Command #16: .m1 + Command #16: .m1 + Command #16: .m1 COMMAND: Setm1 ARGUMENTS: INTEGER in the range 1..5 DEFAULT: 1 BREAK: No ACTION: Sets the M1 margin (the number of lines between the Top of Page and the Header Line). Command #17: .m2 + Command #17: .m2 + Command #17: .m2 + Command #17: .m2 COMMAND: Setm2 ARGUMENTS: INTEGER in the range 1..10 DEFAULT: 2 BREAK: No ACTION: - 8 - 1 User Guide Fmt V2.1 24 Apr 1980 Sets the M2 margin (the number of lines between the Header and the first line of text). Command #18: .m3 + Command #18: .m3 + Command #18: .m3 + Command #18: .m3 COMMAND: Setm3 ARGUMENTS: INTEGER in the range 1..10 DEFAULT: 2 BREAK: No ACTION: Sets the M3 margin (the number of lines between the last text line and the Footer). Command #19: .m4 + Command #19: .m4 + Command #19: .m4 + Command #19: .m4 COMMAND: Setm4 ARGUMENTS: INTEGER in the range 1..5 DEFAULT: 1 BREAK: No ACTION: Sets the M4 margin (the number of lines between the Fotter and the Top of the Next Page). Command #20: .pn + Command #20: .pn + Command #20: .pn + Command #20: .pn COMMAND: Setpagenum ARGUMENTS: INTEGER DEFAULT: N/A (However, first output page is CURRPAGE := 1). BREAK: No ACTION: Sets the value of CURRPAGE. Useful when preparing documents in many chapters. Command #21: .pg + Command #21: .pg + Command #21: .pg + Command #21: .pg COMMAND: Startpage ARGUMENTS: None DEFAULT: N/A BREAK: Yes ACTION: Breaks the current unfilled line, vertical tabs to the Footer, outputs the Footer, starts a new page, and outputs the Header of the new page. Command #22: .bo + Command #22: .bo + Command #22: .bo + Command #22: .bo COMMAND: Boldface ARGUMENTS: STRING(s) (of lines) DEFAULT: N/A BREAK: No ACTION: - 9 - 1 User Guide Fmt V2.1 24 Apr 1980 BOLDFACEs the arguments bracketed by the commands. Terminated by another occurence of the command. Works only with the ".lpt" option. Do not use in Headers, Footers, or Titles. Command #23: .ul + Command #23: .ul + Command #23: .ul + Command #23: .ul COMMAND: Underline ARGUMENTS: STRING(s) (of lines) DEFAULT: N/A BREAK: No ACTION: UNDERLINES the arguments bracketed by the commands. Terminated by another occurence of the command. Works only with the ".lpt" option. Do not use in Headers, Footers, or Titles. Command #24: .ls + Command #24: .ls + Command #24: .ls + Command #24: .ls COMMAND: Setlinespacing ARGUMENTS: INTEGER in the range 1..3 DEFAULT: 1 BREAK: No ACTION: Alters the current value of LINESPACING. Command #25: .ps + Command #25: .ps + Command #25: .ps + Command #25: .ps COMMAND: Setpagesize ARGUMENTS: INTEGER in the range 30..63 DEFAULT: 63 BREAK: No ACTION: Alters the value of PAGESIZE, the number of lines on a page counting M1, M2, M3, M4 and the text between.. Command #26: .pi + Command #26: .pi + Command #26: .pi + Command #26: .pi COMMAND: Pindentation ARGUMENTS: INTEGER in the range 1..20 DEFAULT: 5 BREAK: No ACTION: Alters the value of PDENT, the number of spaces in- dented whenever a new paragraph is started (with a ".pp"). Command #27: .ti + Command #27: .ti + Command #27: .ti + Command #27: .ti COMMAND: Tindentation ARGUMENTS: INTEGER in the range 1..20 DEFAULT: N/A - 10 - 1 User Guide Fmt V2.1 24 Apr 1980 BREAK: Yes ACTION: This command causes a break followed by an indentation of the next line TDENT spaces, where TDENT is the argument of the command. Command #28: .sp+ + Command #28: .sp+ + Command #28: .sp+ + Command #28: .sp+ COMMAND: Skipplus ARGUMENTS: INTEGER in the range 2..50 DEFAULT: N/A BREAK: Yes ACTION: This commands breaks the current unfilled line and skips THESKIP * LINESPACING lines, where THESKIP is the com- mand argument. Note that after this command executes, it is necessary to execute a command like ".pp" to start a new line in the LEFTMARGIN. Command #29: .noadj + Command #29: .noadj + Command #29: .noadj + Command #29: .noadj COMMAND: Donotrightadjusttext ARGUMENTS: None DEFAULT: False BREAK: No ACTION: Toggles the value of NOADJ; text from this command foward (until another occurence of the command) will be word justified such that if a word is attempted to be added to a line and cannot fit, the line will be broken and the word will begin the next line. This is useful whenever the user wants to give the rightmargin a ragged, typewriter look. Note that the ".noadj" option has been selected for this paragraph as an example. Command #30: .ne + Command #30: .ne + Command #30: .ne + Command #30: .ne COMMAND: Need ARGUMENTS: INTEGER in the Range 1..50 DEFAULT: N/A BREAK: Yes ACTION: Checks to see whether the argument number of lines remain in the text portion of a given page before the next line of input is processed. If not, a new page is begun before the the line of input is processed. Command #31: .pr + Command #31: .pr + Command #31: .pr + Command #31: .pr COMMAND: Prompt ARGUMENTS: STRING DEFAULT: N/A - 11 - 1 User Guide Fmt V2.1 24 Apr 1980 BREAK: Yes ACTION: Used just before the ".so -" command, this writes a prompt to the crt if and only if the ".lpt" option is in effect. The user should use this command only when building output text files on disk, as interspersing prompts and text on the crt is very confusing. Command #32: .# + Command #32: .# + Command #32: .# + Command #32: .# COMMAND: Comment ARGUMENTS: STRING DEFAULT: N/A BREAK: No ACTION: Allows the user to comment the input text file; no ac- tion is taken with the comment (it is ignored by "Fmt"; however, it must be there!) Helpful Hints on Using Fmt + __________________________ + __________________________ + __________________________ Once the user of "Fmt" has studied the available com- mands alongside of the input file(s) and output files, it is necessary to observe a few factors when using "Fmt". First, keep strings of characters less than TWENTY-ONE characters long; otherwise, you'll find that "Fmt" does a COBOL-like job of character truncation of the righthand part of long strings! Next, realize that the output file will be on the order of 3 times larger than the input file; ensure adequate space for it to be built. Once your output file is built with "FORTRAN" carriage controls within (using the ".lpt" option), use the program "SP" to spool your output to your printer. You may have to tinker with "SP" and your printer to turn off automatic Line Feeds at the end of a line (since the "+" carriage control character, used for boldfacing and underlining, requires only a carriage return). Watch out for ".nf" and ".sp+ " commands; their behavior is sometimes questionable, and it is best to put a ".pp" after ending a ".nf" or after a ".sp+". Above all, never "nest" any commands inside bracketed + "nest" + "nest" + "nest" "Fmt" commands (.nf,.bo, etc.). - 12 - 1 User Guide Fmt V2.1 24 Apr 1980 Lastly, to learn how to use any textformatter, you must study the input alongside the output (that's the third time I've recommended this, please take note!). The Future of Fmt... + The Future of Fmt... + The Future of Fmt... + The Future of Fmt... When time permits, the following additional features will be added to "Fmt": 1) User defined macros for sequences of "Fmt" commands. 2) Tabbing and replacement tab characters. 3) IO checking to make it almost impossible to bomb "Fmt". 4) Character mapping Function to enable upper and lower case hyphenation and commands. 5) User defined in-line variables. Where to Send Bug Reports and Suggestions: + __________________________________________ + __________________________________________ + __________________________________________ Address until 14 June 1980: Francis J. Monaco Captain, US ARMY 679 Lowell Drive Marietta, Georgia 30060 404-424-1460 Address after 14 June 1980: Francis J. Monaco Captain, US ARMY Department of Geography and Computer Science The United States Military Academy West Point, New York 10996 914-938-2063 ======================================================================================== DOCUMENT :usus Folder:VOL05:screencntl.text ======================================================================================== SEPARATE UNIT SCREENCONTROL; INTERFACE PROCEDURE ClearScreen; PROCEDURE EraseEOL; PROCEDURE GoAndClearLine (y: integer); PROCEDURE EraseEOS; FUNCTION Yes (Prompt: string) : boolean; IMPLEMENTATION PROCEDURE ClearScreen; BEGIN Page (Output) END; PROCEDURE EraseEOL; VAR ch: PACKED ARRAY [0..1] OF integer; BEGIN ch [0] := 21; Unitwrite (1,ch,1) END; PROCEDURE GoAndClearLine; BEGIN Gotoxy (0,y); EraseEOL END; PROCEDURE EraseEOS; VAR ch: PACKED ARRAY [0..1] OF integer; BEGIN ch [0] := 22; Unitwrite (1,ch,1) END; FUNCTION Yes { (Prompt: string) : boolean }; VAR ch: char; BEGIN Write (Prompt, ' (Y/N)? '); REPEAT Read (keyboard, ch) UNTIL (ch IN ['Y', 'y', 'N', 'n']); CASE ch OF 'Y', 'y': BEGIN Writeln ('Yes'); Yes := true END; 'N', 'n': BEGIN Writeln ('No'); Yes := false END END {case} END; END. (*end of unit*) ======================================================================================== DOCUMENT :usus Folder:VOL05:sp.text ======================================================================================== PROGRAM SP (* converts Fortran Carriage Controls inserted by selecting the ".lpt" option in "Fmt" to ascii printer controls *); (* ******************************************************* * FORTRAN CARRIAGE CONTROL * * 1....sends FF * * +....sends CR * ******************************************************* *) VAR FIRSTPART, FILENAME : STRING; F : TEXT; FIRSTPOS, BOLDFACE, FORTRANCONTROLS : BOOLEAN; I : INTEGER; CH, LASTCH : CHAR; PROCEDURE PUTP; EXTERNAL; (* ASSEMBLY ROUTINE THAT PUTS ONE CHARACTER INTO THE H14'S SERIAL BOARD AT 177514. ALSO CHECKS BIT 15 (RTS) OF 177510 TO VERIFY STATUS OF FIFO BUFFER. ; THIS PROCEDURE MUST BE ASSEMBLED AND THE ".CODE" ; FILE MUST BE PLACED IN '*SYSTEM.LIBRARY' ; ; ; TESTS H14 INTERFACE SIO AND SENDS ONE ; CHARACTER TO PRINTER WHEN BOTH TRANSMIT ; STATUS AND RTS (BUFFER) ARE READY ; THIS ALLOWS OPERATION AT 4800 BAUD ; (MAXIMUM) WITH FULL HANDSHAKING ; ; ; THIS CODE IS WRITTEN IN UCSD PASCAL ; ASSEMBLER FOR THE LSI11/2 (HEATHKIT H11A) ; AND MUST BE RE-WRITTEN FOR THE PARTICULAR ; PROCESSOR THE UCSD PASCAL OPERATING SYSTEM ; IS RUNNING UNDER. ; ; .PROC PUTP ; EXTERNAL PROCEDURE TO PASCAL ; HOST .PUBLIC CH ; GLOBAL VARIABLE BETWEEN ; PASCAL HOST AND "PUTP" PRS .EQU 177510 ; PRINTER RECEIVE STATUS PXS .EQU 177514 ; PRINTER TRANSMIT STATUS PXB .EQU 177516 ; PRINTER TRANSMIT BUFFER L1: TSTB @#PXS ; TRANSMIT READY? BPL L1 ; NO - WAIT L2: BIT #100000,@#PRS ; RTS READY (FIFO BUFFER)? BNE L2 ; NO - WAIT MOVB @#CH,@#PXB ; EVERYTHING READY: PRINT CH MOV (SP)+,R0 ; SET UP RETURN TO PASCAL HOST JMP @R0 ; AND RETURN .END ; END EXTERNAL PROCEDURE NOTE!!! IF YOUR PRINTER DRIVER IS BOUND IN TO YOUR PASCAL SYSTEM, SUBSTITUTE THE FOLLOWING IN LINE FOR PUTP: SPECIAL NOTE: IN ORDER FOR THIS TO WORK, YOUR PRINTER DRIVER MUST BE ABLE TO UNDERSTAND THE DIFFERENCE BETWEEN A CARRIAGE RETURN AND A LINE FEED!!! OTHERWISE, REWRITE "PUTP" FOR YOUR PRINTER!!! PROCEDURE PUTP; VAR CHBUF : PACKED ARRAY [ 0 .. 1 ] OF CHAR; BEGIN CHBUF [ 0 ] := CH; UNITWRITE ( 6, CHBUF, 1 ) END; *) PROCEDURE FORTRAN; (* USES THE CHARACTER IN COLUMN ONE FOR CARRIAGE CONTROL *) BEGIN BOLDFACE := FALSE; WHILE NOT EOF(F) DO BEGIN FIRSTPOS := TRUE; WHILE NOT EOLN (F) DO BEGIN IF FIRSTPOS THEN BEGIN READ(F,CH); CASE CH OF '1' : BEGIN (* TOP OF FORM CASE *) CH := CHR(12); (* ASCII FF *) PUTP; FIRSTPOS := FALSE END; '+' : BEGIN (* OVERSTRIKE CASE *) BOLDFACE := TRUE; FIRSTPOS := FALSE END END; (*CASE*) IF FIRSTPOS THEN BEGIN LASTCH := CH; CH := CHR(10); (* ASCII LF *) PUTP; CH := LASTCH; PUTP; WRITE(CH); FIRSTPOS := FALSE END; END ELSE BEGIN IF BOLDFACE THEN (* COMPENSATE FOR '+' IN COLUMN ONE *) BEGIN BOLDFACE := FALSE; CH := ' '; PUTP END ELSE BEGIN READ(F,CH); PUTP; WRITE(CH) END END END; READLN(F); IF FIRSTPOS THEN CH := CHR ( 10 ) (* ASCII LF *) ELSE CH := CHR(13); (* ASCII CR *) PUTP; WRITELN; END; END; (* PROCEDURE FORTRAN *) PROCEDURE GETFILE; (* SOLICIT FILE NAME TO BE PRINTED FROM USER *) BEGIN WRITE('Please enter text file name--> '); READLN(INPUT,FIRSTPART); FILENAME := CONCAT(FIRSTPART,'.text'); RESET(F,FILENAME); END; PROCEDURE ASKFORMORE; (* MORE FILES TO PRINT? *) BEGIN WRITE('Do you want to print any more files? '); READLN(KEYBOARD,CH); CLOSE ( F , NORMAL ) END; (*ASKFORMORE*) BEGIN (* SP *) REPEAT GETFILE; FORTRAN; ASKFORMORE UNTIL CH IN ['n','N']; END. (* SP *) ======================================================================================== DOCUMENT :usus Folder:VOL05:struct.text ======================================================================================== PROGRAM STRUCT; (* BUILDS A STRUCTURED FILE "#5:ADDRESS.TEXT" FROM AN UNSTRUCTURED TEXT FILE "#5:ADDS.TEXT"*) CONST BLANK = ' '; (* *********************************************************** THE FILE "#5:ADDS.TEXT" SHOULD BE BUILT USING THE EDITOR AND SHOULD LOOK LIKE THIS: NAMELINE STREETLINE CITYSTATEZIPLINE PHONELINE KEYLINE NEXTNAMELINE ETC... ************************************************************* *) TYPE STRUCTURE = RECORD NAME : STRING; STREET : STRING; CITYSTATEZIP : STRING; PHONE : STRING; KEY : STRING END; VAR RECNUM : INTEGER; FID : FILE OF STRUCTURE; S : STRING; FIN : TEXT; PROCEDURE ZEROREC (VAR REC : STRUCTURE); BEGIN (* ZEROREC *) WITH REC DO BEGIN NAME := BLANK; STREET := BLANK; CITYSTATEZIP := BLANK; PHONE := BLANK; KEY := BLANK END; END; (* ZEROREC *) BEGIN (* BUILDADDRESS.TEXT *) REWRITE(FID,'#5:address.text'); (*$I+*) WRITELN ('... Building the structured file ...'); WRITELN ('... Transferring these records: '); WRITELN; RECNUM := 0; RESET(FIN,'#5:adds.text'); WHILE NOT EOF(FIN) DO BEGIN SEEK(FID,RECNUM); GET(FID); ZEROREC(FID^); READLN(FIN,S); FID^.NAME := S; READLN(FIN,S); FID^.STREET := S; READLN(FIN,S); FID^.CITYSTATEZIP := S; READLN(FIN,S); FID^.PHONE := S; READLN(FIN,S); WRITELN(S); FID^.KEY := S; WRITELN; SEEK(FID,RECNUM); PUT(FID); RECNUM := SUCC (RECNUM) END; CLOSE(FID,LOCK); CLOSE(FIN,LOCK); REWRITE (FIN,'#5:KEYNO.TEXT'); WRITELN (FIN, RECNUM ); CLOSE ( FIN, LOCK ); WRITELN; WRITELN (' ... Finished ...'); END. (* PROGRAM BUILDADDRESS.TEXT *) ======================================================================================== DOCUMENT :usus Folder:VOL05:unit.good.text ======================================================================================== (*$S+*) UNIT GOODSTUFF; INTERFACE { I call these routines GOOD STUFF: they really ease the chore of programming in UCSD PASCAL; I recommend that you try them... you won't be sorry } { Global stuff.... } TYPE (* THIS MUST BE A GLOBAL TYPE!!!!!! *) CRTCOMMAND = (ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT,LEADIN); FILET = FILE; DATEREC = PACKED RECORD MONTH: 0..12; DAY: 0..31; YEAR: 0..100 END; DIRRANGE = 0..77; VID = STRING[7]; TID = STRING[15]; FILEKIND = (UNTYPED,XDISK,CODE,TEXT, INFO,DATA,GRAF,FOTO,SECUREDIR); DIRENTRY = RECORD DFIRSTBLK: INTEGER; DLASTBLK: INTEGER; CASE DFKIND:FILEKIND OF SECUREDIR,UNTYPED: (DVID:VID; DEOVBLK, DLOADTIME, DBLOCKS:INTEGER; DLASTBOOT:DATEREC); XDISK,CODE,TEXT,INFO,DATA, GRAF,FOTO: (DTID:TID; DLASTBYTE:1..512; DACCESS:DATEREC) END; DIRP = ^DIRECTORY; DIRECTORY = ARRAY[DIRRANGE] OF DIRENTRY; VAR (* THESE MUST BE GLOBAL VARIABLES !!!!! *) CRTINFO: PACKED ARRAY[CRTCOMMAND] OF CHAR; PREFIXED: ARRAY[CRTCOMMAND] OF BOOLEAN; F : FILE; DIRX: DIRECTORY; PROCEDURE GETCRTINFO; PROCEDURE CRT ( C : CRTCOMMAND ); PROCEDURE DIR; PROCEDURE GETSTRING ( VAR TYPED: STRING; X, Y, MAXLENGTH : INTEGER); PROCEDURE GETFILE ( VAR THEFILE : FILET; ISINPUTFILE : BOOLEAN ); PROCEDURE GETDATE ( VAR THEDATE : STRING ); IMPLEMENTATION PROCEDURE GETCRTINFO; (* BY ROGER SOLES, GEORGIA TECH *) (* CALL THIS ROUTINE AT THE BEGINNING OF EVERY PROGRAM BEFORE USING "CRT"*) (* READ SYSTEM.MISCINFO AND GET CRT CONTROL CHARACTER INFO *) VAR BUFFER: PACKED ARRAY[0..511] OF CHAR; I, BYTE: INTEGER; (* F: FILE; *) BEGIN RESET(F,'*SYSTEM.MISCINFO'); I := BLOCKREAD(F,BUFFER,1); CLOSE(F); BYTE := ORD(BUFFER[72]); (* PREFIX INFORMATION BYTE *) CRTINFO[LEADIN] := BUFFER[62]; PREFIXED[LEADIN] := FALSE; CRTINFO[ERASEOS] := BUFFER[64]; PREFIXED[ERASEOS] := ODD(BYTE DIV 8); CRTINFO[ERASEOL] := BUFFER[65]; PREFIXED[ERASEOL] := ODD(BYTE DIV 4); CRTINFO[RIGHT] := BUFFER[66]; PREFIXED[RIGHT] := ODD(BYTE DIV 2); CRTINFO[UP] := BUFFER[67]; PREFIXED[UP] := ODD(BYTE); CRTINFO[LEFT] := BUFFER[68]; PREFIXED[LEFT] := ODD(BYTE DIV 32); CRTINFO[DOWN] := CHR(10); PREFIXED[DOWN] := FALSE; END; PROCEDURE CRT(*C: CRTCOMMAND *); (* BY ROGER SOLES, GEORGIA TECH *) (* CRT COMMANDS ARE: ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT; CALL THIS ROUTINE WITH ONE OF THESE PARAMETERS ANYWHERE AFTER INITIALLY CALLING "GETCRTINFO". *) BEGIN IF PREFIXED[C] THEN UNITWRITE(1,CRTINFO[LEADIN],1,0,12); UNITWRITE(1,CRTINFO[C],1,0,12); END; PROCEDURE DIR; VAR UNITNUM,I: INTEGER; BUFR: PACKED ARRAY[0..2048] OF CHAR; CHBUF : char; BEGIN repeat WRITELN; WRITE('Enter unit number for required directory --> '); READLN(UNITNUM); WRITELN until unitnum in [ 4 .. 5 ]; (*$I-*) UNITCLEAR ( UNITNUM ); UNITREAD(UNITNUM,DIRX[0],2048,2); UNITCLEAR ( UNITNUM ); IF IORESULT <> 0 THEN BEGIN WRITELN('Unit not online'); (*$I+*) EXIT(DIR); END; WITH DIRX[0] DO WRITELN('VOL = ',DVID,':'); FOR I:=1 TO DIRX[0].DLOADTIME DO BEGIN WITH DIRX[I] DO BEGIN IF LENGTH(DTID)>0 THEN BEGIN WRITE(DTID,' ':16-LENGTH(DTID),DLASTBLK-DFIRSTBLK: 4,' '); WITH DACCESS DO BEGIN WRITE(DAY:3,'-'); CASE MONTH OF 1: WRITE('Jan'); 2: WRITE('Feb'); 3: WRITE('Mar'); 4: WRITE('Apr'); 5: WRITE('May'); 6: WRITE('Jun'); 7: WRITE('Jul'); 8: WRITE('Aug'); 9: WRITE('Sep'); 10: WRITE('Oct'); 11: WRITE('Nov'); 12: WRITE('Dec'); END; WRITE('-',YEAR:2,' ':3); END; CASE DFKIND OF XDISK: WRITE('Bad block'); CODE: WRITE('Code file'); TEXT: WRITE('Text file'); INFO: WRITE('Info file'); DATA: WRITE('Data file'); GRAF: WRITE('Graf file'); FOTO: WRITE('Foto file'); END; (* CASE OF *) WRITELN; END; END; if i mod 21 = 0 then begin writeln; write (' tap to continue '); repeat read ( chbuf ) until chbuf = ' '; writeln; end; END; WRITELN; WRITE (' tap to continue '); repeat read ( chbuf ) until chbuf = ' '; writeln; END; (*$I+*) PROCEDURE GETSTRING (*VAR TYPED: STRING; X,Y, MAXLENGTH: INTEGER ( "TYPED" IS THE NEW STRING NAME (DEFINED GLOBALLY OR IN THE CALLING PROCEDURE); X, Y DEFINE THE SCREEN COORDINATES OF THE INPUT POINT; MAXLENGTH DEFINES THE LENGTH OF THE STRING *); (* procedure by Jim Gagne, modified by Frank Monaco *) VAR J, K: INTEGER; GOTSTRING: BOOLEAN; BELL: CHAR; BEGIN BELL := CHR (7); GOTSTRING := FALSE; REPEAT GOTOXY (X,Y); FOR J := 1 TO MAXLENGTH DO WRITE ('.'); GOTOXY (X,Y); READLN (TYPED); K := LENGTH (TYPED); IF K > MAXLENGTH THEN BEGIN GOTOXY (X,Y); WRITE (' ':K); GOTOXY (0,23); WRITE (BELL, 'You have entered too many characters in this line. ', 'Please try again.') END ELSE GOTSTRING := TRUE UNTIL GOTSTRING; GOTOXY ((X+K),Y); WRITE (' ':(MAXLENGTH - K)); GOTOXY (2,22); WRITE (' ':70); GOTOXY (0,73); WRITE (' ':70) END (*GETSTRING*); PROCEDURE GETFILE (* VAR THEFILE : FILE; ISINPUTFILE: BOOLEAN ( THEFILE IS THE INPUT OR OUTPUT FILE YOU HAVE GLOBALLY DEFINED (OR DEFINED IN THE CALLING PROCEDURE); ISINPUTFILE IS "TRUE" OR "FALSE" TO TOGGLE RESET/REWRITE...*) ; (* procedure by Jim Gagne, modified by Frank Monaco *) VAR GOTFN: BOOLEAN; BELL, RESPONSE: CHAR; FILENAME, FILETYPE, TYPED : STRING; BEGIN (* GETFILE *) getcrtinfo; BELL := CHR (7); REPEAT GOTOXY ( 0, 0 ); CRT ( ERASEOS ); IF ISINPUTFILE THEN FILETYPE := 'input' ELSE FILETYPE := 'output'; GOTOXY (11,20); WRITE ('Please type the name of the desired ', FILETYPE, ' file '); GOTOXY (15,21); WRITE ('--> '); GOTOXY (11,22); WRITE (' (Or just press the key if you wish to quit.)'); TYPED := ''; GETSTRING ( TYPED, 20,21, 23); IF LENGTH (TYPED) = 0 THEN BEGIN GOTOXY (11,23); WRITE ('Would you prefer to quit this program (Y/N)? '); READ (KEYBOARD, RESPONSE); GOTOXY (11,23); WRITE (' ':47); IF (RESPONSE = 'Y') OR (RESPONSE = 'y') THEN EXIT (PROGRAM) END ELSE BEGIN FILENAME := TYPED; (*$I-*) IF ISINPUTFILE THEN RESET (THEFILE, FILENAME) ELSE REWRITE ( THEFILE, FILENAME); IF IORESULT > 0 THEN IF ISINPUTFILE THEN RESET (THEFILE, CONCAT (FILENAME, '.TEXT')) ELSE REWRITE ( THEFILE, CONCAT ( FILENAME, '.TEXT') ); (*$I+*) GOTFN := IORESULT = 0; IF NOT GOTFN THEN BEGIN GOTOXY (0,23); WRITE (BELL, '<<**** ERROR ****>> ', 'Wrong volume or file name. Type for Directory.'); REPEAT READ (KEYBOARD, RESPONSE) UNTIL RESPONSE = ' '; GOTOXY ( 0, 0 ); CRT ( ERASEOS ); DIR END END(*ELSE*) UNTIL GOTFN; END (*GETFILE*); PROCEDURE GETDATE(*VAR ( RETURNING ) THEDATE: STRING ( THEDATE IS A STRING VARIABLE DEFINED BY THE CALLING ROUTINE (OR GLOBALLY) AND WILL LOOK LIKE THIS WHEN RETURNED: "24 Apr 1980"*); (* ALGORITHM BY ROGER SOLES, FRANK MONACO, GEORGIA TECH *) CONST FIRSTBYTE = 21; SECONDBYTE = 22; START = 1; FINISH = 24; TYPE RANGE = START .. FINISH; ARAYTYPE = PACKED ARRAY [ RANGE ] OF CHAR; VAR DUMMY : ARAYTYPE; HIGH, LOW : INTEGER; DAY, MONTH, YEAR: INTEGER; CMONTH, CDAY, CYEAR : STRING; BEGIN UNITREAD( 4, DUMMY, 24, 2); HIGH := ORD ( DUMMY [ SECONDBYTE ] ); (* GET THE DATE BYTES INTO HIGH AND LOW *) LOW := ORD ( DUMMY [ FIRSTBYTE ] ); DAY := ( HIGH MOD 2 ) * 16 + LOW DIV 16; MONTH := LOW MOD 16; (* EXTRACT NECESSARY INFO *) YEAR := HIGH DIV 2; STR ( DAY, CDAY ); (* CONVERT INTEGERS TO STRINGS *) STR ( YEAR, CYEAR ); CASE MONTH OF 1: CMONTH := 'Jan'; 2: CMONTH := 'Feb'; 3: CMONTH := 'Mar'; 4: CMONTH := 'Apr'; 5: CMONTH := 'May'; 6: CMONTH := 'June'; 7: CMONTH := 'July'; 8: CMONTH := 'Aug'; 9: CMONTH := 'Sept'; 10: CMONTH := 'Oct'; 11: CMONTH := 'Nov'; 12: CMONTH := 'Dec' END; THEDATE := CONCAT ( CDAY, ' ', CMONTH, ' 19', CYEAR ); END; (* PROCEDURE GETDATE *) END. { UNIT GOODSTUFF } ======================================================================================== DOCUMENT :usus Folder:VOL05:update.text ======================================================================================== PROGRAM UPDATE; (* UPDATES DISK FILE "#5:ADDRESS.TEXT": CAN ADD DELETE, OR PRINT RECORDS BASED ON KEY *) (* REQUIRES "#5:KEYS.TEXT" AND "#5:ADDRESS.TEXT"*) TYPE KEYRANGE = 0..300; (* CHANGE THIS IF YOU EXPECT > 300 RECORDS *) KEYTYPE = PACKED ARRAY [ KEYRANGE ] OF STRING; STRUCTURE = RECORD NAME : STRING; STREET : STRING; CITYSTATEZIP : STRING; PHONE : STRING; KEY : STRING END; VAR RECNUM, MAXKEYS : INTEGER; FID : FILE OF STRUCTURE; FIN, LP, KEYNO : TEXT; PATTERN, BUFFER : STRING[80]; KEYS : KEYTYPE; LF, LI, CH, BELL, ESC, FG, BG, CS : CHAR; PRINTIT, FINISHED, MUSTRUNKEYIT : BOOLEAN; PROCEDURE PUTP; BEGIN WRITE ( LP, CH ); END; PROCEDURE KEYIT;(* CREATES "#5:KEYS.TEXT" CONTAINING THE KEYS FROM "#5:ADDRESS.TEXT" *) BEGIN (* KEYSFORADDRESSTEXT *) WRITELN (' ... Updating the keys ... '); WRITELN; RESET ( KEYNO, '#5:KEYNO.TEXT'); READLN( KEYNO, MAXKEYS); CLOSE (KEYNO, NORMAL); REWRITE(FIN, '#5:keys.text'); WRITELN(FIN, MAXKEYS); RECNUM := 0; RESET(FID,'#5:address.text'); WHILE ((NOT EOF(FID)) AND (RECNUM <= MAXKEYS)) DO BEGIN SEEK(FID, RECNUM); GET(FID); BUFFER := FID^.KEY; WRITELN(FIN,BUFFER); WRITE ('.'); SEEK(FID,RECNUM); PUT(FID); RECNUM := SUCC(RECNUM) END; CLOSE(FID,LOCK); CLOSE(FIN,LOCK); END; PROCEDURE PRINT ( T : STRING ); (* REMOVE IF NO PRINTER *) VAR I : INTEGER; BEGIN FOR I := 1 TO LENGTH ( T ) DO BEGIN CH := T [ I ]; PUTP END; CH := LF; PUTP; END; (* PROCEDURE PRINT *) PROCEDURE ZEROREC (VAR REC : STRUCTURE ); CONST BLANK = ' '; BEGIN WITH REC DO BEGIN NAME := BLANK; STREET := BLANK; CITYSTATEZIP := BLANK; PHONE := BLANK; KEY := BLANK END; END; (* ZEROREC *) PROCEDURE SHOWREC(REC : STRUCTURE); BEGIN WRITELN(LI,CS,BELL); WITH REC DO BEGIN WRITELN(LI, FG, 'Name: ', LI, BG, NAME); IF PRINTIT THEN BEGIN CH := LF; PUTP; PUTP; PRINT (NAME); END; WRITELN(LI, FG, 'Street: ', LI, BG, STREET); IF PRINTIT THEN PRINT(STREET); WRITELN(LI, FG, 'City, State, and Zip: ', LI, BG, CITYSTATEZIP); IF PRINTIT THEN BEGIN PRINT (CITYSTATEZIP); CH := LF; PUTP; PRINTIT := FALSE END; WRITELN(LI, FG, 'Phone: ', LI, BG, PHONE); WRITELN(LI, FG, 'Key: ', LI, BG, KEY); WRITELN; END; END; (* SHOWREC *) PROCEDURE WRITELIMIT ( LEN : INTEGER ); VAR BS : CHAR; I : INTEGER; BEGIN BS := CHR ( 8 ); WRITE ( ' ': LEN, '| < -- ' ); FOR I := 1 TO (LEN + 7) DO WRITE ( BS ); WRITE ( LI, BG, BELL ); END; PROCEDURE GETREC ( VAR REC : STRUCTURE); VAR S : STRING; FUNCTION READIT (VAR T: STRING): BOOLEAN; BEGIN (* READIT *) READIT := FALSE; READLN(S); IF LENGTH(S) > 0 THEN IF S [ LENGTH(S) ] = ESC THEN READIT := TRUE ELSE BEGIN IF ((T = REC.KEY) AND (LENGTH(T) > 2)) THEN BEGIN KEYS [ RECNUM ] := S; T := S; MUSTRUNKEYIT := TRUE END ELSE T := S; END END; (* FUNCTION READIT *) BEGIN (* GETREC *) WRITELN(BELL); WRITELN(LI,FG, BELL, 'RETURN skips item with no change'); WRITELN('ESC and RETURN skips the whole record', LI, BG, BELL); WRITELN; WITH REC DO BEGIN WRITE(LI, FG, 'Name: '); WRITELIMIT ( 60 ); IF (NOT READIT(NAME)) THEN BEGIN WRITE(LI,FG,'Street: '); WRITELIMIT ( 60 ); IF (NOT READIT(STREET)) THEN BEGIN WRITE(LI,FG,'CityStateZip: '); WRITELIMIT ( 60 ); IF (NOT READIT(CITYSTATEZIP)) THEN BEGIN WRITE(LI,FG,'Phone: '); WRITELIMIT ( 60 ); IF (NOT READIT(PHONE)) THEN BEGIN WRITE(LI,FG,'Key: '); WRITELIMIT ( 60 ); IF (NOT READIT(KEY)) THEN WRITELN; END END END END END END; (* PROCEDURE GETREC *) PROCEDURE SEARCHFORPATTERN; BEGIN REPEAT RECNUM := SUCC(RECNUM) UNTIL ((POS(PATTERN,KEYS[RECNUM]) <> 0) OR (RECNUM > MAXKEYS) OR ( FINISHED )); END; (* PROCEDURE SEARCHFORPATTERN *) PROCEDURE BUFFERKEYS; BEGIN RESET(FIN,'#5:keys.text'); RECNUM := 0; WRITELN(LI,CS,LI,FG,BELL,BELL); WRITELN(' ... Transferring Keys to RAM ...'); WRITELN; READLN(FIN,MAXKEYS); WHILE NOT EOF(FIN) DO BEGIN READLN(FIN,KEYS [ RECNUM]); WRITE('.'); RECNUM := SUCC(RECNUM) END; WRITELN; WRITELN(LI,BG,BELL); CLOSE(FIN,LOCK); MAXKEYS := PRED ( RECNUM ); END; (* BUFFERKEY *) PROCEDURE CHECKFORKEYS; BEGIN WRITE(' Is this the first time through UPDATE? Y/N: '); READLN ( CH ); IF CH IN ['Y', 'y'] THEN KEYIT; END; BEGIN (* UPDATEADDRESS.TEXT *) REWRITE ( LP, 'PRINTER:'); CHECKFORKEYS; MUSTRUNKEYIT := FALSE; FINISHED := FALSE; PRINTIT := FALSE; LF := CHR(10); (* SET LF..BELL = CHR(0) (OR NULL) FOR DUMB TERMINAL *) (* LF = LINE FEED, LI = LEAD-IN TO THE SCREEN, BG = BACKGROUND FOLLOWS (SINGLE INTENSITY) FG = FOREGROUND FOLLOWS (DOUBLE INTENSITY) ESC = ESCAPE CS = CLEAR THE SCREEN BELL = RING TERMINAL BELL NOTE THAT CS ALSO HOMES CURSOR AND THAT "CHR" REQUIRES A DECIMAL ARGUMENT OF THE ASCII CHARACTER (TERMINAL DEPENDENT)*) LI := CHR(27); ESC := LI; BG := CHR(25); FG := CHR(31); CS := CHR(28); BELL := CHR(7); BUFFERKEY; RESET(FID, '#5:address.text'); RECNUM := 0; WHILE (( RECNUM >= 0) AND (NOT FINISHED)) DO BEGIN WRITE(LI,CS,BELL); WRITE(BELL,' Enter Key --> '); READLN(PATTERN); WRITELN; IF ((PATTERN = 'STOP') OR (PATTERN = 'stop')) THEN FINISHED := TRUE; IF ((PATTERN = 'PRINT') OR (PATTERN = 'print')) THEN BEGIN PRINTIT := TRUE; WRITE(LI,CS,BELL); WRITE(BELL, ' Enter Key of Record to be Printed --> '); READLN(PATTERN); WRITELN END; RECNUM := -1; SEARCHFORPATTERN; IF ((RECNUM > MAXKEYS) AND (NOT FINISHED)) THEN BEGIN WRITELN(LI,FG,BELL); WRITE(BELL, ' Not found. Do you want to 1) Add another record') ; WRITELN; WRITE(BELL, ' **** OR **** 2) Try another key? --> '); READLN(BUFFER); WRITELN(LI,BG,BELL); IF BUFFER = '1' THEN BEGIN WRITELN; MUSTRUNKEYIT := TRUE; MAXKEYS := RECNUM END END; WRITELN; IF ((RECNUM >= 0) AND (RECNUM <= MAXKEYS) AND (NOT FINISHED)) THEN BEGIN SEEK(FID,RECNUM); GET(FID); IF EOF(FID) THEN BEGIN WRITELN(LI,CS,BELL, 'Enter new record...'); ZEROREC(FID^) END ELSE BEGIN WRITELN(LI,CS,BELL, 'Old Record...'); SHOWREC(FID^); WRITELN; WRITELN(BELL,'Enter Any Changes...') END; GETREC(FID^); SEEK(FID,RECNUM); PUT(FID) END END; (* WHILE *) CLOSE(FID,LOCK); WRITELN(LI,CS); REWRITE ( KEYNO, '#5:KEYNO.TEXT'); WRITELN ( KEYNO, MAXKEYS ); CLOSE ( KEYNO, LOCK ); IF MUSTRUNKEYIT THEN KEYIT; WRITELN; WRITELN (' ... Finished ...'); END. (* PROGRAM UPDATE *) ======================================================================================== DOCUMENT :usus Folder:VOL06:banner.text ======================================================================================== (* By David Mundie for Culinary Software Systems. *) (* Types four lines of 32 characters on a hard-copy device. *) { Modified 21 July 1981 by Jim Gagne...Now it a) works on my system, b) has meaningful variable & constant names, c) fills in more than just a 5x7 matrix, by adding partial dots to fill in diagonals, and d) allows up to 4-size letters just by printing everything up to 4 times. You'll want to fiddle with this to get it going, as I've changed some things around (eg, adding nulls so as not to overwhelm my printer). REQUESTS: a) increase matrix to a more ample size (at least 7x9) b) bring in letter matrix definitions from a file, so we can print block, Old English, Roman, etc., letters at a whim. BEST would be a letter- definition program that allowed letter matrices to be entered interactively and with character graphics (eg, 7x9 matrix of dots on the screen, where a dot would show as "X"). } PROGRAM banner; CONST AbsMaxLine = 5; {Maximum lines of text - 1} MaxChPerLn = 31; {Max chars per line - 1} ColPerCh = 5; {Columns of dots per character} ColPChM1 = 4; {above -1} RowPerCh = 8; {Rows of dots per character} RowPChM1 = 7; {above -1} MaxPixels = 39; {Dots per character (RowPerCh X ColPerCh -1)} HasDiablo = true; {if so, uses 1/2 linefeeds to fill in char's} TYPE pixel = 0..MaxPixels; {MOD ColPerCh = Column; DIV RowPerCh = Row} {SO a character grid (upright) looks like: 0 1 2 3 4 ...and on its side (the 5 6 7 8 9 way it's printed): 10 11 12 13 14 35 30 25 20 15 10 5 0 15 16 17 18 19 36 31 26 21 16 11 6 1 20 21 22 23 24 37 32 27 22 17 12 7 2 (top) 25 26 27 28 29 38 33 28 23 18 13 8 3 30 31 32 33 34 39 34 29 24 19 14 9 4 35 36 37 38 39 } pixset = set of pixel; VAR c: char; MaxLine, LinesTyped, n, m: integer; SizeFactor: 1..10; filename: string; message: ARRAY [0..AbsMaxLine,0..MaxChPerLn] OF pixset; textin: ARRAY [0..AbsMaxLine] OF string; table : ARRAY [' '..'z'] OF pixset; list: text; PROCEDURE initialize; BEGIN table['!'] := [2,7,12,17,32]; table['A'] := [1..3,5,10,9,14,15..19,20,25,30,24,29,34]; table['B'] := [0..3,5,10,9,14,15..18,20,25,30,24,29,30..33]; table['C'] := [1..3,5,10,15,20,25,31..33,29,9]; table['D'] := [0..2,5,10,15,20,25,30..32,28,24,19,14,8]; table['E'] := [0..4,5,10,15..19,20,25,30..34]; table['F'] := [0..4,5,10,15..18,20,25,30]; table['G'] := [1..4,5,10,15,20,25,31..34,29,24,18..19]; table['H'] := [0,5,10,15,20,25,30,4,9,14,19,24,34,29,16..18]; table['I'] := [1..3,7,12,22,17,12,27,31..33]; table['J'] := [0..4,8,13,18,23,28,31..32,25]; table['K'] := [0,5,10,15,20,25,30,16,12,8,4,22,28,34]; table['L'] := [0,5,10,15,20,25,30..34]; table['M'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,6,8,12,17]; table['N'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,11,17,23]; table['O'] := [1..3,31..33,5,10,15,20,25,9,14,19,24,29]; table['P'] := [0..3,5,10,15,20,25,30,16..18,14,9]; table['Q'] := [1..3,5,10,15,20,25,31,32,34,28,22,24,19,14,9,4]; table['R'] := [0..3,5,9,10,14,19,15..18,20,25,30,22,28,34]; table['S'] := [1..4,30..33,16..18,5,10,24,29]; table['T'] := [0..4,7,12,17,22,27,32]; table['U'] := [0,5,10,15,20,25,31..33,29,24,19,14,9,4]; table['V'] := [0,5,10,15,20,26,32,28,24,19,14,9,4]; table['W'] := [0,5,10,15,20,25,31,33,27,22,17,29,24,19,14,9,4]; table['X'] := [0,5,25,30,4,9,29,34,21,17,13,11,17,23]; table['Y'] := [0,5,10,16,22,27,32,18,14,9,4]; table['Z'] := [0..4,30..34,25,21,17,13,9]; table[' '] :=[]; table['a'] := [11..14,19,21..24,25,29,31..34]; table['b'] := [0,5,10,20,25,15..18,30..33,24,29]; table['c'] := [11..13,15,20,25,31..33]; table['d'] := [4,9,14,15,16..19,31..34,20,25,24,29]; table['e'] := [11,12,15,18,20..23,25,31,32]; table['f'] := [2,6,8,11,15..17,21,26,31]; table['g'] := [11,12,15,18,20,23,26..28,33,36,37]; table['h'] := [0,5,10,15,20,25,30,16,17,23,28,33]; table['i'] := [7,16,17,22,27,31..33]; table['j'] := [8,18,23,28,33,31,37]; table['k'] := [0,5,10,15,20,25,30,21,17,27,33]; table['l'] := [1,2,7,12,17,22,27,31..33]; table['m'] := [11,13,15,17,19,20,22,24,25,29,30,34]; table['n'] := [11,12,15,18,20,23,25,28,30,33]; table['o'] := [11,12,15,18,20,23,25,28,31,32]; table['p'] := [10..12,15,18,20,23,25..27,30,35]; table['q'] := [11..13,15,18,20,23,26..28,33,38,39]; table['r'] := [10,12,13,15,16,20,25,30]; table['s'] := [11..13,15,21..23,29,31..33]; table['t'] := [6,10..12,16,21,26,32]; table['u'] := [10,13,15,18,20,23,25,28,31..34]; table['v'] := [10,14,15,19,20,24,26,28,32]; END; PROCEDURE Init2; BEGIN table['w'] := [10,14,15,17,19,20,22,24,25,27,29,31,33]; table['x'] := [10,14,16,18,22,26,28,30,34]; table['y'] := [10,13,15,18,20,23,26..28,33,36,37]; table['z'] := [10..14,18,22,26,30..34]; table['-'] := [16,17,18]; table['*'] := [7,12,17,22,27,16,18,10,14,20,24]; table['?'] := [1..3,5,9,13,17,22,32]; table['.'] := [29,34]; table[','] := [28,33,37]; table[':'] := [12,17,27,32]; table[';'] := table[':'] + [36]; END; PROCEDURE Show; VAR i,CCount,Col,Lines,Row, Size:integer; maxlen:integer; PROCEDURE WriteDot; VAR x, y: integer; BEGIN FOR y := 1 TO SizeFactor DO BEGIN Write(list,'%',CHR(8),'M',CHR(8),'#'); IF HasDiablo THEN FOR x := 1 TO 8 DO Write(list,CHR(0)) END END; PROCEDURE WriteBlank; VAR i: integer; BEGIN FOR i := 1 TO SizeFactor DO Write(List, ' ') END; FUNCTION FillLeft: boolean; VAR x, {current pixel} y: integer; {1 pixel to left} TCh: pixset; BEGIN IF Row >= RowPChM1 THEN FillLeft := false ELSE BEGIN TCh := message[Lines,CCount]; x := Row*ColPerCh + Col; y := x + ColPerCh; IF NOT(y IN TCh) THEN FillLeft := false ELSE IF Col <= 0 THEN FillLeft := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh) ELSE IF Col >= ColPChM1 THEN FillLeft := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh) ELSE FillLeft := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)) OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)) END END; FUNCTION FillRight: boolean; VAR x, {current pixel} y: integer; {1 pixel to right} TCh: pixset; BEGIN IF Row <= 0 THEN FillRight := false ELSE BEGIN TCh := message[Lines,CCount]; x := Row*ColPerCh + Col; y := x - ColPerCh; IF NOT(y IN TCh) THEN FillRight := false ELSE IF Col <= 0 THEN FillRight := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh) ELSE IF Col >= ColPChM1 THEN FillRight := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh) ELSE FillRight := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)) OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)) END END; BEGIN maxlen := 0; FOR i := 0 TO LinesTyped-1 DO IF length(textin[i]) > maxlen THEN maxlen := length(textin[i]); FOR CCount := 1 TO maxlen DO {write each column of characters} BEGIN FOR Col := 0 TO 4 DO FOR Size := 1 TO SizeFactor DO {write dot col's} BEGIN FOR Lines := LinesTyped-1 DOWNTO 0 DO BEGIN FOR Row := 7 DOWNTO 0 DO BEGIN IF Row * ColPerCh + Col IN message[Lines,CCount] THEN FOR i := 1 TO 2 DO WriteDot ELSE IF FillLeft THEN BEGIN WriteDot; WriteBlank END ELSE IF FillRight THEN BEGIN WriteBlank; WriteDot END ELSE FOR i := 1 TO 2 DO WriteBlank END; FOR i := 1 TO 2 DO WriteBlank {space between lines} END; IF HasDiablo THEN FOR i := 1 TO 20 DO Write(List,CHR(0)); Writeln(list) END; FOR Size := 1 TO SizeFactor DO Writeln(list) END; END; BEGIN FOR n := 0 TO AbsMaxLine DO BEGIN FOR m := 0 TO 31 DO message[n,m] := []; textin[n] := '' END; Initialize; Init2; SizeFactor := 1; Write( 'By what factor (1 to 4) do you wish to multiply the size of the letters? '); Readln(SizeFactor); MaxLine := AbsMaxLine DIV SizeFactor + 1; Writeln( 'Enter your message (up to ',MaxLine,' lines of up to 32 characters): '); n := 0; REPEAT Readln(textin[n]); m := Length(textin[n]); IF m > MaxChPerLn THEN DELETE(Textin[n],MaxChPerLn, m - MaxChPerLn + 1); n := n + 1 UNTIL (n > MaxLine) OR (textin[n-1] = ' ') OR (textin[n-1] = ''); IF (textin[n-1] = ' ') OR (textin[n-1] = '') THEN LinesTyped := n-1 ELSE LinesTyped := n; Write('Please enter name of output -> '); Readln(filename); {$I-} Rewrite(list,filename); IF IORESULT > 0 THEN Rewrite(list,concat(filename,'.text')); {$I-} IF IORESULT > 0 THEN Write('Can''t open that file.') ELSE BEGIN FOR n := 0 TO LinesTyped-1 DO FOR m := 1 TO length(textin[n]) DO message[n,m] := table[textin[n,m]]; Show; CLOSE(list,lock); END END. ======================================================================================== DOCUMENT :usus Folder:VOL06:baud.a.text ======================================================================================== .PROC BAUD,0 .PRIVATE OUTC,RETADDR .PUBLIC BAUDRATE TPORT .EQU 0C0H ;UART CNTRL RPORT .EQU TPORT+2 ;RATE GENERATOR TIMER CPORT .EQU TPORT+3 ;MODEM CONTROL TODTR3 .EQU 07FH ;NORMAL OP - DTR ON, <300 BAUD TODTR6 .EQU 05FH ;NORMAL OP - DTR ON, >300 BAUD B300 .EQU 52 ;TIMER RATE FOR 300 BAUD UART .EQU 5CH ;8 BITS, NO PARITY, 2 STOP BITS ANSMODE .EQU 2H ;RI BIT SETS ANS MODE ORGMODE .EQU 1H ;SH BIT SETS ORIG MODE POP HL LD (RETADDR),HL ; TURN OFF SH AND RI BITS, SET UART MODES NXT LD A,UART OUT (TPORT),A ; SET BAUD RATE LD A,(BAUDRATE) ; GET RATE OUT (RPORT),A ;SET NEW RATE ; IF RATE IS ABOVE 300 BAUD CHANGE MODEM RATE BIT LD A,TODTR3 ;FIRST SET IT TO 300 BAUD OR LOWER OUT (CPORT),A LD A,(BAUDRATE) ;GET RATE CP B300 ;COMPARE TO 300B JP NC,CONT ;DON'T CHANGE LD A,TODTR6 ;ABOVE 300 OUT (CPORT),A ; CHANGE RATE BIT CONT LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:catalog.6.text ======================================================================================== VOLUME 6 CATALOG USUS SOFTWARE LIBRARY PTP and FORMAT revisited Filename Blocks Description PTP.BUSH.TEXT 154 The all-new Pascal Transfer Program, updated by its author, Mark Gang, and edited by Randy Bush. Baud rate selected by inter-modem dialogue; choice of radix-41 or true binary file transfer; improved al- gorithms speed up data transfer. PTP has been select- ed as the USUS standard file interchange program. BAUD.A.TEXT 6 I've added an "A.TEXT" suffix to 8080 assembly- CTS.A.TEXT 4 language files used by PTP; the function of each DIALER.A.TEXT 6 routine is described by "PTP-FILES.TEXT". Note that DTONEDET.A.TEXT 4 these routines are highly processor- and modem- DTRON.A.TEXT 4 specific, which is why Bob Peterson is working on a HANGUP.A.TEXT 4 communications UNIT that will pack all this material KBSTAT.A.TEXT 4 once and for all into a standardized form. MODEMINI.A.TEXT 4 MREAD.A.TEXT 4 Rewrite these files for your machine. MRECSTAT.A.TEXT 4 MWRITE.A.TEXT 4 RI.A.TEXT 4 RINGING.A.TEXT 4 SH.A.TEXT 4 SYSNAME.TEXT 4 User ID (just a few characters) used by PTP. PTP-FILES.TEXT 8 PTP documentation - which files are which. PTP-INST.TEXT 6 PTP documentation - how to set it up. PTP-USE.TEXT 20 PTP documentation - how to use. FORMAT.TEXT 6 I corrected and greatly updated FORMAT (from USUS Vol. FORMAT.1.TEXT 16 1), so that now it works reasonably well. Most bugs FORMAT.2.TEXT 24 are gone (except the program still has trouble with FORMAT.3.TEXT 18 extended comments and may terminate prematurely). FORMAT.4.TEXT 20 Format options are now MENU SELECTED!! Finally, it FORMAT.5.TEXT 22 accepts nearly all valid UCSD Pascal syntax. It is FORMAT.6.TEXT 24 handy for reformatting Pascal source to fit on CRT screens of different sizes. FMT.64MASK.DATA 5 Mask for FORMAT menu for 64-column screens. FMT.64MENU.TEXT 4 Source for above data; needs MAKEMASKS from Vol. 5. FMT.MASK.DATA 5 This menu mask is for 80-column CRTs and Apples. FMT.MENU.TEXT 6 Source for the above data; needs MAKEMASKS from Vol 5. FMT.NEWDOC.TEXT 20 Documentation on my changes to FORMAT. FORMAT.DOC.TEXT 30 Copy of original FORMAT documentation from Vol. 1. BANNER.TEXT 20 This program was added 26-Jul-81, and was donated by David Mundie. Prints a banner vertically on print- out paper, with up to 6 lines or 7-inch letters. NOTE: USUS Library material may be used only in accordance with policy outlined elsewhere. In particular, these programs may not be given to nonmembers of USUS, nor may commercial use be made of them, without the written permission of the authors. Although an Apple version of the original PTP is in the works, we will release the same material for all versions until it works well. Keep an eye on the USUS newsletter for corrections and updates. ======================================================================================== DOCUMENT :usus Folder:VOL06:cts.a.text ======================================================================================== .FUNC CTS,0 .PRIVATE RETADDR STAT .EQU 0C2H CARDET .EQU 4H POP HL LD (RETADDR),HL POP HL ;CORRECT STACK POP HL LD HL,1 ;TRUE IN A,(STAT) ;READ STATUS CPL AND CARDET ;CHECK FOR CARRIER JP NZ,DONE LD HL,0 ;FALSE DONE PUSH HL LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:dialer.a.text ======================================================================================== .PROC DIALER,1 .PRIVATE DIGIT,RETADDR TPORT .EQU 0C0H ;UART CONTROL/STATUS PORT RPORT .EQU TPORT+2 ;RATE GEN PORT D10PP .EQU 250 ;10 PULSES PER SECOND TRATE .EQU 250 ;VALUE FOR .1 SECOND DELAY TMPUL .EQU 80H ;TIMER PULSES MASK MAKEM .EQU 01H ;TEL LINE MAKE (OFF HOOK) BRKM .EQU 00H ;TEL LINE ON HOOK INTER .EQU 7 ;INTER DIGIT TIME INTERVAL POP HL LD (RETADDR),HL POP HL LD A,L ; GET DIGIT AND 0FH ;CONVERT TO BINARY CP 0H ; IF 0 CONVERT TO 10 JP NZ,DIALS LD A,0AH DIALS LD C,A ; LOAD TIMER WITH DIAL RATE LD A,D10PP OUT (RPORT),A ; WAIT IF TIMER PULSE NOT ZERO DIALC IN A,(RPORT) ;GET TIMER PULSE AND TMPUL JP NZ,DIALC ;WAIT UNTIL TRANSITION TO 1 TO SYNCHRONIZE DIALER DIALB IN A,(RPORT) AND TMPUL JP Z,DIALB ; MAKEP LD A,MAKEM ;START WITH A MAKE OUT (TPORT),A TIMEM IN A,(RPORT) AND TMPUL ;WAIT FOR MAKE INTERVAL JP NZ,TIMEM ; LD A,BRKM OUT (TPORT),A ;NOW DO A BREAK ; TIMEB IN A,(RPORT) AND TMPUL ;WAIT FOR BREAK INTERVAL JP Z,TIMEB ; DEC C ;ANY MORE PULSES IN THIS DIGIT JP NZ,MAKEP ;IF SO LOOP FOR NEXT PULSE ; ; LAST PULSE WAIT FOR INTERDIGIT TIME LD A,MAKEM OUT (TPORT),A LD B,INTER ; TIMER TIMER LD A,TRATE OUT (RPORT),A TIMES IN A,(RPORT) AND TMPUL JP Z,TIMES TIMEE IN A,(RPORT) AND TMPUL JP NZ,TIMEE DEC B JP NZ,TIMES DONE LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:dtonedet.a.text ======================================================================================== .FUNC DTONEDET,0 .PRIVATE RETADDR STAT .EQU 0C2H DTONE .EQU 1H POP HL LD (RETADDR),HL POP HL ;CORRECT STACK POP HL LD HL,0 ;FALSE IN A,(STAT) ;READ STATUS AND DTONE ;CHECK FOR DIAL TONE JP NZ,DONE LD HL,1 ;TRUE DONE PUSH HL LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:dtron.a.text ======================================================================================== .PROC DTRON,0 .PRIVATE RETADDR TPORT .EQU 0C0H ;UART CONTROL PORT RPORT .EQU TPORT+2; ;TIMER PORT CPORT .EQU TPORT+3 ;MODEM CONTROL UART .EQU 5CH ;8BITS, NO PARITY, 2 STOP BITS TODTR3 .EQU 07FH ;NORMAL OP, 300 BAUD TRATE .EQU 250 ;TIMER RATE TMPUL .EQU 80H ;TIMER MASK POP HL LD (RETADDR),HL LD A,TODTR3 ;SET DTR ON OUT (CPORT),A LD A,TRATE OUT (RPORT),A TIMES: IN A,(RPORT) ; DELAY .1 SECONDS AND TMPUL JP Z,TIMES TIMEE: IN A,(RPORT) AND TMPUL JP NZ,TIMEE LD A,UART ;SET UART TO NORMAL (SH AND RI OFF) OUT (TPORT),A LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:fmt.64mask.data ======================================================================================== PASCAL TEXT FORMATTER -*- by Mike Condict, modified by Jim Gagne R(ead margins - 1st/last char A(lign declaratns on column no. read: L(eft. R(ight. ("0" means no alignment)... W(rite margins - output for- B(unch statements and declaratns mat: L(eft. R(ight. together on each line?..... S(paces inserted between: C(ompress program maximally?. I(dent's. S(tatemts. D(elve into INCLUDE files?... I(ndentatn added at new line: E(nd statement comments?..... L(ogical. O(verflow. P(rocedure/functn comments?.. L(ines to skip between proce- N(umber each line [N(o, place at dures/functions......... R(ight/L(eft margin]?.... #( to start. J(umping by. GLOBALS: 4(0-columns wide; 6(4-columns; 8(0-columns; M(odem Xfer €€€€À€€€€€€À€€€@Ž€€Ž€š€‹€Áš€‹ €š €=€Áš €=€A=€A= €½€; €B, €½ €=€€À €€@@@@€€€€€€€€€€ ======================================================================================== DOCUMENT :usus Folder:VOL06:fmt.64menu.text ======================================================================================== PASCAL TEXT FORMATTER -*- by Mike Condict, modified by Jim Gagne R(ead margins - 1st/last char A(lign declaratns on column no. read:^L(eft.^11 R(ight.^12 ("0" means no alignment)...^19 W(rite margins - output for- B(unch statements and declaratns mat:^ L(eft.^13 R(ight.^14 together on each line?.....^21 S(paces inserted between:^ C(ompress program maximally?.^22 I(dent's.^15 S(tatemts.^16 D(elve into INCLUDE files?...^28 I(ndentatn added at new line:^ E(nd statement comments?.....^24 L(ogical.^17 O(verflow.^18 P(rocedure/functn comments?..^23 L(ines to skip between proce- N(umber each line [N(o, place at dures/functions.........^20 R(ight/L(eft margin]?....^25** #( to start.^26 J(umping by.^27 GLOBALS: 4(0-columns wide; 6(4-columns; 8(0-columns; M(odem Xfer ^30************************************************************* ======================================================================================== DOCUMENT :usus Folder:VOL06:fmt.mask.data ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL06:fmt.menu.text ======================================================================================== PASCAL SOURCE TEXT FORMATTING PROGRAM by Mike Condict...Modified by Jim Gagne R(ead margins - 1st/last char. read B(unch statements and declarations in a line:^ L(eft..^11 R(ight..^12 together on each line?..........^21 C(ompress program maximally?.....^22 W(rite margins - output formatting:^ D(elve into INCLUDE files?.......^28 L(eft.........^13 R(ight......^14 comments added automatically at: S(paces inserted between text items:^ P(rocedure/function BEGIN/END?..^23 I(dentifiers..^15 S(tatements..^16 E(very compound statement?......^24 I(ndentation added at start of line:^ handy commands (affect several params.) L(og'l nesting.^17 O(verflow...^18 4(0-column wide 6(4-column wide 8(0-column wide M(odem transfer A(lign declarations on column # ("0" means no alignment takes place)..^19 N(umber each line [N(o, R(ight margin, L(eft margin]?..................^25 L(ines to skip between procedures/ #( you wish lines to start with?.^26 functions........................^20 J(umping in value by what amount.^27 ^30*************************************************************************** ======================================================================================== DOCUMENT :usus Folder:VOL06:fmt.newdoc.text ======================================================================================== DOCUMENTATION FOR THE REVISED PASCAL SOURCE FORMATTER by Michael Condict; published in Pascal News No. 13, December 1978 Debugged and extensively modified by Jim Gagne Datamed Research, 1433 Roscomare Road, Los Angeles. 28 August 1980 I've spent a lot of time on FORMAT, and I think that it's safe to say that except for the bugs only more extensive use will uncover, it works. Programs now will format into compilable textfiles that actually look better than the original, even if it had been prepared on a good editor. FORMAT will format itself, and the resulting file compiles and executes correctly. Briefly, here is what is new. FORMAT is now menu driven. It will reformat programs for any width screen, as well as compressing text for modem transfer, to be restored by another run at the receiving end. It will format correctly nearly all of the variant UCSD features, including UNITs. At your option, it will follow INCLUDE files. Thus, I hope that it will find maximal use in transferring textfiles between different systems. The major remaining problem with FORMAT is that it is slow; if it becomes popular, someone should run timing statistics and discover the bottlenecks. In more detail, I've modified FORMAT as follows: 1) The problems with the "range" symbol (".."), due to errors in the number-processing part of READSYMBOL, have been corrected. 2) The section of READSYMBOL dealing with comments has been overhauled, and it now handles them fairly intellegently. Both brace- and parenthesis-and- asterisk-type comment delimiters work properly. There has been special provision made for long comments: they are reformatted for the proper line length, with word boundaries at the ends of lines respected 98% of the time. Comments are brought to a new line only if they won't fit on the previous one or if they contain compiler or formatter directives. Comments at the beginning of a program no longer cause FORMAT to die. Further, since comments are by no means extraneous to a program, one has the option of retaining them during maximal program compression by a new command: if both procedure/ function comments and end-symbol comments are enabled, even though they now DO NOT appear in compressed text, previously typed comments are retained. This feature was added to aid in the transmission of compressed text by modem, allowing the correct program to be fully restored by another run of FORMAT. Finally, no matter what, comments beginning with a compiler directive are retained in compressed text. The only problems I've identified with comments so far are: a) if one has a series of long comments within a section that is normally contained within one line if possible, FORMAT is apt to break this up into lines beginning with long comments, plus whatever else fits on the line. Since I usually put comments AFTER the text they refer to, this looks weird. The problem came up with a lengthy procedure declaration section of a UNIT. b) long comments BEFORE a procedure/function declaration are closed up with the previous section. Solution: comment your procedures after the declaration. c) many people like to write pretty comments that are themselves formatted. Although the original program preserved the comment structure, it looked pretty funny when going from a larger to a smaller line size. Now, all extraneous ends of lines and spaces are removed, somewhat to the detriment of such statements as authorship and names and addresses. 3) Handling of long strings was problematical; they now FORMAT correctly. Especially long strings are made flush with the left margin. Strings longer than the current maximal line length are broken up into substrings set off by commas. Although this will create an error in any but WRITE statements, it was the most intellegent behavior I could devise. 4) Assorted typos in my original typed-in version have been corrected. 5) FORMAT now will handle all the UCSD Pascal variant features, including UNITS, SEPARATE UNITS, SEGMENT PROCEDURES/FUNCTIONS, etc., with the exception of the INTRINSIC UNITS limited to the Apple version. This is easily added if you wish (at the beginning of the main program). Of course, standard Pascal files also format correctly. 6) There is one important alteration in procedure WRITEA: blanks at the beginning of new lines are compressed with the UCSD blank-compression code. This change occupies one line and is well marked. It saves oodles of disk space. 7) FORMAT now will incorporate INCLUDE files (i.e., the compiler directive "I", used in the following format: "{$I}" or "(*$I*)", where "" refers to any valid UCSD filename, including if needed volume name or unit number. Unless a volume is specified, FORMAT will look on volumes 4 and 5 for the filename if it can't find it on the default volume. Comments are printed in the output at the start and end of an INCLUDED file, and a message noting a new INCLUDE file is printed on the console. You may enable or disable FORMAT from acting on INCLUDE directives with the "D(elve into INCLUDE files" parameter on the menu. If disabled, INCLUDE directives are treated like any other parameter. Nested INCLUDEs are always ignored. If you have enabled INCLUDE files and there is a problem with one, an error message will be printed on the console, and FORMAT will do as little damage as possible, restoring the original compiler directive in the output. Of course, it is difficult to format an INCLUDE file primarily, since you can put virtually anything in an INCLUDE file, so long as the larger program pieces it together properly. FORMAT is just as helpless with a fragment of a program as your compiler is. If you MUST format an INCLUDE file separately from its host, you'll have to kludge: the file in question must start out with either a "PROGRAM" or "UNIT" declaration, then contain some sort of standard Pascal format. FORMAT does not check that identifiers have been previously declared; so only the program structure must be correct. If your INCLUDE file does not meet these specifications, you'll have to write a dummy host and INCLUDE the desired file. 8) Finally, and by far the most useful feature, is the addition of menu- selected formatting parameters in a highly user-friendly manner. Once you've read the main FORMAT.DOC documentation, you should find choosing the format you desire quite simple. For those who like single key-stroke parameter setting, the global commands 4(0, 6(4, and 8(0-column widths and M(odem transfer will select and display a reasonable set of parameters for each of those situations. Several caveats should be observed in using the menu. First, if FORMAT cannot find the file "FMT.MASK.DATA" (a structured binary file that will NOT look good on your screen or printer) on either units 4 or 5, menu selection is skipped. Second, the current FMT.MASK.DATA is designed for 80-column, 24- line screens, including the standard Apple variant (40 columns with horizontal scrolling). There is an alternate file, FMT.64MASK.DATA, designed for those souls with 16x64 screens, but as the data file is still in 24x80 format (filled in with blanks) you will have to alter the procedure OPENDATAFILE (part of GETNEWINITVALUES in FORMAT.3.TEXT) to NOT write more than 64 characters per line nor print more than 15 lines (actually, 13 will do), or you are apt to have the menu scroll off the screen. If you then change the name of FMT.MASK.DATA to something else and rename FMT.64MASK.DATA as FMT.MASK.DATA, the program should work fine. Finally, there is no way for the menu portion to work properly if you do not have a valid GOTOXY bound into your system. If you wish to alter the menu, you will have to use the program MAKEMASKS on the UCSD Pascal Users' Library, Volume 5, or write your own. Despite my testing, I'm certain that someone will find problems with FORMAT, in view of the extensive changes I've made. The major remaining area I would like to deal with is the aesthetic problem of dangling punctuation, caused by a statement that almost but not quite fits on a line; one or two characters are apt to hang off the line in a most irritating manner. Please let me know if you find bugs and, more importantly, if you can fix them. However, make SURE you tell me what the problem is you're fixing with a bug fix. Have fun. Sincerely, Jim Gagne, M.D., President Datamed Research 1433 Roscomare Road Los Angeles, CA 90024 ======================================================================================== DOCUMENT :usus Folder:VOL06:format.1.text ======================================================================================== PROGRAM Format; CONST AlfaLeng = 10; MinChar = 0; MaxChar = 127; (* minimum/max char values *) LastPascSymbol = 31; (* if needed, change the values on the following line TOGETHER *) BufferSize = 160; BuffSzP1 = 161; BuffSzM1 = 159; BuffSzDiv10 = 16; MaxReadRightCol = 999; MaxWriteRightCon = 72; TYPE Alfa = PACKED ARRAY [1..AlfaLeng] OF char; CharSet = SET OF char; StatmntTypes = (ForWithWhileStatement, RepeatStatement, IfStatement, CaseStatement, CompoundStatement, OtherStatement); Symbols = (ProgSymbol, UnitSymbol, Comment, BeginSymbol, (* 2 new JLG*) EndSymbol, SemiColon, ConstSymbol, TypeSymbol, RecordSymbol, ColonSymbol, EqualSymbol, PeriodSymbol, Range, CaseSymbol, OtherSymbol, IfSymbol, ThenSymbol, ElseSymbol, DoSymbol, OfSymbol, ForSymbol, WithSymbol, WhileSymbol, RepeatSymbol, UntilSymbol, Identifier, VarSymbol, ProcSymbol, FuncSymbol, SegmntSymbol, LeftBracket, RightBracket, CommaSymbol, LabelSymbol, LeftParenth, RightParenth, AlphaOperator); Width = 0..BufferSize; Margins = -100..BufferSize; SymbolSet = SET OF Symbols; OptionSize = -99..99; CommentText = ARRAY [1..BuffSzDiv10] OF Alfa; SymbolString = ARRAY [Width] OF char; (*the only UNPACKED char array*) VAR ChIsEOL, NextChIsEOL: Boolean; I, J: Integer (*loop counters *); Character: char; ReadColumn, ReadRightCol: 0..1000; Length, Oldest: Width; OutputCol, WriteColumn, LeftMargin, ActualLeftMargin, ReadLeftCol, WriteLeftCol, WriteRightCol : Margins; DisplayIsOn, ProcNamesWanted, EndCommentsWanted, PackerIsOff, SavedBunch, BunchWanted, NoFormatting: boolean; LineNumber, Increment: integer; IndentIndex, LongLineIndent, SymbolGap, DeclarAlignment, StatmtSeparation, ProcSeparation: OptionSize; ThisIsAUnit, SymbolIsNumber, LastProgPartWasBody, LastSymWasRange, (*JLG*) InIncludeFile, ReadIncludeFiles: Boolean; LastSymbol, SymbolName: Symbols; CharCount: integer; AlphaSymbols, EndLabel, EndConst, EndType, EndVar: SymbolSet; Symbol: SymbolString; Digits, Letters, LettersAndDigits: CharSet; Main: CommentText; MainNmLength: Width; CommentDelimiter: (Brace, ParenAsterisk); (*JLG*) Blanks, Zeroes: Alfa; UnWritten: ARRAY [Width] OF RECORD Ch: char; ChIsEndLine: boolean; IndentAfterEOL: margins END; PascalSymbol: ARRAY [1..LastPascSymbol] OF Alfa; PascSymbolName: ARRAY [1..LastPascSymbol] OF Symbols; NameOf: ARRAY [Char] OF Symbols; StatementTypeOf: ARRAY [Symbols] OF StatmntTypes; Infile, IncludeFile, Outfile: text; PROCEDURE Const1Init; BEGIN Main [1] := 'MAIN '; MainNmLength := 4; Blanks := ' '; Zeroes := '0000000000'; FOR I := 0 TO BuffSzM1 DO WITH UnWritten [I] DO BEGIN ch := 'A'; ChIsEndLine := false; IndentAfterEOL := 0 END; FOR Character := Chr (MinChar) TO chr (MaxChar) DO NameOf [Character] := OtherSymbol; Character := ' '; NameOf ['('] := LeftParenth; NameOf [')'] := RightParenth; NameOf ['='] := EqualSymbol; NameOf [','] := CommaSymbol; NameOf ['.'] := PeriodSymbol; NameOf ['['] := LeftBracket; NameOf [']'] := RightBracket; NameOf [':'] := ColonSymbol; NameOf ['<'] := EqualSymbol; NameOf ['>'] := EqualSymbol; NameOf [';'] := Semicolon; PascalSymbol [ 1] := 'PROGRAM '; PascalSymbol [ 2] := 'BEGIN '; PascalSymbol [ 3] := 'END '; PascalSymbol [ 4] := 'CONST '; PascalSymbol [ 5] := 'TYPE '; PascalSymbol [ 6] := 'VAR '; PascalSymbol [ 7] := 'RECORD '; PascalSymbol [ 8] := 'CASE '; PascalSymbol [ 9] := 'IF '; PascalSymbol [10] := 'THEN '; PascalSymbol [11] := 'ELSE '; PascalSymbol [12] := 'DO '; PascalSymbol [13] := 'OF '; PascalSymbol [14] := 'FOR '; PascalSymbol [15] := 'WHILE '; PascalSymbol [16] := 'WITH '; PascalSymbol [17] := 'REPEAT '; PascalSymbol [18] := 'UNTIL '; PascalSymbol [19] := 'PROCEDURE '; PascalSymbol [20] := 'FUNCTION '; PascalSymbol [21] := 'LABEL '; PascalSymbol [22] := 'IN '; PascalSymbol [23] := 'MOD '; PascalSymbol [24] := 'DIV '; PascalSymbol [25] := 'AND '; PascalSymbol [26] := 'OR '; PascalSymbol [27] := 'NOT '; PascalSymbol [28] := 'ARRAY '; PascalSymbol [29] := 'UNIT '; PascalSymbol [30] := 'SEGMENT '; PascalSymbol [31] := 'NOSYMBOL '; (*JLG*) END; PROCEDURE ConstantsInitialization; BEGIN Const1Init; PascSymbolName [ 1] := ProgSymbol; PascSymbolName [ 2] := BeginSymbol; PascSymbolName [ 3] := EndSymbol; PascSymbolName [ 4] := ConstSymbol; PascSymbolName [ 5] := TypeSymbol; PascSymbolName [ 6] := VarSymbol; PascSymbolName [ 7] := RecordSymbol; PascSymbolName [ 8] := CaseSymbol; PascSymbolName [ 9] := IfSymbol; PascSymbolName [10] := ThenSymbol; PascSymbolName [11] := ElseSymbol; PascSymbolName [12] := DoSymbol; PascSymbolName [13] := OfSymbol; PascSymbolName [14] := ForSymbol; PascSymbolName [15] := WhileSymbol; PascSymbolName [16] := WithSymbol; PascSymbolName [17] := RepeatSymbol; PascSymbolName [18] := UntilSymbol; PascSymbolName [19] := ProcSymbol; PascSymbolName [20] := FuncSymbol; PascSymbolName [21] := LabelSymbol; PascSymbolName [29] := UnitSymbol; PascSymbolName [30] := SegmntSymbol; PascSymbolName [31] := Identifier; FOR I := 22 TO 28 DO PascSymbolName [I] := AlphaOperator; (*^JLG*) FOR SymbolName := ProgSymbol TO AlphaOperator DO StatementTypeOf [SymbolName] := OtherStatement; StatementTypeOf [ BeginSymbol] := CompoundStatement; StatementTypeOf [ CaseSymbol] := CaseStatement; StatementTypeOf [ IfSymbol] := IfStatement; StatementTypeOf [ ForSymbol] := ForWithWhileStatement; StatementTypeOf [ WhileSymbol] := ForWithWhileStatement; StatementTypeOf [ WithSymbol] := ForWithWhileStatement; StatementTypeOf [RepeatSymbol] := RepeatStatement; END (*ConstantsInitialization*); ======================================================================================== DOCUMENT :usus Folder:VOL06:format.2.text ======================================================================================== PROCEDURE WriteA (Character: char); VAR I: Width; TestNo: Integer; BEGIN CharCount := CharCount + 1; Oldest := CharCount MOD BufferSize; WITH UnWritten [Oldest] DO BEGIN IF CharCount > BuffSzP1 THEN BEGIN IF ChIsEndLine THEN BEGIN IF IndentAfterEOL < 0 THEN BEGIN Write (Outfile, Blanks: - IndentAfterEOL); OutputCol := OutputCol - IndentAfterEOL; END ELSE BEGIN IF Increment < 0 THEN BEGIN I := WriteRightCol - OutputCol + 1; IF I > 0 THEN Write (Outfile, Blanks: I); TestNo := LineNumber; I := 0; REPEAT TestNo := TestNo DIV 10; I := I + 1; UNTIL TestNo = 0; Write (Outfile, Zeroes: (6 - I), LineNumber: I); LineNumber := LineNumber - Increment; IF LineNumber > 9999 THEN LineNumber := LineNumber - 10000; Writeln (Outfile); END ELSE BEGIN Writeln (Outfile); IF Increment > 0 THEN BEGIN Write (Outfile, LineNumber: 4,' '); LineNumber := LineNumber + Increment; END END; IF IndentAfterEOL > 0 (* ORIGINAL: THEN Write (Outfile, Blanks: IndentAfterEOL); INSTEAD: -JLG-*) THEN WRITE (OUTFILE, CHR (16), CHR (INDENTAFTEREOL + 32)); OutputCol := IndentAfterEOL + 1; END; ChIsEndLine := false; END (*IF ChIsEndLine*) ELSE BEGIN Write (Outfile, ch); OutputCol := OutputCol + 1; END; END (*IF CharCount > *); Ch := Character; WriteColumn := WriteColumn + 1; END (*with*) END (*WriteA*); PROCEDURE FlushUnwrittenBuffer; BEGIN WriteA (' '); WITH UnWritten [Oldest] DO BEGIN ChIsEndLine := true; IndentAfterEOL := 0; END; WriteColumn := 0; FOR I := 0 TO BuffSzM1 DO WriteA (' '); END; PROCEDURE StartNewLineAndIndent; BEGIN IF PackerIsOff AND DisplayIsOn THEN BEGIN WriteA (' '); LastSymbol := PeriodSymbol; WITH UnWritten [Oldest] DO BEGIN ChIsEndLine := true; IndentAfterEOL := WriteLeftCol + LeftMargin - 1; END; WriteColumn := WriteLeftCol + LeftMargin; END END; PROCEDURE ReadACharacter; PROCEDURE WriteIncludeEnd; TYPE futz = RECORD CASE boolean OF TRUE: (s: string); FALSE: (n: PACKED ARRAY[0..160] OF 0..255) END; VAR i, SaveMargin: Margins; x: futz; BEGIN x.s := '{The INCLUDE file has been completed.}'; SaveMargin := LeftMargin; LeftMargin := 0; StartNewLineAndIndent; StartNewLineAndIndent; FOR i := 1 TO x.n[0] DO WriteA (x.s[i]); StartNewLineAndIndent; LeftMargin := SaveMargin END; PROCEDURE DoReadACharacter (VAR f: text); BEGIN IF ReadColumn > ReadRightCol THEN BEGIN IF ReadRightCol < MaxReadRightCol THEN BEGIN NextChIsEOL := true; Readln (f) END ELSE ReadColumn := 2 END ELSE IF ReadColumn = 1 THEN WHILE ReadColumn < ReadLeftCol DO BEGIN IF EOLN (f) THEN ReadColumn := 1 ELSE BEGIN ReadColumn := ReadColumn + 1; Get (f) END END; IF NextChIsEOL THEN BEGIN Character := ' '; NextChIsEOL := false; ChIsEOL := true; ReadColumn := 1; IF NoFormatting THEN BEGIN WriteA (' '); WITH UnWritten [Oldest] DO BEGIN ChIsEndLine := true; IndentAfterEOL := WriteLeftCol - 1; END; WriteColumn := WriteLeftCol - 1; END; END ELSE IF NOT eof (f) THEN BEGIN Character := f^; ReadColumn := ReadColumn + 1; NextChIsEOL := EOLN (f); Get (f); ChIsEOL := false; IF NoFormatting THEN WriteA (Character) END ELSE BEGIN FlushUnwrittenBuffer; EXIT (Program) END END (*DoReadACharacter*); BEGIN {ReadACharacter - added to allow for INCLUDE files - JLG} IF InIncludeFile THEN IF EOF (IncludeFile) THEN BEGIN WriteIncludeEnd; DoReadACharacter (Infile); InIncludeFile := false; Close (IncludeFile, Lock) END ELSE DoReadACharacter (IncludeFile) ELSE DoReadACharacter (Infile); END; PROCEDURE WriteSymbol; VAR I: Width; NumberBlanksToWrite: OptionSize; PROCEDURE WriteLongString (StringLength: Width; VAR LongString: SymbolString); VAR SaveMargin: Margins; MaxLength, LineLength: Width; EndString: SymbolString; BEGIN SaveMargin := LeftMargin; LeftMargin := 0; StartNewLineAndIndent; MaxLength := WriteRightCol - WriteLeftCol + 1; IF StringLength <= MaxLength THEN FOR LineLength := 1 TO StringLength DO WriteA(LongString[LineLength]) ELSE BEGIN LineLength := 0; REPEAT LineLength := LineLength + 1; WriteA (LongString[LineLength]) UNTIL (LineLength > MaxLength -3) OR ((LineLength > MaxLength - 9) AND (LongString[LineLength] = ' ')); WriteA(''''); WriteA(','); EndString[1] := ''''; FOR I := 1 TO StringLength - LineLength DO EndString[I+1] := LongString[I+LineLength]; WriteLongString (StringLength - LineLength + 1, EndString); END; LeftMargin := SaveMargin; END; BEGIN IF DisplayIsOn THEN BEGIN NumberBlanksToWrite := SymbolGap; IF (LastSymbol IN [LeftParenth, LeftBracket, PeriodSymbol]) OR (SymbolName IN [Semicolon, RightParenth, RightBracket, CommaSymbol, PeriodSymbol, ColonSymbol]) OR (SymbolName IN [LeftBracket, LeftParenth]) AND (LastSymbol = Identifier) THEN NumberBlanksToWrite := 0 ELSE IF (SymbolName IN AlphaSymbols) AND (LastSymbol IN AlphaSymbols) THEN IF WriteColumn <= WriteRightCol THEN BEGIN WriteA (' '); NumberBlanksToWrite := SymbolGap - 1; END; IF WriteColumn + Length + NumberBlanksToWrite - 1 > WriteRightCol THEN BEGIN WriteA (' '); WITH UnWritten [Oldest] DO BEGIN ChIsEndLine := true; IF PackerIsOff THEN BEGIN IndentAfterEOL := WriteLeftCol - 1 + LeftMargin + LongLineIndent; WriteColumn := WriteLeftCol + LeftMargin + LongLineIndent; I := WriteRightCol - LeftMargin - LongLineIndent - WriteLeftCol + 1; IF I < Length THEN IF Symbol[1] = '''' THEN BEGIN ChIsEndLine := false; WriteLongString (Length, Symbol); Length := 0 {suppress writing string AGAIN} END ELSE IF I < 10 THEN Length := 10 ELSE Length := I; END ELSE BEGIN IF Length > WriteRightCol - WriteLeftCol + 1 THEN Length := WriteRightCol - WriteLeftCol + 1; IndentAfterEOL := WriteLeftCol - 1; WriteColumn := WriteLeftCol END; END (*with*); END (*then*) ELSE FOR I := 1 TO NumberBlanksToWrite DO WriteA (' '); FOR I := 1 TO Length DO WriteA (Symbol [I]); END (*IF DisplayIsOn*); LastSymbol := SymbolName END (*WriteSymbol*); PROCEDURE CopyACharacter; BEGIN IF DisplayIsOn THEN BEGIN IF (WriteColumn > WriteRightCol) OR ((WriteColumn + 7 > WriteRightCol) AND (Character = ' ')) (*JLG*) THEN BEGIN WHILE (Character = ' ') AND NOT ChIsEOL DO ReadACharacter; IF NOT ChIsEOL THEN StartNewLineAndIndent END; IF ChIsEOL THEN BEGIN LeftMargin := 0; StartNewLineAndIndent; LeftMargin := ActualLeftMargin END ELSE WriteA (Character) END; ReadACharacter END (*CopyACharacter*); PROCEDURE DoFormatterDirectives; CONST Invalid = -1; TYPE ParamCount = 1..2; Params = ARRAY [ParamCount] OF integer; VAR Specification: Params; FormatOption: char; PrevDisplay, PrevNoFormatting: boolean; EndDirectiv: CharSet; PROCEDURE ReadIn (N: ParamCount; VAR Specification: Params); VAR I: ParamCount; BEGIN FOR I := 1 TO N DO BEGIN WHILE NOT (Character IN (Digits + EndDirectv)) DO CopyACharacter; Specification [I] := 0; IF NOT (Character IN EndDirectiv) THEN REPEAT Specification [I] := 10 * Specification [I] + ORD (Character) - ORD ('0'); CopyACharacter UNTIL NOT (Character IN Digits) ELSE Specification [I] := Invalid; END END (*ReadIn*); BEGIN (*DoFormatterDirectives*); EndDirective := ['*', ']', '}']; (*JLG*) REPEAT IF Character IN ['A'..'G', 'I', 'L', 'N', 'P', 'R', 'S', 'W'] THEN BEGIN FormatOption := Character; CASE FormatOption OF 'A', 'E', 'I', 'G', 'P', 'L', 'S': BEGIN ReadIn (1, Specification); IF (Specification [1] < WriteRightCol - WriteLeftCol - 9) OR (FormatOption = 'P') THEN CASE FormatOption OF 'A': DeclarAlignment := Specification [1]; 'E': IF Specification [1] < 4 THEN BEGIN ProcNamesWanted := Specification [1] > 1; EndCommentsWanted := Odd(Specification [1]) END; 'G': SymbolGap := Specification [1]; 'I': IndentIndex := Specification [1]; 'L': LongLineIndent := Specification [1]; 'P': ProcSeparation := Specification [1]; 'S': StatmtSeparation := Specification [1] END (*case*) END (*1st 7 letters*); 'W', 'R', 'N': BEGIN ReadIn (2, Specification); IF Specification [2] <> Invalid THEN CASE FormatOption OF 'W': IF (Specification [1] > 0) AND (Specification [2] < BufferSize - 2) AND (Specification [2] - Specification [1] > 8) THEN BEGIN WriteLeftCol := Specification [1]; WriteRightCol := Specification [2] END; 'R': IF (Specification [1] > 0) AND (Specification [2] - Specification [1] > 8) THEN BEGIN ReadLeftCol := Specification [1]; ReadRightCol := Specification [2] END; 'N': BEGIN LineNumber := Specification [1]; Increment := Specification [2]; WHILE NOT (Character IN (['<'] + EndDirectv)) AND (Character <> '>') DO CopyACharacter; IF Character = '>' THEN Increment := - Increment END END (*case*); END (*Next 2 letters*); 'B', 'C', 'D', 'F': BEGIN REPEAT CopyACharacter UNTIL Character IN (['+', '-'] + EndDirectv); IF Character IN ['+', '-'] THEN CASE FormatOption OF 'B': IF DisplayIsOn THEN BunchWanted := Character = '+'; 'C': PackerIsOff := Character = '-'; 'D': BEGIN PrevDisplay := DisplayIsOn; DisplayIsOn := Character = '+'; IF PrevDisplay AND NOT DisplayIsOn THEN BEGIN WriteA ('*'); WriteA (')'); SavedBunch := BunchWanted; BunchWanted := false END ELSE IF NOT PrevDisplay AND DisplayIsOn THEN BEGIN StartNewLineAndIndent; WriteA ('('); WriteA ('*'); BunchWanted := SavedBunch END END; 'F': BEGIN PrevNoFormatting := NoFormatting; NoFormatting := Character = '-'; DisplayIsOn := NOT NoFormatting; IF PrevNoFormatting AND NOT NoFormatting THEN ReadACharacter; IF NOT PrevNoFormatting AND NoFormatting THEN WriteA ('-'); END END (*case*) END (*boolean parameters*) END (*main case statement*); END (*then*) ELSE IF NOT (Character IN EndDirectv) THEN CopyACharacter UNTIL Character IN EndDirectv; IF Character = ']' THEN CopyACharacter END (*DoFormatterDirectives*); ======================================================================================== DOCUMENT :usus Folder:VOL06:format.3.text ======================================================================================== PROCEDURE GetNewInitValues; {The following CONST and TYPE are DERIVED from MAKEMASKS; DO NOT CHANGE!} CONST MaxX = 79 {max line length}; MaxY = 23 {max lines/screen - 1}; MaxData = 50 {max entries in data field table}; TYPE XLimits = 0..MaxX; YLimits = 0..MaxY; FieldNo = 1..MaxData; DataRec = PACKED RECORD X: XLimits; Y: YLimits; Lngth, Dec: XLimits END; DataArry = ARRAY [FieldNo] OF DataRec; MaskRec = RECORD Line: ARRAY [YLimits] OF PACKED ARRAY [XLimits] OF char; Data: DataArry END; Characset = SET OF char; VAR i, j: integer; c: char; Done, NegIncrement: boolean; Field: DataArry; PROCEDURE OpenDataFile {Implementation Dependent!!!}; CONST DFileName = 'FMT.MASK.DATA'; VAR i, j: integer; Mask: MaskRec; DataFile: FILE OF MaskRec; BEGIN {$I-} Reset (DataFile, DFileName); IF IORESULT > 0 THEN Reset (DataFile, CONCAT ('#4:', DFileName)); IF IORESULT > 0 THEN Reset (DataFile, CONCAT ('#5:', DFileName)); {$I+} IF IORESULT > 0 THEN BEGIN Write ( 'Cannot open the CRT mask file; we''ll skip this portion of FORMAT.'); EXIT (GetNewInitValues) END; Gotoxy (0, 0); Mask := DataFile^; FOR i := 0 TO MaxY DO BEGIN UnitWrite(1,Mask.Line[i],MaxX); IF i < MaxY DO Writeln END; FOR i := 1 TO MaxData DO Field[i] := Mask.Data[i]; END; PROCEDURE GoToFieldNo (f: FieldNo); BEGIN WITH Field[f] DO Gotoxy (X, Y) END; PROCEDURE GoAndEraseField (f: FieldNo); BEGIN WITH Field[f] DO Gotoxy (X, Y); Write (' ': Field[f].Lngth); WITH Field[f] DO Gotoxy (X, Y); END; PROCEDURE WritePrompt (prompt: string); BEGIN GoAndEraseField (30); Write (prompt) END; FUNCTION GetChar (f: integer; prompt: string; charset: characset): char; VAR ch: char; BEGIN WritePrompt (prompt); IF f > 0 THEN GoToFieldNo (f); REPEAT Read (keyboard, ch); IF (ch IN ['a'..'z']) THEN ch := CHR (ORD(ch) + ORD('A') - ORD('a') ); UNTIL ch IN charset; GetChar := ch; END; FUNCTION GetBoolean (f: integer; prompt: string): boolean; VAR NewPrompt: string; BEGIN NewPrompt := CONCAT ('Do you wish ', prompt, ' (Y/N)? '); IF GetChar (f, NewPrompt, ['Y', 'N']) = 'Y' THEN BEGIN Write ('Yes'); GetBoolean := true END ELSE BEGIN Write (' No'); GetBoolean := false END; END; PROCEDURE GetInteger (f: FieldNo; VAR Wanted: integer); CONST UpperLimit = 1000; VAR i, ilngth: integer; ch, backsp, esc: char; BEGIN backsp := CHR (8); esc := CHR (27); ilngth := Field[f].Lngth; i := 0; WritePrompt ( 'Type desired number, then , or use to restore original value.'); REPEAT GoToFieldNo (f); IF i <> 0 THEN Write (i: ilngth) ELSE Write (' ': ilngth); REPEAT Read (keyboard, ch) UNTIL (ch IN ['0'..'9', ' ', backsp, esc]); IF ch = backsp THEN IF i < 0 THEN i := -(ABS(i) DIV 10) ELSE i := i DIV 10 ELSE IF ch IN ['0'..'9'] THEN i := i * 10 + ORD(ch) - ORD('0'); UNTIL (i * 10 > UpperLimit) OR (ch IN [' ', esc]); IF ch <> esc THEN Wanted := i; GoToFieldNo (f); Write (Wanted: Field[f].Lngth); END; PROCEDURE WriteValues; VAR i: integer; PROCEDURE WriteInt (n: integer); BEGIN WITH Field[i] DO BEGIN Gotoxy (X,Y); Write (n:Lngth) END END; PROCEDURE WriteBool (b: boolean); BEGIN WITH Field[i] DO Gotoxy (X,Y); IF b THEN Write ('Yes') ELSE Write (' No') END; BEGIN FOR i := 11 TO 28 DO CASE i OF 11: WriteInt (ReadLeftCol); 12: WriteInt (ReadRightCol); 13: WriteInt (WriteLeftCol); 14: WriteInt (WriteRightCol); 15: WriteInt (SymbolGap); 16: WriteInt (StatmtSeparation); 17: WriteInt (IndentIndex); 18: WriteInt (LongLineIndent); 19: WriteInt (DeclarAlignment); 20: WriteInt (ProcSeparation); 21: WriteBool (BunchWanted); 22: WriteBool (NOT PackerIsOff); 23: WriteBool (ProcNamesWanted); 24: WriteBool (EndCommentsWanted); 25: BEGIN GoToFieldNo (25); IF Increment = 0 THEN Write (' No') ELSE IF NegIncrement THEN Write ('Right') ELSE Write (' Left') END; 26: WriteInt (LineNumber); 27: WriteInt (Increment); 28: WriteBool (ReadIncludeFiles); END; END; PROCEDURE FortyColumnFormat; BEGIN BunchWanted := false; SymbolGap := 1; StatmtSeparation := 1; IndentIndex := 1; LongLineIndent := 2; WriteRightCol := 39; WriteLeftCol := 1; WriteValues; END; PROCEDURE SixtyFourColumnFormat; BEGIN SymbolGap := 1; StatmtSeparation := 2; IndentIndex := 2; LongLineIndent := 2; WriteRightCol := 63; WriteLeftCol := 1; WriteValues END; PROCEDURE EightyColumnFormat; BEGIN StatmtSeparation := 3; IndentIndex := 3; LongLineIndent := 4; WriteRightCol := 79; WriteLeftCol := 1; WriteValues END; PROCEDURE ModemFormat; BEGIN PackerIsOff := false; EndCommentsWanted := true; ProcNamesWanted := true; WriteValues; END; BEGIN {GetNewInitValues} Done := false; OpenDataFile; WriteValues; REPEAT CASE GetChar (-1, 'Please type letter of option you wish to change; "G" to go on; "Q" to quit. ', ['A'..'E', 'G', 'I', 'J', 'L'..'N', 'P'..'S', 'W', '4', '6', '8','#']) OF 'A': GetInteger (19, DeclarAlignment); 'B': BunchWanted := GetBoolean (21, 'to bunch statements'); 'C': PackerIsOff := NOT GetBoolean (22, 'to krunch your program'); 'D': ReadIncludeFiles := GetBoolean (28, 'to incorporate INCLUDE files'); 'E': EndCommentsWanted := GetBoolean (24, 'to comment END statements'); 'G': Done := GetBoolean (-1, 'to get on with formatting your program'); 'I': CASE GetChar (4, 'Indent L)ogical nesting or O)verflow (continuation) lines? ', ['L', 'O']) OF 'L': GetInteger (17, IndentIndex); 'O': GetInteger (18, LongLineIndent) END; 'J': GetInteger (27, Increment); 'L': GetInteger (20, ProcSeparation); 'M': ModemFormat; 'N': BEGIN CASE GetChar (25, 'Type an "N", "R", or "L": ', ['N', 'R', 'L']) OF 'N': Increment := 0; 'L': BEGIN NegIncrement := false; IF Increment = 0 THEN Increment := 1 END; 'R': BEGIN NegIncrement := true; IF Increment = 0 THEN Increment := 1 END; END; WriteValues; END; 'P': ProcNamesWanted := GetBoolean (23, 'procedure/function name comments'); 'Q': IF GetBoolean (-1, 'TO *EXIT* THIS PROGRAM') THEN EXIT (Program); 'R': CASE GetChar (1, 'L)eft or R)ight margins of input file? ', ['L','R']) OF 'L': GetInteger (11, ReadLeftCol); 'R': GetInteger (12, ReadRightCol) END; 'S': CASE GetChar (3, 'Spacing between I)dentifiers & symbols or S)tatements on the same line? ', ['I', 'S']) OF 'I': GetInteger (15, SymbolGap); 'S': GetInteger (16, StatmtSeparation) END; 'W': CASE GetChar (2, 'L)eft or R)ight margins on output page? ', ['L', 'R']) OF 'L': GetInteger (13, WriteLeftCol); 'R': GetInteger (14, WriteRightCol) END; '4': FortyColumnFormat; '6': SixtyFourColumnFormat; '8': EightyColumnFormat; '#': GetInteger (26, LineNumber) END; UNTIL Done; Writeln; IF NegIncrement THEN Increment := -Increment END; ======================================================================================== DOCUMENT :usus Folder:VOL06:format.4.text ======================================================================================== PROCEDURE ReadSymbol; CONST ReadNextCh = true; DontReadNextCh = false; TYPE CmtDelmtrs = (Brace, PrnAstrsk); VAR TestSymbol: Alfa; CharNumber, I: Width; CmntDelimitr: CmtDelmtrs; PROCEDURE CompilerDirectives; VAR Lngth: Width; DoInclude: boolean; str: string[25]; PROCEDURE WriteString (st:String); TYPE futz = RECORD CASE boolean OF TRUE: (s: string); FALSE: (n: PACKED ARRAY[0..160] OF 0..255) END; VAR i: integer; x: futz; BEGIN x.s := st; FOR i := 1 TO x.n[0] DO WriteA (x.s[i]) END; BEGIN DoInclude := false; str := ''; ReadACharacter; IF ReadIncludeFiles AND (Character IN ['I', 'i']) {INCLUDE compiler directive} THEN BEGIN REPEAT ReadACharacter UNTIL Character <> ' '; IF Character IN ['+', '-'] {"I" is also I/O-checking directive} THEN str := 'I' ELSE BEGIN IF InIncludeFile THEN BEGIN str := 'I'; Writeln ('**ERROR**--INCLUDE directives not allowed within INCLUDED files.') END ELSE BEGIN Lngth := 0; REPEAT Lngth := Lngth + 1; INSERT (' ', str, Lngth); str [Lngth] := Character; ReadACharacter UNTIL (Character IN [' ', '[', '*', '}']) OR (Lngth >= 23); {$I+} Reset (IncludeFile, str); IF IORESULT > 0 THEN Reset (IncludeFile, CONCAT ('#4:', str)); IF IORESULT > 0 THEN Reset (IncludeFile, CONCAT ('#5:', str)); {$I-} IF IORESULT = 0 THEN BEGIN DoInclude := true; InIncludeFile := true; WriteString (CONCAT ('Now INCLUDING ', str, '.')); Writeln ('Now INCLUDING ', str, '.') END ELSE Writeln ('*ERROR* - could not open INCLUDE file ', str, '; will skip it.') END {else} END {else} END {if}; IF NOT DoInclude THEN WriteString (CONCAT ('$', str)); WHILE NOT (Character IN ['[', '*', '}']) DO CopyACharacter END; PROCEDURE DoComment; VAR I, Length: OptionSize; FoundEnd, LoopDone: boolean; ComText: PACKED ARRAY [Width] OF char; FUNCTION LineTooLong (LookingFor: char): boolean; VAR EndLength, WordEndLength: width; TooLong: boolean; BEGIN EndLength := WriteRightCol - WriteColumn - 1 {room for comment close}; IF CmntDelimitr = PrnAstrsk THEN EndLength := EndLength - 1; IF EndLength < 7 THEN WordEndLength := 0 ELSE WordEndLength := EndLength - 7; TooLong := (Length > EndLength) OR ((Character = ' ') AND (Length <= WordEndLength)); WHILE NOT (TooLong OR (Character = LookingFor)) DO BEGIN ComText [Length] := Character; Length := Length + 1; ReadACharacter; TooLong := (Length > EndLength) OR ChIsEOL OR ((Character = ' ') AND (Length > WordEndLength)); END; LineTooLong := TooLong; END; PROCEDURE NewCommentLine; BEGIN LeftMargin := 0; StartNewLineAndIndent; LeftMargin := ActualLeftMargin END; PROCEDURE CopyCommentChar; BEGIN If DisplayIsOn THEN BEGIN IF (WriteColumn > WriteRightCol) OR ((Character = ' ') AND (WriteColumn + 7 > WriteRightCol)) THEN BEGIN WHILE Character = ' ' DO ReadACharacter; NewCommentLine; END; IF ChIsEOL {skip over blanks at beginning of next line} THEN WHILE Character = ' ' DO ReadACharacter; WriteA(Character); END; ReadACharacter; END; BEGIN {DoComment} FoundEnd := false; IF (LastSymbol = Comment) OR (ReadRightCol < 3) OR (Character IN ['$','[']) THEN BEGIN NewCommentLine; WriteSymbol; If Character = '$' THEN CompilerDirectives; IF Character = '[' THEN DoFormatterDirectives; END ELSE BEGIN Length := 1; IF CmntDelimitr = Brace THEN IF LineTooLong ('}') THEN NewCommentLine ELSE FoundEnd := true ELSE REPEAT IF LineTooLong ('*') THEN BEGIN LoopDone := true; NewCommentLine END ELSE BEGIN ComText [Length] := Character; Length := Length + 1; ReadACharacter; LoopDone := Character = ')'; FoundEnd := Character = ')'; END UNTIL LoopDone; WriteSymbol; FOR I := 1 TO Length - 1 DO WriteA (ComText[I]); END; IF NOT FoundEnd THEN IF CmntDelimitr = Brace THEN WHILE Character <> '}' DO CopyCommentChar ELSE REPEAT WHILE Character <> '*' DO CopyCommentChar; CopyCommentChar UNTIL Character = ')'; CopyCommentChar; LastSymbol := Comment; ReadSymbol END {DoComment}; PROCEDURE SkipComment; {Now won't dump compiler directives; handles brace-type comments. JLG} VAR NeedsClosure: boolean; BEGIN IF Character = '$' THEN BEGIN WriteSymbol; CompilerDirectives; NeedsClosure := true END ELSE NeedsClosure := false; IF CmntDelimitr = Brace THEN BEGIN WHILE Character <> '}' DO ReadACharacter; IF NeedsClosure THEN WriteA ('}') END ELSE BEGIN REPEAT WHILE Character <> '*' DO ReadACharacter; ReadACharacter UNTIL Character = ')'; IF NeedsClosure THEN BEGIN WriteA ('*'); WriteA (')') END END; ReadACharacter; LastSymbol := comment; ReadSymbol END; PROCEDURE CheckFor (SecondChar: char; TwoCharSymbol: Symbols; ReadAllowed: Boolean); BEGIN IF ReadAllowed THEN BEGIN Length := 1; Symbol[1] := Character; SymbolName := NameOf [Character]; ReadACharacter END; IF Character = SecondChar THEN BEGIN Symbol [2] := Character; Length := 2; SymbolName := TwoCharSymbol; ReadACharacter; IF (NOT PackerIsOff) AND (SymbolName = Comment) THEN Length := 0 END END {CheckFor}; BEGIN {ReadSymbol} IF LastSymWasRange {added - JLG} THEN BEGIN Symbol[1] := '.'; Symbol[2] := '.'; SymbolName := Range; Length := 2; LastSymWasRange := false END ELSE IF (Character IN Letters) {evaluation order revised - JLG} THEN BEGIN CharNumber := 1; SymbolIsNumber := false; REPEAT Symbol [CharNumber] := Character; ReadACharacter; CharNumber := CharNumber + 1 UNTIL NOT (Character IN LettersAndDigits); Length := CharNumber - 1; FOR CharNumber := CharNumber TO AlfaLeng DO Symbol [CharNumber] := ' '; { PACK (Symbol, 1, TestSymbol); } {EQUIVALENT (WITH ADDED UPPER/LOWER CASE TRANSPARENCY): } FOR I := 1 TO AlfaLeng DO BEGIN TestSymbol [I] := Symbol [I]; IF (TestSymbol [I] IN ['a'..'z']) {lower --> upper case JLG} THEN TestSymbol [I] := CHR (ORD (TestSymbol [I]) + ORD ('A') - ORD ('a')) END; I := 1; PascalSymbol [LastPascSymbol] := TestSymbol; WHILE PascalSymbol [I] <> TestSymbol DO I := I + 1; SymbolName := PascSymbolName [I] END {letters} ELSE IF (Character IN ['0'..'9', ' ', '(', '{', '.', ':', '''', '<', '>']) THEN CASE Character OF '{': BEGIN {brace added - JLG} SymbolName := Comment; CmntDelimitr := Brace; ReadACharacter; Length := 1; Symbol[1] := '{'; IF PackerIsOff OR (EndCommentsWanted AND ProcNamesWanted) THEN DoComment ELSE SkipComment END; '(': BEGIN {Revised -- JLG} CheckFor ('*', Comment, ReadNextCh); IF SymbolName = Comment THEN BEGIN CmntDelimitr := PrnAstrsk; IF PackerIsOff OR (EndCommentsWanted AND ProcNamesWanted) THEN DoComment ELSE SkipComment END END; '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': BEGIN SymbolIsNumber := true; CharNumber := 1; REPEAT REPEAT Symbol [CharNumber] := Character; ReadACharacter; CharNumber := CharNumber + 1 UNTIL NOT (Character IN Digits); IF Character = '.' THEN BEGIN Symbol [CharNumber] := Character; ReadACharacter; CharNumber := CharNumber + 1 END UNTIL NOT (Character IN Digits); IF (Character = '.') AND (Symbol [CharNumber-1] = '.') THEN BEGIN { stmt added - JLG} LastSymWasRange := true; ReadACharacter; CharNumber := CharNumber - 1 END; IF (Character IN ['B', 'E']) AND NOT LastSymWasRange THEN BEGIN Symbol [CharNumber] := Character; ReadACharacter; CharNumber := CharNumber + 1; IF Character IN Digits + ['+', '-'] THEN REPEAT Symbol [CharNumber] := Character; ReadACharacter; CharNumber := CharNumber + 1 UNTIL NOT (Character IN Digits) END; Length := CharNumber - 1; SymbolName := Identifier; END {numbers}; ' ': BEGIN REPEAT ReadACharacter UNTIL Character <> ' '; ReadSymbol END; '>', ':': CheckFor ('=', OtherSymbol, ReadNextCh); '<': BEGIN CheckFor ('=', OtherSymbol, ReadNextCh); IF SymbolName <> OtherSymbol THEN CheckFor ('>', OtherSymbol, DontReadNextCh) END; '.': IF LastSymbol <> EndSymbol THEN CheckFor ('.', Range, ReadNextCh) ELSE SymbolName := PeriodSymbol; '''': BEGIN CharNumber := 1; REPEAT REPEAT Symbol [CharNumber] := Character; CharNumber := CharNumber + 1; ReadACharacter UNTIL Character = ''''; Symbol [CharNumber] := Character; CharNumber := CharNumber + 1; ReadACharacter UNTIL Character <> ''''; Length := CharNumber - 1; SymbolName := OtherSymbol; END {string} END {then case} ELSE BEGIN Symbol [1] := Character; SymbolName := NameOf [Character]; Length := 1; ReadACharacter END END {ReadSymbol}; ======================================================================================== DOCUMENT :usus Folder:VOL06:format.5.text ======================================================================================== PROCEDURE ChangeMarginTo (NewLeftMargin: Margins); VAR IndentedLeftMargin: Margins; BEGIN ActualLeftMargin := NewLeftMargin; LeftMargin := NewLeftMargin; IF LeftMargin < 0 THEN LeftMargin := 0 ELSE BEGIN IndentedLeftMargin := WriteRightCol - 9 - LongLineIndent; IF LeftMargin > IndentedLeftMargin THEN LeftMargin := IndentedLeftMargin END END (*ChangeMarginTo*); PROCEDURE DoDeclarationUntil (EndDeclaration: SymbolSet); PROCEDURE DoParentheses; VAR SavedLgLnId: OptionSize; BEGIN SavedLgLnId := LongLineIndent; IF DeclarAlignment > 0 THEN BEGIN LongLineIndent := WriteColumn + SymbolGap + 1 - LeftMargin - WriteLeftCol; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = RightParenth; WriteSymbol; ReadSymbol END ELSE BEGIN LongLineIndent := 1; ChangeMarginTo (ActualLeftMargin + IndentIndex); StartNewLineAndIndent; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = RightParenth; WriteSymbol; ReadSymbol; ChangeMarginTo (ActualLeftMargin - IndentIndex); END; LongLineIndent := SavedLgLnId END (*DoParentheses*); PROCEDURE DoFieldListUntil (EndFieldList: SymbolSet); VAR LastEOL: Margins; AlignColumn: Width; PROCEDURE DoRecord; VAR SavedLeftMargin: Width; BEGIN SavedLeftMargin := ActualLeftMargin; WriteSymbol; ReadSymbol; ChangeMarginTo (WriteColumn - 6 + IndentIndex - WriteLeftCol); StartNewLineAndIndent; DoFieldListUntil ([EndSymbol]); ChangeMarginTo (ActualLeftMargin - IndentIndex); StartNewLineAndIndent; WriteSymbol; ReadSymbol; ChangeMarginTo (SavedLeftMargin); END (*DoRecord*); PROCEDURE DoVariantRecordPart; VAR SavedLeftMargin, OtherSavedMargin: Margins; BEGIN OtherSavedMargin := ActualLeftMargin; IF DeclarAlignment > 0 THEN BEGIN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName IN [ColonSymbol, OfSymbol]; IF SymbolName = ColonSymbol THEN BEGIN WriteSymbol; ReadSymbol; WITH UnWritten [LastEOL] DO BEGIN IndentAfterEOL := IndentAfterEOL + AlignColumn - WriteColumn; IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0 END; WriteColumn := AlignColumn; ChangeMarginTo (ActualLeftMargin + AlignColumn - WriteColumn) END END (*then*); IF SymbolName <> OfSymbol THEN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = OfSymbol; ChangeMarginTo (ActualLeftMargin + IndentIndex); REPEAT WriteSymbol; ReadSymbol; IF SymbolName <> EndSymbol THEN BEGIN StartNewLineAndIndent; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName IN [LeftParenth, SemiColon, EndSymbol]; IF SymbolName = LeftParenth THEN BEGIN WriteSymbol; ReadSymbol; SavedLeftMargin := ActualLeftMargin; ChangeMarginTo (WriteColumn - WriteLeftCol); DoFieldListUntil ([RightParenth]); WriteSymbol; ReadSymbol; ChangeMarginTo (SavedLeftMargin) END END; UNTIL SymbolName <> Semicolon; ChangeMarginTo (OtherSavedMargin) END (*DoVariantRecordPart*); BEGIN (*DoFieldListUntil*) LastEOL := Oldest; IF LastSymbol = LeftParenth THEN FOR I := 1 TO DeclarAlignment - Length DO WriteA (' '); AlignColumn := LeftMargin + WriteLeftCol + DeclarAlignment + 1; WHILE NOT (SymbolName IN EndFieldList) DO BEGIN IF LastSymbol IN [Semicolon, Comment] THEN IF SymbolName <> Semicolon THEN BEGIN StartNewLineAndIndent; LastEOL := Oldest END; IF SymbolName IN [RecordSymbol, CaseSymbol, LeftParenth, CommaSymbol, ColonSymbol, EqualSymbol] THEN CASE SymbolName OF RecordSymbol: DoRecord; CaseSymbol: DoVariantRecordPart; LeftParenth: DoParentheses; CommaSymbol, ColonSymbol, EqualSymbol: BEGIN WriteSymbol; IF DeclarAlignment > 0 THEN IF NOT (EndLabel <= EndFieldList) THEN BEGIN WITH UnWritten [LastEOL] DO BEGIN IndentAfterEOL := IndentAfterEOL + AlignColumn - WriteColumn; IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0; WriteColumn := AlignColumn END; IF SymbolName = CommaSymbol THEN BEGIN StartNewLineAndIndent; LastEOL := Oldest END END (*then*); ReadSymbol END (* , : = *) END (*case*) ELSE BEGIN WriteSymbol; ReadSymbol END; END (*while*) END (*DoFieldListUntil*); BEGIN (*DoDeclarationUntil*) StartNewLineAndIndent; WriteSymbol; ChangeMarginTo (ActualLeftMargin + IndentIndex); StartNewLineAndIndent; ReadSymbol; DoFieldListUntil (EndDeclaration); StartNewLineAndIndent; ChangeMarginTo (ActualLeftMargin - IndentIndex) END (*DoDeclarationUntil*); PROCEDURE DoBlock (BlockName: CommentText; BlockNmLength: Width); VAR I: Width; IfThenBunchNeeded, AtProcBeginning: boolean; PROCEDURE DoProcedures; VAR I: 0..20; ProcName: CommentText; ProcNmLenght: Width; BEGIN FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent; StartNewLineAndIndent; WriteSymbol; ReadSymbol; IF SymbolName IN [ProcSymbol, FuncSymbol] THEN BEGIN WriteSymbol; ReadSymbol END; {handle SEPARATE PROCEDURES--JLG} (* FOR I := 0 TO (Length - 1) DIV AlfaLeng DO Pack (Symbol, I * AlfaLeng + 1, ProcName [I + 1]; *) (* Equivalent: *) FOR I := 0 TO (Length - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO ProcName [I + 1, J] := Symbol [J + I*AlfaLeng]; ProcNmLength := Length; WriteSymbol; ReadSymbol; IF SymbolName = LeftParenth THEN BEGIN WriteSymbol; REPEAT ReadSymbol; WriteSymbol UNTIL SymbolName = RightParenth; ReadSymbol END; IF SymbolName = ColonSymbol THEN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = Semicolon; WriteSymbol; ReadSymbol; ChangeMarginTo (ActualLeftMargin + IndentIndex); StartNewLineAndIndent; LastProgPartWasBody := false; DoBlock (ProcName, ProcNmLength); LastProgPartWasBody := true; ChangeMarginTo (ActualLeftMargin - IndentIndex); WriteSymbol; ReadSymbol; StartNewLineAndIndent END (*DoProcedures*); PROCEDURE DoStatement (VAR AddedBlanks: Width; StatmtSymbol: CommentText; StmtSymLength: Width); VAR I: Width; StatmtBeginning, BlksOnCurrntLine, BlksAddedByThisStmt: integer; StatmtPart: ARRAY [1..4] OF integer; Successful: boolean; PROCEDURE Bunch (Beginning, Breakpt, Ending: integer; StatmtSeparation: OptionSize); BEGIN IF BunchWanted OR IfThenBunchNeeded THEN BEGIN IF StatmtSeparation < 1 THEN StatmtSeparation := 1; BlksOnCurrntLine := BlksOnCurrntLine + StatmtSeparation - 1; Successful := ((Ending - Beginning + BlksOnCurrntLine + UnWritten [Beginning MOD BufferSize].IndentAfterEOL) < WriteRightCol) AND (CharCount - Beginning < BufferSize); IF Successful THEN BEGIN BlksAddedByThisStmt := BlksAddedByThisStmt + StatmtSeparation - 1; UnWritten [Breakpt MOD BufferSize].IndentAfterEOL := - StatmtSeparation; END END END (*bunch*); PROCEDURE WriteComment; VAR I, SavedLength: Width; SavedSymbolName: Symbols; SavedChars: SymbolString; BEGIN IF PackerIsOff (*added - JLG*) THEN BEGIN SavedSymbolName := SymbolName; FOR I := 1 TO Length DO SavedChars [I] := Symbol [I]; SavedLength := Length; SymbolName := OtherSymbol; Symbol [1] := '('; Symbol [2] := '*'; Length := 2; WriteSymbol; (* FOR I := 0 TO (StmtSymLength - 1) DIV AlfaLeng DO Unpack (StatmtSymbol [I + 1], Symbol, (I * AlfaLeng + 1));*) (* EQUIVALENT: *) FOR I := 0 TO (StmtSymLength - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO Symbol [J + I * AlfaLeng] := StatmtSymbol [I + 1, J]; Length := StmtSymLength; SymbolName := PeriodSymbol; LastSymbol := PeriodSymbol; WriteSymbol; Symbol [1] := '*'; Symbol[2] := ')'; Length := 2; WriteSymbol; SymbolName := SavedSymbolName; Length := SavedLength; FOR I := 1 TO Length DO Symbol [I] := SavedChars [I] END END (*WriteComment*); PROCEDURE DoStmtList (EndList: Symbols); VAR BlksAfterPrt2: Width; AtProcEnd: boolean; BEGIN AtProcEnd := AtProcBeginning; WriteSymbol; ReadSymbol; StatmtPart [1] := CharCount + 1; StatmtPart [2] := StatmtPart [1]; IF SymbolName <> EndList THEN BEGIN IF ProcNamesWanted THEN IF AtProcBeginning THEN IF LastProgPartWasBody THEN IF LastSymbol = BeginSymbol THEN WriteComment; AtProcBeginning := false; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksAfterPrt2 := AddedBlanks; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; WHILE SymbolName <> EndList DO BEGIN WriteSymbol; ReadSymbol; IF SymbolName <> EndList THEN BEGIN StatmtPart [3] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := AddedBlanks + BlksAfterPrt2; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; Bunch (StatmtPart [2], StatmtPart [3], CharCount, StatmtSeparation); IF NOT Successful THEN BEGIN BlksAfterPrt2 := AddedBlanks; StatmtPart [2] := StatmtPart [3]; END ELSE BlksAfterPrt2 := BlksOnCurrntLine; END (*then*) END (*while*) END (*main then*); BlksOnCurrntLine := BlksAddedByThisStmt; Bunch (StatmtBeginning, StatmtPart [1], CharCount, SymbolGap); StartNewLineAndIndent; StatmtPart [1] := CharCount; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName IN [Semicolon, UntilSymbol, EndSymbol, ElseSymbol, PeriodSymbol]; IF Successful THEN BEGIN IF EndList = UntilSymbol THEN StatmtPart [4] := StatmtSeparation ELSE StatmtPart [4] := SymbolGap; Bunch (StatmtBeginning, StatmtPart [1], CharCount, StatmtPart [4]); END; IF NOT (Successful AND BunchWanted) THEN IF EndList = EndSymbol THEN IF LastSymbol = EndSymbol THEN IF AtProcEnd AND ProcNamesWanted THEN WriteComment ELSE IF EndCommentsWanted THEN WriteComment; END (*DoStmtList*); ======================================================================================== DOCUMENT :usus Folder:VOL06:format.6.text ======================================================================================== BEGIN {DoStatment} BlksOnCurrntLine := 0; Successful := false; BlksAddedByThisStmt := 0; ChangeMarginTo (ActualLeftMargin + IndentIndex); StartNewLineAndIndent; StatmtBeginning := CharCount; IF SymbolIsNumber THEN BEGIN WITH UnWritten [Oldest] DO BEGIN IndentAfterEOL := IndentAfterEOL - 1 - Length - SymbolGap; IF IndentAfterEOL < 0 THEN IndentAfterEOL := 0 END; WriteSymbol; ReadSymbol {Write LABEL}; WriteSymbol; ReadSymbol {Write COLON} END; CASE StatementTypeOf [SymbolName] OF ForWithWhileStatement: BEGIN { PACK (Symbol, 1, StatmtSymbol [1]); EQUIVALENT: } FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I]; StmtSymLength := Length; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = DoSymbol; WriteSymbol; ReadSymbol; StatmtPart [1] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := BlksOnCurrntLine + AddedBlanks; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; Bunch (StatmtBeginning, StatmtPart [1], CharCount, SymbolGap) END; RepeatStatemtnt: DoStmtList (UntilSymbol); IfStatement: BEGIN { PACK (Symbol, 1, StatmtSymbol [1]); EQUIVALENT: } FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I]; StmtSymLength := Length; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = ThenSymbol; StartNewLineAndIndent; StatmtPart [1] := CharCount; WriteSymbol; ReadSymbol; StatmtPart [2] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := AddedBlanks; BlksAddedByThisStmt := AddedBlanks; Bunch (StatmtPart [1], StatmtPart [2], CharCount, SymbolGap); IF Successful THEN Bunch (StatmtBeginning, StatmtPart [1], CharCount, StatmtSeparation) ELSE IfThenBunchNeeded := true; If SymbolName = ElseSymbol THEN BEGIN { PACK (Symbol, 1, StatmtSymbol [1]); EQUIVALENT: } FOR I := 1 TO AlfaLeng DO StatmtSymbol [1, I] := Symbol [I]; StmtSymLength := Length; IfThenBunchNeeded := false; StartNewLineAndIndent; StatmtPart [3] := CharCount; WriteSymbol; ReadSymbol; StatmtPart [4] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := AddedBlanks; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; Bunch (StatmtPart [3], StatmtPart [4], CharCount, SymbolGap); BlksOnCurrntLine := BlksAddedByThisStmt; IF Successful THEN Bunch (StatmtBeginning, StatmtPart [3], CharCount, StatmtSeparation) END ELSE IF (CharCount - StatmtBeginning) < BufferSize THEN BEGIN BunchWanted := NOT BunchWanted; BlksOnCurrntLine := 0; Bunch (StatmtBeginning, StatmtPart [1], StatmtPart [2], SymbolGap); BunchWanted := NOT BunchWanted; END; IfThenBunchNeeded := false END {IfStatement}; CaseStatement: BEGIN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = OfSymbol; WriteSymbol; ReadSymbol; ChangeMarginTo (ActualLeftMargin + IndentIndex); WHILE SymbolName <> EndSymbol DO BEGIN StartNewLineAndIndent; StatmtPart [1] := CharCount; { FOR I := 0 TO (Length - 1) DIV AlfaLeng DO PACK (Symbol, (I + AlfaLeng + 1), StatmtSymbol [I + 1]);} { EQUIVALENT: } FOR I := 0 TO (Length - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO StatmtSymbol [I + 1, J] := Symbol [J + I * AlfaLeng]; StmtSymLength := Length; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = ColonSymbol; WriteSymbol; ReadSymbol; IF NOT (SymbolName IN [Semicolon, EndSymbol]) THEN BEGIN StatmtPart [2] := CharCount + 1; DoStatement (AddedBlanks, StatmtSymbol, StmtSymLength); BlksOnCurrntLine := AddedBlanks; BlksAddedByThisStmt := BlksAddedByThisStmt + AddedBlanks; Bunch (StatmtPart [1], StatmtPart [2], CharCount, SymbolGap); END; IF SymbolName = Semicolon THEN BEGIN WriteSymbol; ReadSymbol END END {while}; ChangeMarginTo (ActualLeftMargin - IndentIndex); StartNewLineAndIndent; WriteSymbol; ReadSymbol; IF EndCommentsWanted AND (LastSymbol = EndSymbol) THEN BEGIN StatmtSymbol [1] := 'CASE '; StmtSymLength := 4; WriteComment END END {CaseStatement}; OtherStatement: WHILE NOT (SymbolName IN [Semicolon, UntilSymbol, EndSymbol, ElseSymbol]) DO BEGIN WriteSymbol; ReadSymbol END; CompoundStatement: DoStmtList (EndSymbol) END {main case }; AddedBlanks := BlksAddedByThisStmt; ChangeMarginTo (ActualLeftMargin - IndentIndex); END {DoStatement}; BEGIN {DoBlock} IF CharCount > BufferSize * 2 {clear out buffer if too long - JLG} THEN CharCount := (CharCount MOD BufferSize) + BufferSize; LastProgPartWasBody := LastProgPartWasBody AND (SymbolName = BeginSymbol); IF SymbolName = LabelSymbol THEN DoDeclarationUntil (EndLabel); IF SymbolName = ConstSymbol THEN DoDeclarationUntil (EndConst); IF SymbolName = TypeSymbol THEN DoDeclarationUntil (EndType ); IF SymbolName = VarSymbol THEN DoDeclarationUntil (EndVar ); WHILE SymbolName IN [SegmntSymbol, FuncSymbol, ProcSymbol] DO DoProcedures; IF SymbolName = BeginSymbol THEN BEGIN IF LastProgPartWasBody THEN FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent; IfThenBunchNeeded := false; AtProcBeginning := true; ChangeMarginTo (ActualLeftMargin - IndentIndex); DoStatement (I, BlockName, BlockNmLength) {I is dummy param}; LastProgPartWasBody := true; ChangeMarginTo (ActualLeftMargin + IndentIndex) END ELSE BEGIN WriteSymbol; ReadSymbol {Write FORWARD } END END {DoBlock}; PROCEDURE DoImplementationDeclaration; VAR I: integer; BEGIN ChangeMarginTo (ActualLeftMargin + IndentIndex); IF SymbolName = LabelSymbol THEN DoDeclarationUntil (EndLabel); IF SymbolName = ConstSymbol THEN DoDeclarationUntil (EndConst); IF SymbolName = TypeSymbol THEN DoDeclarationUntil (EndType ); IF SymbolName = VarSymbol THEN DoDeclarationUntil (EndVar ); WHILE SymbolName IN [ProcSymbol, FuncSymbol] DO BEGIN FOR I := 2 TO ProcSeparation DO StartNewLineAndIndent; StartNewLineAndIndent; WriteSymbol; ReadSymbol; WriteSymbol; ReadSymbol; IF SymbolName = LeftParenth THEN BEGIN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = RightParenth; WriteSymbol; ReadSymbol; END; IF SymbolName = ColonSymbol THEN REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = Semicolon; WriteSymbol {semicolon}; ReadSymbol END; ChangeMarginTo (ActualLeftMargin - IndentIndex); FOR I := 1 TO ProcSeparation DO StartNewLineAndIndent; StartNewLineAndIndent; WriteSymbol; ReadSymbol {write IMPLEMENTATION part} END; PROCEDURE Initialize; VAR I: Width; InfileName, OutfileName: string [25]; BEGIN {Constants:} Digits := ['0'..'9']; Letters := ['A'..'Z', 'a'..'z']; {JLG} LettersAndDigits := Letters + Digits; AlphaSymbols := [ProgSymbol, BeginSymbol, EndSymbol, ConstSymbol, TypeSymbol, RecordSymbol, CaseSymbol, IfSymbol, ThenSymbol, ElseSymbol, DoSymbol, OfSymbol, ForSymbol, WithSymbol, WhileSymbol, RepeatSymbol, UntilSymbol, Identifier, VarSymbol, ProcSymbol, FuncSymbol, LabelSymbol, AlphaOperator]; EndLabel := [ConstSymbol, TypeSymbol, VarSymbol, ProcSymbol, FuncSymbol, BeginSymbol]; EndConst := EndLabel - [ConstSymbol]; EndType := EndConst - [TypeSymbol]; EndVar := EndConst - [VarSymbol]; { Initialize Column Data: } WriteColumn := 0; LeftMargin := 0; ActualLeftMargin := 0; OutputCol := 1; ReadLeftCol := 1; ReadRightCol := MaxReadRightCol; WriteLeftCol := 1; WriteRightCol := MaxWriteRightCol; Oldest := 1; CharCount := 1; LineNumber := 0; Increment := 0; { Initialize Boolean Parameters: } PackerIsOff := true; BunchWanted := false; DisplayIsOn := true; ProcNamesWanted := true; EndCommentsWanted := false; NoFormatting := false; LastSymWasRange := false; { Initialize Numeric Parameters: } IndentIndex := 3; LongLineIndent := 3; ProcSeparation := 2; SymbolGap := 1; StatmtSeparation := 3; DeclarAlignment := 0; { Initialize Input Context Data: } ReadColumn := 1; ChIsEOL := false; NextChIsEOL := false; FOR I := 0 TO BufferSize DO Symbol [I] := ' '; LastSymbol := PeriodSymbol; LastProgPartWasBody := false; { Now get filenames } Writeln; Writeln ('Welcome to the P a s c a l F O R M A T T E R.':65); Writeln ('From the Pascal News No. 13. Written by Michael Condict.':68); REPEAT Writeln; Write ('Please type input file name --> '); Readln (Infilename); IF Infilename = '' THEN EXIT (Program); {$I-} Reset (Infile, Infilename); IF IORESULT > 0 THEN Reset (Infile, CONCAT (Infilename, '.TEXT')); {$I+} I := IORESULT; IF I > 0 THEN BEGIN Writeln ('Oops, something''s wrong. IORESULT = ', I); Writeln ('To exit the program, just type .'); END UNTIL I = 0; REPEAT Write ('Now the output filename (type if you wish to print): '); Readln (Outfilename); IF Outfilename = '' THEN Outfilename := 'PRINTER:'; IF (Outfilename = 'quit') OR (Outfilename = 'QUIT') THEN Exit (Program); {$I-} Rewrite (Outfile, outfilename); {$I+} I := IORESULT; IF I > 0 THEN BEGIN Writeln ('Oops, something''s wrong. IORESULT = ', I); Writeln ('To exit the program, just type "QUIT".'); END UNTIL I = 0; END {Initialize }; BEGIN {MAIN PROGRAM !!!} ConstantsInitialization; Initialize; GetNewInitValues; IF eof(Input) THEN Writeln (' *** No Program Found To Format') ELSE BEGIN ReadACharacter; ReadSymbol; WHILE SymbolName = Comment DO ReadSymbol; {JLG} ThisIsAUnit := SymbolName = UnitSymbol; IF NOT (SymbolName IN [ProgSymbol, UnitSymbol]) THEN BEGIN WriteSymbol; ReadSymbol END; {skip SEPARATE/INTRINSIC JLG} IF NOT (SymbolName IN [ProgSymbol, UnitSymbol]) THEN Writeln (' *** "PROGRAM" or "UNIT" EXPECTED.') ELSE BEGIN StartNewLineAndIndent; WriteSymbol; ReadSymbol; { FOR I := 0 TO (Length - 1) DIV AlfaLeng DO PACK (Symbol, (I * AlfaLeng + 1), Main [I + 1]); } {EQUIVALENT:} FOR I := 0 TO (Length - 1) DIV AlfaLeng DO FOR J := 1 TO AlfaLeng DO Main [I + 1, J] := Symbol [J + I * AlfaLeng]; IF ThisIsAUnit THEN MainNmLength := 0 ELSE MainNmLength := Length; REPEAT WriteSymbol; ReadSymbol UNTIL SymbolName = Semicolon; WriteSymbol; ReadSymbol; StartNewLineAndIndent; WHILE (SymbolName IN [Semicolon, Comment, CommaSymbol, Identifier]) DO BEGIN WriteSymbol; ReadSymbol END; {JLG} IF ThisIsAUnit THEN DoImplementationDeclaration; StartNewLineAndIndent; DoBlock (Main, MainNmLength); WriteA ('.'); FlushUnwrittenBuffer; Close (Outfile, lock) END END END {main program }. ======================================================================================== DOCUMENT :usus Folder:VOL06:format.doc.text ======================================================================================== FORMAT DOCUMENTATION The following text accompanied the program listing in Pascal News, No. 13 (December 1978). For further comments, see "PRETTY.DOC.TEXT" elsewhere on this disk. What Format Does Format is a flexible prettyprinter for Pascal programs. It takes as input a syntactically correct Pascal program and produces as output an equivalent but reformatted Pascal program. The resulting program consists of the same sequence of Pascal symbols and comments, but they are rearranged with respect to line boundaries and columns for readability. Format maintains consistent spacing between symbols, breaks control and data structures onto new lines if necessary, indents lines to reflect the syntactic level of statements and declarations, and more. Miscellaneous features, such as supplying line numbers and automatic comments or deleting all unnecessary blanks to save space, are described below. The flexibility of Format is accomplished by allowing you to supply various directives (options) which override the default values. Rather than being a rigid prettyprinter which decides for you how your program is to be formatted, you have the ability to control how formatting is done, not only prior to execution, but also during execution through the use of prettyprinter directives embedded in your program. Experience with Format over the last three years has shown that most users can find a set of values for the directives which produce satisfactory results. The default values are typical. How To Use Format The use of Format will vary from implementation to implementation, but will involve one major input file containing a Pascal program and one output file for the reformatted program. Additionally it may be possible to supply the initial values of directives to Format when it begins execution. [NOTE to UCSD users: I did not implement this feature, though it should be easy to do.] Directives to Format may always be specified in the program itself inside comments with a special syntax. Thus the first line of a program is an ideal spot for a comment containing directives. Subsequent use of embedded directives allows you to change the kind of formatting for different sections of your program. The syntax of these special comments is given below (The syntax is given using "EBNF"--Extended Backus-Naur Form--see Communications ACM, November, 1977, page 822.): DirectiveComment = "(*" DirectiveList "*)" | "(*$" CompilerOptionList CommentText DirectiveList"*)". DirectiveList = "[" Directive {"," Directive} "]" CommentText. Directive = Letter Setting. Letter = "A"| "B"| "C"| "D"| "E"| "F"| "G"| "H"| "I"| "L"| "N"| "P"| "R"| "S"| "W". Setting = Switch | Value | Range. Switch = "+" | "-". Value = "=" Unsigned Integer. Range = "="UnsignedInteger "-" UnsignedInteger ["<" | ">"]. UnsignedInteger = Digit(Digit). CommentText = (Any character except "]" or close-comment). Note: As defined above, a Directive may be within a comment specifying a Pascal CompilerOptionList. On most implementations this is a "$" followed by a series of letters and values ("+", "-", or digits), separated by commas. See your local manual. Examples of DirectiveComments: (*[A=15, E=3, N=1,1<]*) - good for publication quality. (*[G-0, W=1-100, C+]*) - good for compact storage. (*$U+ [R=1-72, I=2]*) - an example of a DirectiveList with a CompilerOptionList. Directives to Format. A=n Align declarations. The A directive forces the alignment of ":" and "=" in declarations. If A is set to a value greater than O, then n should be equal to the maximum identifier length for that section of your program. The A directive visually clarifies the declaration part of your program. See example below. Default: A=O (no alignment). B+ or B- Bunch statements and declarations reasonably. B+ will place as many statements or declarations onto one line as will fit within the specified write margins (W directive) subject to read- ability constraints. Bunching (B+) when the display is off (D-) has no effect. In general, B+ saves paper and prevents your program from becoming overly stretched in the vertical direction. See example below. Default: B- (one statement or statement part per line). C+ or C- Fully Compress program. C+ removes all non-essential blanks, end-of-lines, and comments from your program. A compilable, packed program will be written within the specified write margins (W directive). The number of spaces specified by the G directive will still be written between symbols. C+ might save some space on long-term storage media such as disk; you might store a program in compressed form and expand it later by reformatting with C-. Default: C-. D+ or D- Turn Display on or off. D allows you to selectively display portions of your program during formatting. Therefore, D must be switched on and off with directives which are appropriately placed in your program. D is perhaps useful to obtain program fragments for publication (such as one or more pro- cedures) without having to print the whole program. Default: D+. E=n Supply END comments. The E directive generates comments after "END" symbols if none are already there. Common Pascal coding styles frequently employ these comments. E=1 creates comments after the "END" symbol in compound statements which are within structured statements, as well as those constituting procedure and function bodies. The comments take the form: (*StatementPart*) or (*ProcedureName*). E=2 creates comments after the "BEGIN" and "END" symbols constituting procedure and func- tion bodies only. E=O creates no comments at all. E=3 means E=1 and E=2. See example below. Default: E=2. F+ or F- Turn Formatting on or off. F allows you to format selected portions of your program. F- causes Format to copy the input program directly with no changes. Therefore by switching F on and off with directives which are appropriately placed in your program, you can preserve text which is already properly formatted (such as comments). Default: F+ (of course!). G=n Specify symbol Gap. The G directive determines the number of spaces placed between Pascal symbols during formatting. G=O still places one space between two identifiers and reserved words. The symbols [] () , and : are handled independently of G. Default: G=1. I=n Specify Indent tab. I indents each nesting level of statements and declarations a given number of columns. Using I=2 or I=1 helps prevent excessively- narrow lines within the specified write margins (W directive) where there are heavily-nested constructs. Default: I=3. L=n Specify Line-wraparound indent tab. L determines the indentation of the remainder of statements or declarations which are too long to fit on one line. Default: L=3. N=x-y< or N=x-y> Generate line-numbers on the left or right. The N directive indicates the starting line-number (x) and the incre- ment (y) for each succeeding line-number. If y > O then line-numbers are written outside the specified write margins for the formatted pro- gram in sequential order starting at x; y = O shuts off line-number- ing. "<" writes up to 4-digit, right-justified line numbers together with a trailing space ot the left of each line. ">" writes 6-digit, zero-filled line numbers to the right of each line. Use the N directive along with the W directive. Default: N=0-0> (no line numbers). P=n Specify spacing between Procedure and function declarations. The P directive determines the number of blank lines to be placed between procedure and function declarations. n>2 makes procedures and functions visually stand out. Default: P=2. R=x-y Specify Read margins. The R directive indicates which columns are significant when Format reads from the input file. R allows Format to accept files which have line numbers in the first (x-1) columns or after the y~h column. Default: R=1-999 (large enough to read end-of-line in most cases). S=n Specify Statement separation. The S directive determines the number of spaces between statements bunched on the same line by the use of the B+ directive. Note that this directive is in effect only if B+ is used. Default: S=3. W=x-y Specify Write margins. The W directive indicates which columns are used for writing the reformatted program on the output file. Any line numbers generated (N directive) are written outside these margins. Default: N=1-72. EXAMPLES The A directive. Here is a sample program fragment before using Format: PROGRAM SAMPLE(OUTPUT); CONST A=6; ABC='LETTERS'; THREE=3; TYPE RANGE=1..6; COLOR=(RED,BLUE); VAR I,I2,I33,I444,I555:RANGE; YES,NO,MAYBE:BOOLEAN; BEGIN END. Here is the output from Format with all defaults set: PROGRAM SAMPLE(OUTPUT); CONST A = 6; ABC = 'LETTERS'; THREE = 3; TYPE RANGE = 1 .. 6; COLOR = (RED, BLUE); VAR I, I2, I33, I444, I5555: RANGE; YES, NO, MAYBE: BOOLEAN; BEGIN END (*SAMPLE*). Here is the output from Format with an added A=5 directive: (*[A=5] ALIGN DECLARATIONS. *) PROGRAM SAMPLE(OUTPUT); CONST A = 6; ABC = 'LETTERS'; THREE = 3; TYPE RANGE = 1 .. 6; COLOR = (RED, BLUE); VAR I, I2, I33, I444, I5555: RANGE; YES, NO, MAYBE: BOOLEAN; BEGIN END (*SAMPLE*). The B Directive. If the input to Format is: PROGRAM T(OUTPUT); CONST INCREMENT = 5; VAR I,J,N:INTEGER; BEGIN N:=0; J:=3; I:=SQR(N); N:=N+INCREMENT; IF N>73 THEN BEGIN DOTHIS; DOTHAT END ; IF N>5 THEN IF J>6 THEN DOSOMETHINGELSE; END. then the output from Format (using the default, B-) is: PROGRAM T(OUTPUT); CONST INCREMENT = 5; VAR I,J,N:INTEGER; BEGIN N:=0; J:=3; I:=SQR(N); N:=N + INCREMENT; IF N>73 THEN BEGIN DOTHIS; DOTHAT END; IF N>5 THEN IF J>6 THEN DOSOMETHINGELSE; END (*T*). and the output from Format with B directives embedded is: (*[B+] BUNCH STATEMENTS. *) PROGRAM T(OUTPUT); CONST INCREMENT = 5; VAR I,J,N:INTEGER; BEGIN N:=0; J:=3; I:=SQR(N); N:=N + INCREMENT; IF N>73 THEN BEGIN DOTHIS; DOTHAT END; (*[B-] UNBUNCH. *) IF N>5 THEN IF J>6 THEN DOSOMETHINGELSE; END (*T*). The E Directive. Suppose that a Pascal program fragment looked like: PROCEDURE SAMPLE; PROCEDURE INNER; BEGIN END; BEGIN IF X=3 THEN BEGIN X := 1; I := I+1 END ELSE BEGIN X := X+I; I := 0 END; WHILE (CH <> 'X') AND FLAG1 DO BEGIN I := I+3; INNER END; END; then using Format with E=3 produces: PROCEDURE SAMPLE; PROCEDURE INNER; BEGIN END (*INNER*); BEGIN (*SAMPLE*) IF X=3 THEN BEGIN X := 1; I := I+1 END (*IF*) ELSE BEGIN X := X+I; I := 0 END (*ELSE*); WHILE (CH <> 'X') AND FLAG1 DO BEGIN I := I+3; INNER END (*WHILE*); END (*SAMPLE*); How Format Works. Format parses your program by performing syntax analysis similar to the Pascal compiler: recursive descent within nested declarations and statements. It gathers characters into a buffer in which the indenting count of each character is maintained. The characters are being continually emptied from the buffer as new ones are added. Format has limited error-recovery facilities, and no results are guaranteed if a syntactically incorrect program is input. The bane of most Pascal prettyprinters is the treatment of comments. Format considers them in the context of a declaration or statement. Therefore using comments like: CONST LS=6 (*LINESIZE*); is a good idea because Format will carry the comment along with the declaration. Similarly: BEGIN (* 'Z' < CH <= ' ' *) is also okay. Stand-alone comments, however, receive rough treatment from Format. The first line of such comments is always left justified and placed on a separate line. See the F directive. Thus: CONST LS=6; (*LINESIZE*) will be reformatted as: CONST LS = 6; (*LINESIZE*) Proper treatment of comments is certainly an area of future development for Format. Error Messages. Format issues the following error messages: 1. " *** 'PROGRAM' EXPECTED." The Pascal program you fed to Format did not contain a Standard Pascal program declaration. 2. " *** ERRORS FOUND IN PASCAL PROGRAM." Your program is syntactically incorrect. The output from Format probably does not contain all of the text from your input file. The cause could be any syntactic error, most commonly unmatched "BEGIN-END" pairs or the lack of semicolons, string quotation marks, or the final period. 3. " *** STRING TOO LONG." Your program contains a character string (including both the quotes) which is wider than the specified write margins (W directive). 4. " *** NO PROGRAM FOUND TO FORMAT." The input file is empty. ======================================================================================== DOCUMENT :usus Folder:VOL06:format.text ======================================================================================== {$S+} { PROGRAM Format THE PASCAL PROGRAM FORMATTER AUTHOR: Michael M. Condict, 1975 Par Corp. 228 Liberty Plaza Rome, NY 13440 UPDATED: Aug 1978, by Rick Marcus & Andy Mickel, then PUBLISHED in Pascal News No. 13 CONVERTED TO UCSD PASCAL, IDENTIFIER CASE-TRANSPARENCY ADDED: Jan 1980 EXTENSIVELY REVISED (SEE ACCOMPANYING DOCUMENTATION): Aug 1980 Jim Gagne 1433 Roscomare Road Los Angeles THIS PROGRAM IS FOR NONCOMMERCIAL USE ONLY. FOR ALL OTHER PURPOSES, FIRST CONTACT MICHAEL CONDICT.} {$IFORMAT.1.TEXT} {FORMAT.1 contains the global declarations & constants initialization sections.} {$IFORMAT.2.TEXT} {FORMAT.2 has the (largely) original text from FORMAT.1 thru WRITESYMBOL.} {$IFORMAT.3.TEXT} {FORMAT.3 is the new menu-driven parameter setting section.} {$IFORMAT.4.TEXT} {FORMAT.4 contains a revised READSYMBOL, including the expanded comment-handling part.} {$IFORMAT.5.TEXT} {FORMAT.5 has the middle portion of the original FORMAT, to DOSTMTLIST.} {$IFORMAT.6.TEXT} {FORMAT.6 wraps up with the rest of DOBLOCK, DOSTATEMENT, etc., with many changes near the end.} ======================================================================================== DOCUMENT :usus Folder:VOL06:hangup.a.text ======================================================================================== ; NOTE THIS IS THE SAME ROUTINE AS USED BY MODEM INIT .PROC HANGUP,0 .PRIVATE RETADDR MCNTRL .EQU 0C3H ;STATUS PORT IDLE .EQU 03FH ;DEFINES IDLE STATE FOR PMMI MODEM POP HL LD (RETADDR),HL LD A,IDLE OUT (MCNTRL),A ;SET MODEM TO IDLE STATE LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:kbstat.a.text ======================================================================================== .FUNC KBSTAT,0 .PRIVATE RETADDR POP HL LD (RETADDR),HL POP HL ;CORRECT STACK POP HL LD HL,RADDR ; RETURN ADDRESS PUSH HL LD HL,(1) LD L,6 JP (HL) RADDR OR A ; SET FLAGS LD HL,1 JP NZ,DONE ;READY LD HL,0 ;FALSE DONE PUSH HL LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:modemini.a.text ======================================================================================== .PROC MODEMINIT,0 .PRIVATE RETADDR MCNTRL .EQU 0C3H ;STATUS PORT IDLE .EQU 03FH ;DEFINES IDLE STATE FOR PMMI MODEM POP HL LD (RETADDR),HL LD A,IDLE OUT (MCNTRL),A ;SET MODEM TO IDLE STATE LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:mread.a.text ======================================================================================== .FUNC MREAD,0 .PRIVATE RETADDR TPORT .EQU 0C0H ;STATUS PORT DPORT .EQU 0C1H ;DATA PORT RECRDY .EQU 02H ;REC BUF FULL POP HL LD (RETADDR),HL ;SAVE RET ADDR POP HL ;CORRECT STACK POP HL ;CORRECT STACK WAIT: IN A,(TPORT) ;READ STATUS WORD AND RECRDY ;IS REC FULL JP Z,WAIT IN A,(DPORT) LD L,A ;STORE FOR RETURN PUSH HL ;RETURN VALUE ON STACK LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:mrecstat.a.text ======================================================================================== .FUNC MRECSTAT,0 .PRIVATE RETADDR TPORT .EQU 0C0H RECRDY .EQU 2H POP HL LD (RETADDR),HL POP HL ;CORRECT STACK POP HL LD HL,1 ;TRUE IN A,(TPORT) ;READ STATUS AND RECRDY ;CHECK READ STATUS JP NZ,DONE ;REC NOT RDY LD HL,0 ;FALSE DONE PUSH HL LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:mwrite.a.text ======================================================================================== .PROC MWRITE,1 .PRIVATE OUTC,RETADDR TSTAT .EQU 0C0H ;STATUS PORT DATA .EQU 0C1H ;DATA PORT TRE .EQU 01H ;XMIT REG EMPTY POP HL LD (RETADDR),HL POP HL LD (OUTC),HL WAIT: IN A,(TSTAT) ;GET STATUS AND TRE ;CK STATUS JP Z,WAIT ;XMIT BUSY LD A,(OUTC) OUT (DATA),A ;SEND DATA LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:ptp-files.text ======================================================================================== The following files make up the Pascal Transfer Program: PTP.TEXT - This the main program written entirely Pascal. PTP.CODE - A compiled but not linked version of the main program PTP.TEXT. PTP.TEXT requires a 56K system to compile therefore this precompiled version can be used as the main program during linking by those with less memory. Be sure not to call the outfile of the linker PTP.CODE or this file will be destroyed. PTPMMI.CODE - A linked version ready to run with a PMMI modem. SYSNAME - A text file that contains the nodes id string (see example). KBSTAT - An assemble language function which return a TRUE if there is a character ready at the keyboard port. Since this routine calls the CP/M keyboard status routine it should work with most system that use the CP/M BIOS. MRECSTAT - An assemble language function which returns TRUE if there is a character ready at the modem receiver port. MREAD - An assemble language function which returns a character from the modem receive port. If no character is ready this routine will wait for one. This routine could be replaced by a read from unit #7 (remote in) if implemeted in your system. MWRITE - An assemble language procedure which writes a character to the modem xmit port. If the line is busy this routine will wait for the line to become ready. This routine could be replaced by a write to unit #7 (remote out) if implemented in your system. MODEMINI - An assemble language routine to initialize the modem at startup. HANGUP - An assemble language routine to hangup the phone (on hook) CTS - Returns TRUE if clear-to-send is set on the modem (may use carrier detect on other modems). Indicates that a connection is established. DTRON - Turns data-terminal-ready on to allow the modem to operate. RINGING - Returns TRUE if the phone is ringing. RI - Set the ring-indicator in the PMMI modem causing the modem to go off-hook in answer mode. SH - Causes the modem to go off-hook in orginate mode. DTONEDET - Returns TRUE if a dial tone is detected. DIALER - Dials one digit of a phone number, digit maybe in either ASCII or binary. BAUD - Set the specified baud rate. The value passed to this assemble language routine must be the value to output to the modem not necessarly the actual baud rate. Baud rate calculations are done in the PASCAL program. ======================================================================================== DOCUMENT :usus Folder:VOL06:ptp-inst.text ======================================================================================== The PTP system is made up of a large Pascal program and 13 small assemble language routines, and one small text file. The large Pascal program should work with most systems and because it requires 56K to compile a precomplied version PTP.CODE has been provided. The text of this file is too large for the L1 editor you may wish to break it into smaller files. With the exception of the routine KBSTAT most of the assemble language will have to modified to work with your system. The current modem routines are intended to work with the PMMI modem, if some of the functions are not available in your system these routines can be replaced with dummies. The routine KBSTAT should work with most system that use CP/M BIOS. After modifing these routines for your system they can be entered into the comm libraries which is then linked with PTP.CODE (be sure to use another name for the output file so as to not destroy this file). If you do not understand the library procedures you can link the program by entering each of the routine names when the linker asks for lib file. PTP.CODE is always used as the host file. The library "system.library" is not used by this program and automatic linking which may occur if you say run after compiling will not work correctly. The file systemname.text should contain the lat/long of your system and your system name. This file can be edited with the standard editor. ======================================================================================== DOCUMENT :usus Folder:VOL06:ptp-use.text ======================================================================================== An Introduction to Using the Pacsal Transfer Program This brief introduction will hopefully provide you with enough information to run PTP. The first question you will be asked after starting PTP is if your system can support binary mode. Inorder to support this your modem (serial port) must be able to pass any 8-bit byte to the PTP program (most home systems can do this - most time sharing systems can not). Binary mode always considerably fast transfer and should be used if possible. The next questions select valid speeds at which your modem can operate. Simply answer yes to the valid baud rates. To support mulitple baud rates your modem baud rate must be software settable with the baud assembly language routine, if is not answer yes only to the 300 baud rate which will keep the baud rate at its inital value. Because the program uses a split baud rate for transmit and receive during baud rate negotiation it is not possible to switch baud rates manually. Next the number of data characters that can be sent and received in one packet is requested. The actual packet maybe considerable larger due to packet overhead. The larger the packet the more likely a transmission error will occur. The answer or orginate mode of the program must be different for two communciating programs. This is set to orginate mode when you dial a number and to answer when you go into an answer mode. The mode of the modem is set to the same mode as the program. The top level menu varies depending upon if a carrier is detect. In the case there is no carrier the menu is as followed: Autoans - Wait for the phone to ring, answer in answer mode and establish a connection. Typing any character will abort this mode. Cntdial - Continously redial the number after a delay in an attempt to establish a connection. Dial - Dial the number to be supplied. Do not use in spaces or other characters inbetween digits. A "*" should cause the dialer to wait for another dial tone detect (not tested). Typing any character will interrupt this function. Exit - Exit the PTP program. Go - Used to continue when a modem connection is already established. Hangup - Hangup the phone. Options - Go to the options menu (see below). Redial - Redial the number last dialed. Unattended - Same as autoanswer except that the program will go back into the autoanswer mode at the end of a connection to wait for the next call. Typing any character will exit this mode. If a carrier is present the top level menu will be a subset of the above. The "go" command in this case causes the modems to attempt to establish a connection (usefully when you have been using voice and now wish to connect the programs without having to hangup). The options menu allows the following options to be set: PTP - Set the PTP mode which is what the program is all about. Mode- Allows the resetting of the modes and baud rates setup when the program was started. This will result in the renegotion of the mode and baud rates with the other computer. Trace- Set the tracing flags used for debugging. Also used to set the local loopback mode (see trace below). Raw - This puts you in a raw terminal mode in which makes the system look like a terminal and is intented mainly to allow logging into timesharing systems. Type a control-E to exit this mode. Baud- Set the baud rate to be used in raw mode. Fullduplex - Set full duplex raw mode. Halfduplex - Set half duplex raw mode. If you have made contact with another PTP both programs should now be in a loop sending empty packets back and forth. The first thing you will see after a connection is established is the id of the other program. After this the programs will negotate binary or radix-41 mode, the baud rate and buffer sizes. At this point you may try to send a terminal to terminal message. To do this type the first character of the message and wait for a ">" follwed by the character you typed. Type the rest of the message and hit return (if the message is to long echoing will stop and the first part will be sent). The message will then be sent to the other PTP. It should be realised that whenever a PTP program is waiting for a character from the keyboard it will not be listening or sending on the modem line. This will cause the PTP on the other end to timeout while waiting for a transmission and display a receiver timeout message. If this were to continue for a long time the PTP on the other end would finally give up and abort. Also even after you finish typing your message it may take several transmissions for the programs to get their half duplex transmissions resynced (both programs may be sending at the same time and miss part of the other's transmission). This condition should correct itself shortly since the timeout for answer and orginate modes are different. To send files or perform other functions it is first necessary to get the attention of the PTP, to do this type a control-E and wait. A menu should be displayed shortly simlar to the type displayed by the UCSD Pascal system. It should be remebered that when the program is in this mode it is the other PTP will be experiencing receiver timeouts. To exit the menu function and return control to PTP just hit a carriage return to the menu display. The following is a description of the current menu functions: Get - Get a file from the other system. It should be noted that you must already know the name of the file you wish transfered and there is no remote list directory function. For this reason it would be a good idea if each system contained a file with the well know name "dir.text" which contains the name of the files which that person is willing to have transfered. Send - Send a file from your system to the other system. The PTP program will not create a file on a system if it already exists. This is to prevent overwriting files on the other system which you did not know existed. Init - This function will reinitialize most of the counters in the program. If you are in contact with another PTP this will result in a loss of sequencing. Exit - Will cause PTP to terminate and return to the top menu level. Mode- See mode above. Trace- See trace below. Trace allows you to control various trace and other options as described below: Trace LTB - Trace the link transmission blocks. This trace dumps the variously encoded forms of all transmissions sent and received. It is helpful in gaining an understanding of how the program works but does a lot of data and must be used with CRT type terminal. Trace PPS - Trace the process to process stream functions. In general this trace is not very helpful unless you already know what you are looking for. Trace FTP - Trace the file transfer functions and data. Local loopback test - This puts the program in a mode where it talks to itself and can be very useful in testing the program especially when combined with the LTB trace. You should try this mode before attempting to use this program with another PTP to see if the program will run on your system. Because of the low baud rates that our modems use and the encoding done in the PCNET format the transmission of files will be very slow, however, the transfered file should contain no transmission errors and any type of file including binary can be transfered. In addition files can be transfered in both directions at the same time and the terminal to terminal mode can still be used. Inorder to give you some assurance that the program is running a dot will be printed when an packet is received. Be sure you are in PTP mode when you wish to transfer files. Best of luck and please contact me with errors, questions, or suggestions you may have. Mark Gang 408-267-4913 ======================================================================================== DOCUMENT :usus Folder:VOL06:ptp.bush.text ======================================================================================== {$S+} {$G+} {||| $R-} {***************************************************************} { } { PTP } { } { PASCAL TRANSFER PROGRAM } { } { } { (C) COPYRIGHT 1979 J. MARK GANG } { } { } { PERMISSION GRANTED FOR NON-COMMERCIAL USE BY INDIVIDUALS. } { ALL OTHER RIGHTS RESERVED. } { } { HISTORY: } (* 05-Oct-80 turn off iochecking around disk writes 05-Oct-80 uattended lets estconnection do call to progstart 05-Oct-80 timeouts halved {9k,6k}, autoans clears modem when through 04-Oct-80 close files in modemmenu 03-Oct-80 disk writes verified 03-Oct-80 wln adjustments, prompt info and ans/org options 03-Oct-80 init modemmode with mynode in init 02-Oct-80 tell duplexity 02-Oct-80 timeouts * 10 {30000 & 20000} 02-Oct-80 DotCount rather than .......................... 01-Oct-80 originate_wait_time to 60 secs from 20 30-Sep-80 preset baudrates and reclengths 30-Sep-80 only test Ringing once for uarts who tell and forget 30-Sep-80 Wait for Carrier from 200 to 20 secs 25-Sep-80 Delay Timer set to 1166 for uEngine for .1sec. 25-Sep-80 ModemMode to Org if loopback mode 25-Sep-80 Scan loop terminates on < also for recd ltb 25-Sep-80 GenCkSum fix Val Rge Err 24-Sep-80 m41wd41 brought over from old 24-Sep-80 IO.DCL include 24-Sep-80 Range check inhibit localization started 24-Sep-80 titling, logs version etc. *) { VERSION 1.0 JULY 1979 } { VERSION 1.1 NOV 1979 PMMI MODEM CONTROL } { VERSION 1.2 MAR 1980 LINK MODE CONTROL } { } {***************************************************************} {Note 1: In several places in this program it was necessary to set the length of a string. The length is held in byte 0 of the string. In order to assign to this byte it is necessary that range checking be turned of. |xjm$ver|nx|f8|ejm$profile|n|n|*|f1|. |. } program ptp (); const {|||} title = 'PTP {Pascal Transfer Program} by J M Gang / Volition Systems, Inc.'; version = ' uEngine Version of 05-Oct-80'; LOR = 160; STO = 196; {|||} TIMER = {|||28 |||} 1166; {adjust to .1 second for DELAY} (*||| Vol Sys Mod ANSTIMEOUT = 3000; {receiver timeout } ORGTIMEOUT = 2000; {a different timeout for org mode} |||*) AnsTimeOut = 9000; {receiver timeout } OrgTimeOut = 6000; {a different timeout for org mode} (*|||*) ATTENCHAR=05; {^E - used to get to menu} BLKSZ = 512; {disk block size} PPSBUFSZ = 130; {size of pps data buffers} MAXLTBSZ= 271; {size of the LTB buffer} MAXDATASZ = 128; {max amount of unencoded data in LTB blocks} MAXREXMIT = 16; {maximum number of retransmit attempts} MAXDUPSEQ = 5; {max allowed dup seq before correction} LTBHDLEN = 2; {length of the LTB header} ESC = 27; {escape} LF = 10; {line feed} CR = 13; {carriage return} NULLPPS = 255; {indicates invalid pps} {process numbers} CTRL = 0; {process number of control process} LSTNER=1; {process number of file xfer listener} FTPREC = 2; {process number of file xfer receiver} FTPSND = 3; {process number of file xfer sender} TERM = 4; {process number of terminal hanndler} GETFILE = 5; {process number of remote file requester} SINK = 6; {dummy process to dump unwamted input} MAXPROCESS = 6; {maximum process number} MAXPPS = 9 {MAXPROCESS+3}; {maximum process to process streams allows for a few 2 stream processes} {control messages codes} IWN = 0; {I won't} PDN = 64; {Please don't - hex 40} IW = 128; {I will - hex 80} PD = 192; {Please do - hex C0} SF = 17; {send file - hex 11} RF = 18; {receive file - hex 12} AF = 19; {accept file - hex 13} PROTO = 22; {sending valid modes} GOPROTO = 23; {go to following modes} PDPROTO = 214; {PD + PROTO} PDGOPROTO = 215; {PD + GOPROTO} IWPROTO = 150; {IW + PROTO (returns common vaild modes)} IWGOPROTO = 151; {IW + GOPROTO (have gone to common modes)} type seqno=0..7; bytesz=0..255; iam= (ORG, ANS); exception = (EMPTY, FULL, LAST, OK, ERROR); {status of PPS buffer} controlState = (SNDSYSNAME, REQPROTO, CIDLE);{state of control process} ftpState = (idle, initiate, request, send, terminate, ack, localabort); {state of ftp process} fileLength = ARRAY [0:2] of integer; {holds length of file to be transfered in bits low byte first} pSelect = (PT, {PTP mode} RT); {raw terminal mode} coroutine = (rltb, xltb, done); blk= packed array [0..511] of char; {disk block buffer} word = packed record case integer of {address word as int or two char} 0: (intval: integer); 1: (byteval: packed record hibyte, lobyte : char; end); end; byte = packed record case char of 'a':(hdr: packed record {LTB header format} oob: seqno; seq: seqno; esc: 0..1; oa : iam; end); 'b':(ppsh: packed record {PPS header format} seq: seqno; fil: seqno; lst: boolean; fst: boolean; end); 'c':(bte:bytesz); 'd':(ch: char); 'e':(op: packed record {control character format} msg: 0..63; flavor: 0..3; end); 'f':(md: packed record {LTB and hardware modes} bin: boolean; {binary mode vs r41} full: boolean; {full duplex vs half} res: 0:63; {reserved for future use} end); 'g':(bd: packed record {defines baud rates} b110: boolean; b150: boolean; b300: boolean; b450: boolean; b600: boolean; b1200: boolean; b2400: boolean; b4800: boolean; end); end; ltbarray = packed array [0..MAXLTBSZ] of byte; {LTB buffer} datarray = packed array [0..MAXDATASZ] of byte; {send data buffer} pps = packed record {PPS header record format} ppsnum:bytesz; pseq:seqno; active:boolean; err: boolean; fstblk:boolean; lstblk:boolean; srcproc:bytesz; destproc:bytesz; fstptr: integer; nxtptr: integer; buf: packed array [0:PPSBUFSZ] of char; end; ppsarray = packed array [0..MAXPPS] of pps; {PPS table} {---------------- GLOBALS ------------------------------------------} var c:char; acr: string[1]; {a carriage return} {-- TEST --} ppsmon:boolean; {indicates PPS tracing is on} ftpmon:boolean; {indicates ftp tracing is on} loopbk:boolean; {internal loop back for debugging} trace:boolean; {LTB tracing} serbuf:array[0..256] of char; {loopback buffer} serptr:integer; {loopback buffer pointer} {-- SCHEDULING/SEQUENCE/FLOW --} mynode:iam; {indicates sex of this site during a connection} i:integer; {answer delay counter} timeout: integer; {holds timeout constant} ansbrkt,orgbrkt:char; {hold answer and orignate break characters} xmtgen:seqno; {seq no for next LTB generated} rcvoob:seqno; {old block not yet received } xmtoob:seqno; {oldest LTB not yet acked by other end} sch:coroutine; {next LTB process to be run} {---- LTB GENERAL ---} vMode: byte; {vaild modes for this node} vBaud: byte; {vaild bauds for this node} cMode: byte; {current mode for this node} cBaud: byte; {current baud for this node} {---- LTB XMIT ---} xmitBinary: boolean; {LTB xmit is using pure binary mode } xmitFull: boolean; {full duplex (not implemented)} xmitBaud: integer; {baud rate for transmitting} r41:string; {holds r41 character set} rmtRecDataSz: integer; {max data remote will accept} maxXmitDataSz: integer; {max data to send in one LTB} xmitDataSz: integer; {max amoutn data to send in one LTB} rexmtcnt:integer; {number of consetive rexmits attempted} xbuf: ltbarray; {LTB xmit buffers} xdataptr,xlen: integer; {LTB xmit buffer pointers} {-- LTB REC --} recDataSz: integer; {max data to receive in one LTB} recEscSet: boolean; {binary mode last char was escape} recBinary: boolean; {LTB rec is using pure binary mode } recFull: boolean; recBaud:integer; {baud rate for receiving} turncnt: integer; atcnt:integer; {-- PPS --} rppstbl: ppsarray; {receive PPS table} xppstbl: ppsarray; {xmit PPS table} lstOpenPPS: integer; { last xmit PPS which was opened } pollpps:bytesz; {next process to be polled by PPS xmitter} ctrLock: boolean; {send only control messages} {-- CTRL --} ctrlInPPS: integer; {incomming PPS stream number} ctrlInSlot: integer; {incomming PPS slot number} ctrlState: controlState; {state of control process} ctrlOtPPS:integer; {hold control process PPS number (always 0)} ctrlReply: array [0:2] of byte; {holds msg to be sent to remote} ctrlMsgLen: integer; {length of ctrl msg to send to remote} ctrlRequestCnt: integer; {number of request to send} {--- TERMINAL---} termppsno:bytesz; {holds terminal handler PPS number} termInPPS: integer; {incomming PPS stream number} termInSlot: integer; {incomming PPS slot number} termot: integer; {out going PPS stream number} fstKbCh: char; {first char of terminal string} kbInterrupt: boolean; {keyboard interrupt set} {-- FTP XMITTER --} xfile:file; {fileid of file to be xmitted} xfilptr:integer; {xmit file pointer} xblk:blk; {number of blocks xmitted} xbufptr:integer; {pointer into xmit data buffer} xname:string; {name of file to be xmitted} destname:string; {destination name of file being xmitted} xeof:boolean; {xmit file EOF flag} fSndOtPPS: integer; {out going PPS stream number} fSndInPPS: integer; {incomming PPS stream number} fSndInSlot:integer; {incomming PPS slot number} xfiletype:bytesz; {indicates type of file being xfered (not version 1.0)} xfilesize:word; {indicates size of file to be xfered (not version 1.0)} fsndstate: ftpState; {FTP sender state} fsndcode:bytesz; {holds control to be sent} {---- LISTENER ------} lsnrInSlot: integer; {listner incomming slot numner} lsnrInPPS: integer; {listner incomming stream numner} lsnrOtPPS: integer; {listner out going stream number} {---- FTP RECEIVER ----} rfile:file; {ftp receive file fileid} rfilptr:integer; {receive file block pointer} rblk:blk; {receive buffer} rbufptr:integer; {receive buffer pointer} rname:string; {receive file name} rck0, rck1:integer; {checksums} srcname:string; {name of file at sending end} receiving:boolean; {indicates ftp receiver is active} lastc: byte; { holds last character received } firstChar: boolean; {first char of incomming stream} fRecInSlot: integer; {incomming slot number} fRecInPPS: integer; {incomming PPS stream number} fRecOtPPS: integer; {out going PPS stream number} {--- GET FILE ---} getstr:string; {name of remote file to be gotten} {---- RAW TERMINAL ----} halfduplex: boolean; {raw terminal half duplex else full} {--- MENU --- } menuexit:boolean; {flag to indicate to exit the menu} {---- MODEM CONTROL-----} currentBaud: integer; {current rate before computation} baudrate: integer; {baud rate } telnum: string; {telphone number } modemMode: iam; {ans/org mode of modem } progSelect: pSelect; {current program selected} unattended: boolean; {indicates unatteneded mode in use} {|||} DotCount : INTEGER; {$I UTIL_5:IO.DCL.TEXT } {|||} {------------------------- FORWARD DECLARATIONS -------------------------} procedure ltbinit; forward; procedure sched; forward; procedure xpps; forward; procedure rpps (var rbuf:ltbarray; var rstrt:integer; var rcnt:integer); forward; function frecstart(inSlot: integer):boolean; forward; function rmtsndstart(inSlot: integer):boolean; forward; procedure pollProcesses; forward; procedure pCtrl; forward; procedure pSinker; forward; procedure pListner; forward; procedure pFtpSnd; forward; procedure pFtpRec; forward; procedure pTerm; forward; procedure pGetFtp; forward; procedure menu; forward; procedure init; forward; procedure initState; forward; procedure setBaud (rate: integer); forward; procedure changeBaud (rate: integer); forward; (*||| REPLACED UNITS WITH ONE BIG INCLUDE ||| {--- external functions ----} function mread:char; external; { returns char from modem rec } function kbstat: boolean; external; { returns true if keyboard char rdy} function mrecstat: boolean; external; { returns true if modem rec char rdy} function ringing: boolean; external; { returns true if phone is ringing } function cts: boolean; external; { returns true if modem clear to send set} function dtonedet: boolean; external; { returns true if dial tone present } {--- external procedures ----} procedure mwrite(c:char); external; { write char to modem xmitter } procedure modemInit; external; { performs modem initialization } procedure hangup; external; { hangup phone - go on hook } procedure ri; external; { go off hook in answer mode } procedure baud; external; { set modem baud rate } procedure dtron; external; { set data terminal ready } procedure dialer (c: char); external; { dial a digit } procedure sh; external; { go off hook in orginate mode } |||*) {$I UTIL_5:IO.PKG.TEXT } {|||} {----------------- GENERAL ----------------------------------------------} procedure delay (ticks: integer); {purpose: delay .1 seconds for each tick } var i: integer; begin while ticks > 0 do begin i := timer; while i > 0 do i := i-1; ticks := ticks -1; end; end; procedure byteprint (c: char); {purpose: Print characters use decimal when not a printing character} var w: word; begin if (ord(c) < 32) or (ord(c) > 126) then begin w.byteval.lobyte := c; w.byteval.hibyte := chr(0); write ('<',w.intval,'>') end else write (c); end; {-------------------- LTB RECEIVER SECTION --------------------------------} procedure getserial(var x:byte); {purpose : Get a character for the LTB receiver from either the loopback buffer or the serial line - if no character arrives on the serial line by TIMEOUT return a turnaround character } var i:integer; begin if loopbk then begin x.ch := serbuf[serptr]; if trace then byteprint (x.ch); serptr := serptr +1; end else begin i:=0; while (i<>timeout) and (not mrecstat) do i := i+1; if i=timeout then begin if trace then writeln ('RECEIVER TIMEOUT'); if mynode = ORG then x.ch:=ansbrkt else x.ch:=orgbrkt; end else begin x.ch := mread ; {if r41 mode clear high order bit} if not recBinary and (x.bte > 127) then x.bte := x.bte - 128; if trace then byteprint (x.ch); end; end; end; procedure m41wd1 (var buf:ltbarray; var len:integer); {purpose: Convert 3 bytes of mod 41 to 2 bytes of binary repeat thur entire buffer, output is placed back in source buffer, length is set to the length of the converted form. } {||| rb and rhk thought of this hairy one w/o overflow |||} var i,j:integer; tmp:word; K : INTEGER; K_0 : INTEGER; K_1 : INTEGER; begin j:=0; i:=0; while j < len do begin K := Buf[J+1].Bte + Buf[J+2].Bte * 41 ; K_0 := K * 1 + Buf[J].Bte ; K_1 := K * 10 ; IF ( (((MAXINT - K_1) - K_1) - K_1) - K_1 ) > K_0 THEN Tmp.IntVal := K_0 + 4 * K_1 ELSE BEGIN K := ((K_0 + 2 * (K_1 - 16384)) + K_1) + K_1 ; PMACHINE (^Tmp.IntVal, (K), (-MAXINT-1), LOR, STO) END; buf[i].ch := tmp.byteval.lobyte; buf[i+1].ch := tmp.byteval.hibyte; j:= j+3; i:= i+2; end; len := i; end; procedure r41m41(var c:byte); {purpose: Converts a character from radix 41 character set to mod 41} var cv:integer; begin if c.ch = '(' then cv := 0 else if (c.bte > 47) and (c.bte < 58) then {'0' to '9'} cv := c.bte - 47 else if (c.bte > 64) and (c.bte < 91) then {'A' to 'Z'} cv := c.bte - 54 else if c.ch = '*' then cv := 37 else if c.ch = '+' then cv := 38 else if c.ch = '-' then cv := 39 else if c.ch = ')' then cv := 40 else cv := 41; {invalid character} c.bte := cv; end; function spCharChk (x: byte; rcnt: integer): boolean; begin spCharChk := TRUE; if recEscSet then begin spCharChk := FALSE; recEscSet := FALSE; end else begin if x.ch = '@' then begin if turncnt < 3 then turncnt := turncnt+1; if (rcnt = 0) and (atcnt > 0) then atcnt := atcnt -1; if rcnt <> 0 then atcnt := 1; {stop after first data block} end else if ((x.ch=ansbrkt) and (mynode=ORG)) or ((x.ch=orgbrkt) and (mynode=ANS)) then turncnt:=turncnt-1 else if recBinary and (x.bte = ESC) then recEscSet := TRUE else spCharChk := FALSE; end; end; procedure hdxscanner (var rbuf:ltbarray; var rcnt:integer); {purpose: Pack incomming stream into LTB packets. Expects one packet per transmission. } var x:byte; specChar: boolean; begin if trace then begin writeln; write ('LTB REC ='); writeln; end; atcnt := 3; turncnt:=3; rcnt := 0; repeat getserial(x); {get character from serial line} specChar := spCharChk (x, rcnt); if not specChar then if (rcnt < MAXLTBSZ) and (atcnt = 0) then begin if not recBinary then begin r41m41(x); if x.bte<>41 then {valid char} begin rbuf[rcnt] := x; rcnt := rcnt+1; end end else {is binary} begin rbuf[rcnt] := x; rcnt := rcnt+1; if odd(rcnt) then {compute binary checksum} rck0 := rck0 + x.bte else rck1 := rck1 + x.bte; end end else {block has not begun } if atcnt < 3 then atcnt := atcnt+1; until turncnt=0; end; function ckcksum (rbuf:ltbarray; rcnt:integer) : boolean; {purpose: Check checksum of an incomming LTB packet} var i:integer; begin i:=0; while i < rcnt do begin rck0 := rck0 + rbuf[i].bte; i:=i+1; rck1 := rck1 + rbuf[i].bte; i := i+1; end; rck0 := rck0 mod 256; rck1 := rck1 mod 256; if (rck0 <> 0) or (rck1 <> 0) then begin writeln ('ck0=',rck0,' ck1=',rck1); ckcksum := false end else ckcksum := true; end; procedure ltbframer; {purpose: Checks validity of incomming LTB packet. Updates sequence numbers as needed. Check to see if a character has been typed on the keyboard before returning to the LTB xmitter. } label 1; var rbuf:ltbarray; rstrt, rcnt,i:integer; c:char; begin if recBaud <> currentBaud then changeBaud (recBaud); rck0 := 0; rck1 := 0; {clear checksums} hdxscanner (rbuf, rcnt); if rcnt >= MAXLTBSZ then begin writeln; writeln ('REC ERROR - LTB TOO LONG'); goto 1; end; if not recBinary then begin if (rcnt mod 3) <> 0 then begin writeln; writeln ('REC ERROR - NOT MULTIPLE OF THREE RADIX-41 CHARACTERS'); goto 1; end; m41wd1 (rbuf, rcnt); {convert 3 byte m41 to 2 binary} end; if rcnt < 4 then begin writeln; writeln ('REC ERROR - TIMEOUT OR LTB TOO SHORT.'); goto 1; end; if not recBinary then if ckcksum (rbuf, rcnt) = FALSE then begin writeln ('REC ERROR - RECEIVE CHECKSUM'); goto 1; end else begin rck0 := rck0 mod 256; rck1 := rck1 mod 256; if (rck0 <> 0) or (rck1 <> 0) then begin writeln ('ck0=',rck0,' ck1=',rck1); writeln ('REC ERROR - RECEIVE CHECKSUM'); goto 1; end; end; if odd(rbuf[1].bte) and (rbuf[rcnt-1].bte = 0) then rcnt:=rcnt-1; rcnt:=rcnt-2; {delete checksum bytes} if trace then begin writeln; writeln ('RECEIVED ',rcnt,' BYTES'); end; if rcnt <> rbuf[1].bte then {lengths not equal} begin writeln; writeln ('REC ERROR - LTB LENGTH CHECK ERROR'); goto 1; end; with rbuf[0], hdr do begin if (oa = mynode) and not loopbk or (oa <> mynode) and loopbk then begin writeln; writeln ('REC ERROR - LTB O/A MODE INCORRECT.'); goto 1; end; if esc = 1 then {should always be zero} begin writeln; writeln ('REC ERROR - PROTOCOL ESCAPE NON ZERO.'); goto 1; end; if loopbk then xmtoob := (seq+1) mod 8 else xmtoob:= oob; if seq = rcvoob-1 then begin writeln; writeln ('REC ERROR - DUPLICATE SEQUENCE RECEIVED.'); goto 1; end; if seq <> rcvoob then begin writeln; writeln ('UNEXPECTED SEQUENCE NUMBER RECEIVED.'); writeln; writeln ('REINITIALIZING PTP'); ltbinit; goto 1; end else rcvoob:=(rcvoob+1) mod 8; rstrt := LTBHDLEN; end; {if length less than or equal to LTBHDLEN then no data in this LTB} {||| Vol Sys Mod |||} DotCount := (DotCount+1) MOD (10000); IF (DotCount MOD 50) = 0 THEN BEGIN WRITELN; WRITE ('[', DotCount:4, ']') END; {|||} write ('.'); if rcnt > LTBHDLEN then rpps (rbuf, rstrt, rcnt); 1: if sch<>done then sch := xltb; end; {--------------- LTB XMITTER SECTION ----------------------------} procedure mkhdr(var buf:ltbarray; length:integer); {purpose: Create LTB header for packet to sent} begin with buf[0] do begin hdr.oob := rcvoob; hdr.seq := (xmtgen+7) mod 8; hdr.esc := 0; hdr.oa := mynode; end; buf[1].bte := length; end; procedure gencksum( var buf:ltbarray; var len:integer ); {purpose: Generate checksum for LTB packet to be sent} var ck0,ck1,i:integer; begin ck0 := 0; ck1 := 0; i := 0; len := buf[1].bte; buf[len].bte := 0; while i < len do begin ck0 := ck0+ buf[i].bte; i := i+1; ck1 := ck1 + buf[i].bte; i := i+1; end; {||| buf[len+(len mod 2)].bte := (-ck0) mod 256; buf[len+((len + 1) mod 2)].bte := (-ck1) mod 256; |||} buf[len+(len mod 2)].ch := chr( 256 - (ck0 mod 256) ); buf[len+((len + 1) mod 2)].ch := chr( 256 - (ck1 mod 256) ); {|||} len := len + 2; if odd(len) then begin buf[len].bte := 0; len := len + 1; end; end; procedure putserial( c:char ); {purpose: Put a character out to either the loopback buffer or the the serial line } begin if loopbk then begin serbuf[serptr] := c; serptr := serptr+1; end else begin mwrite(c); end; if trace then byteprint(c); end; procedure binm41(c1, c2: char); {purpose: Convert incomming buffer from binary to mod 41 and place in output buffer} var k, dtmp:integer; wd, tmp:word; c: char; begin wd.byteval.lobyte := c1; wd.byteval.hibyte := c2; for k:=0 to 2 do begin if wd.intval < 0 then {correct for overflow problem} begin tmp.byteval.lobyte := wd.byteval.hibyte; tmp.byteval.hibyte := chr (0); dtmp := (tmp.intval div 41)*256; tmp.intval := tmp.intval mod 41; wd.byteval.hibyte := tmp.byteval.lobyte; end else dtmp := 0; c := r41[(wd.intval mod 41) + 1 ]; putserial (c); wd.intval := (wd.intval div 41) + dtmp; end; end; procedure binExpand (c: char); {purpose: Place escape character in front of special characters when they are not special and send cahracter} begin if c in [chr(ESC), '@', ']', '[' ] then putserial (chr(ESC)); putserial (c); end; procedure endxmit; {purpose: Send turnaround characters.} var i:integer; begin putserial( '@' ); for i:=1 to 5 do begin if mynode = ANS then putserial ('[') else putserial (']'); end; putserial (chr(CR)); end; procedure xmitblk( buf:ltbarray; len:integer); {purpose: Send the LTB buffer.} var i:integer; begin for i:=1 to 6 do putserial( '@' ); if xmitBinary then begin for i:=0 to len-1 do binExpand (xbuf[i].ch); {expand escape char} end else begin i:=0; while i < len-1 do begin binm41(xbuf[i].ch, xbuf[i+1].ch); i:=i+2; end; end; endxmit; end; procedure ltbsend; {purpose: Create an LTB packet containing the data, send it} var i:integer; begin if trace then begin writeln; writeln ('XMIT ',xdataptr,' BYTES'); end; xlen := xdataptr; mkhdr (xbuf, xlen); {update header info} gencksum (xbuf, xlen); {generate checksum, return total length} if trace then begin writeln; for i:=0 to xlen-1 do byteprint (xbuf[i].ch); writeln; end; xmitblk(xbuf,xlen); {transmit} end; procedure xmitltb; {purpose: Determine if the previous packet must be retransmitted or if a new packet can be sent. In the case of excessive retransmission attempts aborts the program. } begin if xmitBaud <> currentBaud then changeBaud (xmitBaud); if rexmtcnt >= MAXREXMIT then begin writeln; writeln ('EXCESSIVE RETRANSMISSION ATTEMPTS -- CONNECTION ABORTED'); sch := done; end else begin if xmtoob = xmtgen then begin xdataptr := 2; xpps; rexmtcnt := 0; xmtgen := (xmtgen+1) mod 8; {increment seq number} end else begin rexmtcnt := rexmtcnt+1; end; ltbsend; end; if sch<>done then sch := rltb; end; {----------- LTB GENERAL ------------------------------------} procedure sched; {purpose: Low level dispatcher for the LTB receiver and transmitter.} var ch: array [0..0] of char; begin {|||} DotCount := 0; {|||} repeat if (not cts) and (not loopbk) then begin writeln ('CARRIER LOST'); initState; sch := done end; if kbstat then begin unitread (2,ch[0],1,0,0); if ch[0] = chr(ATTENCHAR) then menu else begin fstKbCh := ch[0]; kbInterrupt := TRUE; end; end; serptr := 0; case sch of {the heart of the system} xltb:xmitltb; rltb:ltbframer; end; until sch=done; end; procedure ltbinit; {purpose: Initialize LTB values at startup.} begin { Define radix 41 character set. } r41 := '(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ*+-)'; xmtgen := 0; rcvoob := 0; xmtoob := 0; rexmtcnt := 0; serptr:=0; if loopbk then sch := xltb else sch := rltb; end; procedure modeInit; begin xmitBinary := FALSE; recBinary := FALSE; recEscSet := FALSE; xmitDataSz := 64; recBaud := 300; xmitBaud := 300; end; {-------------------- PPS TRANSMIT --------------------------} procedure ppsinit; {purpose:Initialize PPS tables at startup.} var i:integer; begin for i:= 0 to MAXPPS do begin with xppstbl[i] do begin active := FALSE; ppsnum := i; err := FALSE; end; with rppstbl[i] do begin active := FALSE; ppsnum := i; err := FALSE; end; end; lstOpenPPS := 0; pollpps:=0; end; procedure ppsopen (src, dest:integer; var ppsno:bytesz); {purpose: Open a new xmit PPS, enter the source and the destination process numbers in the xmit PPS table. The number of the PPS that is opened is returned to the caller. } begin ppsno := lstOpenPPS; repeat ppsno := (ppsno+1) mod MAXPPS; until not xppstbl[ppsno].active or (ppsno = lstOpenPPS); if xppstbl[ppsno].active then begin writeln; writeln('PPS xmit table full'); end else begin lstOpenPPS := ppsno; with xppstbl[ppsno] do begin active := TRUE; err := FALSE; srcproc := src; destproc := dest; pseq := 0; fstblk := TRUE; lstblk := FALSE; fstptr := 0; nxtptr := 0; if ppsmon then begin writeln; writeln ('Opening xmit PPS ',ppsno,' source ',src, ' destination ',dest); end; end; end; end; procedure ppsclose (ppsno:bytesz); {purpose: Close the specified xmit PPS number. Note: One more transmission (last block) will occur on this stream. } begin if xppstbl[ppsno].active = FALSE then begin if ppsmon then begin writeln; writeln ('Request to close inactive xmit PPS ',ppsno); end end else begin xppstbl[ppsno].lstblk := TRUE; if ppsmon then begin writeln; writeln ('Closing xmit PPS ',ppsno); end; end; end; procedure mkpps (ppsno:integer); {purpose: Build the PPS } var orglen:integer; begin orglen := xdataptr; with xppstbl[ppsno] do begin if ppsmon then begin writeln; write ('Sending PPS ',ppsno,' seq no ',pseq); if fstblk then write(' - first block'); end; { pps header } with xbuf[xdataptr] do begin ppsh.fst := fstblk; ppsh.lst := FALSE; ppsh.fil := 0; {zero filler} ppsh.seq := pseq; end; pseq := (pseq +1) mod 8; xbuf[xdataptr+1].bte := ppsno; if fstblk then begin xbuf[xdataptr+3].bte := srcproc; xbuf[xdataptr+4].bte := destproc; xdataptr := xdataptr+5; fstblk := FALSE; end else begin xdataptr := xdataptr+3; end; {move data to pps} while (fstptr <> nxtptr) and (xdataptr-orglen < xmitDataSz) do begin xbuf[xdataptr].ch := buf[fstptr]; xdataptr := xdataptr+1; fstptr := fstptr+1; if fstptr = PPSBUFSZ then fstptr := 0; end; xbuf[orglen+2].bte := xdataptr-orglen; if ppsmon then write (' - length ',(xdataptr-orglen)); {if last block and no more data to send} if lstblk and (fstptr = nxtptr) then begin active := FALSE; lstblk := FALSE; xbuf[orglen].ppsh.lst := TRUE; if ppsmon then write (' - last block'); end; end {with}; if ppsmon then writeln; end; procedure xpps; {purpose: Search for an acitive pps with something to send} var dlen:integer; ppsno:bytesz; done: boolean; begin { to simulate multiple processes we poll the process procedures here} pollProcesses; done := FALSE; ppsno:= pollpps; {Continue from last poll + 1} repeat {poll sending processes for out going} with xppstbl[ppsno] do begin if active then if (fstptr<>nxtptr) or fstblk or lstblk then if not ctrLock then begin mkpps (ppsno); done := TRUE; end else if srcproc = CTRL then begin mkpps (ppsno); ctrLock := FALSE; if ppsmon then writeln ('PPS control lock reset'); done := TRUE; end; end; ppsno := (ppsno +1)mod MAXPPS; until (ppsno = pollpps) or done; pollpps := ppsno; end; function statusOtPPS (ppsNum: integer): exception; var tmp: integer; begin statusOtPPS := ERROR; if ppsNum <= MAXPPS then begin with xppstbl[ppsNum] do begin if active and not err then begin if lstblk then statusOtPPS := LAST else begin tmp := nxtptr+1; if tmp = PPSBUFSZ then tmp := 0; if tmp <> fstptr then statusOtPPS := OK else statusOtPPS := FULL; end; end; end; end; end; function ppsWrite (ppsNum: integer; c: char): exception; var tmp: integer; begin {there are several checks that should be made here they are not done in this version for efficiency reasons} ppsWrite := ERROR; with xppstbl[ppsNum] do begin tmp := nxtptr+1; if tmp = PPSBUFSZ then tmp := 0; if tmp <> fstptr then begin buf[nxtptr] := c; if ppsmon then byteprint (c); nxtptr := tmp; tmp := nxtptr+1; if tmp = PPSBUFSZ then tmp := 0; if tmp = fstptr then begin ppsWrite := FULL; if ppsmon then writeln ('FULL'); end else ppsWrite := OK; end end end; {--------- PPS RECEIVER ---------------} procedure findRecPPS (dest, fstEntry: integer; VAR slot: integer; VAR ppsNo: integer); {purpose: find any incomming streams to the specified destanation starting at the specified slot. Returns slot and PPS number if found, NULLPPS otherwise} var i: integer; done: boolean; begin done := FALSE; ppsNo := NULLPPS; if fstEntry <= MAXPPS then begin i := fstEntry; repeat if (rppstbl[i].destproc = dest) and (rppstbl[i].active) then begin slot := i; ppsNo := rppstbl[i].ppsnum; done := TRUE; end; i := i+1; until (i > MAXPPS) or done; end; if ftpmon and (ppsNo <> NULLPPS) then writeln (' Found destination ', dest, ' ppsNo ', ppsNo, ' in slot ', slot); end; procedure rpps; {purpose: Check incomming PPS packets and place in buffer} label 1; var ppsno:bytesz; index: integer; begin ppsno := rbuf[rstrt+1].bte; if ppsmon then writeln ('Receiving PPS ',ppsno,' length ',rbuf[rstrt+2].bte); rcnt := rbuf[rstrt+2].bte - 3; index := 0; while (indexppsno) or not rppstbl[index].active ) do index := index + 1; with rbuf[rstrt].ppsh do begin if index = MAXPPS then begin if not fst then begin writeln ('PPS ERROR - received packet on inactive PPS number ',ppsno); end else {activate this pps} begin index := 0; while (index pseq then begin writeln; writeln ('PPS ERROR - received unexpected sequence number ',seq,' on ',ppsno); err := TRUE; end else pseq := (pseq+1) mod 8; {move data to pps buffer} rstrt := rstrt + 3; {skip pps header} if ppsmon then writeln ('PPS rec buffer ='); while (rcnt > 0) and not err do begin buf[nxtptr] := rbuf[rstrt].ch; if ppsmon then byteprint (rbuf[rstrt].ch); rcnt := rcnt -1; rstrt := rstrt+1; nxtptr := nxtptr+1; if nxtptr = PPSBUFSZ then nxtptr := 0; if nxtptr = fstptr then begin writeln ('Receive buffer overflow on PPS ',ppsno); err := TRUE; end; end; end {with}; end {with}; 1: end; procedure rppsredirect (ppsno, newdest:bytesz); {purpose: Redirect all further packets received on the specified PPS stream to the specified destination process. } begin with rppstbl[ppsno] do begin destproc:=newdest; if ppsmon then begin writeln; writeln ('PPS REC - Redirecting PPS ',ppsnum,' to destination ',destproc); end; end; end; function ppsRead (ppsSlot: integer; VAR c: char): exception; begin {there are several checks that should be made here they are not done in this version for efficiency reasons} ppsRead := ERROR; with rppstbl[ppsSlot] do begin if not err then begin if (fstptr <> nxtptr) then begin c := buf[fstptr]; fstptr := fstptr+1; if fstptr = PPSBUFSZ then fstptr := 0; ppsRead:= OK; end else if not lstblk then begin ppsRead := EMPTY; if ppsmon then writeln ('EMPTY'); end else begin ppsRead := LAST; if ppsmon then writeln ('LAST'); active := FALSE; end end end end; {-------------- PROCESS GENERAL --------------} procedure pollProcesses; {purpose: Polls the pseudo processes} begin pCtrl; pSinker; pListner; pFtpSnd; pFtpRec; pTerm; pGetFtp; end; {------------------ SINK ----------------------} procedure pSinker; {a dummy receiver process to dump unwanted input } var i, ppsno, slot: integer; c: char; begin i := 0; repeat findRecPPS (SINK, i, slot, ppsno); if ppsno <> NULLPPS then begin while ppsRead (slot, c) = OK do; i := slot+1; end; until ppsno = NULLPPS; end; {--------------- CONTROL PROCESS ----------------------} procedure ctrlinit; begin ppsopen (CTRL, CTRL, ctrlOtPPS); ctrlState := SNDSYSNAME; ctrlInPPS := NULLPPS; ctrLock := TRUE; end; procedure maxCommonBaud (x, y: byte; VAR max: byte; VAR ibaud: integer); {purpose: Find highest common baud rate} begin max.bte := 0; if x.bd.b4800 and y.bd.b4800 then begin max.bd.b4800 := TRUE; ibaud := 4800; end else if x.bd.b2400 and y.bd.b2400 then begin max.bd.b2400 := TRUE; ibaud := 2400; end else if x.bd.b1200 and y.bd.b1200 then begin max.bd.b1200 := TRUE; ibaud := 1200; end else if x.bd.b600 and y.bd.b600 then begin max.bd.b600 := TRUE; ibaud := 600; end else if x.bd.b450 and y.bd.b450 then begin max.bd.b450 := TRUE; ibaud := 450; end else if x.bd.b300 and y.bd.b300 then begin max.bd.b300 := TRUE; ibaud := 300; end else if x.bd.b150 and y.bd.b150 then begin max.bd.b150 := TRUE; ibaud := 150; end else if x.bd.b110 and y.bd.b110 then begin max.bd.b110 := TRUE; ibaud := 110; end else begin writeln ('No compatable baud rates in request.'); ibaud := 0; end; end; procedure decodeCtrlMsg; {purpose: Decode incomming control messages} var c: char; x: byte; newBaud: integer; result: exception; begin result := ppsRead (ctrlInSlot, c); x.ch := c; if result = OK then begin if x.bte = PDPROTO then begin writeln; write ('Setting '); {check modes } result := ppsRead (ctrlInSlot, c); x.ch := c; cMode.md.bin := x.md.bin and vMode.md.bin; recBinary := cMode.md.bin; if loopbk then xmitBinary := recBinary; if cMode.md.bin then begin write ('binary '); end else write ('radix 41 '); cMode.md.full := x.md.full and vMode.md.full; recFull := cMode.md.full; if cMode.md.full then begin write ('full duplex ') end else write ('half duplex '); {check baud rate} result := ppsRead (ctrlInSlot, c); x.ch := c; maxCommonBaud (x, vBaud, cBaud, newBaud); write (newBaud, ' baud.'); recBaud := newBaud; writeln; {get rmt max ltb size} result := ppsRead (ctrlInSlot, c); x.ch := c; rmtRecDataSz := x.bte; writeln ('Max remote receive data size: ',rmtRecDataSz); if maxXmitDataSz > rmtRecDataSz then xmitDataSz := rmtRecDataSz else xmitDataSz := maxXmitDataSz; writeln ('Xmit data size: ', xmitDataSz); {send reply} ctrLock := TRUE; x.bte := IW+PROTO; result := ppsWrite (ctrlOtPPS, x.ch); result := ppsWrite (ctrlOtPPS, cMode.ch); result := ppsWrite (ctrlOtPPS, cBaud.ch); x.bte := recDataSz; result := ppsWrite (ctrlOtPPS, x.ch); end else if x.bte = IWPROTO then begin writeln; write ('Setting '); {set modes} result := ppsRead (ctrlInSlot, c); cMode.ch := c; if cMode.md.bin then begin recBinary := TRUE; xmitBinary := TRUE; write ('binary '); end else begin recBinary := FALSE; xmitBinary := FALSE; write ('radix 41 '); end; if cMode.md.full then begin recFull := TRUE; xmitFull := TRUE; write ('full duplex '); end else begin recFull := FALSE; xmitFull := FALSE; write ('half duplex '); end; {set baud} result := ppsRead (ctrlInSlot, c); x.ch := c; maxCommonBaud (x, vBaud, cBaud, newBaud); recBaud := newBaud; xmitBaud := newBaud; writeln (newBaud, ' baud.'); {get rmt max LTB size} result := ppsRead (ctrlInSlot, c); x.ch := c; rmtRecDataSz := x.bte; writeln ('Max remote receive data size: ',rmtRecDataSz); if maxXmitDataSz > rmtRecDataSz then xmitDataSz := rmtRecDataSz else xmitDataSz := maxXmitDataSz; writeln ('Xmit data size: ', xmitDataSz); {send reply to complete sequence} ctrLock := TRUE; x.bte := PDGOPROTO; result := ppsWrite (ctrlOtPPS, x.ch); end else if x.bte = PDGOPROTO then begin xmitBinary := cMode.md.bin; xmitFull := cMode.md.full; xmitBaud := recBaud; writeln ('Mode change complete.'); end else begin byteprint (x.ch); while ppsRead (ctrlInSlot, c) = OK do byteprint (c); end; end; end; procedure pCtrl; {purpose:Control process} var i:integer; x: byte; sysname: string; result: exception; sfile: text; begin case ctrlState of SNDSYSNAME: begin ctrLock := TRUE; {|||} WRITELN; {|||} {$I-} reset (sfile, 'sysname.text'); {$I+} if IORESULT <> 0 then begin writeln ('Unable to open sysname.text.'); end else begin repeat read (sfile, c); result := ppsWrite(ctrlOtPPS, c); until EOLN(sfile) or (result <> OK); close (sfile); end; if mynode = ORG then ctrlState := REQPROTO else ctrlState := CIDLE; end; REQPROTO : begin ctrLock := TRUE; x.bte := PD + PROTO; {send control code} result := ppsWrite (ctrlOtPPS, x.ch); {send valid modes} result := ppsWrite (ctrlOtPPS, vMode.ch); {send valid bauds} result := ppsWrite (ctrlOtPPS, vBaud.ch); x.bte := recDataSz; {max amount of data to rec } result := ppsWrite (ctrlOtPPS, x.ch); ctrlState := CIDLE; end; end; if ctrlInPPS = NULLPPS then findRecPPS (CTRL, 0, ctrlInSlot, ctrlInPPS); if ctrlInPPS <> NULLPPS then decodeCtrlMsg; end; {---------------- FTP MESSAGE PARSER ------------------------} procedure ftpMsgParser (inSlot: integer; VAR srcname, destname: string; VAR fLength: fileLength); {purpose: Parse incomming FTP request} var msgLen, i: integer; x: byte; result: exception; begin result := ppsRead (inSlot, c); x.ch := c; msgLen := x.bte; result := ppsRead (inSlot, c); x.ch := c; fLength[0] := x.bte; {length of file in bits } result := ppsRead (inSlot, c); x.ch := c; fLength[1] := x.bte; {not used in this version} result := ppsRead (inSlot, c); x.ch := c; fLength[2] := x.bte; {$R-} {get source file name } result := ppsRead (inSlot, c); x.ch := c; i := 1; while x.ch <> chr(CR) do begin srcname[i] := x.ch; result := ppsRead (inSlot, c); x.ch := c; i := i+1; end; srcname[0]:=chr(i-1); {See Note 1} { get destnation name } result := ppsRead (inSlot, c); x.ch := c; i := 1; while x.ch <> chr(CR) do begin destname[i] := x.ch; result := ppsRead (inSlot, c); x.ch := c; i := i+1; end; destname[0]:=chr(i-1); {See Note 1} {$R+} end; {--------------- FTP SENDER ---------------------------} procedure fsndinit; {purpose: Initialize ftp sender at startup.} begin fsndstate:=idle; xfiletype:=0; xfilesize.intval:=0; xname := ' '; destname := ' '; fSndInPPS := NULLPPS; end; procedure ftpstart; {purpose: Does setup for file sending when requested locally.} var cnt:integer; begin if fsndstate<>idle then begin {$I-} writeln;writeln ('Sender is busy transfering ',xname,' to ',destname); write ('Do you wish to abort this transfer ? (Y/N):'); read (c); writeln; if c in ['Y','y'] then begin {set up conditions that indicate end to sender} fsndstate:= localabort; menuexit := TRUE; end; end else begin {||| writeln; |||} writeln; write ('Name of file to be sent: '); readln (xname); {||| writeln; |||} write ('Name of destination file: '); readln (destname); {||| writeln; |||} reset (xfile, xname); if IORESULT <> 0 then begin writeln ('Unable to open ',xname); end else begin fsndstate:=initiate; ppsopen (FTPSND, LSTNER, fSndOtPPS); menuexit := TRUE; end; end; {$I+} end; function rmtsndstart; {purpose: Does setup for file sending when requested from remote.} var fLength: fileLength; begin {$I-} {$R-} if fsndstate<>idle then {already busy} rmtsndstart:=FALSE else begin ftpMsgParser (inSlot, xname, destname, fLength); if ftpmon then begin writeln;writeln ('Remote start opening ',xname,' to ',destname); end; reset (xfile, xname); if IORESULT<>0 then {could not open file} rmtsndstart := false else begin ppsopen (FTPSND, LSTNER, fSndOtPPS); fsndstate:=initiate; rmtsndstart :=TRUE end end {$R+} {$I+} end; procedure ftpSndRec (x: byte); {purpose: Decode incomming FTP conrol messages} begin case fsndstate of request: begin if x.bte = (IW + RF) then { i will receive file} begin writeln ('accepted'); fsndstate:=send; end else begin writeln ('refused'); rppsredirect (fSndInSlot, SINK); fSndInPPS := NULLPPS; ppsclose (fSndOtPPS); close (xfile); fsndstate := idle; end; end; ack: begin {|||} WRITELN; {|||} write ('Transfer of ',xname,' to ',rname); if x.bte = (IW + AF) then { i will accept this file} writeln(' completed sucessfully.') else writeln (' refused - code: ', x.bte); rppsredirect (fSndInSlot, SINK); fSndInPPS := NULLPPS; close (xfile); fsndstate := idle; end; send: begin if x.bte = (IWN + AF) then begin writeln; writeln ('Transfer of ',xname,' to ',rname,' aborted by receiver.'); ppsclose (fSndOtPPS); rppsredirect (fSndInSlot, SINK); fSndInPPS := NULLPPS; close (xfile); fsndstate := idle; end; end; end; end; procedure pFtpSnd; {purpose: Transmits file contents to FTP receiver.} label 1; var result: exception; i, cnt:integer; x: byte; c:char; tmpstr:string; tmp: integer; begin if fsndstate = idle then goto 1; if fSndInPPS = NULLPPS then findRecPPS (FTPSND, 0, fSndInSlot, fSndInPPS); if fSndInPPS <> NULLPPS then begin result := ppsRead (fSndInSlot, c); x.ch := c; if (result = LAST) or (result = ERROR) then fSndInPPS := NULLPPS else if result <> EMPTY then begin ftpSndRec (x); end; end; case fsndstate of request: ; ack: ; idle: ; localabort: begin x.bte := PDN + AF; result := ppsWrite (fSndOtPPS, x.ch); ppsclose (fSndOtPPS); rppsredirect (fSndInSlot, SINK); fSndInPPS := NULLPPS; close (xfile); fsndstate := idle; end; send: begin {$R-} if statusOtPPS (fSndOtPPS) = OK then begin repeat if xbufptr = BLKSZ then {get next blk from disk} begin if EOF(xfile) then {note: this eof occurred on the previous read} begin x.bte := PD + AF; result := ppsWrite (fSndOtPPS, x.ch); ppsclose (fSndOtPPS); fsndstate := ack; end else begin {$I-} cnt := blockread (xfile, xblk, 1, xfilptr); {$I+} xfilptr := xfilptr+1; if IORESULT <> 0 then begin writeln; writeln ('File sender I/O error ',IORESULT,' file ', xname,'...'); x.bte := PDN + AF; result := ppsWrite (fSndOtPPS, x.ch); ppsclose (fSndOtPPS); rppsredirect (fSndInSlot, SINK); fSndInPPS := NULLPPS; close (xfile); fsndstate := idle; end else xbufptr := 0; end end else begin {for efficency this transfer does not use ppsWrite} with xppstbl[fsndOtPPS] do begin buf[nxtptr] := xblk[xbufptr]; nxtptr := nxtptr+1; if nxtptr = PPSBUFSZ then nxtptr := 0; tmp := nxtptr+1; if tmp = PPSBUFSZ then tmp := 0; xbufptr := xbufptr+1; end; end; until (tmp = xppstbl[fsndOtPPS].fstptr) or (fsndstate <> send); end; end; {$R+} initiate: begin {||| writeln; |||} write ('Request to transfer ',xname,' to ',destname); x.bte:= PD + RF; { please do receive file} result := ppsWrite (fSndOtPPS, x.ch); tmpstr:= concat(xname, acr ,destname, acr); x.bte := length(tmpstr)+5; {length of this message in bytes } result := ppsWrite (fSndOtPPS, x.ch); x.bte:= 0; {24 bit length in bits, low byte first } {always zero in this version } result := ppsWrite (fSndOtPPS, x.ch); result := ppsWrite (fSndOtPPS, x.ch); result := ppsWrite (fSndOtPPS, x.ch); for i:= 1 to length(tmpstr) do result := ppsWrite (fSndOtPPS, tmpstr[i]); xeof:= FALSE; xbufptr := BLKSZ; xfilptr:=0; fsndstate:=request; end end; 1: end; {------- LISTNER ------------} { This process acts as a well known process to setup file transfers.} procedure pListner; {purpose: Listner process} var i:integer; x: byte; result: exception; begin {$I-} findRecPPS (LSTNER, 0, lsnrInSlot, lsnrInPPS); if lsnrInPPS <> NULLPPS then begin result := ppsRead (lsnrInSlot, c); x.ch := c; if ftpmon then begin writeln; writeln ('Listener requested to:',x.bte); end; if x.bte= (PD + RF) then { please receive file} begin ppsopen (LSTNER, rppstbl[lsnrInSlot].srcproc, lsnrOtPPS); if frecstart (lsnrInSlot) then {FTP receiver ready} begin x.bte:= IW + RF; { i will receive file}; rppsredirect (lsnrInSlot, FTPREC) end else {receiver not ready} begin x.bte := IWN + RF; { i will not receive file} rppsredirect (lsnrInSlot, SINK) end; result := ppsWrite (lsnrOtPPS, x.ch); ppsclose (lsnrOtPPS); end else if x.bte= (PD + SF) then { please do send file} begin ppsopen (LSTNER, rppstbl[lsnrInSlot].srcproc, lsnrOtPPS); if rmtsndstart(lsnrInSlot) then x.bte := IW + SF { i will send file} else x.bte := IWN + SF; { i will not send file} if ftpmon then begin writeln; write ('LISTENER - remote request to transfer '); if x.bte= (IWN + SF) then writeln(' refused') else writeln(' accepted'); end; result := ppsWrite (lsnrOtPPS, x.ch); ppsclose (lsnrOtPPS); end else {unknown request} if ftpmon then begin writeln; writeln ('LISTENER - Unknown request type ',x.bte) end; end; {$I+} end; {------- FTP RECEIVER -------------} procedure frecinit; {purpose: Initializes FTP receiver at startup.} begin receiving:=FALSE; srcname := ' '; rname := ' '; end; function frecstart; {purpose: Setup receiver for a file transfer.} var msgLen: integer; fLength: fileLength; begin frecstart:=FALSE; if not receiving then begin {initialization for receiver } ftpMsgParser (inSlot, srcname, rname, fLength); {|||} WRITELN; {|||} write('Request to receive ',rname,' from ',srcname, '...'); {$I-} reset (rfile,rname); if IORESULT=0 then {file already exists} begin {||| writeln; |||} writeln ('local file ',rname,' already exists, transfer refused.'); close (rfile); end else begin rewrite (rfile, rname); if IORESULT<>0 then begin {||| writeln; |||} writeln ('unable to create local file ',rname,' transfer refused.') end else begin writeln ('accepted.'); frecInPPS := NULLPPS; rfilptr:=0; rbufptr := 0; receiving := TRUE; frecstart:=TRUE; firstChar := TRUE; end end end {$I+} end; procedure pftpRec; {purpose: FTP receiver process} label 1; var {|||} SpareBlk : Blk; {|||} cnt,i:integer; x: byte; result: exception; begin if not receiving then goto 1; if frecInPPS = NULLPPS then begin findRecPPS (FTPREC, 0, frecInSlot, frecInPPS); if frecInPPS = NULLPPS then goto 1; end; if firstChar then begin result := ppsRead (fRecInSlot, c); lastc.ch := c; if result = OK then firstChar := FALSE; end; {||| $R-} {turn off range checking for speed} if not firstChar then repeat result := ppsRead (fRecInSlot, c); x.ch := c; if result = OK then begin rblk[rbufptr] := lastc.ch; lastc.ch := x.ch; rbufptr := rbufptr+1; if rbufptr = BLKSZ then begin {$I-|||} cnt := blockwrite (rfile, rblk, 1, rfilptr); {||| Vol Sys Mod |||} WHILE Cnt = 1 DO BEGIN IF (BLOCKREAD (RFile, SpareBlk, 1, RFilPtr) = 1) AND (SpareBlk = RBlk) THEN Cnt := 0 ELSE Cnt := BLOCKWRITE (RFile, RBlk, 1, RFilPtr) END; {$I+|||} rfilptr := rfilptr+1; rbufptr := 0; if IORESULT <> 0 then begin ppsopen (FTPREC, rppstbl[frecInSlot].srcproc, fRecOtPPS); x.bte:=IWN + AF; {i will not accept file} ppsclose (fRecOtPPS); rppsredirect (fRecInSlot, SINK); receiving := FALSE; end; end; end; until result <> OK; {|||$R+} {$I-} if result = LAST then {last block of a file transfer} begin receiving := FALSE; writeln; if lastc.bte= (PDN + AF) then begin close (rfile); writeln ('Received abort request on transfer of ',rname); end else begin close (rfile, lock); ppsopen (FTPREC, rppstbl[frecInSlot].srcproc, fRecOtPPS); if IORESULT <> 0 then begin writeln ('FTP REC - close error ',IORESULT,' on ',rname); x.bte:=IWN + AF; end else begin writeln ('FTP REC - transfered ',rfilptr,' blocks to ',rname); x.bte:=IW + AF; {i will accept file} end; result := ppsWrite (fRecOtPPS, x.ch); ppsclose (fRecOtPPS); receiving := FALSE; end end else if result = ERROR then begin ppsopen (FTPREC, rppstbl[frecInSlot].srcproc, fRecOtPPS); x.bte:=IWN + AF; result := ppsWrite (fRecOtPPS, x.ch); ppsclose (fRecOtPPS); rppsredirect (fRecInSlot, SINK); receiving := FALSE; end; 1: {$I+} end; {------------ GET - REQUEST A FILE FROM REMOTE ----------------} {Local process to request a file from remote node.} procedure getftp; {purpose: Get name of remote file from user.} var getFtpOtPPS: integer; gname,localname:string; x: byte; result: exception; begin {|||writeln; |||} write ('Transfer remote file: '); readln (gname); {|||writeln;|||} write ('To local file: '); readln (localname); {|||writeln;|||} write ('Transfer of ',gname,' to ',localname,'...'); ppsopen (GETFILE, LSTNER, getFtpOtPPS); x.bte:= PD + SF; { please do receive file} result := ppsWrite (getFtpOtPPS, x.ch); getstr:=concat (gname, acr, localname, acr); x.bte := length(getstr)+5; {length of this message in bytes } result := ppsWrite (getFtpOtPPS, x.ch); x.bte:= 0; {24 bit length in bits, low byte first } {always zero in this version } result := ppsWrite (getFtpOtPPS, x.ch); result := ppsWrite (getFtpOtPPS, x.ch); result := ppsWrite (getFtpOtPPS, x.ch); for i:= 1 to length(getstr) do result := ppsWrite (getFtpOtPPS, getstr[i]); ppsclose (getFtpOtPPS); menuexit:=TRUE; end; procedure pGetFtp; {purpose: Get FTP process} var ppsno, slot: integer; result: exception; x: byte; begin findRecPPS (GETFILE, 0, slot, ppsno); if ppsno <> NULLPPS then begin result := ppsRead (slot, c); x.ch := c; if result = OK then if x.bte = (IW + SF) then writeln ('initiated') else writeln ('refused - code: ', x.bte); end; end; {----------------- TERMINAL PROCESS --------------------------------} procedure terminit; {purpose: Initialize terminal process at setup time.} begin ppsopen (TERM, TERM, termot); termInPPS := NULLPPS; kbInterrupt := FALSE; end; procedure pTerm; {purpose: PTP terminal process} var c: char; chc:packed array[0..0] of char; status: exception; begin if termInPPS = NULLPPS then findRecPPS (TERM, 0, termInSlot, termInPPS); if termInPPS <> NULLPPS then while ppsRead (termInSlot, c) = OK do write (c); { check for key board character} if kbInterrupt then begin kbInterrupt := FALSE; writeln; write ('> '); write (fstKbCh); if ppsWrite (termot, fstKbCh) = OK then repeat unitread (2,chc[0], 1,0,0); status := ppsWrite (termot, chc[0]); write (chc[0]); if status <> OK then writeln (' status not ok'); until (chc[0] = chr(13)) or (status <> OK); end; end; {-------- PTP START --------------------} procedure ptpinit; {purpose: Initialize PTP } begin modeInit; ltbinit; ppsinit; ctrlinit; terminit; frecinit; fsndinit; end; procedure firstptpinit; {purpose: Initialization required before first PTP invocation} begin trace := FALSE; ppsmon := FALSE; ftpmon := FALSE; loopbk := FALSE; ansbrkt := '['; orgbrkt := ']'; ptpinit; end; procedure ptprun; {purpose: Start PTP} begin mynode := modemMode; if mynode = ANS then timeout := ANSTIMEOUT else timeout := ORGTIMEOUT; ptpinit; if mynode = ANS then {|||} BEGIN Delay (10); {|||} endxmit; {send turn around } {|||} END; {|||} sched; end; {--------------------- PTP MENU ---------------------------} procedure monitor; {purpose: Allows the user to control tracing for debugging.} begin repeat writeln; write('Trace LTB ? (Y/N)'); read(c); case c of 'y','Y': trace := TRUE; 'n','N': trace :=FALSE; end; until c in ['y','Y','n','N']; repeat writeln; write('Trace PPS ? (Y/N)'); read(c); case c of 'y','Y': ppsmon := TRUE; 'n','N': ppsmon :=FALSE; end; until c in ['y','Y','n','N']; repeat writeln; write('Trace FTP ? (Y/N)'); read(c); case c of 'y','Y': ftpmon := TRUE; 'n','N': ftpmon :=FALSE; end; until c in ['y','Y','n','N']; repeat writeln; write('Local loopback test ? (Y/N)'); read(c); case c of 'y','Y': begin ansbrkt:=']'; orgbrkt:=']'; loopbk := TRUE; end; 'n','N': begin ansbrkt:='['; orgbrkt:=']'; loopbk := FALSE; end end; until c in ['y','Y','n','N']; {|||writeln; |||} end; procedure setModes; {purpose: Sets the valid PTP modes and baud rates} begin {|||writeln; |||} vMode.bte := 0; repeat writeln; write('Binary mode? (Y/N)'); read(c); case c of 'y','Y': vMode.md.bin := TRUE; 'n','N': vMode.md.bin := FALSE; end; until c in ['y','Y','n','N']; vBaud.bte := 0; {||| while vBaud.bte = 0 do begin writeln; writeln ('Enter valid baud rates (y/n)'); write ('4800:'); read (c); if (c = 'y') or (c = 'Y') then vBaud.bd.b4800 := TRUE; write (' 2400:'); read (c); if (c = 'y') or (c = 'Y') then vBaud.bd.b2400 := TRUE; write (' 1200:'); read (c); if (c = 'y') or (c = 'Y') then vBaud.bd.b1200 := TRUE; write (' 600:'); read (c); if (c = 'y') or (c = 'Y') then vBaud.bd.b600 := TRUE; write (' 450:'); read (c); if (c = 'y') or (c = 'Y') then vBaud.bd.b450 := TRUE; write (' 300:'); read (c); if (c = 'y') or (c = 'Y') then vBaud.bd.b300 := TRUE; write (' 150:'); read (c); if (c = 'y') or (c = 'Y') then vBaud.bd.b150 := TRUE; write (' 110:'); read (c); if (c = 'y') or (c = 'Y') then vBaud.bd.b110 := TRUE; if vBaud.bte = 0 then begin writeln; writeln ('Please enter at least one valid baud rate.'); end; end; writeln; |||} WITH vBaud.Bd DO BEGIN b_300 := TRUE; b1200 := TRUE; WRITELN; WRITELN ('Baud Rates : 300, 1200') END; {|||} {$I-} repeat {||| write ('Enter recever data size (32-'); write (MAXLTBSZ-15); write ('): '); readln (recDataSz); |||} RecDataSz := MaxLtbSz-18; WRITELN ('Receiver Data Size - ', RecDataSz) {|||} until (IORESULT = 0) and (recDataSz >= 32) and (recDataSz <= (MAXLTBSZ-15)); repeat {||| write ('Enter xmitter data size (32-'); write (MAXLTBSZ-15); write ('): '); readln (maxXmitDataSz); |||} MaxXmitDataSz := MaxLtbSz-18; WRITELN ('Tansmitter Data Size - ', MaxXmitDataSz) {|||} until (IORESULT = 0) and (maxXmitDataSz >= 32) and (maxXmitDataSz <= (MAXLTBSZ-15)); {|||writeln; |||} {$I+} ctrlState := REQPROTO; end; procedure exiter; {purpose : Terminates PTP program after warning user if transfers are in progress.} var c:char; begin {$I-} if receiving or (fsndstate <> idle) then begin writeln; write('Currently engaged in file transfer.'); writeln; write ('Are you sure you want to exit? (Y/N): '); read (c); if (c='Y') or (c='y') then begin close (rfile,lock); close (xfile); sch := done; menuexit := true; end; end else begin sch := done; menuexit := true; end; {$I+} end; procedure menu; {purpose: PTP menu loop.} begin menuexit := FALSE; repeat writeln; write ('G(et S(end M(ode T(race I(nitialize E(xit: '); read (c); case c of 'S','s':ftpstart; 'E','e':exiter; 'M','m': setModes; 'T','t':monitor; 'I','i':ptpinit; 'G','g':getftp; end; until eoln or menuexit; writeln; end; {------------ RAW TERMINAL ---------------} {Process which allows raw data typed on the terminal to be sent over the serial line, used for debugging. Also used to allow login to timesharing systems. } procedure rawterm; var c: char; termdone:boolean; ch:packed array [0..0] of char; begin termdone:=FALSE; repeat if not cts then begin writeln; writeln ('CARRIER LOST'); termdone := true; end; if kbstat then begin unitread (2,ch[0],1,0,0); if ch[0]=chr(ATTENCHAR) then termdone:=TRUE else begin if halfduplex then write(ch[0]); putserial(ch[0]) end end; if mrecstat then begin c:=mread; if c <> chr(LF) then write (c); end; until termdone=TRUE; end; procedure initrawterm; begin halfduplex := false; end; {--------------------- MODEM CONTROL ---------------------------} procedure hangitup; {purpose: Hangup phone and wait for loss of carrier} begin hangup; while cts do; end; procedure progStart; {purpose: Start the selected program} begin case progSelect of PT: ptprun; RT: rawterm; end; end; function estconnection: boolean; {purpose: Establish modem connection} var i: integer; cd: boolean; begin delay (10); {turn dtr on sh off } dtron; {||| write ('waiting for carrier... '); |||} WRITELN ('Modem Switch may be needed to Engage Carriers.'); WRITE ('Waiting 60 seconds for Carrier... '); {|||} { set baud rate and mode} delay (1); {.10 seconds } baud; {wait for carrier } i := 0; {Pascal for this might be } repeat { WHILE (NOT (Cts OR KbStat)) AND (I<200) DO BEGIN } cd :=cts; { I := I + 1; } if cd = false then{ Delay (10) } delay (10); { END; } i := i+1; (*||| Vol Sys Mod until cd or (i = 200) or kbstat; { 20 seconds to answer } |||*) until cd or (i = 60) or kbstat; { 60 seconds to answer } {|||} if cd = false then { IF NOT Cd THEN } begin {||| writeln ('no answer, phone on hook'); |||} WRITELN ('Never got their Carrier.'); {|||} hangitup; end else begin writeln ('carrier detected'); progStart; end; estconnection := cd; end; procedure go; {purpose: Used when modem connection may already be established} var result: boolean; begin if modemMode = ANS then ri else sh; result := estconnection; end; procedure dialnum; {purpose: Get dial tone and dial number} var i, j: integer; result: boolean; begin modemMode := ORG; result := true; { hangup } hangitup; {go off hook } sh; {wait for dial tone } i := 0; repeat result := dtonedet; if not result then delay (5); {.5 seconds } i := i+1; until result or (i = 10); { 5 seconds for dial tone } if not result then writeln ('no dial tone') else { dial number } begin delay (3); { delay .3 seconds } writeln; write ('DIALING: '); i := 1; while (i <= length(telnum)) and result do begin write (telnum[i]); if (telnum[i] >= '0') and (telnum[i] <= '9') then dialer (telnum[i]) else if telnum[i] = '*' then begin {wait for dial tone } j := 0; repeat result := dtonedet; if not result then (*||| delay (50); {.5 seconds } |||*) Delay (5); {.5 seconds } {|||} j := j+1; until dtonedet or (i = 10); { 5 seconds for dial tone } if not result then writeln ('no dial tone') end; i:= i+1; end; writeln; if result then result := estconnection; end; end; procedure dial; {purpose: Get number to be dialed, and call dialer} var ready: boolean; begin writeln; write ('Enter number to be dialed: '); readln (telnum); dialnum; end; procedure contRedial; {purpose: Redail continuely} var ready: boolean; kbrdy: boolean; begin repeat dialnum; kbrdy := kbstat; if not ready and not kbrdy then delay (30); { wait 30 seconds} kbrdy := kbstat; until ready or kbrdy; end; function autoanswer: boolean; begin initState; progSelect := PT; modemMode := ANS; autoanswer := false; writeln; write ('Waiting for call...'); repeat until ringing or kbstat; {||| Vol Sys Mod if ringing then delay (10); if ringing then begin ri; autoanswer := estconnection; end; |||} IF NOT KbStat THEN BEGIN {Only test Ringing once} DtrOn; Delay (10); Ri; AutoAnswer := EstConnection; UartCmd (FALSE) {can't hangitup cause might be unattended} END {|||} end; procedure uattended; {purpose: Unattended autoanswer mode} begin repeat if autoanswer then {||| progStart; ||| ; {autoanswer will have done it |||} until kbstat; end; procedure changeBaud; {purpose: Change to specified baud rate} const baudFac = 15625; {used to calculate baud rate for PMMI modem only} begin currentBaud := rate; {||| baudrate := baudFac div rate; |||} BaudRate := Rate; {|||} baud; end; procedure setBaud; {purpose: Set PTP receiver and xmitter baud rates and set baud rate} begin xmitBaud := rate; recBaud := rate; changeBaud (rate); end; procedure getBaud; {purpose: Get user requested baud rate and set} var rate: integer; begin {$I-} repeat writeln; write ('Enter baud rate (110-4800): '); readln (rate); until (IORESULT = 0) and (rate >=110) and (rate <= 4800); {$I+} setBaud (rate); end; procedure options; {purpose: Call specified option setting routine} begin writeln; write ( 'P(TP M(ode T(race O(rg A(ns / R(awTerm B(aud F(ullduplex H(alfduplex: '); read (c); case c of 'P','p': progSelect := PT; 'R','r': progSelect := RT; 'B','b': getBaud; 'F','f': halfduplex := false; 'H','h': halfduplex := true; 'T','t': monitor; 'M','m': setModes; {|||} 'O','o': ModemMode := Org; 'A','a': ModemMode := Ans; {|||} end; end; procedure modemMenu; {purpose: Display modem menu} var c: char; ready: boolean; begin repeat writeln; {$I-|||} CLOSE (RFile, LOCK); CLOSE (XFile, LOCK); {$I+|||} case progSelect of {||| Vol Sys Mod |||} PT: BEGIN WRITE ('PTP Mode-'); IF ModemMode = Org THEN WRITE ('ORG') ELSE IF ModemMode = Ans THEN WRITE ('ANS'); WRITE (' Xmit-'); IF XmitBinary THEN WRITE ('Bin') ELSE WRITE ('R41'); WRITE (' Recv-'); IF RecBinary THEN WRITE ('Bin') ELSE WRITE ('R41') END; RT: BEGIN write ('RAW '); IF HalfDuplex THEN WRITE ('Half') ELSE WRITE ('Full'); WRITE ('Duplex') END; {|||} end; write (' ',currentBaud,' baud '); {|||} if cts or loopbk then begin writeln (' Carrier'); {||| writeln; |||} write ('E(xit G(o H(angup O(ptions U(nattended: '); read (c); case c of 'H','h': hangitup; 'G','g': progStart; 'O','o': options; 'U','u': uattended; end; end else begin writeln (' OnHook'); {||| writeln; |||} write ( 'A(utoans C(ntdial D(ial E(xit G(o H(angup O(ptions R(edial U(nattended : '); read (c); case c of 'D','d': dial; 'R','r': dialnum; 'C','c': contRedial; 'A','a': ready := autoanswer; 'O','o': options; 'G','g': go; 'H','h': hangitup; 'U','u': uattended; end; end; until (c = 'E') or (c = 'e'); end; procedure initState; {purpose: Initial modem state} begin setBaud (300); cBaud.bte := 0; cBaud.bd.b300 := TRUE; recBinary := FALSE; xmitBinary := FALSE; recFull := FALSE; xmitFull := FALSE; end; procedure modInit; {purpose: Initial state at starup} begin progSelect := RT; unattended := false; initState; modemInit; end; {------------------- INITIALIZATION -----------------} procedure init; {purpose: Calls individual initialization procedures.} begin {init a CR string} {$R-} acr[0] := chr(1); acr[1] := chr(CR); {$R+} {|||} ModemMode := ORG; {|||} mynode := ORG; initrawterm; firstptpinit; modInit; end; begin {main} {|||} PAGE (OUTPUT); writeln; writeln (title); writeln; writeln (version); {|||} writeln; setModes; init; modemMenu; hangitup; end. ======================================================================================== DOCUMENT :usus Folder:VOL06:ri.a.text ======================================================================================== .PROC RI,0 .PRIVATE RETADDR TPORT .EQU 0C0H ;UART CONTROL PORT RPORT .EQU TPORT+2 ;RATE PORT RIBT .EQU 02H ;RI (MODEM WILL BE IN ANSWER MODE) TRATE .EQU 250 ;TIMER RATE FOR .1 DELAY TMPUL .EQU 80H ;TIME MASK POP HL LD (RETADDR),HL LD A,RIBT OUT (TPORT),A ; DELAY REQUIRED FOR OFF HOOK LD A,TRATE OUT (RPORT),A TIMES IN A,(RPORT) AND TMPUL JP Z,TIMES TIMEE IN A,(RPORT) AND TMPUL JP NZ,TIMEE ; RETURN LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:ringing.a.text ======================================================================================== .FUNC RINGING,0 .PRIVATE RETADDR STAT .EQU 0C2H RING .EQU 2H POP HL LD (RETADDR),HL POP HL ;CORRECT STACK POP HL LD HL,0 ;FALSE IN A,(STAT) ;READ STATUS AND RING ;CHECK FOR RINGING JP NZ,DONE LD HL,1 ;TRUE DONE PUSH HL LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:sh.a.text ======================================================================================== .PROC SH,0 .PRIVATE RETADDR TPORT .EQU 0C0H ;UART CONTROL PORT RPORT .EQU TPORT+2 ;RATE PORT SHBT .EQU 01H ;SH (MODEM WILL BE IN ORGINATE MODE) TRATE .EQU 250 ;TIMER RATE FOR .1 DELAY TMPUL .EQU 80H ;TIME MASK POP HL LD (RETADDR),HL LD A,SHBT OUT (TPORT),A ; DELAY REQUIRED FOR OFF HOOK LD A,TRATE OUT (RPORT),A TIMES IN A,(RPORT) AND TMPUL JP Z,TIMES TIMEE IN A,(RPORT) AND TMPUL JP NZ,TIMEE ; RETURN LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL06:sysname.text ======================================================================================== 37.17N121.52W408-267-4913/URNAME ======================================================================================== DOCUMENT :usus Folder:VOL07:catalog.7.text ======================================================================================== VOLUME 7 CATALOG USUS SOFTWARE LIBRARY Macro precompiler and several Pascal source cross-referencers. Filename Blocks Description FASTREAD.TEXT 8 Dan Dorrough's unit (used in MAP) that speeds up Readln for strings by a factor of about 10. MAP.TEXT 38 The precompiler from PUG News #17 that allows Pascal MAP-A.TEXT 42 macros, fancy constant expressions, nested INCLUDE MAP-B.TEXT 32 files, conditional compilation, and more, converted by Dan Dorrough of PCD Systems. MAP.DOC.TEXT 18 Documentation from PUG News. PRXREF.TEXT 30 David Lewis' superb Pascal cross-referencer and source PRXREF.TBL.TEXT 34 lister with several nice features: follows INCLUDE PRXREF.OPT.TEXT 24 files, adds line numbers that match those of the UCSD PRXREF.INI.TEXT 24 compiler, and marks procedures/functions in the xref PRXREF.UTL.TEXT 28 list. Request: someone please add the ability to PRXREF.PFI.TEXT 38 pull in a UNIT interface declaration, with line numbers matching the compiler's weird system. KEYHIT.TEXT 4 Assembly language keyboard poller (from USUS) PRX.DOC.TEXT 68 Clear and thorough (!) documentation for PRXREF. PROC.REF1.TEXT 44 Procedure/function cross-referencer from PUG News #17. It died when I tried it on a large program with many cross-references, but works fine with smaller sources. Use is obvious. Help me find the bug! PROC.REF2.TEXT 22 Pat Horton's own procedure cross-referencer. NOTE: USUS Library material may be used only in accordance with policy outlined elsewhere. In particular, these programs may not be given to nonmembers of USUS, nor may commercial use be made of them, without the written permission of the authors. Apple and other versions are the same as noted above. Keep an eye on the USUS newsletter for corrections and updates. ======================================================================================== DOCUMENT :usus Folder:VOL07:fastread.text ======================================================================================== { FASTREAD - fast text file string read for UCSD pascal. } { dhd - PCD Systems, Inc. } unit fastread; interface { file control block } const bufsiz = 1024; linemax = 255; type lineindex = 0..linemax; longstring = string[linemax]; ffile = file; fcb = record inlfn: string[30]; { input file name } line: longstring; { current text line } bpos: integer; { buffer position } endfile: boolean; { true when end of file } buf: packed array[0..bufsiz] of char; blknr: integer; end; procedure getstring(var phyle: fcb; var infile: ffile; var s: longstring); procedure openfile(var phyle: fcb; var infile: ffile; var lfn: string); implementation const cr = 13; procedure openfile{var phyle: fcb; var infile: ffile; var lfn: string}; begin { openfile } with phyle do begin reset(infile, lfn); inlfn := lfn; line := ''; bpos := bufsiz + 1; endfile := false; blknr := 2; end; end; { openfile } procedure getstring{var phyle: fcb; var infile: ffile; var s: longstring}; const dle = 16; var bcnt, chg: integer; begin { getstring } {$R- disable string range checks } with phyle do repeat if bpos >= bufsiz then { time for next buffer } begin bcnt := blockread(infile, buf[0], 2, blknr); bpos := 0; blknr := blknr + bcnt; if bcnt < 2 then { eof } begin endfile := true; EXIT(getstring) end; end; chg := scan(bufsiz-bpos, =chr(cr), buf[bpos]); if (bpos + chg) < bufsiz then { found a carriage return } begin moveleft(buf[bpos], S[1], chg); { copy string except CR } S[0] := chr(chg); bpos := bpos + chg + 1; end else begin chg := scan(bufsiz-bpos, =chr(0), buf[bpos]); { look for null } if (bpos + chg) < bufsiz then begin moveleft(buf[bpos], S[1], chg-1); S[0] := chr(chg); bpos := bufsiz; end; end; until chg > 0; if length(s) > 2 then if s[1] = chr(dle) then { insert leading blanks } begin chg := ord(s[2])-32; if chg > 2 then moveright(s[3], s[chg+1], length(s)-2) else moveleft (s[3], s[chg+1], length(s)-2); fillchar(s[1], chg, ' '); s[0] := chr(length(s)+chg-2); end; end; { getstring } {$R+} end. { of unit } ======================================================================================== DOCUMENT :usus Folder:VOL07:keyhit.text ======================================================================================== ; THIS FUNCTION CALLS THE CP/M CONSOLE READY ENTRY POINT AND RETURNS ; A BOOLEAN VALUE (TRUE OR FALSE). CODE WILL OPERATE ON EITHER 8080 OR Z80 ; .FUNC KEYHIT ;TESTS CONSOLE CHAR READY AND RETURNS T ! F POP DE ;RETURN ADDR POP HL POP HL ;ZEROS LD L,06H ;CP/M CONSOLE READY ENTRY POINT CALL BIOS LD L,A PUSH HL ;BOOLEAN RESULT TO STACK EX DE,HL ;RETURN ADDR TO HL HERE: JP (HL) ;EXIT BIOS: LD A,(0002H) ;PAGE NO IN LOCATION 02H LD H,A JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL07:map-a.text ======================================================================================== { MAP-A } (* PROCEDURE DEBUG(N: INTEGER); VAR INCH: CHAR; CHT: PACKED ARRAY[0..0] OF CHAR; BEGIN { DEBUG } IF DEBUGON THEN IF N IN DEBUGSET THEN BEGIN WRITELN('*** ', N, ', CH=', CH, ', ORD(CH)=', ORD(CH), ', NEXT=', NEXT, ', LAST=', LAST, ', LEXTYP=', ORD(LEXTYP), ', LEXLEN=', LEXLEN); WRITELN('LEXSTR=', LEXSTR:LEXLEN); REPEAT UNITREAD(2, CHT[0], 1); INCH := CHT[0]; IF INCH = 'X' THEN DEBUGON := FALSE ELSE IF INCH = 'Q' THEN EXIT(MAP) ELSE IF INCH = 'R' THEN BEGIN WRITE('REMOVE WHICH BREAKPOINT: '); READLN(N); DEBUGSET := DEBUGSET - [N] END ELSE IF INCH = 'L' THEN WRITELN(INLINE:LAST) ELSE IF INCH = 'B' THEN { set breakpoint } BEGIN WRITE('SET WHICH BREAKPOINT: '); READLN(N); DEBUGSET := DEBUGSET + [N] END ELSE IF INCH = 'T' THEN WITH CTAB[CTOP] DO BEGIN WRITE('CNAME: ', CNAME); CASE CTYP OF TIN: WRITE(', INTEGER: ', CI); TRE: WRITE(', REAL: ', CR); TCH: BEGIN WRITELN(', STRING : CFIRST=', CFIRST, ', CLEN=',CLEN); FOR N := CFIRST TO CFIRST+CLEN-1 DO WRITE(CSTR[N]); END; TBL: IF CB THEN WRITE(', BOOLEAN: TRUE') ELSE WRITE(', BOOLEAN: FALSE'); TOT: WRITE(', TOT: ', CO); END { CASE }; WRITELN; END; UNTIL INCH = 'G'; END; END; { DEBUG } *) procedure arith; var op : lex; begin { arith } term; if (lextyp in [lexor,lexadd,lexsub]) and (not typeis([terr])) then if ((lextyp = lexor) and typeis([tbl])) or ((lextyp in [lexadd,lexsub]) and typeis([tin,tre])) then begin over(ctop, maxcons); while lextyp in [lexor,lexadd,lexsub] do begin ctop := ctop + 1; op := lextyp; getkey; term; if (op = lexor) and typeis([tbl]) then with ctab[ctop-1] do cb := cb or ctab[ctop].cb else if (op in [lexadd,lexsub]) and typeis([tin,tre]) then with ctab[ctop-1] do if (ctyp = tin) and (ctab[ctop].ctyp = tin) then case op of lexadd: ci := ci + ctab[ctop].ci; lexsub: ci := ci - ctab[ctop].ci end else begin forcereal; case op of lexadd: cr := cr + ctab[ctop].cr; lexsub: cr := cr - ctab[ctop].cr end end else if ctab[ctop].ctyp <> terr then experror('arith- bad type'); ctop := ctop - 1; end end end; { arith } procedure ckformal{name: alfa; var found: boolean}; var a : aptr; begin { ckformal } found := false; if mtop > 0 then begin a := mstack[mtop].margs; while (a <> nil) and (not found) do begin with a^ do if aform = name then begin found := true; pushback; mtop := mtop + 1; with mstack[mtop] do begin margs := nil; mnext := afirst; mlast := alast; matop := atop; end; getch; end; a := a^.anext; end; if found then gettok end end; { ckformal } procedure ckmacro{name: alfa; var found: boolean}; var d : drng; { index to defined macros } begin { ckmacro } d := dtop; defs[0].dname := name; while defs[d].dname <> name do d := d - 1; if d > 0 then begin found := true; if d <= nsysmac then dosysmac(d) else begin over(mtop, maxcalls); with mstack[mtop+1], defs[d] do begin margs := nil; mnext := dfirst; mlast := dlast; matop := atop; while ch = blank do getch; if ch = lparen then begin getch; getactuals(dargs, margs); if ch <> rparen then error('ckmacro- right paren expected'); end else error('ckmacro- left paren expected') end; mtop := mtop + 1; getch; end; gettok; end; end; { ckmacro } procedure closefile; begin { close } close(infile); ftop := ftop - 1; if ftop >= 0 then with fstack[ftop] do openfile(ffcb, infile, ffcb.inlfn); end; { close } procedure convrt; var i : integer; c : char; sign: boolean; xxx : packed array[1..5] of char; temp: string[36]; begin { convrt } with ctab[ctop] do case ctyp of tin: begin str(ci, temp); lexlen := length(temp); moveleft(temp[1], lexstr[1], lexlen); lextyp := lexint; end; terr:; tot: begin moveleft(co[1], lexstr[1], alfaleng); lextyp := lexalpha; while lexstr[lexlen] = blank do lexlen := lexlen - 1; end; tch: begin lextyp := lexst; lexstr[1] := quote; moveleft(cstr[cfirst], lexstr[2], clen); lexlen := clen + 2; lexstr[lexlen] := quote end; tbl: begin lextyp := lexalpha; if cb then begin xxx := 'TRUE ';moveleft(xxx[1], lexstr[1], 4);lexlen := 4 end else begin xxx := 'FALSE';moveleft(xxx[1], lexstr[1], 5);lexlen := 5 end end; tre: begin error('convrt- real conversion not implemented'); end; end; end; { convrt } procedure convrti; var i : integer; l : lnrng; begin { convrti } with ctab[ctop] do begin ctyp := tin; ci := 0; for l := 1 to lexlen do ci := 10 * ci + ord(lexstr[l])-ord(zero); end; end; { convrti } procedure convrtr; var i : lnrng; begin { convrtr } (* reset(dummy); for i := 1 to lexlen do write(dummy, lexstr[i]); writeln(dummy, blank); reset(dummy); with ctab[ctop] do begin ctyp := tre; read(dummy, cr) end; *) error('convrtr - not implemented'); end; { convrtr } procedure convrts; var l : lnrng; begin { convrts } with ctab[ctop] do begin ctyp := tch; clen := lexlen-2; cfirst := cstop + 1; over(cstop+clen,maxcstr); moveleft(lexstr[2], cstr[cfirst], clen); cstop := cstop + clen; end; end; { convrts } procedure docodeif; var a : dsrng; { save area for dtop upon entry } ctr : integer; { left parent count } begin { docodeif } getkey; over(ctop,maxcons); ctop := ctop + 1; expression; ctop := ctop - 1; a := atop; if lextyp <> lexcomma then experror('docodeif- comma expected') else with ctab[ctop+1] do if ctyp = tbl then if cb then begin over(mtop, maxcalls); with mstack[mtop+1] do begin margs := nil; mlast := atop - 1; getcdparm; mnext := atop; matop := a; end; mtop := mtop + 1; getch end else begin ctr := 1; while ctr > 0 do begin if ch = newline then begin if (mtop = 0) and (ftop = 0) and (fstack[0].ffcb.endfile) then begin error('docodeif- unexpected end of file'); exit(map) end end else if ch = rparen then ctr := ctr - 1 else if ch = lparen then ctr := ctr + 1; getch end end else if ctyp <> terr then error('docodeif- type error. boolean needed.') end; { docodeif } procedure dodefine; begin { dodefine } gettok; if lextyp <> lexalpha then error('dodefine- name expected') else begin over(dtop, maxdefs); dtop := dtop + 1; with defs[dtop] do begin dname[1] := dollar; moveleft(lexstr[1], dname[2], alfaleng-1); dfirst := dstop + 1; dlast := dstop; gettok; if lextyp = lexlparen then begin gettok; getformals(dargs); gettok end else dargs := nil end; if lextyp <> lexcomma then begin error('dodefine- missing comma'); dtop := dtop - 1 end else getbody; end; end; { dodefine } procedure doinclude; var name: lfnstring; begin { doinclude } {$R- disable string range checks } getbsu; if lextyp <> lexalpha then error('doinclude- bad file name') else begin lexstr[0] := chr(lexlen); moveleft(lexstr[1], name[1], lexlen); getkey; if lextyp <> lexrparen then error('doinclude- right paren expected'); open(name) end; end; { doinclude } procedure doindex; var i : lnrng; begin { doindex } over(ctop, maxcons); ctop := ctop + 1; getkey; if lextyp = lexrparen then with ctab[ctop] do begin ctyp := tin; ci := 0 end else expression; if lextyp <> lexrparen then error('doindex- right paren expected') else begin pushback; with ctab[ctop] do if not (ctyp in [terr,tin]) then error('doindex- type error. integer needed') else if ctyp = tin then begin index := index + 1; ci := ci + index; convrt; over(mtop, maxcalls); mtop := mtop + 1; with mstack[mtop] do begin margs := nil; mnext := atop; mlast := atop - 1; matop := atop; for i := lexlen downto 1 do begin mnext := mnext - 1; defstr[mnext] := lexstr[i]; end; getch end end end; ctop := ctop - 1; end; { doindex } procedure dooptions; var i : integer; begin { dooptions } gettok; while not (lextyp in [lexrparen,lexeof]) do begin if lextyp = lexalpha then if toupper(lexstr[1]) in ['R', 'P', 'N', 'L', 'E'] then case lexstr[1] of 'P', 'R': begin while not (ch in ['0'..'9', ')']) do getch; i := 0; while ch in ['0'..'9'] do begin i := 10 * i + ord(ch) - ord('0'); getch end; if (mincol <= i) and (i <= maxcol) then case toupper(lexstr[1]) of 'P': prcopt := i; 'R': rcopt := i end { case }; end; 'N': if lexlen >= 3 then if toupper(lexstr[3]) = 'L' then listopt := false else if toupper(lexstr[3]) = 'E' then expropt := false; 'L': listopt := true; 'E': expropt := true end else error('dooptions- error in option list') else if lextyp <> lexcomma then error('dooptions- comma expected'); gettok end; end; { dooptions } procedure dosysmac{d: drng}; { which macro } begin { dosysmac } gettok; if lextyp <> lexlparen then error('dosysmac- left paren expected') else case d of sysinc: doinclude; syscodeif: docodeif; sysindex: doindex; sysdefine: dodefine; sysoption: dooptions; end end; { dosysmac } procedure error{err: errmsg}; var i: lnrng; begin { error } need(2); if listopt then writeln(space, errflag, space:next-1, arrow) else writeln(' AT LINE:', line:2, ' (pascal line:', pline:2, ')'); writeln(space, errprefix, err); nerrors := nerrors + 1; end; { error } procedure evalfns{f: fns}; begin { evalfns } case f of fabs: evalabs; fatn: evalatn; fchr: evalchr; fcos: evalcos; fexp: evalexp; flen: evallen; fln: evalln; fodd: evalodd; ford: evalord; frou: evalrou; fsin: evalsin; fsqr: evalsqr; fstr: evalstr; ftru: evaltru end { case }; end; { evalfns } procedure evalabs; begin { evalabs } with ctab[ctop] do if typeis([tre,tin]) then case ctyp of tin: ci := abs(ci); tre: cr := abs(cr); end else experror('evalabs- type error. Number needed.'); end; { evalabs } procedure evalatn; begin { evalatn } writeln('--UNIMP--17'); end; { evalatn } procedure evalchr; var i : integer; begin { evalchr } with ctab[ctop] do if ctyp = tin then begin i := ci; ctyp := tch; over(cstop, atop); cstop := cstop + 1; clen := 1; cstr[cstop] := chr(i); cfirst := cstop end else experror('evalchr- type error. Number needed.'); end; { evalchr } procedure evalcos; begin { evalcos } writeln('--UNIMP--19'); end; { evalcos } procedure evalexp; begin { evalexp } writeln('--UNIMP--20'); end; { evalexp } procedure evallen; var i : integer; begin { evallen } with ctab[ctop] do if ctyp = tch then begin i := clen; cstop := cfirst - 1; ctyp := tin; ci := i end else experror('evallen- type error. String needed.'); end; { evallen } procedure evalln; begin { evalln } writeln('--UNIMP--22'); end; { evalln } procedure evalodd; var i : integer; begin { evalodd } with ctab[ctop] do if ctyp = tin then begin i := ci; ctyp := tbl; cb := odd(i) end else error('evalodd- type error. Number expected'); end; { evalodd } procedure evalord; var c : char; begin { evalord } with ctab[ctop] do if ctyp = tch then if clen = 1 then begin c := cstr[cfirst]; ctyp := tin; ci := ord(c) end else experror('evalord- ord requires 1 char arg') else experror('evalord- type error. Char needed'); end; { evalord } procedure evalrou; var r : real; begin { evalrou } with ctab[ctop] do if ctyp = tre then begin r := cr; ctyp := tin; ci := round(r) end else error('evalrou- type error. Real number expected'); end; { evalrou } procedure evalsin; begin { evalsin } writeln('--UNIMP--26'); end; { evalsin } procedure evalsqr; begin { evalsqr } with ctab[ctop] do if typeis([tre,tin]) then case ctyp of tin: ci := sqr(ci); tre: cr := sqr(cr); end { case } else experror('evalsqr- type error. Number needed'); end; { evalsqr } procedure evalstr; var astring: string[10]; begin { evalstr } with ctab[ctop] do if ctyp <> tin then experror('evalstr- type error. Integer needed') else begin ctyp := tch; str(ci, astring); clen := length(astring); cfirst := cstop + 1; over(cfirst+clen, atop); moveleft(astring[1], cstr[cfirst], clen); cstop := cstop + clen; end; end; { evalstr } procedure evaltru; var r : real; begin { evaltru } with ctab[ctop] do if ctyp = tre then begin r := cr; ctyp := tin; ci := trunc(r) end else experror('evaltru- type error. Real needed'); end; { evaltru } procedure experror{err: errmsg}; begin { experror } error(err); ctab[ctop].ctyp := terr; flush; end; { experror } procedure expression; begin { expression } relate; if typeis([tch]) then begin over(ctop, maxcons); ctop := ctop + 1; while lextyp in [lexst,lexalpha] do begin relate; if typeis([tch]) then with ctab[ctop-1] do clen := clen + ctab[ctop].clen else if not typeis([terr]) then experror('expression- invalid operand type') end; ctop := ctop - 1; end; end; { expression } procedure factor; var op : lex; begin { factor } if lextyp in [lexnot,lexsub] then begin op := lextyp; getkey; factor; with ctab[ctop] do if typeis([tbl]) and (op = lexnot) then cb := not cb else if typeis([tin,tre]) and (op = lexsub) then case ctyp of tin: ci := -ci; tre: cr := -cr; end else if ctyp <> terr then begin ctyp := terr; error('factor- type conflict') end end else if lextyp = lexlparen then begin getkey; expression; if not typeis([terr]) then if lextyp <> lexrparen then experror('factor- right paren expected') else getkey end else variable end; { factor } procedure findcon{name: alfa; var found: boolean}; var c : crng; i, f : integer; begin { findcon } c := cvalid; ctab[0].cname := name; while ctab[c].cname <> name do c := c - 1; if c > 0 then begin ctab[ctop] := ctab[c]; with ctab[ctop] do if ctyp = tch then begin over(cstop+clen, maxcstr); cfirst := cstop + 1; f := ctab[c].cfirst; for i := 0 to clen-1 do begin cstop := cstop + 1; cstr[cstop] := cstr[f + i] end end; found := true end; end; { findcon } procedure flookup{name: alfa; var fun: fns; var found: boolean}; var f : fnrng; begin { flookup } funct[0].fnnme := name; f := maxfns; while funct[f].fnnme <> name do f := f - 1; found := f <> 0; if found then fun := funct[f].fntyp; end; { flookup } procedure flush; begin { flush } while not (lextyp in [lexeof,lexsemi]) do getkey; end; { flush } procedure forcereal; var i : integer; begin { forcereal } with ctab[ctop] do if ctyp = tin then begin i := ci; ctyp := tre; cr := i end; with ctab[ctop-1] do if ctyp = tin then begin i := ci; ctyp := tre; cr := i end; end; { forcereal } procedure getactuals{f: fptr; var act: aptr}; begin { getactuals } if f = nil then { if no formals then no actuals } else begin new(act); with act^, f^ do begin aform := fname; alast := atop - 1; getparm; afirst := atop; if ch = comma then getch; getactuals(fnext, anext) end; end; end; { getactuals } procedure getbody; var ctr : integer; { left paren counter } begin { getbody } if ch = rparen then with defs[dtop] do begin getch; dlast := dstop; dfirst := dstop + 1 end else begin ctr := 1; with defs[dtop] do begin while ctr > 0 do begin over(dstop, atop); dstop := dstop + 1; defstr[dstop] := ch; dlast := dstop; if ch = rparen then ctr := ctr - 1 else if ch = lparen then ctr := ctr + 1 else if (ch = newline) and (ftop = 0) and fstack[0].ffcb.endfile then begin error('getbody- unexpected eof'); exit(map) end; getch end; defstr[dlast] := blank { replace trailing ")" } end end end; { getbody } procedure getbsu; var name : alfa; found : boolean; begin { getbsu } gettok; while lextyp = lexmac do begin moveleft(lexstr[1], name[1], alfaleng); ckformal(name, found); if not found then begin ckmacro(name, found); if not found then begin error('getbsu- undefined macro call'); gettok end end; end; end; { getbsu } procedure getcdparm; var ctr : integer; d : dsrng; begin { getcdparm } d := dstop; ctr := 0; while (ctr > 0) or (ch <> rparen) do begin over(d, atop); d := d + 1; defstr[d] := ch; if ch = lparen then ctr := ctr + 1 else if ch = rparen then ctr := ctr - 1; getch end; if d > dstop then begin over(d, atop); d := d + 1; defstr[d] := blank; while d > dstop do begin atop := atop - 1; defstr[atop] := defstr[d]; d := d - 1; end end; end; { getcdparm } procedure getch; begin { getch } if mtop > 0 then while (mstack[mtop].mnext > mstack[mtop].mlast) and (mtop > 0) do begin atop := mstack[mtop].matop; mtop := mtop - 1 end; if mtop > 0 then with mstack[mtop] do begin ch := defstr[mnext]; mnext := mnext + 1 end else begin if next > last then getline; ch := inline[next]; next := next + 1; end; end; { getch } procedure getformals{var f: fptr}; begin { getformals } if lextyp <> lexalpha then f := nil else begin new(f); with f^ do begin fname[1] := dollar; moveleft(lexstr[1], fname[2], alfaleng-1); gettok; if lextyp = lexcomma then begin gettok; getformals(fnext) end else fnext := nil end; end end; { getformals } procedure getkey; var name : alfa; { name of constant } k : krng; { pointer to keywords } begin { getkey } getbsu; if lextyp = lexalpha then begin moveleft(lexstr[1], name[1], alfaleng); keywd[0].kname := name; k := maxkeys; while keywd[k].kname <> name do k := k - 1; if k > 0 then lextyp := keywd[k].klex end; end; { getkey } procedure getline; var i : integer; mode : (skipping,nonblank,endline,endfile); begin { getline } while fstack[ftop].ffcb.endfile and (ftop > 0) do closefile; {$R- disable string range checks } if fstack[ftop].ffcb.endfile then begin next := 1; last := 0; inline[next] := newline; inline[0] := chr(next) end else with fstack[ftop] do begin if listopt then begin writeln('UNIMP'); end else repeat if not ffcb.endfile then begin getstring(ffcb, infile, inline); if not onscreen then begin if (line mod 50) = 0 then begin writeln; write('<', line:4, '> ') end; write('.'); end; line := line + 1; fline := fline + 1; next := 1; insert(blank, inline, length(inline)+1); last := length(inline); mode := skipping; repeat if next > last then mode := endline else if inline[next] <> blank then mode := nonblank else next := next + 1; until mode <> skipping; end else begin next := 1; last := 0; inline[next] := newline; inline[0] := chr(next); mode := endfile; end; until mode <> endline; inline[last+1] := newline; {$R+} end; end; { getline } procedure getparm; var ctr : integer; d : dsrng; begin { getparm } d := dstop; ctr := 0; while (ctr > 0) or not (ch in [comma,rparen]) do begin over(d, atop); d := d + 1; defstr[d] := ch; if ch = lparen then ctr := ctr + 1 else if ch = rparen then ctr := ctr - 1; getch; end; if d > dstop then begin over(d, atop); d := d + 1; defstr[d] := blank; while d > dstop do begin { move parm to right } atop := atop - 1; defstr[atop] := defstr[d]; d := d - 1 end; end; end; { getparm } ======================================================================================== DOCUMENT :usus Folder:VOL07:map-b.text ======================================================================================== { MAP-B } procedure gettok; procedure readname; begin { readname } getch; ch := toupper(ch); lextyp := lexalpha; fillchar(lexstr[2], alfaleng, space); while ch in ['A'..'Z', '0'..'9'] do begin putc(ch); getch; ch := toupper(ch) end; if lexlen > alfaleng then lexlen := alfaleng; end; { readname } procedure readnumber; begin { readnumber } getch; lextyp := lexint; while ch in ['0'..'9'] do begin putc(ch); getch end; if ch = period then begin getch; if ch = period then pushback else begin lextyp := lexreal; putc(period); while ch in ['0'..'9'] do begin putc(ch); getch end end end; ch := toupper(ch); if ch = lettere then begin lextyp := lexreal; putc(ch); getch; if ch in [plus,minus] then begin putc(ch); getch end; while ch in ['0'..'9'] do begin putc(ch); getch end; end; end; { readnumber } procedure readc1; { handle comment } begin { readc1 } getch; if ch = dollar then begin lexlen := 0; putc('('); putc('*'); putc('$'); repeat repeat getch; putc(ch); until ch = star; getch; putc(ch); until ch = rparen; getch; end else begin lexlen := 0; repeat while ch <> star do getch; getch; until ch = rparen; getch end end; { readc1 } procedure readc2; { handle comment } begin { readc2 } getch; if ch = dollar then begin lexlen := 0; putc('{'); putc(dollar); repeat getch; putc(ch); until ch = '}'; getch; end else begin lexlen := 0; repeat getch; until ch = '}'; getch; end; end; { readc2 } procedure readmacro; begin { readmacro } getch; ch := toupper(ch); if not (ch in ['A'..'Z']) then begin error('readmacro- illegal macro name'); lexlen := 0 end else begin lextyp := lexmac; fillchar(lexstr[lexlen+1], alfaleng-lexlen, space); while ch in ['A'..'Z', '0'..'9'] do begin putc(ch); getch; ch := toupper(ch); end; if lexlen > alfaleng then lexlen := alfaleng; end; end; { readmacro } procedure readstring; begin { readstring } lexlen := 0; repeat over(lexlen, maxline); putc(ch); repeat getch; if ch = newline then begin error('readstring- string exceeds source line'); pushback; ch := quote { supply missing quote } end; over(lexlen, maxline); putc(ch) until lexstr[lexlen] = quote; getch; until ch <> quote; lextyp := lexst; end; { readstring } procedure readlop; begin { readlop } getch; if ch = equal then begin lexlen := 2; lexstr[2] := equal; lextyp := lexle; getch end else if ch = greater then begin lexlen := 2; lexstr[2] := greater; lextyp := lexne; getch end else lextyp := lexlt end; { readlop } procedure readgop; begin { readgop } getch; if ch = equal then begin lexlen := 2; lexstr[2] := equal; lextyp := lexge; getch end else lextyp := lexgt end; { readgop } begin { gettok } lexlen := 0; while lexlen = 0 do begin while ch = blank do getch; ch := toupper(ch); lexlen := 1; lextyp := lexother; lexstr[1] := ch; if ch = newline then if (ftop = 0) and (fstack[ftop].ffcb.endfile) then lextyp := lexeof else begin getch; ch := toupper(ch); lexlen := 0 end else if ch in ['A'..'Z'] then readname else if ch in ['0'..'9'] then readnumber else case ch of '+': begin lextyp := lexadd; getch end; '-': begin lextyp := lexsub; getch end; '*': begin lextyp := lexmult; getch end; '/': begin lextyp := lexdvd; getch end; '(': begin getch; if ch <> star then lextyp := lexlparen else readc1; end; '{': readc2; ')': begin lextyp := lexrparen; getch; end; '$': readmacro; '=': begin lextyp := lexeq; getch end; ',': begin lextyp := lexcommac; getch end; '.': begin getch; if ch = period then begin lexstr[2] := period; lexlen := 2; getch end; end; '''': readstring; ':': begin getch; if ch = equal then begin putc('='); getch end end; '<': readlop; '>': readgop; ';': begin lextyp := lexsemi; getch end; '[', ']', '^', '_', '?': getch { all other characters } end; end; end; { gettok } procedure need{L: pgrng}; begin { need } if (linectr + 1) > pagesize then begin linectr := 1; newpg end else linectr := linectr + l; end; { need } procedure newpg; begin { newpg } end; { newpg } procedure open{name: lfnstring}; { file name to open } var f : flrng; begin { open } over(ftop, maxfiles); fstack[ftop+1].ffcb.inlfn := name; f := 0; while fstack[f].ffcb.inlfn <> name do f := f + 1; if f <= ftop then error('open- recursive includes ignored') else begin ftop := ftop + 1; with fstack[ftop] do begin openfile(ffcb, infile, name); fline := 0; last := 0; next := 1; inline := ' '; inline[next] := newline; mtop := 0; getch end end; end; { open } procedure over{i: integer; maxval: integer}; begin { over } if i >= maxval then begin error('over- table overflow'); exit(map) end; end; { over } procedure parse{top: crng; tok: lex}; begin { parse } getkey; while not (lextyp in [lexeof,lexend,lexfwd]) do if lextyp in [lexrec,lexfun,lexproc,lexcon,lexmcon,lexbeg,lexcas] then case lextyp of lexbeg: begin puttok; if tok in [lexproc,lexfun] then begin tok := lexbeg; getkey; end else parse(ctop, lexbeg) end; lexcas: begin puttok; if tok = lexrec then getkey else parse(ctop, lexcas) end; lexcon: begin puttok; if expropt then parsecon else getkey end; lexfun: begin puttok; scanheader; parse(ctop, lexfun) end; lexmcon: parsemcon; lexproc: begin puttok; scanheader; parse(ctop, lexproc) end; lexrec: begin puttok; parse(ctop, lextyp) end; end { case } else begin puttok; getkey end; puttok; if (lextyp = lexeof) and (tok <> lexeof) then begin error('parse- unexpected end of file'); exit(map) end else if (lextyp = lexend) and not (tok in [lexbeg,lexcas,lexrec]) then error('parse- unmatched end') else if (lextyp = lexfwd) and not (tok in [lexproc,lexfun]) then error('parse- unmatched forward'); if lextyp <> lexeof then getkey; ctop := top; cvalid := top end; { parse } procedure parsecon; var savtyp : lex; savstr : strng; savlen : lnrng; svalid : boolean; consnam : alfa; begin { parsecon } getkey; while lextyp = lexalpha do begin puttok; over(ctop,maxcons); ctop := ctop + 1; moveleft(lexstr[1], consnam[1], alfaleng); getkey; if lextyp <> lexeq then begin error('parsecon- equal sign needed'); ctab[ctop].ctyp := terr; flush; getkey; end else begin puttok; getkey; while ch = blank do getch; if (ch = semi) and (lextyp in [lexint,lexreal,lexother]) then begin savstr := lexstr; savlen := lexlen; savtyp := lextyp; svalid := true end else svalid := false; expression; if (lextyp <> lexsemi) and (not typeis([terr])) then begin experror('parsecon- semi colon expected'); ctab[ctop].ctyp := terr end; if ctab[ctop].ctyp <> terr then begin if svalid then begin lexstr := savstr; lextyp := savtyp; lexlen := savlen end else convrt; puttok; lextyp := lexsemi; lexstr[1] := semi; lexlen := 1; puttok; ctab[ctop].cname := consnam; cvalid := ctop; end else begin lexstr[1] := zero; lexstr[2] := semi; lextyp := lexst; lexlen := 2; puttok; end end; if ctab[ctop].ctyp in [terr,tot] then ctop := ctop - 1; getkey end end; { parsecon } procedure parsemcon; var consnam : alfa; begin { parsemcon } getkey; while lextyp = lexalpha do begin over(ctop, maxcons); ctop := ctop + 1; moveleft(lexstr[1], consnam, alfaleng); getkey; if lextyp <> lexeq then begin error('parsemcon- equal sign needed'); ctab[ctop].ctyp := terr; flush; getkey end else begin getkey; while ch = blank do getch; expression; if (lextyp <> lexsemi) and (not typeis([terr])) then begin error('parsemcon- semi colon expected'); ctab[ctop].ctyp := terr end; if ctab[ctop].ctyp <> terr then begin ctab[ctop].cname := consnam; cvalid := ctop end; end; if ctab[ctop].ctyp in [terr,tot] then ctop := ctop - 1; getkey end end; { parsemcon } procedure pushback; begin { pushback } if mtop > 0 then with mstack[mtop] do mnext := mnext - 1 else next := next - 1 end; { pushback } procedure putc{ch: char}; begin { putc } lexlen := lexlen + 1; lexstr[lexlen] := ch end; { putc } procedure puttok; begin { puttok } if (lastlex in confl) and (lextyp in confl) then begin write(psource, blank); outpos := outpos + 1 end; if lextyp = lexeof then begin writeln(psource); outpos := 0 end else begin if (outpos+lexlen) > prcopt then begin pline := pline + 1; writeln(psource); outpos := 0; if lexlen > prcopt then begin error('puttok- token too large'); lexlen := prcopt end end; write(psource, lexstr:lexlen); outpos := outpos + lexlen; lastlex := lextyp end; end; { puttok } procedure relate; var op : lex; i : integer; r : real; c1, c2 : csrng; begin { relate } arith; while (lextyp in [lexlt..lexne]) and (not typeis([terr])) do begin over(ctop, maxcons); ctop := ctop + 1; op := lextyp; getkey; arith; if typesmatch then with ctab[ctop-1] do case ctyp of tin: begin i := ci; ctyp := tbl; case op of lexlt: cb := i < ctab[ctop].ci; lexle: cb := i <= ctab[ctop].ci; lexeq: cb := i = ctab[ctop].ci; lexge: cb := i >= ctab[ctop].ci; lexgt: cb := i > ctab[ctop].ci; lexne: cb := i <> ctab[ctop].ci; end; end; tre: begin r := cr; ctyp := tbl; case op of lexlt: cb := r < ctab[ctop].cr; lexle: cb := r <= ctab[ctop].cr; lexeq: cb := r = ctab[ctop].cr; lexge: cb := r >= ctab[ctop].cr; lexgt: cb := r > ctab[ctop].cr; lexne: cb := r <> ctab[ctop].cr; end; end; tbl: begin case op of lexlt: cb := cb < ctab[ctop].cb; lexle: cb := cb <= ctab[ctop].cb; lexeq: cb := cb = ctab[ctop].cb; lexge: cb := cb >= ctab[ctop].cb; lexgt: cb := cb > ctab[ctop].cb; lexne: cb := cb <> ctab[ctop].cb; end; end; tot: begin experror('relate- illegal type for rel. op'); ctyp := terr end; tch: begin c1 := cfirst; c2 := ctab[ctop].cfirst; i := 1; while (i < clen) and (cstr[c1] = cstr[c2]) do begin i := i + 1; c1 := c1 + 1; c2 := c2 + 1 end; cstop := cstop - clen - ctab[ctop].clen; ctyp := tbl; case op of lexlt: cb := cstr[c1] < cstr[c2]; lexle: cb := cstr[c1] <= cstr[c2]; lexeq: cb := cstr[c1] = cstr[c2]; lexge: cb := cstr[c1] >= cstr[c2]; lexgt: cb := cstr[c1] > cstr[c2]; lexne: cb := cstr[c1] <> cstr[c2]; end; end; end else if ctab[ctop].ctyp <> terr then begin experror('relate- type conflict in relation'); ctab[ctop].ctyp := terr end; ctop := ctop - 1; end; end; { relate } procedure scanheader; var ctr : integer; begin { scanheader } getkey { get name }; puttok; getkey { get paren if parameters }; if lextyp <> lexlparen then puttok else begin ctr := 1; puttok; repeat getkey; if lextyp = lexlparen then ctr := ctr + 1; if lextyp = lexrparen then ctr := ctr - 1; puttok; until ctr = 0; end; end; { scanheader } procedure term; var op : lex; begin { term } factor; if (lextyp in [lexand..lexmod]) and (not typeis([terr])) then if (typeis([tbl]) and (lextyp = lexand)) or (typeis([tre]) and (lextyp in [lexmult..lexmax])) or (typeis([tin]) and (lextyp in [lexmult..lexmod])) then while lextyp in [lexand..lexmod] do begin ctop := ctop + 1; op := lextyp; getkey; factor; with ctab[ctop-1] do if (op = lexand) and (ctyp = tbl) then cb := cb and ctab[ctop].cb else if (op in [lexdiv..lexmod]) and (ctyp = tin) then case op of lexdiv: ci := ci div ctab[ctop].ci; lexmod: ci := ci mod ctab[ctop].ci; end { case } else if (op in [lexmult..lexmax]) and typeis([tin,tre]) then begin if (ctyp = tin) and (typeis([tin])) and (op <> lexdvd) then case op of lexmult: ci := ci * ctab[ctop].ci; lexmin: if ctab[ctop].ci < ci then ci := ctab[ctop].ci; lexmax: if ctab[ctop].ci > ci then ci := ctab[ctop].ci; end { case } else begin forcereal; case op of lexmult: cr := cr * ctab[ctop].cr; lexdvd: cr := cr / ctab[ctop].cr; lexmin: if ctab[ctop].cr < cr then cr := ctab[ctop].cr; lexmax: if ctab[ctop].cr > cr then cr := ctab[ctop].cr; end { case } end end else if ctab[ctop].ctyp <> terr then experror('term- invalid operand type'); ctop := ctop - 1; end else error('term- invalid operand type'); end; { term } procedure terminate; begin { terminate } close(psource, lock); end; { terminate } function toupper{ch: char): char}; begin { toupper } if (ch >= 'a') then if (ch <= 'z') then toupper := chr(ord(ch)-ord('a')+ord('A')) else toupper := ch else toupper := ch; end; { toupper } function typeis{c: cset): boolean}; begin { typeis } typeis := ctab[ctop].ctyp in c end; { typeis } function typesmatch{: boolean}; begin { typesmatch } typesmatch := false; with ctab[ctop-1] do if ctyp = ctab[ctop].ctyp then if ctyp <> tch then typesmatch := true else if clen = ctab[ctop].clen then typesmatch := true end; { typesmatch } procedure variable; var name : alfa; found : boolean; fun : fns; begin { variable } if not (lextyp in [lexalpha,lexint,lexreal,lexst]) then begin experror('variable- value or name expected'); ctab[ctop].ctyp := terr end else case lextyp of lexint: begin convrti; getkey end; lexreal: begin convrtr; getkey end; lexst: begin convrts; getkey end; lexalpha: begin moveleft(lexstr[1], name[1], alfaleng); getkey; found := false; if lextyp <> lexlparen then begin findcon(name,found); if not found then with ctab[ctop] do begin ctyp := tot; co := name end end else begin flookup(name, fun, found); { function call } if not found then experror('variable- unknown function. 0 used') else begin getkey; expression; if lextyp <> lexrparen then experror('variable- right paren expected') else begin getkey; evalfns(fun) end end end end end { case }; end; { variable } ======================================================================================== DOCUMENT :usus Folder:VOL07:map.doc.text ======================================================================================== DOCUMENTATION FOR MAP - from the Pascal User Group News #17 MAP provides four basic functions to Pascal: constant expression evalu- ation, source file inclusion, parameterized macro substitution, and condition- al compilation. This section discusses each of these facilities. MAP evaluates constant expressions (expressions where operands are constants or previously defined symbolic constants) on the right-hand side of CONST declarations. Expressions may contain the following operators (listed in descending precedence): function: name (arguments) negating: NOT - multiplying: AND * / DIV MOD MIN MAX adding: OR + relating: < <= = <> >= > concatenating: (one or more blanks) All standard operators have the same meaning as in Pascal, and strong typing is observed. The operators MIN and MAX require operators of type INTEGER or REAL and return the smaller and larger of their operands, respectively. Concatenation requires operands of type PACKED ARRAY OF CHAR, and returns a PACKED ARRAY OF CHAR which is their concatenation (the type CHAR is assumed to be a packed array of one character for concatenation). MAP recognizes the standard Pascal functions ABS, SQR, CHR, ORD, ROUND, TRUNC, as well as two nonstandard functions, LENGTH and STRINGOF. LENGTH requires an argument of type PACKED ARRAY OF CHAR or CHAR, and returns the number of characters in it. STRINGOF requires an integer argument, and returns a PACKED ARRAY OF CHAR consisting of its decimal representation. Operands in CONST expressions may be constants or previously defined CONST names. Of course, Pascal scope rules apply to defined names. MAP also provides several predefined symbolic constants which may be used in CONST expressions. Two especially useful predefined names, TIME and DATE, give the time and date on which the compilation was performed. These predefined constants help when writing production programs that must be time and date stamped. For example, in a production program a heading is usually printed whenever the program runs: 'PROGRAM XYZ COMPILED ON mm/dd/yy AT hh:mm:ss' Such a heading may provide the only link between an object version of a program and its source. Unfortunately, a programmer may fail to update the heading when making changes to the program. Using the predefined constants in MAP to create the heading relieves the programmer of the updating task and guarantees the heading will always be accurate: CONST READING = 'PROGRAM XYZ COMPILED ON' DATE 'AT' TIME; In addition to constant expression evaluation, MAP supplies a macro substitution facility. A macro, which may have zero or more formal parameters, may be defined anywhere in the source program using the syntax: $DEFINE(name(formals),value) where 'name' is a valid Pascal identifier, 'formals' is a list of identifiers separated by commas, and 'value' is a sequence of Pascal tokens which is well balanced with respect to parentheses. Once a macro has been defined, it can be called by coding: $name(actuals) where 'name' is the name of the macro, and 'actuals' is a list of actual parameters separated by commas. Each actual parameter must be a sequence of Pascal tokens which is well balanced with respect to parentheses. In addition to the user-defined macros, MAP recognizes several system macros. Definition of a new macro, as shown above, requires the use of one such system macro, DEFINE. Another system macro, INCLUDE, provides for source file inclusion. When MAP encounters a call: $INCLUDE(file name) it opens the named file, and continues processing, reading input from the new file. Upon encountering an end-of-file condition, MAP closes the included file, and resumes processing the original file. Includes may be nested, but they may not be recursive (even though there is a way to prevent infinite recursion). One may think of 'include' as a macro whose body is an entire file. This view, however, does not reflect the fact that the user also expects included text to be listed like standard input rather than like the body of a macro. While macro expansions are not usually displayed in the source listing, included files are. Therefore, INCLUDE has a special status among macros. One other system macro, CODEIF, is provided to support the conditional compilation of code. The syntax of CODEIF is: $CODEIF(constant Boolean expression,code) where the 'constant Boolean expression' follows the rules for CONST expressions outlined previously, and 'code' represents a sequence of Pascal tokens which is well balanced with respect to parentheses. If the Boolean expression evaluates to 'true', the code is compiled; if the expression evaluates to 'false', the code is skipped. REFERENCE D. Comer, 'A Pascal Macro Preprocessor for Large Program Development', Software Practice and Experience, Vol. 9, 203-209, 1979. ======================================================================================== DOCUMENT :usus Folder:VOL07:map.text ======================================================================================== { { MAP - Pascal macro preprocessor { written by Doug Comer, Purdue University Computing Center { { from Pascal News #17 { { Copyright (C) 1978. Permission to copy, modify and distribute, { but not for profit, is hereby granted, { provided that this not is included. { Jul 1980 - Modifications for UCSD Pascal - dhd } {$S+ permit compiler to swap } program map; uses fastread; const alfaleng = 10; arrow = '^'; blank = ' '; break = ' '; comma = ','; defexpr = true; { default for expression evaluation } deflist = false;{ default for listing } defprc = 71; { default right column for Pascal } defrc = 140; { default right column for map input } dollar = '$'; double = '0'; { double space carriage control } equal = '='; errprefix = '---> error '; errlen = 40; { length of error messages } errflag = ' '; greater = '>'; letterb = 'B'; lettere = 'E'; lparen = '('; maxcalls = 15; { max macro call depth } maxcons = 200; { max active const defns } maxcol = 120; { max right col for input/output } maxcstr = 1000; { max const string area } maxdefs = 100; { max defined macros } maxdefstr = 4000; { max macro string area } maxfiles = 1; { max included file depth } maxfns = 14; { max recognized functions } maxkeys = 21; { max recognized language keywords } maxline = 140; { max characters / input line } mincol = 70; { min right column for input/output } minus = '-'; ndefconst = 9; { number of pre-defined constants } nsysmac = 5; { number of system macros } pagesize = 55; { lines/page not counting heading } period = '.'; plus = '+'; quote = ''''; rparen = ')'; semi = ';'; space = ' '; star = '*'; sysinc = 1; { codes for system macros } syscodeif = 2; sysindex = 3; sysdefine = 4; sysoption = 5; (* title = ' M A P (vers 2.0p of 4/30/79)'; title1a = ' run on '; title1b = ' at '; title2 = ' include pascal'; title3 = ' line file line line source'; title4 = ' ---- ------------- ------ ------------'; title5 = '------------------------------------------------'; title6 = '-----'; *) zero = '0'; type alfa = packed array[1..alfaleng] of char; crng = 0..maxcons; { constant expression stack } csrng = 0..maxcstr; { constant expression string area } drng = 0..maxdefs; { macro defination stack } dsrng = 0..maxdefstr; { macro def string area } flrng = 0..maxfiles; { included file stack } fnrng = 0..maxfns; { built-in functions } krng = 0..maxkeys; { keywords } lnrng = 0..maxline; { input line } mrng = 0..maxcalls; { macro call stack } pgrng = 0..pagesize; { listing page } msg = packed array[1..140] of char; fptr = ^formal; formal = record fname: alfa; { name of formal parameter } fnext: fptr end; fns = (fabs,fatn,fchr,fcos,fexp, { built-in functions } flen,fln,fodd,ford,frou,fsin,fsqr,fstr,ftru); lex = (lexadd,lexsub, { order dependent } lexand,lexmult,lexdvd,lexmin,lexmax,lexdiv,lexmod, lexalpha,lexint,lexreal,lexst,lexmac, lexbeg,lexcas,lexend,lexrec,lexfun,lexproc,lexcon, lexmcon, lextpe,lexvar,lexfwd, lexor,lexnot, lexlt,lexle,lexeq,lexgt,lexge,lexne, lexsemi,lexother, lexlparen,lexrparen, lexcomma,lexeof); aptr = ^arg; arg = record { actual arg list } aform: alfa; { formal name } afirst: dsrng; { start of actual in dstr } alast: dsrng; anext: aptr end; constyp = (tbl,tch,terr,tin,tot,tre); { type of const expr } cset = set of constyp; strng = packed array[1..maxline] of char; errmsg = string[errlen]; lfnstring = string[30]; var (* DEBUGON : BOOLEAN; DEBUGSET : SET OF 0..100; *) ftop : -1..maxfiles; ctop, { current top of ctab and last const } cvalid : crng; { last non-temporary constant } mtop : mrng; { top of called macro stack } dtop : drng; cstop : csrng; newline : char; { newline character } dstop : dsrng; { top of definition string area } last, next : lnrng; { last char and next char in inline } ch : char; { next char from getch } line : integer; { last line number } pline : integer; { next pascal output line number } atop : dsrng; { actual arguments saved in top of defstr } linectr : integer; { lines so far on this page } nerrors : integer; { number of erros found } lexlen : lnrng; { number of chars in lexstr } lextyp : lex; { type of token in lexstr } index : integer; { for $index macro } onscreen : boolean; { if listing to screen } ctab : array[crng] of { constant table } record cname: alfa; case ctyp: constyp of tin: (ci: integer); tre: (cr: real); tch: (cfirst: csrng; clen: csrng); tbl: (cb: boolean); tot: (co: alfa) end; cstr : packed array[csrng] of char; { string const storage } infile : ffile; { input file } fstack : array[flrng] of { included file stack } record ffcb : fcb; { file control block } fline: integer end; keywd : array[0..maxkeys] of { language keywords } record kname: alfa; { keyword name } klex: lex end; mstack : array[mrng] of { macros calls } record margs: aptr; { list of args } mnext: dsrng; { next char to read } mlast: dsrng; { last char in this macro } matop: dsrng; { actual top upon call } end; defs : array[drng] of { macro definitions } record dname: alfa; { macro name } dfirst: dsrng; { first char in this macro } dlast: dsrng; { last char in this macro } dargs: fptr { list of formals } end; defstr : array[dsrng] of char; { macro definition bodies } funct : array[fnrng] of { list of built in functions } record fnnme: alfa; fntyp: fns end; blankalfa : alfa; inline : longstring; tme, { time of day from system } dte : alfa; { date from system } timein : integer; { clock value at start of run } tottme : integer; { total time used in ms } psource : text; { output file } (* dummy : text; { dummy used for real number conversion }*) rcopt, prcopt : lnrng; { right column on input/output } listopt : boolean; { list on or off } expropt : boolean; { recognize expressions on or off } lastlex : lex; { last token type put by puttok } outpos : lnrng; { last column pos used by puttok } lexstr : strng; { lexical string } confl : set of lex; { set of tokens needing blank between } { MAP-FPROCS } procedure arith; forward; procedure ckformal(name: alfa; var found: boolean); forward; procedure ckmacro(name: alfa; { macro name } var found: boolean); forward; procedure closefile; forward; procedure convrt; forward; procedure convrti; forward; procedure convrtr; forward; procedure convrts; forward; procedure docodeif; forward; procedure dodefine; forward; procedure doinclude; forward; procedure doindex; forward; procedure dooptions; forward; procedure dosysmac(d: drng); { which macro } forward; procedure error(err: errmsg); forward; procedure evalfns(f: fns); forward; procedure evalabs; forward; procedure evalatn; forward; procedure evalchr; forward; procedure evalcos; forward; procedure evalexp; forward; procedure evallen; forward; procedure evalln; forward; procedure evalodd; forward; procedure evalord; forward; procedure evalrou; forward; procedure evalsin; forward; procedure evalsqr; forward; procedure evalstr; forward; procedure evaltru; forward; procedure experror(err: errmsg); forward; procedure expression; forward; procedure factor; forward; procedure findcon(name: alfa; var found: boolean); forward; procedure flookup(name: alfa; var fun: fns; var found: boolean); forward; procedure flush; forward; procedure forcereal; forward; procedure getactuals(f: fptr; var act: aptr); forward; procedure getbody; forward; procedure getbsu; forward; procedure getcdparm; forward; procedure getch; forward; procedure getformals(var f: fptr); forward; procedure getkey; forward; procedure getline; forward; procedure getparm; forward; procedure gettok; forward; procedure need(L: pgrng); forward; procedure newpg; forward; procedure open(name: lfnstring); { file name to open } forward; procedure over(i: integer; maxval: integer); forward; procedure parse(top: crng; tok: lex); forward; procedure parsecon; forward; procedure parsemcon; forward; procedure pushback; forward; procedure putc(ch: char); forward; procedure puttok; forward; procedure relate; forward; procedure scanheader; forward; procedure term; forward; procedure terminate; forward; function toupper(ch: char): char; forward; function typeis(c: cset): boolean; forward; function typesmatch: boolean; forward; procedure variable; forward; segment procedure initialize; var i : integer; valid : boolean; ilfn, olfn : string[30]; procedure timedate; const backspace = 8; var i, l: integer; xstr: packed array[1..16] of char; date, time: string[alfaleng]; begin { timedate } xstr := 'MM/DD/YYHH:MM:SS'; tme := '*TIME* '; dte := '*DATE* '; repeat write('Enter date in form MM/DD/YY'); for i := 1 to 8 do write(chr(backspace)); readln(date); l := length(date); until (l = 8) or (l = 0); if l > 0 then begin moveleft(date[1], xstr[1], 8); moveleft(date[1], dte[1], 8) end; repeat write('Enter time in form HH:MM:SS'); for i := 1 to 8 do write(chr(backspace)); readln(time); l := length(time); until (l = 8) or (l = 0); if l > 0 then begin moveleft(time[1], xstr[9], 8); moveleft(time[1], tme[1], 8) end; moveleft(xstr[1], cstr[1], 16); cstop := 16; end; { timedate } procedure initctab; begin { initctab } with ctab[1] do begin cname := 'MM '; ctyp := tch; clen := 2; cfirst := 1 end; with ctab[2] do begin cname := 'DD '; ctyp := tch; clen := 2; cfirst := 4 end; with ctab[3] do begin cname := 'YY '; ctyp := tch; clen := 2; cfirst := 7 end; with ctab[4] do begin cname := 'TIME '; ctyp := tch; clen := 8; cfirst := 9 end; with ctab[5] do begin cname := 'DATE '; ctyp := tch; clen := 8; cfirst := 1 end; with ctab[6] do begin cname := 'TRUE '; ctyp := tbl; cb := true end; with ctab[7] do begin cname := 'FALSE '; ctyp := tbl; cb := false end; with ctab[8] do begin cname := 'MAXINT '; ctyp := tre; cr := maxint end; with ctab[9] do begin cname := 'MININT '; ctyp := tre; cr := -maxint end; ctop := ndefconst; cvalid := ndefconst; end; { initctab } procedure initkeywd; begin { initkeywd } { keywords are in order of decreasing frequency of access } with keywd[16] do begin kname := 'AND '; klex := lexand end; with keywd[20] do begin kname := 'BEGIN '; klex := lexbeg end; with keywd[14] do begin kname := 'CASE '; klex := lexcas end; with keywd[10] do begin kname := 'CONST '; klex := lexcon end; with keywd[11] do begin kname := 'DIV '; klex := lexdiv end; with keywd[21] do begin kname := 'END '; klex := lexend end; with keywd[ 8] do begin kname := 'EXTERNAL '; klex := lexfwd end; with keywd[ 2] do begin kname := 'FORTRAN '; klex := lexfwd end; with keywd[15] do begin kname := 'FORWARD '; klex := lexfwd end; with keywd[ 9] do begin kname := 'FUNCTION '; klex := lexfun end; with keywd[ 4] do begin kname := 'MAX '; klex := lexmax end; with keywd[ 3] do begin kname := 'MCONST '; klex := lexmcon end; with keywd[ 5] do begin kname := 'MIN '; klex := lexmin end; with keywd[ 6] do begin kname := 'MOD '; klex := lexmod end; with keywd[17] do begin kname := 'NOT '; klex := lexnot end; with keywd[12] do begin kname := 'OR '; klex := lexor end; with keywd[19] do begin kname := 'PROCEDURE '; klex := lexproc end; with keywd[13] do begin kname := 'RECORD '; klex := lexrec end; with keywd[ 1] do begin kname := 'RUN '; klex := lexfwd end; with keywd[ 7] do begin kname := 'TYPE '; klex := lextpe end; with keywd[18] do begin kname := 'VAR '; klex := lexvar end; mtop := 0; dstop := 0; end; { initkeywd } procedure initdefs; begin { initdefs } defs[sysinc ].dname := '$INCLUDE '; defs[sysdefine].dname := '$DEFINE '; defs[sysindex ].dname := '$INDEX '; defs[sysoption].dname := '$OPTIONS '; defs[syscodeif].dname := '$CODEIF '; dtop := nsysmac; atop := maxdefstr; end; { initdefs } procedure initfuncts; begin { initfuncts } with funct[ 01] do begin fnnme := 'ABS '; fntyp := fabs end; with funct[ 02] do begin fnnme := 'ARCTAN '; fntyp := fatn end; with funct[ 03] do begin fnnme := 'CHR '; fntyp := fchr end; with funct[ 04] do begin fnnme := 'COS '; fntyp := fcos end; with funct[ 05] do begin fnnme := 'EXP '; fntyp := fexp end; with funct[ 06] do begin fnnme := 'LENGTH '; fntyp := flen end; with funct[ 07] do begin fnnme := 'LN '; fntyp := fln end; with funct[ 08] do begin fnnme := 'ODD '; fntyp := fodd end; with funct[ 09] do begin fnnme := 'ORD '; fntyp := ford end; with funct[ 10] do begin fnnme := 'ROUND '; fntyp := frou end; with funct[ 11] do begin fnnme := 'SIN '; fntyp := fsin end; with funct[ 12] do begin fnnme := 'SQR '; fntyp := fsqr end; with funct[ 13] do begin fnnme := 'STRINGOF '; fntyp := fstr end; with funct[ 14] do begin fnnme := 'TRUNC '; fntyp := ftru end; end; { initfuncts } begin { initialize } timedate; initctab; initkeywd; initdefs; initfuncts; line := 0; { last line number for listing } pline := 1; { next, not last, pascal line number } rcopt := defrc; prcopt := defprc; listopt := deflist; expropt := defexpr; { parse const expressions } outpos := 0; { last output position used } lastlex := lexeof; { last token type output } nerrors := 0; index := 0; confl := [lexalpha,lexreal,lexint,lexand,lexor,lexnot,lexmin, lexmax,lexdiv,lexmod,lexbeg,lexcas,lexend,lexrec,lexfun, lexproc,lexcon,lextpe,lexvar]; linectr := pagesize; { force newpage on listing } newline := chr(10); blankalfa := ' '; ftop := -1; { no open files } lexlen := 0; ch := ' '; lextyp := lexeof; {$R- disable string range checks } inline[0] := chr(sizeof(inline)); fillchar(inline[1], sizeof(inline), space); {$R+} (* DEBUGON := FALSE; *) repeat write('Input file name: '); readln(ilfn); if ilfn <> '' then begin for i := 1 to length(ilfn) do ilfn[i] := toupper(ilfn[i]); if pos('.TEXT', ilfn) <= 0 then ilfn := concat(ilfn, '.TEXT'); end else ilfn := '*SYSTEM.WRK.TEXT'; write('Output file name: '); readln(olfn); if olfn <> '' then begin for i := 1 to length(olfn) do olfn[i] := toupper(olfn[i]); onscreen := (olfn = '#1:') or (olfn = 'CONSOLE:'); if not onscreen then begin if pos('.TEXT', olfn) <= 0 then olfn := concat(olfn, '.TEXT'); end; end else olfn := '*SYSTEM.WRK.TEXT'; valid := ilfn <> olfn; if not valid then writeln('Input file same as output file'); until valid; open(ilfn); rewrite(psource, olfn); (* rewrite(dummy, 'dummy'); DEBUGON := TRUE; DEBUGSET := []; REPEAT WRITE('SET WHICH BREAKPOINT: '); READLN(I); IF I > 0 THEN DEBUGSET := DEBUGSET + [I]; UNTIL I <= 0; *) end; { initialize } {$I MAP-A} {$I MAP-B} begin { map } initialize; parse(ctop, lexeof); terminate end. { map } ======================================================================================== DOCUMENT :usus Folder:VOL07:proc.ref1.text ======================================================================================== { program referencer Copyright (C) 1979 A.H. Sale Southhamptom, England See Pascal News #17 Permission is granted to copy this program, store it in a computer system, and distribute it provided that this header comment is retained in all copies } {$S+ allow compiler to swap } program refrencer; const sigcharlimit = 10; setlimit = 09; uclcdisplacement = 32; linelimit = 200; linewidth = 80; indentation = 4; bufsiz = 1024; cr = 13; { carriage return } sprogram = 'program'; sprocedure = 'procedure'; sfunction = 'function'; slabel = 'label'; sconst = 'const'; stype = 'type'; svar = 'var'; sbegin = 'begin'; scase = 'case'; send = 'end'; sforward = 'forward'; suses = 'uses'; ssegment = 'segment'; spaces = ''; type natural = 0..maxint; positive = 1..maxint; sixchars = packed array[1..6] of char; sigcharrange = 1..sigcharlimit; setrange = 0..setlimit; pseudostring = string[sigcharlimit]; stringcases = set of setrange; linesize = 1..linelimit; lineindex = 0..linelimit; setofchar = set of char; prockind = (fwdhalf,allfwd,shortform,formal,outside,notproc); ptrtoentry = ^entry; listofusages = ^usagecell; ptrtostackcell = ^stackcell; tokentype = (othersy,namesy,lparensy,rparensy,colonsy, semicolsy,periodsy,assignsy,subrangesy); entry = record procname: pseudostring; caseset: stringcases; linenumber: natural; startofbody: natural; left,right: ptrtoentry; before,after: ptrtoentry; calls: listofusages; localtree: ptrtoentry; case status: prockind of fwdhalf,shortform,formal,outside,notproc: (); allfwd: (forwardblock: natural); end; usagecell = record what: ptrtoentry; next: listofusages end; stackcell = record current: ptrtoentry; scopetree: ptrtoentry; substack: ptrtostackcell; end; longstring = STRING[255]; var lineno: natural; depth: natural; level: -1..maxint; pretty: natural; onscreen: boolean; adjustment: (first,other); movement: integer; printflag: boolean; errorflag: boolean; ch: char; token: tokentype; symbol: pseudostring; symbolcase: stringcase; savesymbol: pseudostring; superroot: ptrtoentry; stack: ptrtostackcell; alphabet: set of char; alphanums: setofchar; uppercase: setofchar; digits: setofchar; usefulchars: setofchar; namesperline: positive; outlfn: string[30]; outfile: text; { include file stuff } including: integer; { include file nest level } { file control block } infile: file; { input file } fcb: array[0..1] of record chno: lineindex; { current char index } inlfn: string[30]; { input file name } line: longstring; { current text line } bpos: integer; { buffer position } endfile: boolean; { true when end of file } buf: packed array[0..bufsiz] of char; blknr: integer; end; procedure getstring(VAR S: longstring); const dle = 16; var bcnt, chg: integer; begin { getstring } {$R- disable string range checks } with fcb[including] do repeat if bpos >= bufsiz then { time for next buffer } begin bcnt := blockread(infile, buf[0], 2, blknr); bpos := 0; blknr := blknr + bcnt; if bcnt < 2 then { eof } begin endfile := true; EXIT(getstring) end; end; chg := scan(bufsiz-bpos, =chr(CR), buf[bpos]); if (bpos + chg) < bufsiz then { found a carriage return } begin moveleft(buf[bpos], S[1], chg); { copy string except CR } S[0] := chr(chg); bpos := bpos + chg + 1; end else begin chg := scan(1024-bpos, =chr(0), buf[bpos]); { look for null } if (bpos + chg) < bufsiz then begin moveleft(buf[bpos], S[1], chg-1); S[0] := chr(chg); bpos := 1024; end; end; until chg > 0; if s[1] = chr(dle) then begin s[1] := ' '; s[2] := ' ' end; end; { getstring } {$R+} procedure printline; var i: linesize; begin { printline } write(outfile, lineno:5, ' '); i := 1; with fcb[including] do if adjustment = first then begin while (i < length(line)) and (line[i] = ' ') do i := succ(i); movement := (level * indentation) - (i - 1); adjustment := other; if level > 0 then write(outfile, ' ':(level*indentation)); end else begin if movement > 0 then write(outfile, ' ': movement) else if movement < 0 then while (i < length(line)) and (line[i] = ' ') and (i <= -movement) do i := succ(i); end; with fcb[including] do while i < length(line) do begin write(outfile, line[i]); i := succ(i); end; writeln(outfile); end; { printline } procedure error(e: positive ); begin { error } errorflag := true; write(outfile, 'FATAL ERROR - '); case e of 1: write(outfile, 'no "program" word'); 2: write(outfile, 'no identifier after prog/proc/func'); 3: write(outfile, 'token after heading unexpected'); 4: write(outfile, 'lost "." check begin/case/ends'); 5: write(outfile, 'same name, but not forward declared'); 6: write(outfile, 'cannot nest include files'); 7: write(outfile, 'file not found'); end; writeln(outfile, ' - at following line'); adjustment := first; printline; writeln(outfile, 'Last symbol: "', symbol, '"'); end; { error } procedure nextch; begin { nextch } with fcb[including] do if (including > 0) and endfile then begin close(infile); including := including -1; with fcb[including] do begin reset(infile, inlfn); writeln('--- re-opening ', inlfn) end; end; with fcb[including] do if chno = length(line) then begin if printflag then printline; getstring(line); line := concat(line, ' '); lineno := lineno + 1; chno := 1; ch := line[1]; if not onscreen then write('.'); end else begin chno := succ(chno); ch := line[chno]; end; end; { nextch } procedure push(newscope: ptrtoentry); var newlevel: ptrtostackcell; begin { push } new(newlevel); newlevel^.current := newscope; newlevel^.scopetree := nil; newlevel^.substack := stack; stack := newlevel; level := level + 1; end; { push } procedure pop; var oldcell: ptrtostackcell; begin { pop } stack^.current^.localtree := stack^.scopetree; oldcell := stack; stack := oldcell^.substack; level := level - 1; end; { pop } procedure findnode(var match: boolean; var follow: ptrtoentry; thisnode: ptrtoentry); begin { findnode } match := false; while (thisnode <> nil) and not match do begin follow := thisnode; if savesymbol < thisnode^.procname then thisnode := thisnode^.left else if savesymbol > thisnode^.procname then thisnode := thisnode^.right else match := true; end; end; function makeentry(mainprog: boolean; proc: boolean): ptrtoentry; var newentry, node: ptrtoentry; located: boolean; procedure puttosupertree(newnode: ptrtoentry); var place: ptrtoentry; procedure findleaf; var subroot: ptrtoentry; begin { findleaf } subroot := superroot; while subroot <> nil do begin place := subroot; if savesymbol < subroot^.procname then subroot := subroot^.before else subroot := subroot^.after end; end; { findleaf } begin { puttosupertree } if superroot = nil then superroot := newnode else begin findleaf; with place^ do begin if savesymbol < procname then before := newnode else after := newnode end end end; { puttosupertree } begin { makeentry } located := false; savesymbol := symbol; if mainprog then new(newentry) else if stack^.scopetree = nil then begin new(newentry); stack^.scopetree := newentry; end else begin findnode(located, node, stack^.scopetree); if not located then begin new(newentry); with node^ do if symbol < procname then left := newentry else right := newentry end end; if not located then begin with newentry^ do begin procname := symbol; caseset := symbolcase; linenumber := lineno; startofbody := 0; if proc then status := shortform else status := notproc; left := nil; right := nil; before := nil; after := nil; calls := nil; localtree := nil; end; makeentry := newentry; if proc then begin puttosupertree(newentry); push(newentry); end; end else begin makeentry := node; push(node); if node^.status = fwdhalf then begin stack^.scopetree := node^.localtree; node^.status := allfwd; node^.forwardblock := lineno; end else error(5) end end; { makeentry } procedure printtree(root: ptrtoentry); var thiscell: listofusages; count: natural; procedure conditionalwrite(n: natural; substitute: sixchars); begin { conditionalwrite } if n = 0 then write(outfile, substitute) else write(outfile, n:6); end; { conditionalwrite } procedure namewrite(p: ptrtoentry); var len: integer; s: setrange; begin { namewrite } with p^ do begin len := length(procname); for s := 0 to len-1 do if s in caseset then write(outfile, chr(ord(procname[s+1])-uclcdisplacement)) else write(outfile, procname[s+1]); end; if len < sigcharlimit then write(outfile, ' ':sigcharlimit-len); end; { namewrite } begin { printtree } if root <> nil then with root^ do begin printtree(before); writeln(outfile); write(outfile, linenumber: 5); conditionalwrite(startofbody, ' '); case status of fwdhalf,notproc: write(outfile, ' eh?'); formal: write(outfile, ' fml'); outside: write(outfile, ' ext'); shortform: write(outfile, ' '); allfwd: write(outfile, forwardblock:6); end; write(outfile, ' '); namewrite(root); write(outfile, ' :'); thiscell := calls; count := 0; while thiscell <> nil do begin if ((count mod namesperline) = 0) and (count <> 0) then begin writeln(outfile); write(outfile, ' ':sigcharlimit+19, ' :'); end; write(outfile, ' '); namewrite(thiscell^.what); thiscell := thiscell^.next; count := count + 1; end; writeln(outfile); printtree(after); end; end; { printtree } procedure nexttoken; procedure ignorecomment(tail: string); procedure getdirective; var i: integer; found: boolean; inclfn: string[30]; begin { getdirective } {$R- disable range checks } nextch; if ch = 'I' then { include } begin nextch; if ch = ' ' then begin nextch; i := 0; while ch <> '}' do begin i := i + 1; inclfn[i] := ch; nextch; end; inclfn[0] := chr(i); { set string length } {$I- disable IO checks } including := including + 1; with fcb[including] do begin close(infile); reset(infile, inclfn); found := ioresult = 0; if not found then { found the file } begin inclfn := concat(inclfn, '.text'); reset(infile, inclfn); found := ioresult = 0; end; {$I+} if found then begin writeln('---opening: ', inclfn); inlfn := inclfn; chno := 0; line := ''; bpos := bufsiz; endfile := false; blknr := 2; end else begin writeln('---cannot find: ', inclfn); close(infile); including := including - 1; with fcb[including] do reset(infile, inlfn); end; end; end; end; {$R+} end; { getdirective } begin { ignorecomment } nextch; if ch = '$' then getdirective; repeat while (ch <> tail[1]) do nextch; if ch = '*' then nextch; until (ch = tail[length(tail)]); nextch; end; { ignorecomment } procedure ignorenumbers; begin { ignorenumbers } while ch in digits do nextch; with fcb[including] do if ch = '.' then begin if (line[chno+1] in digits) then begin nextch; while ch in digits do nextch; end; end; if (ch = 'E') or (ch = 'e') then begin nextch; if (ch = '+') or (ch = '-') then nextch; while ch in digits do nextch; end; end; { ignorenumbers } procedure readident; var j: integer; begin { readident } {$R- disable range check to store string length } token := namesy; symbol := spaces; symbolcase := []; j := 0; while (j < sigcharlimit) and (ch in alphanums) do begin j := j + 1; if ch in uppercase then begin symbol[j] := chr(ord(ch)+uclcdisplacement); symbolcase := symbolcase + [j-1]; end else symbol[j] := ch; nextch; end; symbol[0] := chr(j); {$R+} while ch in alphanums do nextch; end; { readident } begin { nexttoken } token := othersy; repeat if ch in usefulchars then begin case ch of ')': begin nextch; token := rparensy; end; '(': begin nextch; if ch = '*' then ignorecomment('*)') else token := lparensy; end; '{': ignorecomment('}'); '''': begin nextch; while ch <> '''' do nextch; nextch; end; '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': ignorenumbers; ':': begin nextch; if ch = '=' then begin token := assignsy; nextch; end else token := colonsy; end; '.': begin nextch; if ch <> '.' then token := periodsy else begin token := subrangesy; nextch; end; end; ';': begin nextch; token := semicolsy; end; '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': readident; end end else nextch until token <> othersy; end; { nexttoken } procedure processunit(programid: boolean); var at: ptrtoentry; function nameisinscope: boolean; var llevel: ptrtostackcell; discovered: boolean; where: ptrtoentry; begin { nameisinscope } llevel := stack; discovered := false; savesymbol := symbol; while (llevel <> nil) and not discovered do begin findnode(discovered, where, llevel^.scopetree); if not discovered then llevel := llevel^.substack; end; if discovered then nameisinscope := (where^.status <> notproc) else nameisinscope := false; end; { nameisinscope } procedure processblock; var address: ptrtoentry; procedure crossreferencer; var newcell: listofusages; ptr: listofusages; home: ptrtoentry; slevel: ptrtostackcell; found: boolean; procedure findcell; var nextptr: listofusages; begin { findcell } found := false; nextptr := stack^.current^.calls; if nextptr <> nil then repeat ptr := nextptr; found := (ptr^.what^.procname = savesymbol); nextptr := ptr^.next; until found or (nextptr = nil) else ptr := nil; end; { findcell } begin { crossreferencer } slevel := stack; found := false; while (slevel <> nil) and not found do begin findnode(found, home, slevel^.scopetree); if not found then slevel := slevel^.substack end; if found then begin if home^.status <> notproc then begin findcell; if not found then begin new(newcell); if ptr <> nil then ptr^.next := newcell else stack^.current^.calls := newcell; newcell^.what := home; newcell^.next := nil; end; end; end; end; { crossreferencer } procedure scanforname; begin { scanforname } nexttoken; while token <> namesy do nexttoken; end; { scanforname } begin { processblock } while (symbol <> sbegin) do begin while (symbol <> sbegin) and (symbol <> sprocedure) and (symbol <> sfunction) and (symbol <> ssegment) do begin scanforname; if nameisinscope then begin address := makeentry(false, false); end; end; if symbol <> sbegin then begin if symbol = ssegment then nexttoken; processunit(false); scanforname; end; end; depth := 1; stack^.current^.startofbody := lineno; nexttoken; while depth <> 0 do begin if token <> namesy then nexttoken else if (symbol = sbegin) or (symbol = scase) then begin depth := depth + 1; nexttoken end else if (symbol = send) then begin depth := depth - 1; nexttoken; end else begin savesymbol := symbol; nexttoken; if token <> assignsy then crossreferencer else nexttoken end; end; end; { processblock } procedure scanparameters; var which: ptrtoentry; procedure scantillclose; begin { scantillclose } nexttoken; while token <> rparensy do begin if token = lparensy then scantillclose; nexttoken; end; end; { scantillclose } begin { scanparameters } nexttoken; while token <> rparensy do begin if (token = namesy) then begin if (symbol = sprocedure) or (symbol = sfunction) then begin nexttoken; if token = namesy then begin which := makeentry(false, true); which^.status := formal; pop; nexttoken; if token = lparensy then scantillclose; end else begin error(2); nexttoken; end; end else begin if nameisinscope then which := makeentry(false, false); nexttoken; end; end else nexttoken; end; nexttoken; end; { scanparameters } begin { processunit } printflag := true; adjustment := first; nexttoken; if token <> namesy then error(2) else begin at := makeentry(programid, true); while not (token in [lparensy,semicolsy,colonsy]) do nexttoken; if token = lparensy then scanparameters; while token <> semicolsy do nexttoken; printline; printflag := false; writeln(outfile); nexttoken; if token <> namesy then error(3) else begin if (symbol <> slabel) and (symbol <> sconst) and (symbol <> stype) and (symbol <> sprocedure) and (symbol <> sfunction) and (symbol <> svar) and (symbol <> sbegin) and (symbol <> suses) and (symbol <> ssegment) then begin if symbol = sforward then at^.status := fwdhalf else at^.status := outside; pop end else begin processblock; pop end end end; end; { processunit } procedure printheading; begin { printheading } writeln(outfile, 'procedural cross-refrencer - version s-02.01'); writeln(outfile, '============================================'); writeln(outfile); end; { printheading } begin { refrencer } including := 0; with fcb[including] do begin chno := 0; bpos := bufsiz; blknr := 2; line := ''; endfile := false; write('Input file name: '); readln(inlfn); if inlfn = '' then exit(refrencer); {$I- disable system IO checks } reset(infile, inlfn); if ioresult <> 0 then begin inlfn := concat(inlfn, '.text'); reset(infile, inlfn); if ioresult <> 0 then begin error(7); exit(refrencer); end; end; {$I+} onscreen := (inlfn = '#1:') or (inlfn = 'CONSOLE:') or (inlfn = 'console:'); end; write('Output file name: '); readln(outlfn); if outlfn = '' then outlfn := 'CONSOLE:'; rewrite(outfile, outlfn); superroot := nil; new(stack); with stack^ do begin current := nil; scopetree := nil; substack := nil; end; printflag := false; uppercase := ['A'..'Z']; alphabet := uppercase + ['a'..'z']; digits := ['0'..'9']; alphanums := alphabet + digits + ['_']; usefulchars := alphabet + digits + ['(', ')', '{', '.', ':', ';', '''']; namesperline := (linewidth - (sigcharlimit + 21)) div (sigcharlimit + 1); lineno := 0; level := -1; errorflag := false; page(outfile); printheading; writeln(outfile, ' line program/procedure/function heading'); for pretty := 1 to 43 do write(outfile, '-'); writeln(outfile); writeln(outfile); nexttoken; if token <> namesy then error(1) else if symbol <> sprogram then error(1) else begin processunit(true); if not errorflag then begin if (token <> periodsy) and (token <> subrangesy) then error(4) else begin adjustment := first; printline; end end end; if not errorflag then begin page(outfile); printheading; writeln(outfile, ' head body notes ', ' ':sigcharlimit, ' call made to'); for pretty := 1 to (sigcharlimit+37) do write(outfile, '-'); writeln(outfile); printtree(superroot); writeln(outfile); end; close(outfile, lock); end. { refrencer } ======================================================================================== DOCUMENT :usus Folder:VOL07:proc.ref2.text ======================================================================================== { Program Xref2 : Pascal procedural cross reference program Date : July 10, 1980. Programmer : Patrick R. Horton Copyright (c) 1980 - Associated Computer Industries - All rights reserved } PROGRAM Xref2; TYPE fwrdrec = RECORD procname : STRING; link : ^fwrdrec; segnum : INTEGER; proc : INTEGER; END; VAR ifile1,ifile2,ofile : TEXT; lproc,incname, ifilename,ofilename : STRING; line : STRING[255]; highseg, linenum,nesting, temp,seg : INTEGER; prseg, inseg,gotprog, iflg,ln,needready, includefile : BOOLEAN; tneed : ARRAY[1..16] OF INTEGER; procnum : ARRAY[1..16] OF INTEGER; first,ptr,tptr,fnd : ^fwrdrec; PROCEDURE Chkline; BEGIN linenum := linenum + 1; IF linenum MOD 50 = 0 THEN BEGIN WRITELN; WRITE(linenum:6); END; WRITE('.'); END; PROCEDURE Writeincludefile; BEGIN IF ln THEN WRITELN(ofile); ln := FALSE; WRITELN(ofile); WRITELN(ofile,incname); WRITELN(ofile,'-------------------------------------'); END; PROCEDURE Uppercase(VAR line : STRING); BEGIN WHILE POS(' ',line) = 1 DO DELETE(line,1,1); FOR temp := 1 TO LENGTH(line) DO IF (ORD(line[temp])<123) AND (ORD(line[temp])>96) THEN line[temp] := CHR(ORD(line[temp])-32); END; PROCEDURE Paline; VAR ch : CHAR; token : STRING; FUNCTION Notfwrdproc: BOOLEAN; BEGIN Notfwrdproc := TRUE; tptr := first; WHILE tptr <> NIL DO BEGIN IF tptr^.procname = token THEN BEGIN fnd := tptr; tptr := nil; Notfwrdproc := FALSE; END ELSE tptr := tptr^.link; END; END; PROCEDURE Bypassc1; BEGIN DELETE(line,1,1); IF (POS('$U',line) =1) OR (POS('$u',line) =1) THEN highseg := 0; REPEAT IF LENGTH(line)=0 THEN REPEAT IF includefile THEN READLN(ifile2,line) ELSE READLN(ifile1,line); Chkline; Uppercase(line); UNTIL LENGTH(line)<>0; WHILE (LENGTH(line)>0) AND (POS('}',line)<>1) DO DELETE(line,1,1); UNTIL POS('}',line)=1; DELETE(line,1,1); END; PROCEDURE Bypassc2; BEGIN DELETE(line,1,2); IF (POS('$U',line) =1) OR (POS('$u',line) =1) THEN highseg := 0; REPEAT IF LENGTH(line)=0 THEN REPEAT IF includefile THEN READLN(ifile2,line) ELSE READLN(ifile1,line); Chkline; Uppercase(line); UNTIL LENGTH(line)>0; WHILE (LENGTH(line)>0) AND (POS('*)',line)<>1) DO DELETE(line,1,1); UNTIL POS('*)',line)=1; DELETE(line,1,2); END; PROCEDURE Getoken; VAR out : BOOLEAN; BEGIN out := FALSE; WHILE (LENGTH(line)>0) AND (NOT out) DO IF POS('{',line)=1 THEN Bypassc1 ELSE IF POS('(*',line)=1 THEN Bypassc2 ELSE IF line[1] ='''' THEN BEGIN DELETE(line,1,1); REPEAT IF LENGTH(line)=0 THEN BEGIN IF includefile THEN READLN(ifile2,line) ELSE READLN(ifile1,line); Chkline; Uppercase(line); END; IF line[1]<>'''' THEN DELETE(line,1,1); UNTIL line[1] = ''''; DELETE(line,1,1); END ELSE IF NOT(line[1] IN ['0'..'9','_','-','A'..'Z']) THEN DELETE(line,1,1) ELSE out := TRUE; token := ''; out := FALSE; WHILE (LENGTH(line)>0) AND (NOT out) DO IF line[1] IN ['0'..'9','_','-','A'..'Z'] THEN BEGIN token := CONCAT(token,COPY(line,1,1)); DELETE(line,1,1); END ELSE out := TRUE; END; PROCEDURE Doprog; BEGIN Getoken; IF NOT iflg THEN Writeincludfile; iflg := TRUE; WRITELN(ofile,'PROGRAM ',token,';'); gotprog := TRUE; END; PROCEDURE Doseg; BEGIN IF ln THEN WRITELN(ofile); IF NOT iflg THEN Writeincludfile; prseg := TRUE; iflg := TRUE; inseg := TRUE; ln := FALSE; highseg := highseg + 1; seg := highseg; tneed[seg] := 0; procnum[seg] := 0; needready := FALSE; END; PROCEDURE Docas; BEGIN IF ln THEN WRITELN(ofile); ln := FALSE; tneed[seg] := tneed[seg] + 1; needready := TRUE; END; PROCEDURE Dorec; BEGIN IF ln THEN WRITELN(ofile); ln := FALSE; tneed[seg] := tneed[seg] + 1; needready := TRUE; nesting := nesting + 1; END; PROCEDURE Doproc; BEGIN IF ln THEN WRITELN(ofile); ln := FALSE; IF NOT iflg THEN Writeincludfile; iflg := TRUE; tneed[seg] := tneed[seg] + 1; needready := FALSE; Getoken; ln := TRUE; IF Notfwrdproc THEN BEGIN procnum[seg] := procnum[seg] + 1; WRITE(ofile,linenum:4,' ', seg:4,' ',procnum[seg]:4); IF prseg THEN WRITE(ofile,' SEGMENT'); prseg := FALSE; WRITE(ofile,' PROCEDURE ',token,';',' ':20-LENGTH(token)); END ELSE BEGIN WRITE(ofile,linenum:4,' ',fnd^.segnum:4,' ',fnd^.proc:4); IF prseg THEN WRITE(ofile,' SEGMENT'); prseg := FALSE; WRITE(ofile,' PROCEDURE ',token,';', ' ':20-LENGTH(token),'PREVIOUSLY DECLARED;'); END; lproc := token; END; PROCEDURE Dofun; BEGIN IF ln THEN WRITELN(ofile); ln := FALSE; IF NOT iflg THEN Writeincludfile; iflg := TRUE; tneed[seg] := tneed[seg] + 1; needready := FALSE; Getoken; ln := TRUE; IF Notfwrdproc THEN BEGIN procnum[seg] := procnum[seg] + 1; WRITE(ofile,linenum:4,' ', seg:4,' ',procnum[seg]:4, ' FUNCTION ',token,';',' ':20-LENGTH(token)); END ELSE WRITE(ofile,linenum:4,' ', fnd^.segnum:4,' ', fnd^.proc:4,' FUNCTION ',token,';', ' ':20-LENGTH(token),'PREVIOUSLY DECLARED;'); lproc := token; END; PROCEDURE Dofor; BEGIN NEW(ptr); ptr^.procname := lproc; ptr^.link := first; ptr^.segnum := seg; ptr^.proc := procnum[seg]; first := ptr; tneed[seg] := tneed[seg] - 1; WRITE(ofile,' FORWARD;'); END; PROCEDURE Dobeg; BEGIN IF ln THEN WRITELN(ofile); ln := FALSE; needready := TRUE; nesting := nesting + 1; END; PROCEDURE Doend; BEGIN IF ln THEN WRITELN(ofile); ln := FALSE; nesting := nesting - 1; IF (nesting<=0) AND needready THEN BEGIN tneed[seg] := tneed[seg] - 1; IF tneed[seg] = 0 THEN BEGIN inseg := FALSE; seg := 1; END; nesting := 0; END; END; BEGIN WHILE LENGTH(line)>0 DO BEGIN Getoken; IF LENGTH(token)<>0 THEN BEGIN IF NOT gotprog THEN IF token = 'PROGRAM' THEN Doprog ; IF token = 'SEGMENT' THEN Doseg ELSE IF token = 'PROCEDURE' THEN Doproc ELSE IF token = 'FUNCTION' THEN Dofun ELSE IF token = 'FORWARD' THEN Dofor; IF inseg THEN IF token = 'CASE' THEN Docas ELSE IF token = 'RECORD' THEN Dorec ELSE IF token = 'BEGIN' THEN Dobeg ELSE IF token = 'END' THEN Doend; END; END; END; PROCEDURE Pafile; BEGIN WHILE NOT EOF(ifile2) DO BEGIN READLN(ifile2,line); Chkline; Uppercase(line); Paline; END; CLOSE(ifile2); incname := ifilename; iflg := FALSE; END; PROCEDURE Processfiles; BEGIN incname := ifilename; WHILE NOT EOF(ifile1) DO BEGIN includefile := FALSE; READLN(ifile1,line); Chkline; Uppercase(line); temp := POS('{$I ',line); IF temp = 1 THEN BEGIN incname := COPY(line,temp+4,POS('}',line)-temp-4); Uppercase(incname); IF POS('.TEXT',incname)=0 THEN incname := CONCAT(incname,'.TEXT'); RESET(ifile2,incname); iflg := FALSE; includefile := TRUE; Pafile; END; IF temp = 0 THEN BEGIN temp := POS('(*$I ',line); IF temp =1 THEN BEGIN incname := COPY(line,temp+5,POS('*)',line)-temp-5); Uppercase(incname); IF POS('.TEXT',incname)=0 THEN incname := CONCAT(incname,'.TEXT'); iflg := FALSE; RESET(ifile2,COPY(line,temp+5,POS('*)',line)-temp-5)); includefile := TRUE; Pafile; END ELSE Paline; END; END { ifile1 }; CLOSE(ifile1); END; BEGIN WRITE(CHR(27),'*',CHR(0),CHR(0),CHR(0),CHR(0)); {$I-} REPEAT WRITE('enter input file name ---->'); READLN(ifilename); Uppercase(ifilename); IF POS('.TEXT',ifilename)=0 THEN ifilename := CONCAT(ifilename,'.TEXT'); RESET(ifile1,ifilename); UNTIL IORESULT=0; REPEAT WRITE('enter output file name --->'); READLN(ofilename); REWRITE(ofile,ofilename); UNTIL IORESULT=0; {$I+} WRITELN('Processing Program Text '); WRITE(0:6); linenum := 0; nesting := 0; seg := 1; tneed[1] := 1; procnum[1] := 1; highseg := 9; first := NIL; ln := FALSE; iflg := FALSE; prseg := FALSE; inseg := FALSE; gotprog := FALSE; needready := FALSE; Processfiles; WRITELN(ofile);WRITELN(ofile); WRITELN(ofile,'END OF PROGRAM'); CLOSE(ofile,lock); END. ======================================================================================== DOCUMENT :usus Folder:VOL07:prx.doc.text ======================================================================================== PRXref A Pascal Program Print/Cross-reference Processor Users Manual version 2.0 -- July 1980 program and manual written by David J. Lewis Digicomp Research Corporation Terrace Hill Ithaca, New York 14850 607-273-5900 and Department of Mathematics Ithaca College Ithaca, New York 14850 607-274-3108 program and manual Copyright (C) 1980, David J. Lewis Permission is granted to use and copy this program and its documentation under the terms of the UCSD Pascal System Users' Society. Use or copying under any other circumstances or terms is prohibited without the prior, written consent of the author. In particular, any resale or distribution for profit is prohibited. GENERAL DESCRIPTION PRXref is a processor for printing and cross-referencing Pascal programs. It runs under the UCSD Pascal (TM) system, versions I.5, II.0 and III.0. In its program printing function (which can be applied to any file, not just a Pascal program) PRXref provides line and page skipping, line numbering, standard or user-specified headers, the UCSD Pascal include-file mechanism, multiple line spacing, multiple copies and direction of output to any volume or file. For its cross-reference function, PRXref lists all occurrences of identifiers defined by the programmer with their line numbers. Procedure and function definitions are specially flagged. As with printing, files may be included. This, plus a very large space for cross-reference tables via disk, makes PRXref especially suitable for handling large Pascal programs. Note: "UCSD Pascal" is a registered trademark of the Regents of the University of California. PRXEF MANUAL, July 1980 -- General Usage page 2 I. GENERAL USAGE INSTRUCTIONS. A. INVOCATION. PRXref is invoked by X(ecution from the UCSD Pascal command level. This will result in a brief initialization and then display of the user option menu. B. DISPLAY REQUIREMENTS. Options are shown in a vertical menu on on the system display console. The display is presently organized for 18 lines of 64 or more characters. It may be squeezed into 16 lines as described in section IV.F. The screen must have XY-cursor addressing (embodied in the user's GOTOXY procedure) and erase-to-end-of-line and -screen functions. PRXref will automatically adjust to the user's screen environment by reading the SYSTEM.MISCINFO file and report any deficiencies. C. PRINTER REQUIREMENTS. PRXref itself uses 80 columns across the printer carriage for headers and cross-reference. Generally, the user wants each program line to fit on a single printer line, so she/he should maintain the horizontal size of the program within the bounds of their own print device. Certain constants in PRXref control the size of line that can be handled. This is more fully described in sections II.F and IV.B. D. OPTION SPECIFICATION. Default options are shown with the menu. To change any user option type the first letter of the option, upper or lower case. One may continue altering options until printing begins with as described in section I.E. The function of each option is described in section II.D. There are four data types for options: 1. Yes/No. Type "Y" or "N" (upper or lower case). Other characters are ignored. PRXref will respond to the single character with no carriage return required, echoing the full "Yes" or "No". 2. String. Type a string followed by a carriage return. Upper and lower case are irrelevant. Any typable character but a carriage return or end-of-file sequence may be entered. As usual, and (or ) serve to edit strings. 3. Integer. Type an integer, terminating with a space or a carriage return. Illegal characters are ignored. Type to undo one or more characters. The maximum is four digits, and any subsequent digits are ignored. Individual options have differing requirements for range. 4. Character. Type the single character. No carriage return is required. E. INITIATION OF PRINTING. Type (usually control-c) to initiate printing and/or cross-referencing. However, both a PRXEF MANUAL, July 1980 -- General Usage page 3 valid input file (F(ilename option) and output file/volume (O(utput file option) must be specified before printing can begin. If either is not present (missing or showing an error message), the is ignored. If output is directed to the printer (see II.C below), then the printhead should be positioned at the physical top-of-form before initiating printing. The volume containing the PRXref code file must remain mounted during execution, as it uses segment procedures. F. ESCAPING FROM EXECUTION. Anytime during printing or cross- referencing, hitting any key (but ) will suspend execution until another key hit. will give options to terminate: either the entire program (another ) or just the file being processed (any other key). G. REPETITION. After printing is complete, all options remain the same, except for the number of copies, which is set to 1. The user may reselect options and initiate processing of another file. H. QUITTING. Instead of selecting an option, type "Q" to quit PRXREF at any time. PRXREF MANUAL, July 1980 -- Printing Function page 4 II. PRINTING FUNCTION. A. GENERAL FEATURES. When the P(rint option is "Yes," the input file is printed line-for-line. If V(ertical formatting is "Yes," then PRXref will perform line and page skipping and header specification under control of directives in the user's file. PRXref performs no filling, concatenation, indentation or other horizontal formatting functions. (The one exception is that a line is broken when it does not fit into a print line.) In short, PRXref assumes that the user has arranged the program as it should look when printed. If that is not true, one may use a program pretty-printer such as those published by the UCSD Pascal System Users Society (software library, volume 1) or the Pascal News (#13, pages 34-58). B. INPUT FILE. The input file is selected with the "F(ilename" option. This must be a .TEXT file, though the ".TEXT" may be omitted from the filename. Lowercase letters in the filename are translated to uppercase. Specification of an illegal filename or a file not present will result in an error message. Volume prefixes (#5:, #VOL:, etc) may be used, and the default volume prefix set by the UCSD filer is effective. If SYSTEM.WRK.TEXT is present, this will be the default input filename when PRXref is initialized, though the user may alter it. If SYSTEM.WRK.TEXT is not present, there is no default, and the input file must be specified before printing. C. OUTPUT FILE/VOLUME. The output destination is selected with the "O(utput file" option. This may be either a file on a block- structured volume or a non-block-structured volume. In both cases, lowercase letters are translated to uppercase. Output files on block-structured volumes must be specified in full; ".TEXT" is not assumed. Volume prefixes may be used, and the default volume prefix is effective. D. OPTIONS. The basic option "P(rint :Yes" must be set. If "X(ref :Yes" is also set, cross-referencing will occur in addition to printing. See section III for a description of cross-referencing. Other options for printing are: 1. I(nclude. (Yes/No, default: Yes). If "Yes," file-include directives intended for the UCSD Pascal compiler will be respected, resulting in inclusion of the named files (for example, {$I OTHER.STUFF.TEXT}) . If "No," then include directives will be printed like ordinary lines, causing no file inclusion. An include directive in the file being printed must stand alone on a line, possibly indented but without other directives or text. Other than this, all variants of include directives are recognized by PRXref, including both kinds of comment delimiters, upper and lower case and omission of PRXREF MANUAL, July 1980 -- Printing Function page 5 ".TEXT". Included files may themselves contain include directives, nested to any reasonable depth. However, the UCSD Pascal compiler does not support such nesting. When line numbers are printed (see the "N(umbering" option below) and files are included, line numbers will correspond exactly to those on listing output from the the UCSD Pascal compiler (using the (*$L...*) compiler directive). 2. V(ertical formatting. (Yes/No, default: Yes). Setting this option causes PRXref to recognize special vertical formatting directives in the user's file. These provide for line skipping, page skipping and header specification. See section II.E for details. If the V option is "No," such directives are treated as ordinary text and printed. 3. C(ommand char. (character, default: #). This is the character used in the printed file to identify formatting directives. See section II.E. 4. S(kip page. (Yes/No, default: Yes). If "Yes," then a page skip is performed over the perforations of each page. The values currently set to describe the page are discussed in section II.F. If the S option is "No," then page skipping is not performed, and the listing will run over the perforations. If S is "No" and H is "Yes," then a header will be printed after the usual number of text lines for a page, but there will be no skipping over the perforations. Presently, page skipping is performed by printing the appropriate number of empty lines, but a top-of-form character may be used for a printer that recognizes it; see section IV.B. 5. N(umbering. (Yes/No, default: Yes). If "Yes," then line numbers appear to the left of each printed line, in a field of width five. Line numbers begin at 1 and go up to 32767. Turning on the X(ref option automatically turns on line numbering, though it may not show on the options list. PRXref numbers lines exactly the same as the UCSD Pascal compiler, even in the face of included files. Thus, a compiler listing and its line numbers will correspond to a cross-reference produced by PRXref from the same source program. In view of this, the user may sometimes want to produce a listing with the compiler to obtain code file information. The cross-reference may then be obtained from PRXref, turning the P option off. In doing so, be careful to leave the (*$L...*) compiler directive in the file for cross- referencing so line numbers will not change. 6. L(ine spacing. (integer, default: 1). This is the spacing for the printed output: 1 is single spacing, 2 is double PRXREF MANUAL, July 1980 -- Printing Function page 6 spacing, etc. The range is 1 to 8. When the format directive {#S...} is used in the file to skip lines, the skip value is multiplied by the current line spacing factor. 7. E(ject on incl. (Yes/No, default: Yes). If "Yes," then the beginning and end of an included file causes a page ejection. Thus, each included file occupies its own unique pages in the listing, and the file titles in standard headers are unambiguous. If E is "No," then the listing will run continuously across included files. In this case, the title header may not accurately reflect the included source file until the next regular page ejection. The same general effect as the E option may be achieved with the (*#H...*) and (*#P*) format directives described in II.E. 8. #( of copies. (integer, default: 1). The entire print and cross-reference process will be repeated this many times with the same options before returning to the user for reselection of options. Upon completing the repetitions, all options will remain the same except this one, which is reset to 1. The range for # is zero to 9999. E. VERTICAL FORMATTING DIRECTIVES. These are directives embedded in the file being printed to control vertical formatting of the listing under PRXref. The general syntax of vertical formatting directives is a Pascal comment beginning with a special character, called the command character and another character, called the directive character, indicating the operation. This is similar to compiler directives in Pascal, but with a different command character than the "$" (usually "#"). For example, the "P" directive may be written {#P}. Format directives must stand alone on lines of the file, without other directives or text. The default command character is "#", though the user may alter this with the "C(ommand char" option. Directive characters are "S", "P" and "H", with lower case acceptable as well. Some directives require a following operand, and PRXref is tolerant of leading and trailing blanks in such operands except where noted. Format directives are: 1. Line skipping: "S " or "S". This causes a skip of lines, or one line if is omitted. may be up to the size of a physical page. Examples: (*#S 2*), {#S}, {#s10}. 2. Page ejection: "P". Examples: {#p}, (*#P *). This causes immediate page ejection. 3. Header specification: "H+", "H-", "H
. "H+" installs the standard header with file titles. "H-" suppresses all headers. For these, the "+" and "-" must PRXREF MANUAL, July 1980 -- Printing Function page 7 stand next to the "H". The standard header, selected by (*H+*), is the default in case the user's file contains no H directives. It contains the name of the file being printed, the page number for the entire listing and a separator line including the date from the catalog of the booted volume. If a file is being included, then the name of that file and the page number within it are also printed in the standard title header. "H
" installs
as the header for subsequent page ejections, whether caused by {#P} or page overflow. A single space between "H" and
is optional and is deleted if present. The remainder of
is taken literally, including leading and trailing spaces. When
is printed at the top of a page, it will be followed immediately by the listing page number. An example of a header to capitalize on this feature is: (*#H The Perils of Pauline. Page *) User-supplied headers are also followed by a separator line with the date. The H directive does not in itself cause page ejection, but becomes effective upon the next page ejection ocurring naturally or through the P directive. F. PRINTING DIMENSIONS. The page and other printing dimensions are fixed at these values: 66 physical lines per page; 2 lines of margin above the header; 1 line of margin below the header; 4 lines of margin at the page bottom; 80 columns in the header and header separator lines; 5 columns for line numbers, if selected; 130 columns across the page; zero nulls sent to "PRINTER:" upon carriage return; 14 references per line in the cross-reference printout (at 5 columns per reference). For information on changing these, see section IV.B. PRXEF MANUAL, July 1980 -- Cross-reference Function page 8 III. CROSS-REFERENCING. A. GENERAL FEATURES. When the X(ref option is "Yes," the input is assumed to be a Pascal program, and all identifiers in the program but keywords (Pascal reserved words plus some other identifiers) are listed in the cross-reference with every line number on which they occur. This listing is sorted lexicographically and is numbered and headed separately. B. IDENTIFIER NORMALIZATION. Identifiers are normalized in the following ways for processing by X(ref: 1. Identifiers are truncated at length eight. 2. Lower case letters are mapped to upper case. 3. The underscore is ignored and not printed in the cross- reference listing. C. KEYWORDS. Pascal reserved words and some other standard identifiers are omitted from the cross-reference. Keywords include: 1. All the bold-face (or underlined) reserved words appearing in the Pascal grammar or syntax diagrams (such as BEGIN, PROGRAM, END, DO, etc.); 2. The standard simple type identifiers: CHAR, BOOLEAN, INTEGER, REAL; the type identifier TEXT; the type identifiers STRING and INTERACTIVE added to UCSD Pascal; 3. The standard boolean constants: TRUE, FALSE. 4. The standard file names: INPUT and OUTPUT; 5. The intrinsic procedure and function names: WRITE, WRITELN, READ, READLN, PAGE, PUT, GET, RESET, REWRITE, CHR, ORD, SUCC, PRED, NEW, DISPOSE, MARK, TRUNC, ROUND, EOF, EOLN, ODD. Many of these can be redefined by the programmer, but since that practice is questionable, they have been included as keywords. The list of keywords may be altered by a simple change to the source program. See section IV.E for details. D. PROCEDURE AND FUNCTION NAMES. Every occurrence of a identifier immediately following the reserved words PROCEDURE or FUNCTION is flagged in the cross-reference with a left-pointing arrow. This facilitates finding the body of a forward-declared procedure or function, as both the original definition and the body will be flagged. E. LARGE PROGRAMS AND OVERFLOW TO DISK. A large input program can create a cross-reference table too large to be held in main memory. In this case, PRXref will automatically utilize disk to store the table. This allows for programs of tens of thousands of lines to PRXEF MANUAL, July 1980 -- Cross-reference Function page 9 be handled, even by a single-density, eight-inch floppy disk. The occurence of disk overflow is automatic and need not concern the user, except that sufficient space must be allowed on disk to contain the overflow if it occurs. The amount of disk required depends on the number of identifiers and references in a program, which bears no exact relationship to its size in lines or blocks. One example of a 3500 line program required 45 disk blocks for cross-reference overflow; another of 3900 lines fit into 64K without need for disk. Once overflow occurs, disk space required does not vary with main memory size; the entire table is ultimately written to disk. PRXref uses the largest contiguous empty disk region during cross- referencing. If this becomes exhausted, PRXref will display which line and block of the files it was processing. From this information, the user may judge roughly how much more space is needed to finish. Also, if the file is being printed (P(rint: Yes) when disk is exhausted, printing will continue with cross-reference suppressed. PRXEF MANUAL, July 1980 -- Program Internals page 10 IV. Here are some notes on the structure and methods of the program to aid the user in making modifications. They are not intended to be comprehensive internal documentation. A. I/O PROCESSING. To improve processing speed, PRXref uses BLOCKREAD for all input and (as indicated by Boolean UNITOUT) UNITWRITE for output directed to the printer and terminal. READ and WRITE are avoided where possible, and most processing is done directly in the input/output buffer INCBUFF by PFILE and its subprocedures. That is why the routines GETLINE and PUTLINE appear more complex than necessary. GETLINE ensures that a complete line of the file always appears in the buffer for PUTLINE. The current input line is communicated by GETLINE with buffer pointer TPTR and length TLENGTH. The size of the buffer INCBUFF is the constant BUFFMAX. To allow a complete line to be present at all times, BUFFMAX (647) is set to the size of a block (512) plus the maximum size of an input line (132) plus 2 for indent codes plus 1 for the carriage return. There is little harm in leaving BUFFMAX at this figure, even if input lines are all shorter, but if longer input lines are expected, BUFFMAX as well as LINELENGTH should be increased. B. THE PRINTER. The printer dimensions discussed in section II.F are set in the first block of constants of the main program, where they are fully commented. The user may alter them, with the understanding that few such changes have been tested by the author. Many printers require some nulls on carriage return (or a two- way conversation about buffer filling). If this is not handled in your low-level printer drivers, then change the constant NUMPRNULLS from zero to however many nulls are necessary. Also, if your printer responds to a form-feed character (usually Ascii FF, decimal equivalent 12), then change PRFORMFEED to its decimal equivalent. Leaving PRFORMFEED at zero induces PRXref to insert blank lines for page skipping on direct output to the printer. C. CROSS-REFERENCE TABLE. The cross-reference table is maintained as demonstrated by Wirth in "Algorithms + Data Structures = Programs," (Prentice Hall, 1976, pages 164-274). This is scatter storage (hashing) with quadratic probing for collision resolution. Procedure SEARCH does the work. It searches for an identifier (IDX), and adds a reference with the global LINENUMBER. A hash table T of size P contains all identifiers in the table along with pointers to dynamic variables (ITEMs) containing references. Each ITEM is an array of NUMREFS references plus a COUNT of references in the ITEM or a pointer (PTR) to the next PRXEF MANUAL, July 1980 -- Program Internals page 11 ITEM for this identifier. NUMREFS is now set to five, and that seems about right, since there are tend to be around that many references per symbol in large programs. The hash function SEARCH is the sum of the four integers constituting an eight-byte identifier, added modulo the table size P . Real addition is used to avoid arithmetic overflow, and this may not be very efficient on some processors. However, PRXref was largely developed on Pascal-100 (TM), the S-100 CPU based on the Pascal Microengine chipset (TM) where real arithmetic is microcoded and pretty fast, so it is not a problem. Replacing the hash function with your favorite should be easy. (By the way, "Pascal-100" is a trademark of Digicomp Research Corporation, and "Pascal Microengine" is a trademark of Western Digital Corporation. Don't forget that.) For this method of hashing, P must be a prime. It is now 863, which seems about right on a 64K system in balancing overflow of the hash array with exhaustion of dynamic memory. A rough guess (not authoritative) is to reduce P by about 40 for each reduction of 1K of memory, keeping it prime of course. Keywords are placed in the table (by INITXREF) with a special negative linenumber, and no references to them are recorded, though they are tabulated. D. CROSS-REFERENCE TABLE OVERFLOW. When either dynamic storage falls below MEMTHRESH (now 600) or the hash table T is filled to the fraction LOADFACTOR (0.9), use of disk for cross-reference tables is initiated. The entire table at the time is written to disk in a hunk containing records (DRCDS) of DREFSPER references each. The table in main memory is then reinitialized, seeded with the keywords and the program started afresh. This happens again on successive overflows, up to MAXNHUNKS (10) times. After all is done, the disk hunks are read in and merged. All this is handled by PRINTTABLE. E. ADDING/DELETING KEYWORDS. The choice of keywords may not satisfy everybody. This may be changed in INITXREF simply by deleting or inserting more calls to SEARCH. F. DISPLAY SCREEN. A layout of the display screen is shown in the comments to the main program along with controlling constants. To reduce the display lines required from 18 to 16, reduce PRROWA to 2 and PRGAP to 0. Erase-to-end-of-line and -screen functions are set up with strings EOLSTRING and EOSSTRING deduced from SYSTEM.MISCINFO by INITSCREEN. If your screen doesn't have these functions, then some surgery might be required, as PRXref does not keep track of screen coordinates. If your screen doesn't even have XY cursor addressing, then you are not getting your money's worth out of UCSD Pascal. If you don't even have a screen... PRXEF MANUAL, July 1980 -- Program Internals page 12 Note that INITSCREEN always uses the Ascii for screen filler, when required, rather than the character that UCSD added later to SYSTEM.MISCINFO as a variable fill character. If this bothers your terminal, change it. G. ESCAPING EXECUTION. There is code in PRXref to poll the keyboard during printing or cross-referencing. This is in functions ESCAPEHIT and KEYHIT. KEYHIT is the low-level routine, and it is presently disabled, always returning FALSE. There are also two commented-out alternatives: (a) a routine for Pascal-100 with a Cromemco Tuart, using Pascal-100's memory- mapped I/O; (b) an EXTERNAL body to mate with an assembly language routine. H. OPTIONS. Adding your own options is fairly easy, at least as far as data entry, using the option-entry package. Code must be added in two places: 1. In SHOWOPTIONS place a call to an appropriate POxxxx routine with the prompt string and variable name for the option. The order of options here is exactly the order they will appear on the screen. The option-entry package keeps track of that. 2. In the body of OPTIONS place a case with the (upper case) constant for the option, a call to the appropriate PIxxxx routine and any other code needed immediately. I. CROSS-REFERENCE STATISTICS. These are provided after the cross- reference for fun and profit. "Programmer's symbols" means anything but keywords. The number of usages does not distinguish declarations from other usages -- it's really just a count on the table printout. "Keyword usages" obviously does not include keyword declarations. "Total symbol usages" is the sum of the other two usages and probably provides a reasonable measure of "program size." It's certainly better than "lines" or "characters," both of which can vary with superficial aspects of programming style. When disk is used for cross-referencing, information is provided on the extent of each hunk of the table written to disk. This tells both the number of lines and blocks of the file that had been read when the hunk was written. It might be useful in judging the amount of disk storage needed to cross-reference a large program. ======================================================================================== DOCUMENT :usus Folder:VOL07:prxref.ini.text ======================================================================================== (**********************************************) (* PRXREF.INI -- DJL, 1980 JULY 11, 8:00 P.M. *) (**********************************************) SEGMENT PROCEDURE INITXREF; (* was forward *) VAR I, SAVELINE: INTEGER; BEGIN (* use linenumber as a code to indicate keywords *) SAVELINE := LINENUMBER; LINENUMBER := KWCODE; LNUMENTRIES := 0; (* initialize entry counter local to hunk *) (* init hash tbl *) TOP := P; FOR I := 0 TO P DO T[ I].KEY := ' '; (* start with a fresh heap *) RELEASE( HEAPPOINT); MARK( HEAPPOINT); (* place keywords in table *) SEARCH( 'AND '); SEARCH( 'ARRAY '); SEARCH( 'BEGIN '); SEARCH( 'BOOLEAN '); SEARCH( 'CASE '); SEARCH( 'CHAR '); SEARCH( 'CONST '); SEARCH( 'DIV '); SEARCH( 'DOWNTO '); SEARCH( 'DO '); SEARCH( 'ELSE '); SEARCH( 'END '); SEARCH( 'EXIT '); SEARCH( 'FILE '); SEARCH( 'FOR '); SEARCH( 'FUNCTION'); SEARCH( 'GOTO '); SEARCH( 'IF '); SEARCH( 'IN '); SEARCH( 'INPUT '); SEARCH( 'INTEGER '); SEARCH( 'MOD '); SEARCH( 'NIL '); SEARCH( 'NOT '); SEARCH( 'OF '); SEARCH( 'OR '); SEARCH( 'OUTPUT '); SEARCH( 'PACKED '); SEARCH( 'PROCEDUR'); SEARCH( 'PROGRAM '); SEARCH( 'REAL '); SEARCH( 'RECORD '); SEARCH( 'REPEAT '); SEARCH( 'SET '); SEARCH( 'STRING '); SEARCH( 'TEXT '); SEARCH( 'THEN '); SEARCH( 'TO '); SEARCH( 'TYPE '); SEARCH( 'UNTIL '); SEARCH( 'VAR '); SEARCH( 'WHILE '); SEARCH( 'WITH '); SEARCH( 'WRITE '); SEARCH( 'WRITELN '); SEARCH( 'INTERACT'); SEARCH( 'READ '); SEARCH( 'READLN '); SEARCH( 'SUCC '); SEARCH( 'PRED '); SEARCH( 'TRUNC '); SEARCH( 'ROUND '); SEARCH( 'ORD '); SEARCH( 'CHR '); SEARCH( 'ODD '); SEARCH( 'EOF '); SEARCH( 'EOLN '); SEARCH( 'PAGE '); SEARCH( 'PUT '); SEARCH( 'GET '); SEARCH( 'RESET '); SEARCH( 'REWRITE '); SEARCH( 'LABEL '); SEARCH( 'FORWARD '); SEARCH( 'NEW '); SEARCH( 'DISPOSE '); SEARCH( 'MARK '); SEARCH( 'FALSE '); SEARCH( 'TRUE '); LINENUMBER := SAVELINE; (* resore usual linenumber *) END; (* INITIALIZE *) (**************************************************************************) SEGMENT PROCEDURE INITIALIZE( FIRSTTIME: BOOLEAN); (* initialize most variables: *) (* FIRSTTIME ==> at the very beginning of execution *) (* NOT FIRSTTIME ==> preceding each user requested repetition of *) (* processing a file *) VAR I: INTEGER; (**************************************************************************) PROCEDURE NTOSTR( N: INTEGER; VAR S: STRING); (* convert non-negative integer to string for date routine *) BEGIN S := ''; REPEAT INSERT( ' ', S, 1); S[ 1] := CHR( (N MOD 10) + ORD( '0')); N := N DIV 10 UNTIL N = 0 END; (**************************************************************************) PROCEDURE INITSCREEN; (* sets up EOLSTRING and EOSSTRING for erasing parts of screen *) (* gets its information from SYSTEM.MISCINFO *) (* also checks screen width and height against MINSCRWIDTH and *) (* MINSCRHEIGHT and insists on random cursor addressing *) (* before proceeding *) TYPE SYSCOMREC = RECORD (* image of SYSTEM.MISCINFO *) JUNK: ARRAY[ 0..28] OF INTEGER; (* junk and expansion area *) MISCINFO: PACKED RECORD NOBREAK, STUPID, SLOWTERM, HASXYCRT, HASLCCRT, HAS8510A, HASCLOCK: BOOLEAN END; CRTTYPE: INTEGER; CRTCTRL: PACKED RECORD RLF, NDFS, ERASEEOL, ERASEEOS, HOME, ESCAPE: CHAR; BACKSPACE: CHAR; FILLCOUNT: 0..255; CLEARSCREEN, CLEARLINE: CHAR; PREFIXED: PACKED ARRAY[ 0..8] OF BOOLEAN END; CRTINFO: PACKED RECORD WIDTH, HEIGHT: INTEGER; RIGHT, LEFT, DOWN, UP: CHAR; BADCH, CHARDEL, STOP, BREAK, FLUSH, EOF: CHAR; ALTMODE, LINEDEL: CHAR; BACKSPACE, ETX, PREFIX: CHAR; PREFIXED: PACKED ARRAY[ 0..13] OF BOOLEAN; END END (*SYSCOM*); VAR STROFNULLS, ONENULL, PS: CTLSTRING; (* for nulls to terminal *) MISCFILE: FILE OF SYSCOMREC; (* file to read SYSTEM.MISCINFO *) NFILL, I: INTEGER; HADMERR: BOOLEAN; (* error flag *) PROCEDURE MERR( S: STRING); (* error handler for screen setup *) BEGIN WRITELN; WRITE( 'Screen problem: ', S); HADMERR := TRUE END; BEGIN (* INITSCREEN *) HADMERR := FALSE; (* assume no problems in info *) (*$I-*) RESET( MISCFILE, '*SYSTEM.MISCINFO'); (*$I+*) WITH MISCFILE^ DO BEGIN IF IORESULT <> 0 THEN MERR( 'No SYSTEM.MISCINFO file on boot volume') ELSE (* have SYSTEM.MISCINFO; check it out *) BEGIN IF NOT MISCINFO.HASXYCRT THEN MERR( 'No XY CRT.'); IF CRTINFO.WIDTH < MINSCRWIDTH THEN BEGIN MERR( 'Screen width < '); WRITE( MINSCRWIDTH) END; IF CRTINFO.HEIGHT < MINSCRHEIGHT THEN BEGIN MERR( 'Screen height < '); WRITE( MINSCRHEIGHT) END; IF ( CRTCTRL.ERASEEOL = CHR( 0)) OR ( CRTCTRL.ERASEEOS = CHR( 0)) THEN MERR( 'Erase-to-end-of-line or -screen missing'); END; IF HADMERR THEN BEGIN (* found an error *) WRITELN; WRITE( 'Cannot run PRXref.'); EXIT( PRXREF) END; (* all is ok with the screen; set up control strings *) (* first, make strings for prefix and null *) PS := ' '; PS[ 1] := CRTCTRL.ESCAPE; (* NOTE: using null as screen filler *) ONENULL := ' '; ONENULL[ 1] := CHR( 0); (* then, set up string of nulls for screen filler *) IF CRTCTRL.FILLCOUNT > 11 THEN NFILL := 11 ELSE NFILL := CRTCTRL.FILLCOUNT; STROFNULLS := ''; FOR I := 1 TO CRTCTRL.FILLCOUNT DO INSERT( ONENULL, STROFNULLS, 1); (* set up end-of-line erase string *) EOLSTRING := ' '; EOLSTRING[ 1] := CRTCTRL.ERASEEOL; INSERT( STROFNULLS, EOLSTRING, 2); IF CRTCTRL.PREFIXED[ 2] THEN INSERT( PS, EOLSTRING, 1); (* and end-of-screen *) EOSSTRING := ' '; EOSSTRING[ 1] := CRTCTRL.ERASEEOS; INSERT( STROFNULLS, EOSSTRING, 2); IF CRTCTRL.PREFIXED[ 3] THEN INSERT( PS, EOSSTRING, 1); END (* with *) END; (* INITSCREEN *) (**************************************************************************) PROCEDURE GETDATE( VAR RETDATE: STRING); (* get date from unit 4 catalog *) CONST MONTHSTRING = 'JanFebMarAprMayJunJulAugSepOctNovDec'; TYPE (* the date layout in the catalog *) DATERCD = PACKED RECORD MONTH: 0..12; DAY: 0..31; YEAR: 0..100 END; VAR (* catalog layout for extracting date *) BIGRCD: RECORD CASE BOOLEAN OF FALSE: ( DATEARRAY: PACKED ARRAY[ 0..21] OF CHAR); TRUE: (FILLER: PACKED ARRAY[ 0..19] OF CHAR; DATE: DATERCD) END; SDAY, SYEAR: STRING; BEGIN WITH BIGRCD, DATE DO BEGIN (* get date info from catalog *) UNITWAIT( 4); UNITREAD( 4, DATEARRAY[ 0], 22, 2); (* convert numbers to printables *) NTOSTR( DAY, SDAY); NTOSTR( YEAR, SYEAR); (* return date in DD-MMM-YY form *) RETDATE := CONCAT( SDAY, '-', COPY( MONTHSTRING, MONTH*3-2, 3), '-', SYEAR) END END; (**************************************************************************) BEGIN (* INITIALIZE *) IF FIRSTTIME THEN BEGIN (* initialize once per run *) (* get date; establish standard header separator *) GETDATE( TODAY); HEADERSEP := TODAY; FOR I := 1 TO HEADERSIZE-LENGTH( TODAY) DO HEADERSEP := CONCAT( HEADERCHAR, HEADERSEP); (* initialize screen info *) INITSCREEN; (* nulls for the printer, if needed *) FOR I := 1 TO NUMPRNULLS DO NULLS[ I] := CHR( NULL); (* show not yet in the xref print phase *) INXREF := FALSE; (* initialize user options variables *) PAGESKIP := TRUE; INCLU := TRUE; PRINTING := TRUE; NUMBERING := TRUE; XREFFING := FALSE; SPACING := 1; VFORMATTING := TRUE; CMDCHAR := '#'; INCLSKIP := TRUE; (* initialize in and out files and check if ok *) MAINNAME := 'SYSTEM.WRK.TEXT'; IF NOT FILECHECK( MAINNAME) THEN MAINNAME := ' '; PRINTTITLE := 'PRINTER:'; PRINTLAST := PAGELINES - BOTMARGIN; (* set last print line *) (* translate table load factor to threshhold # entries *) MAXNUMENTRIES := TRUNC( LOADFACTOR * P) - 1; CMDCHARSET := [ 'H', 'P', 'S']; (* format directives *) MARK( HEAPPOINT) (* where to cut back xref tbl to *) END ELSE BEGIN (* initialize before each pass at a file *) (* show not in xref print phase *) INXREF := FALSE; (* header and page and line counting variables *) GPAGE := INITPAGE; HEADER := ''; HDRS := TRUE; TITLEHDRS := TRUE; FIRSTPAGE := TRUE; (* show topofpage we are starting *) FININCL := FALSE; (* controls include page skipping *) IF XREFFING THEN BEGIN (* initialize xref (and assume line numbering *) NUMBERING := TRUE; INITXREF END; LINENUMBER := 0; (* init print line number (will get bumped first) *) NUMKWREFS := 0; (* initialize keyword ref counter *) NHUNKS := 0 (* intialize for xref overflow to disk *) END END; (* initialize *) ======================================================================================== DOCUMENT :usus Folder:VOL07:prxref.opt.text ======================================================================================== (*********************************************) (* PRXREF.OPT -- for USUS -- 1980 July 14 *) (*********************************************) SEGMENT PROCEDURE OPTIONS; (* solicits options from user *) CONST NITEMSMAX= 20; (* max number of option items *) TYPE PRRCD= RECORD (* describes an option *) LETTER: CHAR; (* activating key hit *) ROW: INTEGER (* display row *) END; CHSET= SET OF CHAR; VAR PRSTUFF: ARRAY[ 1..NITEMSMAX] OF PRRCD; (* info on options *) CURROW, NITEMS, ITEM: INTEGER; PROMPTLINE: STRING; CH: CHAR; FOUND: BOOLEAN; (* for option character search *) OKTOGO: BOOLEAN; (* controls initiation of printing *) (************************************************************) PROCEDURE RINGBELL; BEGIN WRITE( CHR( BELL)) END; (************************************************************) PROCEDURE ERRMSG( S: STRING); (* prints error messages for user options *) BEGIN RINGBELL; GOTOXY( PRCOLC, CURROW); ERASEEOL; WRITE( S) END; (************************************************************) FUNCTION SETOUTUNIT( VAR S: STRING): BOOLEAN; (* Check and normalize output file/volume title. *) (* Allow output to named file or units 1, 2, 6. *) (* Set PRINTTITLE to file/vol title in any case. *) (* Sets UNITOUT := TRUE and PRINTUNIT in case of unblked unit output. *) (* Check to see if file/vol can be opened -- returns TRUE iff OK. *) VAR DUMMYFILE: FILE; UNITSET: SET OF CHAR; BEGIN UNITSET:= [ '1', '2', '6']; (* normalize numbers with # before and : after *) IF ( LENGTH( S) = 1) THEN IF (S[ 1] IN UNITSET) THEN S := CONCAT( '#', S, ':'); IF LENGTH( S) = 2 THEN IF (S[ 1] = '#') AND ( S[ 2] IN UNITSET) THEN S := CONCAT( S, ':'); (* assume it's to be a blocked file, not a unit *) PRINTUNIT := -1; PRINTTITLE := S; IF S[ LENGTH( S)] = ':' THEN BEGIN IF ( S = '#1:') OR ( S = 'CONSOLE:') THEN BEGIN PRINTTITLE := 'CONSOLE:'; PRINTUNIT := 1 END ELSE IF ( S = '#2:') OR ( S = 'SYSTERM:') THEN BEGIN PRINTTITLE := 'SYSTERM:'; PRINTUNIT := 2 END ELSE IF ( S = '#6:') OR ( S = 'PRINTER:') THEN BEGIN PRINTTITLE := 'PRINTER:'; PRINTUNIT := 6 END END; (* indicate unit or blocked file *) UNITOUT := ( PRINTUNIT > 0); (* see if file can be opened for output *) (*$I-*) REWRITE( DUMMYFILE, PRINTTITLE); (*$I+*) SETOUTUNIT := ( IORESULT = 0); CLOSE( DUMMYFILE) END; (************************************************************) FUNCTION READCH( OKSET: CHSET): CHAR; (* read opt char; transl to upper *) VAR C: CHAR; BEGIN READ( KEYBOARD, C); UCFOLD( C); WHILE NOT ( C IN OKSET) DO BEGIN RINGBELL; READ( KEYBOARD, C); UCFOLD( C) END; WRITE( C); READCH := C END; (************************************************************) FUNCTION READINT: INTEGER; (* interactive integer read *) (* more robust than the one in the UCSD operating system *) (* Accepts up to 4 digits; end with or *) (* bad digits rejected; is effective *) VAR CBS, CH: CHAR; RESULT, DIGITS, I: INTEGER; DIGSET: SET OF CHAR; DONE: BOOLEAN; BEGIN CBS := CHR( BS); DIGSET := ['0'..'9', ' ', CBS]; RESULT := 0; DIGITS := 0; DONE := FALSE; REPEAT READ( KEYBOARD, CH); WHILE NOT( CH IN DIGSET) DO BEGIN RINGBELL; READ( KEYBOARD, CH) END; IF CH = CBS THEN BEGIN (* backspace hit *) IF DIGITS > 0 THEN BEGIN (* erase last char; undo conversion *) WRITE( CBS,' ',CBS); RESULT := RESULT DIV 10; DIGITS := DIGITS-1 END END ELSE IF CH = ' ' THEN (* he wants to quit; shall we let him? *) BEGIN IF DIGITS > 0 THEN (* sure *) DONE := TRUE ELSE (* no digits; no way *) RINGBELL END ELSE (* its a numeral *) BEGIN IF DIGITS < 4 THEN BEGIN (* accept and convert digit *) WRITE( CH); DIGITS := DIGITS + 1; RESULT := RESULT * 10 + ORD( CH) - ORD( '0'); END ELSE RINGBELL END UNTIL DONE; READINT := RESULT END; (* readint *) (************************************************************) PROCEDURE POENTER( S: STRING); (* enter an option in the table; place on display *) BEGIN NITEMS := NITEMS + 1; (* count a new item *) WITH PRSTUFF[ NITEMS] DO BEGIN (* enter letter and row in table *) LETTER := S[ 1]; ROW := NITEMS + PRROWA - 3; MSGLINE := ROW + PRGAP + 1; (* further messages go here on screen *) (* display it *) GOTOXY( PRCOLA, ROW); ERASEEOL; WRITE( S); GOTOXY( PRCOLB, ROW); WRITE( ':') END END; (************************************************************) PROCEDURE POINIT; (* initialize option table *) BEGIN NITEMS := 2; (* account for Q and *) MSGLINE := 2; PRSTUFF[ 1].LETTER := 'Q'; PRSTUFF[ 1].ROW := PRROWA - 1; PRSTUFF[ 2].LETTER := CHR( ETX); PRSTUFF[ 1].ROW := PRROWA - 1; GOTOXY( PRCOL, PRROW); ERASEEOS; PROMPTLINE:= CONCAT( 'Print/Xref: to start; Q(uit ', TODAY) END; (************************************************************) (* routines to display options and receive user responses *) (* types of responses are: *) (* YESNO: Y or N giving TRUE or FALSE to the BOOLEAN variable *) (* STRNG: character string *) (* INTEG: integer (non-negative; <= 4 digits) *) (* CHARR: single character *) (* POxxxxx routines display option of type xxxxx and place info in table *) (* PIxxxxx routines receive user response for option of type xxxxx *) (* PSxxxxx routines display option value ( YESNO only) *) PROCEDURE PSYESNO( VB: BOOLEAN); BEGIN IF VB THEN WRITE( 'Yes') ELSE WRITE( 'No') END; PROCEDURE POYESNO( S: STRING; VB: BOOLEAN); BEGIN POENTER( S); PSYESNO( VB) END; PROCEDURE PIYESNO( VAR VB: BOOLEAN); BEGIN VB := (READCH( [ 'Y', 'N']) = 'Y'); WRITE( CHR( BS)); PSYESNO( VB) END; PROCEDURE POINTEG( S: STRING; VI: INTEGER); BEGIN POENTER( S); WRITE( VI) END; PROCEDURE PIINTEG( VAR VI: INTEGER); BEGIN VI := READINT END; PROCEDURE POSTRNG( S: STRING; VS: STRING); BEGIN POENTER( S); WRITE( VS) END; PROCEDURE PISTRNG( VAR VS: STRING); BEGIN READLN( VS); IF VS = '' THEN VS := ' ' END; PROCEDURE POCHARR( S: STRING; VC: CHAR); BEGIN POENTER( S); WRITE( VC) END; PROCEDURE PICHARR( VAR VC: CHAR); BEGIN READ( VC) END; PROCEDURE PROMPT; (* show prompt line *) BEGIN GOTOXY( PRCOL, PRROW); ERASEEOL; WRITE( PROMPTLINE) END; (************************************************************) PROCEDURE SHOWOPTIONS; (* show options to user as entering in table *) BEGIN POINIT; (* intitialize display screen and table *) POSTRNG( 'F(ilename' ,MAINNAME); POSTRNG( 'O(utput file' ,PRINTTITLE); POYESNO( 'X(ref' ,XREFFING); POYESNO( 'P(rint' ,PRINTING); POYESNO( 'I(nclude' ,INCLU); POYESNO( 'V(ert format' ,VFORMATTING); POCHARR( 'C(ommand char' ,CMDCHAR); POYESNO( 'S(kip Pages' ,PAGESKIP); POYESNO( 'N(umbering' ,NUMBERING); POINTEG( 'L(ine spacing' ,SPACING); POYESNO( 'E(ject on incl' ,INCLSKIPPING); POINTEG( '#( of copies' ,TIMES) END (* showoptions *); (************************************************************) BEGIN (* OPTIONS *) TIMES := 1; (* always set to one repetition initially *) IF NOT SETOUTUNIT( PRINTTITLE) THEN PRINTTITLE := ' '; SHOWOPTIONS; OKTOGO := FALSE; (* not ready to go just yet *) REPEAT (* sequence of user options *) REPEAT (* option solicitation until valid *) PROMPT; READ( KEYBOARD, CH); UCFOLD( CH); (* initialize for option search *) ITEM := 1; FOUND := FALSE; REPEAT (* looking for character in option table *) IF PRSTUFF[ ITEM].LETTER = CH THEN FOUND := TRUE ELSE ITEM := ITEM + 1 UNTIL FOUND OR ( ITEM > NITEMS); UNTIL (* the option is *) FOUND; IF CH = CHR( ETX) THEN (* asking to go *) BEGIN (* but there must be valid input and output files *) IF ( MAINNAME <> ' ') AND ( PRINTTITLE <> ' ') THEN OKTOGO := TRUE ELSE (* a file title missing; complain *) RINGBELL END ELSE IF CH = 'Q' THEN (* goodbye chahlie *) EXIT( PRXREF) ELSE (* ordinary option character; process it *) BEGIN (* move cursor to selected option *) CURROW := PRSTUFF[ ITEM].ROW; GOTOXY( PRCOLB+1, CURROW); ERASEEOL; (* read user's response appropriately *) CASE CH OF 'I' : PIYESNO( INCLU); 'V' : PIYESNO( VFORMATTING); 'S' : PIYESNO( PAGESKIP); 'F' : BEGIN (* input file; verify right now *) PISTRNG( MAINNAME); IF NOT FILECHECK( MAINNAME) THEN BEGIN ERRMSG( 'Bad input file title'); MAINNAME := ' ' END END; 'P' : PIYESNO( PRINTING); 'O' : BEGIN (* output file/vol; verify now *) PISTRNG( PRINTTITLE); IF NOT SETOUTUNIT( PRINTTITLE) THEN BEGIN ERRMSG( 'Bad output file/vol title'); PRINTTITLE := ' ' END END; 'N' : PIYESNO( NUMBERING); 'X' : PIYESNO( XREFFING); 'L' : BEGIN PIINTEG( SPACING); IF SPACING < 1 THEN SPACING := 1 ELSE IF SPACING > 8 THEN SPACING := 8 END; 'C' : BEGIN PICHARR( CMDCHAR); IF CMDCHAR = '$' THEN ERRMSG( 'That''s asking for trouble') END; 'E' : PIYESNO( INCLSKIPPING); '#' : PIINTEG( TIMES) END END UNTIL OKTOGO; MSG( 'Let''s go...', 0); REWRITE( OUTFILE, PRINTTITLE) (* ok to open output for real *) END; {OPTIONS} (**************************************************************************) ======================================================================================== DOCUMENT :usus Folder:VOL07:prxref.pfi.text ======================================================================================== (*********************************************) (* PRXREF.PFI -- for USUS -- 1980 July 14 *) (*********************************************) PROCEDURE PFILE( FNAME:STRING); (* Print the file FNAME. Handles included files recursively, *) (* (thus exceeding UCSD specs). *) TYPE DIRRCD= RECORD (* for compiler and formatter directive info *) DIRTYPE, DIRCHAR: CHAR; (* type ($ or cmdchar) and command *) DIRSTR: BIGSTRING (* text associated with directive *) END; VAR INFILE: FILE; (* input file *) INCBUFF: BUFFER; (* input buffer *) ID: ALFA; (* for accumulating an identifier in SCANNER, handing to SEARCH *) TI:INTEGER; (* pointer for ID *) NOMORE: BOOLEAN; (* signals end of file *) DIR: DIRRCD; (* contains directive info *) PRINTIT: BOOLEAN; (* controls line print/suppresssion with directives *) (* variables to deal with buffer; see GETLINE *) STPTR, TPTR, BUFFLENGTH: BINDX; LASTPTR, TLENGTH, LEFTLENGTH, WLENGTH: BINDXZ; (* name and block number being read in include file *) BLOCKNUM: INTEGER; INCNAME: STRING; (* states for sequential machine in SCANNER *) STATE: (LOOKING, QUOTE, CURLYBRACKET, PARENSTAR, MAYBERC, NEWLC); MAYBELC: BOOLEAN; (* help for seq machine *) PROCFLAG: BOOLEAN; (* indicates PROC/FUNC kw *) {***************************************************************************} PROCEDURE SCANNER( CUTEND: BOOLEAN); (*****************************************************) (* Scan an input line (in the buffer), extract tokens and send them *) (* to SEARCH for entry into the xref table. Respect the sanctity *) (* of comments and quoted strings. *) (* This routine uses a sequential machine tokenizing technique. *) (* Since it must work across line boundaries, the state and *) (* auxilliary variables are global to PFILE. *) (* CUTEND ==> end of the call forces the end of a token; *) (* otherwise, accumulate token across calls *) (*****************************************************) VAR C: CHAR; I, STARTPTR: INTEGER; (***********************) PROCEDURE SEARCHP( ID: ALFA); (* Call the table search routine to enter ID. *) (* Place a special code in the table immediately following any *) (* symbol that is preceded by "PROCEDURE" OR "FUNCTION". *) (* This will result in printing a flag in the xref for such symbols *) VAR SAVELINE: INTEGER; BEGIN (* look for ID in xref table and enter if appropriate *) SEARCH( ID); IF ( ID = 'PROCEDUR' ) OR ( ID = 'FUNCTION' ) THEN (* remember that fact for next round *) PROCFLAG := TRUE ELSE IF PROCFLAG THEN BEGIN (* last round was PROC or FUNC keyword *) (* put the special code into the xref table *) PROCFLAG := FALSE; SAVELINE := LINENUMBER; LINENUMBER := PROCCODE; SEARCH( ID); LINENUMBER := SAVELINE END END; (***********************) BEGIN (* scanner *) (* respect the indent code at the beginning of a line *) IF INCBUFF[ TPTR] = CHR( DLE) THEN STARTPTR := TPTR + 2 ELSE STARTPTR := TPTR; (* main scanning loop -- to end of the line *) FOR I := STARTPTR TO TPTR + WLENGTH - 1 DO BEGIN C := INCBUFF[ I]; (* fold to upper case (efficiently) *) IF ( C >= 'a') THEN IF ( C <= 'z') THEN C := CHR( ORD( C) - 32); IF MAYBELC THEN BEGIN (* had left paren last, is this a * ?*) IF C = '*' THEN (* yep, we are now starting a comment *) STATE := NEWLC; MAYBELC := FALSE END; CASE STATE OF (* main state selection for sequential machine *) LOOKING: BEGIN (* looking for a token *) IF (( C >= 'A') AND ( C <= 'Z')) OR (( C >= '0') AND (C <= '9')) THEN BEGIN (* its an id character; accumulate it *) IF (TI <= ALFALEN) THEN (* still under max token length *) BEGIN ID[ TI] := C; TI := TI + 1 END END ELSE IF C <> '_' THEN BEGIN (* not an id character } (* enter appropriate state *) IF C = '{' THEN STATE := CURLYBRACKET ELSE IF C = '''' THEN STATE := QUOTE ELSE IF C = '(' THEN (* possible left comment *) MAYBELC := TRUE; IF TI > 1 THEN BEGIN (* just finished an id *) (* place in xref table *) SEARCHP( ID); (* initialize the id accumulator *) TI := 1; ID := ' ' END END END; (* end LOOKING *) NEWLC: (* now in middle of a parenstar comment *) STATE := PARENSTAR; QUOTE: IF C = '''' THEN (* leave quoted string *) STATE := LOOKING; CURLYBRACKET: IF C = '}' THEN (* leave comment *) STATE := LOOKING; PARENSTAR: IF C = '*' THEN (* maybe end comment *) STATE := MAYBERC; MAYBERC: IF C = ')' THEN (* leave comment *) STATE := LOOKING ELSE IF C = '*' THEN (* still maybe end comment *) STATE := MAYBERC ELSE (* whoops, back inside the comment *) STATE := PARENSTAR END { case state } END { big for loop }; IF CUTEND THEN (* end of call forces end of token *) IF TI > 1 THEN BEGIN SEARCHP( ID); TI := 1; ID := ' ' END END; (**************************************************************************) (*$G+*) FUNCTION DIRECTIVE( TPTR: INTEGER; TLENGTH: BINDX; VAR DIR: DIRRCD) : BOOLEAN; (* Check input buffer at TPTR, length TLENGTH for a directive, *) (* that is, a Pascal comment beginning with $ or CMDCHAR *) (* This is a compiler directive ($) or format directive (CMDCHAR). *) (* The only $ directive accepted is "$I FILENAME", file inclusion. *) (* If found, TRUE is returned and DIR. set as follows: *) (* DIR.DIRTYPE := '$' or CMDCHAR as the case may be *) (* DIR.DIRCHAR := character following DIRTYPE, the actual directive *) (* DIR.DIRSTR := the string between DIRCHAR and end of the comment *) (* The routine is organized to waste as little time as possible on *) (* non-directives, hence the GOTOs *) LABEL 1; (* exit point *) VAR EPOS, SPTR: INTEGER; ESTR: STRING; CHK: RECORD CASE INTEGER OF (* for string manipulation *) 0: (CHKARR: PACKED ARRAY[ 0..255] OF CHAR); 1: (CHKSTR: STRING[ 255]) END; CHKLENGTH: INTEGER; BEGIN WITH DIR, CHK DO BEGIN DIRECTIVE := FALSE; (* assume not a directive *) IF INCBUFF[ TPTR] = CHR( DLE) THEN BEGIN (* account for ident code *) TPTR := TPTR + 2; TLENGTH := TLENGTH - 2 END; IF TLENGTH < 4 (* not long enough for anything useful *) THEN GOTO 1; IF INCBUFF[ TPTR] = '(' THEN BEGIN IF INCBUFF[ TPTR+1] = '*' THEN BEGIN (* have a paren-star comment *) IF TLENGTH < 6 THEN (* too short for paren-star directive *) GOTO 1; SPTR := TPTR + 2; ESTR := '*)' END ELSE (* false alarm, not paren-star *) GOTO 1 END ELSE IF INCBUFF[ TPTR] = '{' THEN BEGIN (* have a curly bracket comment *) SPTR := TPTR + 1; ESTR := '}' END ELSE (* not a comment *) GOTO 1; (* have a comment; get type and check if acceptable *) DIRTYPE := INCBUFF[ SPTR]; IF DIRTYPE = '$' THEN (* have a compiler directive *) BEGIN DIRCHAR := INCBUFF[ SPTR+1]; UCFOLD( DIRCHAR); (* get command char *) IF DIRCHAR = 'I' THEN (* possible incl *) BEGIN IF INCBUFF[ SPTR+2] IN ['+', '-'] THEN (* reject I+, I- *) GOTO 1 END ELSE (* reject all $ directives but I *) GOTO 1 END ELSE IF DIRTYPE = CMDCHAR THEN (* check for legal command *) BEGIN DIRCHAR := INCBUFF[ SPTR+1]; UCFOLD( DIRCHAR); (* get command char *) IF NOT (DIRCHAR IN CMDCHARSET) THEN GOTO 1 END ELSE (* not a directive of either type *) GOTO 1; (* have acceptable directive; find end of comment with string search *) CHKLENGTH := TLENGTH + TPTR - SPTR - 2; (* length of remainder *) IF CHKLENGTH > 0 THEN MOVELEFT( INCBUFF[ SPTR+2], CHKARR[ 1], CHKLENGTH); (* set up string *) CHKARR[ 0] := CHR( CHKLENGTH); (* with length *) EPOS := POS( ESTR, CHKSTR); (* position of end of comment *) IF EPOS = 0 THEN (* no end-of-comment; forget it *) GOTO 1; DIRSTR := COPY( CHKSTR, 1, EPOS-1); (* extract the directive's text *) DIRECTIVE := TRUE; (* report success *) 1: END END; (*$G-*) (**************************************************************************) PROCEDURE PUTLINE; (* Write line to printer file, directly from buffer if possible *) VAR N: INTEGER; CUTLINE: BOOLEAN; ORCD: RECORD CASE INTEGER OF (* for strng-lngth tricks *) 1: (OBUFF: STRING[ 135]); 2: (NBUFF: PACKED ARRAY[ 0..135] OF 0..255) END; BEGIN (* scan away nulls at beginning of line *) N := SCAN( TLENGTH, <>CHR( NULL), INCBUFF[ TPTR]); IF N < TLENGTH THEN BEGIN (* something other than nulls on the line *) BUMPLINE; (* count an output line *) (* Strip possible carriage return from tail of line *) (* and, indicate (CUTLINE) whether to scan ID's to next line *) IF INCBUFF[ TPTR+TLENGTH-1] = CHR( CR) THEN BEGIN WLENGTH := TLENGTH-1; CUTLINE := TRUE END ELSE BEGIN WLENGTH := TLENGTH; CUTLINE := FALSE END; IF PRINTING THEN BEGIN (* actual output *) IF NUMBERING THEN WRITE( OUTFILE, LINENUMBER: LNUMWIDTH, ' '); IF UNITOUT THEN (* output to unit *) BEGIN UNITWRITE( PRINTUNIT, INCBUFF[ TPTR], WLENGTH) END ELSE WITH ORCD DO BEGIN (* output to a file *) MOVELEFT( INCBUFF[ TPTR], OBUFF[ 1], WLENGTH); NBUFF[ 0] := WLENGTH; WRITE( OUTFILE, OBUFF) END END; IF XREFFING THEN (* scan and enter symbols in table *) SCANNER( CUTLINE); PUTCRLF (* carriage return to printer *) END END; (**************************************************************************) PROCEDURE GETLINE; (* Get an input line using BLOCKREAD. *) (* Variables set here for other routines to use in processing: *) (* INCBUFF: input buffer, filled using BLOCKREAD; *) (* TPTR: start of line in INCBUFF; *) (* TLENGTH: length of line. *) (* Variables used internally: (* LEFTLENGTH: characters left to process in INCBUFF; *) (* LINELENGTH: printer line length (now a constant 130) *) (* TOSCAN: number of chars in INCBUFF to scan for CR *) (* BLKLENGTH: length of INCBUFF data excluding trailing nulls *) VAR I, BLKLENGTH: INTEGER; TOSCAN: BINDXZ; BEGIN TPTR := TPTR + TLENGTH; (* hop over the previous line *) LEFTLENGTH := BUFFLENGTH - TPTR + 1; (* adjust LEFTLENGTH accordingly *) IF LEFTLENGTH <= LINELENGTH THEN BEGIN (* not enough chars in buffer for a full print line *) IF LEFTLENGTH > 0 THEN (* scrunch remaining chars to front of buffer *) MOVELEFT( INCBUFF[ TPTR], INCBUFF[ 1], LEFTLENGTH); (* read new bufferfull from input file *) REPEAT IF EOF( INFILE) THEN BEGIN (* fill remainder with nulls *) FILLCHAR( INCBUFF[ LEFTLENGTH+1], 512, CHR( NULL)); LASTPTR := LEFTLENGTH; BLKLENGTH := 512 END ELSE BEGIN (* read a block from input file *) (*$I-*) I := BLOCKREAD( INFILE, INCBUFF[ LEFTLENGTH+1], 1, BLOCKNUM); (*$I+*) IOERR:=IORESULT; GLOBLOCK := BLOCKNUM; (* for homebrew err msgs *) BLOCKNUM := BLOCKNUM + 1; IF (I <> 1) OR (IOERR > 0) THEN IOE( IOERR, FNAME); (* set blocklength, omit trailing nulls *) BLKLENGTH := 512 + SCAN( -512, <>CHR( NULL), INCBUFF[ LEFTLENGTH + 512]) END UNTIL ( BLKLENGTH > 0) OR EOF( INFILE); (* show a new buffer *) TPTR := 1; BUFFLENGTH := BLKLENGTH + LEFTLENGTH; LEFTLENGTH := BUFFLENGTH; END; (* now have buffer with at least one printer line's worth in it *) (* (or end of file ) *) (* scan for carriage return and set TLENGTH *) IF LEFTLENGTH < LINELENGTH THEN TOSCAN := LEFTLENGTH ELSE TOSCAN := LINELENGTH; TLENGTH := 1 + SCAN( TOSCAN, =CHR( CR), INCBUFF[ TPTR]); NOMORE := (TPTR + TLENGTH > LASTPTR) (* indicate if end of file *) END; (**************************************************************************) PROCEDURE DOCMD( CMD: DIRRCD); (* Carry out a formatting directive (CMD) set up by DIRECTIVE *) VAR NTOSKIP: INTEGER; (* how many to skip for 'S' *) CLEANSTR: BIGSTRING; (* for stripped operand string *) BEGIN WITH CMD DO BEGIN (* set up stripped operand string *) CLEANSTR := DIRSTR; STRIPSTRING( CLEANSTR); IF DIRCHAR = 'H' THEN BEGIN (* header directive *) (* H+ ==> turn on standard title headers (default) *) (* H- ==> turn off headers altogether *) (* H string ==> use string as a header *) IF DIRSTR = '+' THEN BEGIN HDRS := TRUE; TITLEHDRS := TRUE END ELSE IF DIRSTR = '-' THEN BEGIN HDRS := FALSE END ELSE BEGIN HDRS := TRUE; TITLEHDRS := FALSE; (* use unstripped directive operand as header *) HEADER := DIRSTR; (* except for one possible leading space *) IF LENGTH( HEADER) > 0 THEN IF HEADER[ 1] = ' ' THEN DELETE( HEADER, 1, 1) END END (* case 'H' *) ELSE IF DIRCHAR = 'S' THEN BEGIN (* skip directive: S ntoskip *) IF CLEANSTR = '' THEN CLEANSTR := '1'; NTOSKIP := STRTON( CLEANSTR); (* convert to number *) IF (NTOSKIP > PAGELINES) OR (NTOSKIP < 0) THEN (* error *) PRINTIT := TRUE (* give up and just print it *) ELSE SKIP( NTOSKIP * SPACING) (* skip, accounting for scurrent spacing *) END (* case 'S' *) ELSE IF DIRCHAR = 'P' THEN BEGIN (* page skip *) IF CLEANSTR = '' THEN TOPOFPAGE ELSE PRINTIT := TRUE END (* case 'P' *) END END; (**************************************************************************) BEGIN (* PFILE *) IF NOT FILECHECK( FNAME) THEN BEGIN MSG( 'File: ', 1); WRITE( FNAME, ' cannot be opened'); EXIT( PRXREF) END; CLOSE( INFILE); RESET( INFILE, FNAME); (* set name and numbering for included file *) LNAME := FNAME; LPAGE := 1; IF INCLSKIPPING THEN TOPOFPAGE; FININCL := FALSE; (* initialize variables for GETLINE *) BLOCKNUM := 2; LASTPTR := BUFFMAX; BUFFLENGTH := 1; TPTR := BUFFLENGTH + 1; TLENGTH := 0; IF XREFFING THEN (* initialize variables for SCANNER *) BEGIN TI := 1; ID := ' '; (* accumulator for identifiers *) STATE := LOOKING; MAYBELC := FALSE; (* state variables *) PROCFLAG := FALSE (* proc/func kw flag *) END; (* main file read/print loop -- GETLINE and PUTLINE until end of file *) REPEAT GETLINE; LINENUMBER := LINENUMBER + 1; (* account for indent code on the line *) IF INCBUFF[ TPTR] = CHR( DLE) THEN STPTR := TPTR + 2 ELSE STPTR := TPTR; PRINTIT := TRUE; (* assume line will be printed *) (* check for compiler directive or format comment *) IF DIRECTIVE( TPTR, TLENGTH, DIR) THEN WITH DIR DO BEGIN (* directive *) PRINTIT := FALSE; (* line probably won't be printed (could be wrong) *) IF DIRTYPE = '$' THEN (* compiler directive -- include *) BEGIN IF INCLU THEN (* including is enabled *) BEGIN IF DIRCHAR = 'I' THEN (* just double-checking for $I *) BEGIN STRIPSTRING( DIRSTR); (* strip blanks *) INCNAME := DIRSTR; (* this is include file's name *) MSG( 'included file: ', 1); WRITE( INCNAME); LINENUMBER := LINENUMBER - 1; (* adjust for compiler numbering *) (* recursively print the included file *) PFILE( INCNAME); IF ESCAPING THEN (* keep getting out of PFILE *) EXIT( PFILE); LNAME := FNAME; FININCL := TRUE; LINENUMBER := LINENUMBER + 1; (* adjust for compiler numbering *) MSG( ' ', 1); END END END ELSE IF DIRTYPE = CMDCHAR THEN (* format directive *) BEGIN IF VFORMATTING THEN (* its enabled; do the command *) DOCMD( DIR) ELSE (* not enabled; just print the line *) PRINTIT := TRUE END END; IF PRINTIT THEN (* line to be printed as-is *) BEGIN IF FININCL THEN BEGIN (* finish up include with page skip *) FININCL := FALSE; TOPOFPAGE END; PUTLINE (* print the line *) END; (* check user hit on keyboard with escape *) IF ESCAPEHIT THEN EXIT( PFILE) UNTIL (* GETLINE says *) NOMORE END; {pfile} ======================================================================================== DOCUMENT :usus Folder:VOL07:prxref.tbl.text ======================================================================================== (**********************************************) (* PRXREF.TBL -- for USUS -- 1980 July 14 *) (* Bug fixed in PRINTWORD, 1980 Oct 13, JLG *) (**********************************************) SEGMENT PROCEDURE INITXREF; FORWARD; (* initializes the cross-reference with keywords, etc. *) (**************************************************************************) SEGMENT PROCEDURE PRINTTABLE ( WHAT: PTABLETYPE); (* output all or part of the cross-reference table *) (* WHAT = PRINT ==> entire tbl from memory to output file/vol *) (* WHAT = DISK ==> fragment in memory to overflow file *) (* WHAT = MERGE ==> merge and output the fragments overflowed *) TYPE HARRAY = ARRAY[ INDEX] OF WORD; (* for the hash hdr table *) VAR I, M: INDEX; HI: HUNKQINDEX; DRSIZE: INTEGER; (* for SIZEOF( DRCDS) *) NUMSYMS, NUMREFS: INTEGER; (* number of pgmr's symbols and refs to them *) HOLDSPACING: INTEGER; (* so spacing can be restored after setting to 1 *) (********************************************************************) PROCEDURE COMPACT( VAR T: HARRAY; VAR N: INDEX); (* compact the spread-out hash table preparatory to sort *) VAR I: INDEX; BEGIN N := 0; FOR I := 0 TO P DO WITH T[ I] DO BEGIN IF KEY <> ' ' THEN IF FIRST <> NIL THEN BEGIN (* slide this entry backwards *) T[ N] := T[ I]; N := N + 1 END END END; (*********************************************************************) PROCEDURE TSORT( VAR A: HARRAY; VAR N: INDEX); (* good ole quicksort -- more-or-less from Conway & Gries *) (* sorts hash table A by key for printout or write to disk *) VAR LOWER, UPPER: ARRAY[ INDEX] OF INTEGER; COUNT, L, U, M, K, NJ: INTEGER; TEMPA: WORD; BEGIN (* TSORT *) MSG( ' sorting', 1); COMPACT( T, N); (* compact the array first *) LOWER[ 1] := 0; UPPER[ 1] := N-1; M := 1; COUNT := 50; WHILE M <> 0 DO BEGIN IF ESCAPEHIT THEN (* user requests escape *) EXIT( PRINTTABLE); IF COUNT >= 50 THEN BEGIN COUNT := 0; WRITE( '.') END ELSE COUNT := COUNT + 1; L := LOWER[ M]; U := UPPER[ M]; M := M - 1; IF U = L + 1 THEN BEGIN IF A[ L].KEY > A[ U].KEY THEN BEGIN TEMPA := A[ L]; A[ L] := A[ U]; A[ U] := TEMPA END END ELSE IF U > L + 1 THEN BEGIN NJ := L + 1; K := U; WHILE NJ <= K DO BEGIN IF A[ NJ].KEY <= A[ L].KEY THEN NJ := NJ + 1 ELSE BEGIN; WHILE A[ K].KEY > A[ L].KEY DO K := K - 1; IF NJ < K THEN BEGIN TEMPA := A[ NJ]; A[ NJ] := A[ K]; A[ K] := TEMPA; NJ := NJ + 1; K := K - 1 END END END; TEMPA := A[ L]; A[ L] := A[ K]; A[ K] := TEMPA; IF U - K > K - L THEN BEGIN M := M + 1; LOWER[ M] := K + 1; UPPER[ M] := U END; M := M + 1; LOWER[ M] := L; UPPER[ M] := K - 1; IF U - K <= K - L THEN BEGIN M := M + 1; LOWER[ M] := K + 1; UPPER[ M] := U END END END END; (**************************************************************************) PROCEDURE PRINTREF( NEXTREF: INTEGER); (* print a reference *) BEGIN IF NEXTREF <> PROCCODE THEN BEGIN NUMREFS := NUMREFS + 1; WRITE( OUTFILE, NEXTREF: 5) END ELSE (* just a flag for a proc/func *) WRITE( OUTFILE, '<----') END; (**************************************************************************) PROCEDURE PRINTWORD( W: WORD); (* print an id and all its references *) VAR L: INTEGER; X: ITEMPTR; NEXTREF : INTEGER; THISREF: REFINDEX; BEGIN IF W.FIRST <> NIL THEN BEGIN (* have non-keyword *) WRITE( OUTFILE, W.KEY: SYMPRLENGTH); (* print symbol *) NUMSYMS := NUMSYMS + 1; (* count a programmer's symbol *) (* print its references *) X := W.FIRST; L := 0; (* point to first ref; init horizontal counter *) REPEAT {bug fix per author made next 2 lines, 13 Oct 1980, J. Gagne} IF L MOD REFSPERLINE = REFSPERLINE -1 (* start another print line *) THEN BEGIN SKIP(1); WRITE( OUTFILE, ' ': SYMPRLENGTH) END; L := L+1; (* count another ref across *) (* go to next reference *) THISREF := (L-1) MOD REFSPERITEM + 1; NEXTREF := X^.REF[ THISREF]; (* next ref in this array *) IF THISREF = X^.REFNUM THEN X := NIL (* indicate done *) ELSE IF THISREF = REFSPERITEM THEN X := X^.NEXT; (* next array *) PRINTREF( NEXTREF) UNTIL X = NIL; SKIP(1); END END; (**************************************************************************) PROCEDURE SK; BEGIN SKIP(1) END; (**************************************************************************) PROCEDURE DWRITE; (* write the current xref table to a hunk of disk *) VAR D: DRCDS; (* to assemble a file rcd *) I, NR, NREFS, R: INTEGER; RPTR, NEXTRPTR: ITEMPTR; DONE: BOOLEAN; M: INDEX; (**********************************) PROCEDURE DPUT( D: DRCDS); (* actual PUT of xref rcd to disk overflow file *) BEGIN DF^ := D; (*$I-*) PUT( DF); IOERR := IORESULT; (*$I+*) IF IOERR = 8 THEN BEGIN MSG( 'No room on disk for overflow.', 2); WRITE( ' Xref aborted; input block ', GLOBLOCK, '.'); XREFFING := FALSE; IF PRINTING THEN BEGIN WRITE( ' Print continues.'); EXIT( DWRITE) END ELSE EXIT( PRXREF) END ELSE IF IOERR <> 0 THEN BEGIN (* other I/O error *) IOE( IOERR, 'Xref overflow'); EXIT( PRXREF) END; (* count another rcd; reset ref-within-rcd counter *) DFCOUNT := DFCOUNT + 1; NR := 1 END; (**********************************) PROCEDURE DPUTREF( RLN: INTEGER); (* write a single ref entry; if array fills, put it to disk *) BEGIN D.REF[ NR] := RLN; NR := NR + 1; (* place it in array *) IF NR > DREFSPER THEN (* put to disk *) DPUT( D); END; (**********************************) BEGIN (* DWRITE *) MSG( 'xref overflow to disk; hunk #', 2); WRITE( NHUNKS+1, ';'); IF NHUNKS = 0 THEN BEGIN (* initial hunk; open file, initialize *) CLOSE( DF); REWRITE( DF, ',,DF.DFDF.DFDFZ'); DFCOUNT := 0 END; (* record statistics; count hunks *) HUNKSTART[ NHUNKS] := DFCOUNT; NHUNKS := NHUNKS + 1; TSORT( T, M); (* sort the present xref table *) WRITE('; writing'); HUNKLINE[ NHUNKS] := LINENUMBER; FOR I := 0 TO M-1 DO BEGIN (* write each symbol's entry to file *) IF ESCAPEHIT THEN (* user requests escape *) EXIT( PRINTTABLE); IF I MOD 50 = 25 THEN WRITE('.'); (* write the record with the symbol *) D.JUNK := 0; D.KEY := T[ I].KEY; DPUT( D); (* write the record(s) with the line number references *) RPTR := T[ I].FIRST; DONE := FALSE; REPEAT IF RPTR = T[ I].LAST THEN BEGIN (* last piece of refs *) NREFS := RPTR^.REFNUM; (* might not be a full array of refs *) DONE := TRUE END ELSE BEGIN (* not last piece; sure to be full *) NEXTRPTR := RPTR^.NEXT; NREFS := REFSPERITEM END; (* put all the references in this piece *) FOR R := 1 TO NREFS DO DPUTREF( RPTR^.REF[ R]); RPTR := NEXTRPTR (* point to next piece *) UNTIL DONE; (* pad out with some end codes *) FOR R := 1 TO DREFSPER DO DPUTREF( EREFCODE) END; HUNKSTART[ NHUNKS] := DFCOUNT; (* hunk statistics *) MSG( ' ', 2) END; (*****************************************************************) PROCEDURE DMERGE; (* merge and print the xref hunks put on file *) TYPE (* merge buffer template *) HBUFFINDEX = 0..HBUFFSIZE; BUFFRCD = RECORD BUFF: ARRAY[ HBUFFINDEX] OF DRCDS; NEXT, LAST: HBUFFINDEX; (* point to next-to-process, last-in-buff *) DCTR: INTEGER; (* location on disk for this hunk *) NOTFINI: BOOLEAN (* indicates if hunk is exhausted *) END; VAR HI, MINSPOT: HUNKPINDEX; NOMORE: BOOLEAN; MINSOFAR, MAXALFA, LOOKKEY, LASTKEY: ALFA; I, REFCOUNT: INTEGER; BUFFSTUFF: ARRAY[ HUNKPINDEX] OF BUFFRCD; (* merge buffers *) (*****************************************************************) PROCEDURE FILLBUFF( HI: HUNKPINDEX); (* fill merge buffer when it empties *) VAR DI: HBUFFINDEX; BEGIN WITH BUFFSTUFF[ HI] DO BEGIN WRITE( '.'); IF DCTR >= HUNKSTART[ HI] THEN BEGIN (* this hunk exhausted *) (* tell DMERGE that *) NOTFINI := FALSE END ELSE BEGIN (* fill buffer *) (* find correct hunk in file *) SEEK( DF, DCTR); DI := 0; (* read stuff into buffer *) WHILE ( DCTR < HUNKSTART[ HI]) AND ( DI < HBUFFSIZE) DO BEGIN GET( DF); DI := DI + 1; DCTR := DCTR + 1; BUFF[ DI] := DF^ END; (* set pointers to last rcd in buff; next rcd in buff to process *) LAST := DI; NEXT := 1; NOTFINI := TRUE END; END END; (*****************************************************************) PROCEDURE BUMPBUFF( HI: HBUFFINDEX); (* proceed to next rcd in buffer, filling from disk first if necessary *) BEGIN WITH BUFFSTUFF[ HI] DO BEGIN IF NEXT >= LAST THEN (* no more rcds to process in buff *) (* so read some more *) FILLBUFF( HI) ELSE (* just look at the next rcd in buff *) NEXT := NEXT + 1 END END; (*****************************************************************) PROCEDURE MPRINTREF( HI: HUNKPINDEX); (* when merging, print the id and reference at front of buffer HI *) VAR THISREF, RI: INTEGER; REFSDONE: BOOLEAN; BEGIN WITH BUFFSTUFF[ HI] DO BEGIN IF BUFF[ NEXT].KEY <> LASTKEY THEN (* this id different than last *) BEGIN LASTKEY := BUFF[ NEXT].KEY; (* record id for next round's test *) (* start new line and print the id *) SKIP( 1); WRITE( OUTFILE, LASTKEY:9); REFCOUNT := 0; NUMSYMS := NUMSYMS + 1; (* count a pgmr's symbol *) END; REPEAT (* process each array of references *) BUMPBUFF( HI); RI := 1; REFSDONE := FALSE; REPEAT WITH BUFF[ NEXT] DO BEGIN (* process single reference *) THISREF := REF[ RI]; IF THISREF = EREFCODE THEN (* have a end-of-refs flag *) REFSDONE := TRUE ELSE BEGIN (* have a real reference *) IF REFCOUNT >= REFSPERLINE THEN BEGIN (* new print line *) REFCOUNT := 0; SKIP( 1); WRITE( OUTFILE, ' ': 9) END; (* print the ref and bump array and printline counters *) PRINTREF( THISREF); REFCOUNT := REFCOUNT + 1; RI := RI + 1 END END UNTIL ( RI > DREFSPER) OR REFSDONE UNTIL REFSDONE; BUMPBUFF( HI) (* set up next thing in buffer for merging *) END END; (*****************************************************************) BEGIN (* DMERGE *) MSG( 'merging xref hunks from disk', 2); (* set up maximal symbol for merge runout *) FOR I := 1 TO ALFALEN DO MAXALFA[ I] := CHR( ORD( 'Z') + 1); (* fill all merge buffers initially *) FOR HI := 1 TO NHUNKS DO WITH BUFFSTUFF[ HI] DO BEGIN DCTR := HUNKSTART[ HI-1]; FILLBUFF( HI) END; LASTKEY := MAXALFA; (* merge loop; until all is printed *) REPEAT IF ESCAPEHIT THEN (* user requests escape *) EXIT( PRINTTABLE); NOMORE := TRUE; MINSOFAR := MAXALFA; FOR HI := 1 TO NHUNKS DO WITH BUFFSTUFF[ HI] DO BEGIN (* locate buffer with minimum key *) IF NOTFINI THEN BEGIN NOMORE := FALSE; LOOKKEY := BUFF[ NEXT].KEY; IF MINSOFAR > LOOKKEY THEN BEGIN MINSOFAR := LOOKKEY; MINSPOT := HI END END END; IF NOT NOMORE THEN BEGIN (* print the minimum element; bump buffer *) MPRINTREF( MINSPOT) END UNTIL NOMORE END; (*****************************************************************) PROCEDURE SHOWSTATS; VAR I: INTEGER; (* misc index work vbl *) BEGIN DRSIZE := SIZEOF( DRCDS); SKIP( 2); WRITE( OUTFILE, LINENUMBER: 5, ' Lines'); SK; WRITE( OUTFILE, NUMSYMS: 5, ' Programmer''s symbols'); SK; WRITE( OUTFILE, NUMREFS: 5, ' Programmer''s symbol usages (including declarations)'); SK; WRITE( OUTFILE, NUMKWREFS: 5, ' Keyword usages'); SK; WRITE( OUTFILE, (NUMKWREFS + NUMREFS): 5, ' Total symbol usages'); IF NHUNKS > 0 THEN BEGIN (* disk usage stats *) SK; SK; WRITE( OUTFILE, NHUNKS:5, ' Hunks of disk memory used'); SK; WRITE( OUTFILE, TRUNC(0.999+((DFCOUNT-1)*DRSIZE)/512.0): 5, ' Blocks of disk used (512 bytes/block)'); SK; SK; WRITE( OUTFILE, ' HUNK START--END (RCD #) START--END (LINE #)'); HUNKLINE[ 0] := 1; FOR I := 1 TO NHUNKS DO BEGIN SK; WRITE( OUTFILE, I:8, HUNKSTART[ I-1]:7, HUNKSTART[ I]-1: 6); WRITE( OUTFILE, ' ':11, HUNKLINE[ I-1]:5, HUNKLINE[ I]: 6); END END END; (* SHOWSTATS *) (*****************************************************************) BEGIN (* PRINTTABLE *) HOLDSPACING := SPACING; SPACING := 1; (* single space the xref *) NUMSYMS := 0; NUMREFS := 0; (* initialize statistics *) IF WHAT = DISK THEN BEGIN (* write present table to disk *) DWRITE; (* write it *) RELEASE( HEAPPOINT); MARK( HEAPPOINT); (* reclaim heap *) INITXREF (* initialize xref for next disk hunk *) END ELSE BEGIN (* either merge and print from disk or just print xref *) (* show in xref; fix page numbering, new page *) INXREF := TRUE; LPAGE := 1; TOPOFPAGE; IF WHAT = MERGE THEN DMERGE (* merge xref hunks from disk and print *) ELSE IF WHAT = PRINTER THEN BEGIN (* sort and print non-disk xref *) TSORT( T, M); WRITE(' printing xref'); FOR I := 0 TO M-1 DO BEGIN IF ESCAPEHIT THEN (* user requests escape *) EXIT( PRINTTABLE); IF I MOD 20 = 10 THEN WRITE('.'); PRINTWORD( T[ I]) END END; SHOWSTATS END; SPACING := HOLDSPACING (* restore spacing from single *) END; (*PRINTTABLE*) (**************************************************************************) ======================================================================================== DOCUMENT :usus Folder:VOL07:prxref.text ======================================================================================== (************************************************************************) (* *) (* PRXref -- Pascal program printer and cross-referencer *) (* *) (* Version 2.0 -- 1980 July *) (* submitted to UCSD Pascal System Users Society, 1980 July 14 *) (* *) (* program and documentation written by David J. Lewis *) (* *) (* Digicomp Research Corporation, *) (* Terrace Hill, *) (* Ithaca, N.Y. 14850 *) (* 607-273-5900 *) (* and *) (* Department of Mathematics, *) (* Ithaca College, *) (* Ithaca, N.Y. 14850 *) (* 607-274-3108 *) (* *) (* Copyright (C) 1980, David J. Lewis *) (* *) (* Permission is granted to use and copy this program and its *) (* documentation under the terms of the UCSD Pascal Users' Group *) (* as of 1980 July 14. Use or copying of this program or *) (* documentation under any other circumstances or terms is *) (* prohibited without the prior, written consent of the author. *) (* In particular, any resale or distribution for profit is prohibited. *) (* *) (* "UCSD Pascal" is a registered trademark of the Regents of the *) (* University of California. *) (* *) (************************************************************************) (*#P*) PROGRAM PRXREF; LABEL 2; (* for escaping upon keyboard request *) CONST (* constants describing and controlling printer output *) PAGELINES = 66; (* lines per printed page *) TOPMARGIN = 2; (* margin above header *) BOTMARGIN = 4; (* margin at bottom of page *) HEADERMARGIN = 1; (* margin after header *) HEADERSIZE = 80; (* columns in hdr *) HEADERCHAR = '-'; (* character for header separater *) LNUMWIDTH = 5; (* cols for line number print *) LINELENGTH = 130; (* total print columns *) NUMPRNULLS = 0; (* how many nulls to send on CR to printer *) REFSPERLINE = 14; (* refs per print line; 14 is right for 80 columns *) SYMPRLENGTH = 8; (* width of printed symbol *) INITPAGE = 1; (* initial page number *) PRFORMFEED = 0; (* printer form feed char (0 ==> it has none) *) (* miscellaneous ascii characters *) BS = 8; DLE = 16; CR = 13; NULL = 0; ETX = 3; ESC = 27; BELL = 7; (* locations of items on the display; the picture: *) (* +---------------------------------------------+ *) (* | prompt line | <--PRROW *) (* | | *) (* | option :response error message | <--PRROWA *) (* | option :response error message | *) (* | . . . | *) (* | . . . | *) (* | . . . | *) (* | option :response error message | *) (* | | <--PRGAP lines *) (* | message: main file name & copy count | here *) (* | message: included file name | *) (* | miscellaneous messages | *) (* | | *) (* +---------------------------------------------+ *) (* ^PRCOL *) (* ^PRCOLA ^PRCOLB ^PRCOLC *) PRCOL = 0; (* column for prompt line and messages *) PRCOLA = 2; (* column for options *) PRCOLB = 17; (* column for colon for user response *) PRCOLC = 36; (* column for option error messages *) PRROW = 0; (* row for prompt *) PRROWA = 2; (* top row of options *) PRGAP = 1; (* gap between bottom option and 3 lines for messages *) (* These values should fit on a 18 x 64 screen. *) (* Those unfortunates with only 16 lines should set PRROWA=1; PRGAP=0. *) (* minimum dimensions of display; to be checked against SYSTEM.MISCINFO *) MINSCRWIDTH = 64; MINSCRHEIGHT = 18; (* constants describing the scatter storage table and hash headers *) P = 863; (* size of hash table; must be a prime number *) ALFALEN = 8; (* characters per identifier *) REFSPERITEM = 5; (* # refs in a table item *) (* constants controlling shape of xref overflow to disk *) DREFSPER = 5; (* # refs per item in disk overflow *) MAXNHUNKS = 10; (* maximum number of hunks overflowed to disk *) HBUFFSIZE = 100; (* size of merge buffer to process disk overflow *) MEMTHRESH = 600; (* ovflow xref when <= MEMTHRESH bytes left in stack/heap *) LOADFACTOR = 0.9; (* overflow xref when table is this fraction full *) INTSPERALFA = 4; (* num of integers in 8 bytes *) (* codes to enter in xref indicating a keyword and proc/func *) KWCODE = -9998; PROCCODE = -9999; EREFCODE = -9997; (* code to mark end of disk xref item *) BUFFMAX = 647; (* 512+linelength+3 (for indent, CR): buffer size needed *) (* ok to leave this large; now accomodates 132 char line *) TYPE (* input buffer *) BINDX = 1..BUFFMAX; BINDXZ = 0..BUFFMAX; BUFFER = PACKED ARRAY[ BINDX] OF CHAR; (* scatter storage table types *) ALFA = PACKED ARRAY[ 1..ALFALEN] OF CHAR; (* for identifiers *) INDEX = 0..P; (* index for hash table *) ITEMPTR = ^ITEM; WORD = RECORD (* hash table entry *) KEY: ALFA; (* the identifier its very self *) FIRST, LAST: ITEMPTR; (* point to chain of item arrays *) END ; REFINDEX = 1..REFSPERITEM; REFTYPE = ( COUNT, PTR); ITEM = RECORD (* array of references; link these together *) REF: ARRAY[ REFINDEX] OF INTEGER; (* the array *) CASE REFTYPE OF COUNT: ( REFNUM: REFINDEX); (* size of array *) PTR: ( NEXT: ITEMPTR) (* or a pointer to next item array *) END; (* disk records for xref overflow *) HUNKPINDEX = 1..MAXNHUNKS; HUNKQINDEX = 0..MAXNHUNKS; DINDEX = 1..DREFSPER; DRCDS = RECORD CASE BOOLEAN OF (* a disk record *) TRUE: ( JUNK: INTEGER; KEY: ALFA); FALSE: ( REF: ARRAY[ DINDEX] OF INTEGER) END; PTABLETYPE = ( PRINTER, DISK, MERGE); (* instruct PRINTTABLE *) BIGSTRING = STRING[ 255]; CTLSTRING = STRING[ 13]; (* for ERASEEOL and ERASEEOS's strings *) VAR (* output file names *) PRINTUNIT: INTEGER; PRINTTITLE: STRING; UNITOUT: BOOLEAN; (* true ==> output to a unit; false ==> to a file *) (* variables for user options *) (* PRINTING <==> P(rinting: Yes *) (* XREFFING <==> X(ref: Yes *) (* INCLU <==> I(nclude: Yes *) (* PAGESKIP <==> S(kip pages: Yes *) (* SPACING = L(ine spacing *) (* NUMBERING <==> N(umbering: Yes *) (* INCLSKIPPING <==> K( inclsKip: Yes *) (* TIMES = #( of copies *) (* CMDCHAR = C(ommand char *) (* VFORMATTING <==> V(ert format: Yes*) INCLSKIPPING, PRINTING, NUMBERING, XREFFING: BOOLEAN; VFORMATTING, INCLU, PAGESKIP: BOOLEAN; SPACING, TIMES: INTEGER; CMDCHAR: CHAR; (* scatter storage variables *) T: ARRAY [ INDEX] OF WORD; (* hash header table *) TOP: INDEX; (* top of chain linking all entries in T *) (* stuff for statistics *) NUMKWREFS: INTEGER; (* total number of kw references *) LNUMENTRIES: INTEGER; (* local to a hunk: # tbl entries, kws *) (* stuff for overflow to disk *) DF: FILE OF DRCDS; (* file for xref overflow *) NHUNKS: HUNKQINDEX; (* counts disk hunks in DF *) DFCOUNT: INTEGER; (* counts records put to DF *) HEAPPOINT: ^INTEGER; (* for cutting back heap after writing disk hunk *) MAXNUMENTRIES: INTEGER; (* overflow to disk when # entries exceeds this *) (* record and line numbers delimitting disk hunks *) HUNKSTART, HUNKLINE: ARRAY[ HUNKQINDEX] OF INTEGER; GLOBLOCK: INTEGER; (* to report block num in PUT error *) (* misc vbls controlling printed output *) OUTFILE: TEXT; (* output file (if not a unit) *) CURLINE: INTEGER; (* where on page are we printing now *) NULLS: PACKED ARRAY[ 0..NUMPRNULLS] OF CHAR; (* for printer nulls *) LINENUMBER: INTEGER; (* line number in file, for output *) FININCL: BOOLEAN; (* helps control include page skipping *) PRINTLAST: INTEGER; (* last print line to print on before page eject *) FIRSTPAGE: BOOLEAN; (* ==> first page not printed yet, for page eject *) (* misc vbls for print heading *) LPAGE, GPAGE: INTEGER; (* for print page numbering *) HEADER: STRING; (* for print headers *) HEADERSEP: STRING[ HEADERSIZE]; (* separator after standard header *) TITLEHDRS, HDRS: BOOLEAN; (* control type of hdrs *) TODAY: STRING; (* today's date -- printable *) (* misc main prog and global work vbls *) MAINNAME, LNAME: STRING; (* input file and included file names *) INXREF: BOOLEAN; (* ==> in xref phase of pgm *) REPETITION: INTEGER; (* for repeating file processing TIMES times *) IOERR: INTEGER; (* for reporting i/o errors *) C: CHAR; (* for kb hit checking *) MSGLINE: INTEGER; (* where on display for msgs *) CMDCHARSET: SET OF CHAR; (* for checking format directives *) EOLSTRING, EOSSTRING: CTLSTRING; (* for ERASEEOL, -EOS *) ESCAPING: BOOLEAN; (* ==> keyboard escape requesting abort *) GOAHEAD: BOOLEAN; (* kludge for escape and finish up skip *) (**************************************************************************) PROCEDURE SKIP( NUM: INTEGER); FORWARD; (* line skip *) PROCEDURE TOPOFPAGE; FORWARD; (* page eject *) PROCEDURE ERASEEOL; FORWARD; (* erase display to end of line *) PROCEDURE ERASEEOS; FORWARD; (* ...ditto end of screen *) PROCEDURE SEARCH( IDX: ALFA); FORWARD; (* xref tbl lookup/enter *) FUNCTION FILECHECK( VAR S: STRING): BOOLEAN; FORWARD; (* check input file *) PROCEDURE UCFOLD( VAR C: CHAR); FORWARD; (* fold lower case to upper *) PROCEDURE MSG( S: STRING; L: INTEGER); FORWARD; (* display message *) PROCEDURE IOE( I: INTEGER; S: STRING); FORWARD; (* i/o err msg and abort *) FUNCTION ESCAPEHIT: BOOLEAN; FORWARD; (* checks KB, holds up, T iff esc *) (*$I PRXREF.TBL*) (*$I PRXREF.OPT*) (*$I PRXREF.INI*) (*$I PRXREF.UTL*) (*$I PRXREF.PFI*) (*******************************************************************) (*$G+*) BEGIN {main program} INITIALIZE( TRUE); (* first initialization of almost everything *) REPEAT (* forever -- until user says Q(uit *) (* solicit options from user *) OPTIONS; (* process the file the requested number of times *) REPETITION := 1; GOAHEAD := TRUE; WHILE (REPETITION <= TIMES) AND GOAHEAD DO BEGIN INITIALIZE( FALSE); (* init for a repitition *) MSG( 'file: ', 0); WRITE( MAINNAME, ', copy ', REPETITION, ' of ', TIMES); LNAME := MAINNAME; ESCAPING := FALSE; (* assume not escaping yet *) PFILE( MAINNAME); (* do the read/print work *) (* all done printing *) IF ESCAPING THEN (* immediately back to options *) GOTO 2; IF XREFFING THEN BEGIN (* xref was requested; print the table *) IF NOT PAGESKIP THEN SKIP( 1); IF NHUNKS = 0 THEN (* disk wasn't used for xref *) BEGIN PRINTTABLE( PRINTER); IF ESCAPING THEN GOTO 2 END ELSE BEGIN (* disk was used for xref *) (* write last piece to disk, then print whole mess from disk *) PRINTTABLE( DISK); IF ESCAPING THEN GOTO 2; PRINTTABLE( MERGE); IF ESCAPING THEN GOTO 2 END END; 2: (* escape point *) IF ESCAPING THEN BEGIN ESCAPING := FALSE; (* so final page skip will work *) GOAHEAD := FALSE (* but loop will stop *) END; (* final page skip *) IF PAGESKIP THEN PLAINSKIP( PAGELINES - CURLINE + 1); REPETITION := REPETITION + 1 END; IF UNITOUT OR ESCAPING THEN CLOSE( OUTFILE) ELSE CLOSE( OUTFILE, LOCK) UNTIL FALSE END. (*$G-*) ======================================================================================== DOCUMENT :usus Folder:VOL07:prxref.utl.text ======================================================================================== (*****************************************************************) (* PRXREF.UTL -- for USUS -- 1980 July 14 (disabled KEYHIT) *) (*****************************************************************) (* screen control -- takes cues from SYSTEM.MISCINFO, via two strings *) (* EOLSTRING and EOSSTRING established by procedure INITSCREEN *) PROCEDURE ERASEEOL; (* erase display to end of line *) BEGIN UNITWRITE( 1, EOLSTRING[ 1], LENGTH( EOLSTRING), , 4 (* ==> raw output *) ) END; PROCEDURE ERASEEOS; (* erase display to end of screen *) BEGIN UNITWRITE( 1, EOSSTRING[ 1], LENGTH( EOSSTRING), , 4 (* ==> raw output *) ) END; (**************************************************************************) PROCEDURE DOTTEXT( VAR S: STRING); (* appends ".TEXT" to file name S if it doesn't already have one *) VAR I: INTEGER; C: CHAR; BEGIN FOR I := 1 TO LENGTH( S) DO BEGIN C := S[ I]; UCFOLD( C); S[ I] := C END; IF (( POS( '.TEXT', S) <> LENGTH( S) - 4) OR ( LENGTH( S) <= 4)) THEN S := CONCAT( S, '.TEXT') END; (**************************************************************************) FUNCTION FILECHECK (*** VAR S: STRING ): BOOLEAN ***) ; (* verify that input .TEXT file S exists, return TRUE if it does *) VAR DUMMYFILE: FILE; BEGIN DOTTEXT( S); (*$I-*) RESET( DUMMYFILE, S); (*$I+*) FILECHECK := (IORESULT = 0); CLOSE( DUMMYFILE) END; (****************************************************************) PROCEDURE UCFOLD(*** VAR C: CHAR ***); (* Folds lower case alphabetics into upper case. *) BEGIN IF ( C >= 'a') THEN IF ( C <= 'z') THEN C := CHR( ORD( C) - 32) END; (**************************************************************************) PROCEDURE MSG (*** S: STRING; L: INTEGER ***) ; (* display S on msg line L *) BEGIN GOTOXY( PRCOL, MSGLINE+L); ERASEEOL; WRITE( S); END; PROCEDURE IOE(*** N: INTEGER; S: STRING ***); (* handle fatal I/O error *) BEGIN MSG(' I/O error on file: ', 2); WRITE( S); EXIT( PRXREF) END; (**************************************************************************) PROCEDURE SEARCH(*** IDX: ALFA***); (* global: T, TOP *) (*************************************************************************) (* Process and enter symbol IDX in the cross-reference symbol table *) (* The crux of this routine is taken from N. Wirth, ALGORITHMS + DATA *) (* STRUCTURES = PROGRAMS, pages 264-274. The original version *) (* was supplied with the release of UCSD Pascal version I.4. *) (* This version is considerably modified by the present author. *) (* The general method is hashing with quadratic probing. This is *) (* fully documented in the reference, so only modifications will be *) (* discussed here. *) (* The identifier IDX is sought in the table, provided it begins with *) (* a non-numeric character. If a found symbol is a keyword, it is *) (* ignored. Otherwise, it is assumed a programmer's symbol and entered *) (* in the table with the line number on which it occurred. A symbol *) (* not found initiates a new table entry for a programmer's symbol. *) (* Keywords are entered in the table with a special, negative line number, *) (* before the program begins (see INITXREF). *) (* Should the table fill up, the disk table handler is invoked. *) (* The table is sorted and written to disk for later merging with other *) (* portions. The table is then reinitialized for further entries. *) (*************************************************************************) VAR I, H, D: INTEGER; JR: REAL; X : ITEMPTR; F: BOOLEAN; FCH: CHAR; (* record to deal with ID simultaneously as alphanumeric and numeric *) IDREC: RECORD CASE BOOLEAN OF TRUE: ( ID: ALFA); FALSE: ( NUM: PACKED ARRAY[ 1..INTSPERALFA] OF INTEGER ) END; BEGIN (* SEARCH *) WITH IDREC DO BEGIN (* reject symbols beginning with a numeric character *) FCH := IDX[1]; IF (FCH <= '9') AND (FCH >= '0') THEN EXIT( SEARCH); ID := IDX; JR := 0.0; (* hash the symbol (without using integer overflow) *) FOR I := 1 TO INTSPERALFA DO BEGIN JR := JR + NUM[ I]; IF JR > 32766.9 THEN JR := JR - 32766.9 END; H := TRUNC( JR) MOD P; (* search the scatter store with quadratic probing *) F := FALSE; D := 1; REPEAT IF T[H].KEY = ID THEN BEGIN (* found *) F := TRUE; (* terminate search *) IF T[ H].FIRST <> NIL THEN BEGIN (* found is not keyword *) (* check if room left in the current item *) IF T[H].LAST^.REFNUM = REFSPERITEM THEN BEGIN (* no room; create new item and link to previous one *) NEW( X); X^.REFNUM := 1; X^.REF[ 1] := LINENUMBER; T[ H].LAST^.NEXT:= X; T[ H].LAST := X; END ELSE WITH T[ H].LAST^ DO BEGIN (* there is room; insert symbol in current item *) REFNUM := REFNUM + 1; REF[ REFNUM] := LINENUMBER END END ELSE BEGIN (* found is a keyword *) NUMKWREFS := NUMKWREFS + 1 (* count the ref *) END END ELSE IF T[ H].KEY = ' ' THEN BEGIN (* new entry *) F := TRUE; (* terminate search *) LNUMENTRIES := LNUMENTRIES + 1; (* local entry count, for ovflw check *) (* check if this is to be a keyword entry *) IF LINENUMBER <> KWCODE THEN (* non keyword *) BEGIN (* enter symbol and start new item *) NEW( X); X^.REFNUM := 1; X^.REF[1] := LINENUMBER; T[H].FIRST := X; T[H].LAST := X END ELSE (* keyword *) BEGIN (* indicate that by NIL pointer *) T[ H].FIRST := NIL; END; T[ H].KEY := ID; TOP := H END ELSE BEGIN (* collision; quadratic probe *) H := H + D; D := D + 2; IF H >= P THEN H := H - P; IF D = P THEN BEGIN (* table overflow; shouldn't happen if table is sufficiently large *) (* since table will be written to disk before it occurs *) WRITELN( OUTPUT,'Internal error: table overflow!!'); EXIT( PRXREF) END END UNTIL F; (* check if hash load factor exceeded or dynamic memory exhausted *) IF (LNUMENTRIES >= MAXNUMENTRIES) OR (MEMAVAIL < MEMTHRESH) THEN (* write current table contents to disk *) PRINTTABLE( DISK) END END (*SEARCH*) ; (**************************************************************************) PROCEDURE PUTCRLF; (* Do printer line skip, with regard for possible printer need for nulls *) VAR I: INTEGER; BEGIN IF PRINTING OR INXREF THEN FOR I := 1 TO SPACING DO BEGIN WRITE( OUTFILE, CHR(CR)); IF NUMPRNULLS > 0 THEN IF UNITOUT THEN IF PRINTUNIT = 6 THEN UNITWRITE( PRINTUNIT, NULLS[ 1], NUMPRNULLS) END END; (**************************************************************************) PROCEDURE BUMPLINE; (* perform logical line skip; watch for page overflow *) VAR I: INTEGER; BEGIN IF CURLINE >= PRINTLAST THEN TOPOFPAGE; CURLINE := CURLINE + SPACING END; (**************************************************************************) PROCEDURE SKIP(*** NUM: INTEGER***); (* skip NUM lines on printer, logically and physically *) VAR I: INTEGER; BEGIN FOR I := 1 TO NUM DO BEGIN BUMPLINE; PUTCRLF; IF ESCAPEHIT THEN EXIT( SKIP) END END; (**************************************************************************) PROCEDURE PLAINSKIP( N: INTEGER); (* uncomplicated skip; no check for end of page, etc. *) VAR I: INTEGER; BEGIN FOR I := 1 TO N DO BEGIN CURLINE := CURLINE + 1; PUTCRLF; IF ESCAPEHIT THEN EXIT( PLAINSKIP) END END; (**************************************************************************) PROCEDURE TOPOFPAGE; (* Page skip; respects header, pageskipping options, prints hdrs, etc *) VAR I: INTEGER; BEGIN IF PRINTING OR INXREF THEN BEGIN (* otherwise don't bother *) IF PAGESKIP THEN (* skip to top of new physical page *) IF NOT FIRSTPAGE THEN (* actual skip is required *) IF (PRFORMFEED <> 0) AND UNITOUT THEN (* send formfeed char *) WRITE( OUTFILE, CHR( PRFORMFEED)) ELSE (* do it with skips *) PLAINSKIP( PAGELINES - CURLINE + 1); (* else user has set it there already *); (* set curline for new page; show no longer first page *) CURLINE := 1; FIRSTPAGE := FALSE; IF HDRS OR PAGESKIP THEN PLAINSKIP( TOPMARGIN); (* margin above hdr *) IF HDRS THEN BEGIN (* print the header *) IF PRINTING THEN BEGIN IF TITLEHDRS THEN (* use standard file title header *) BEGIN WRITE( OUTFILE, 'FILE: ', MAINNAME, ' PAGE ', GPAGE); IF LNAME <> MAINNAME THEN (* show included file name *) WRITE( OUTFILE, ' ':12, 'INCLUDED FILE: ', LNAME, ' PAGE ', LPAGE) END ELSE (* user header from format command *) WRITE( OUTFILE, HEADER, GPAGE) END; IF INXREF THEN BEGIN (* special header during xref *) IF NOT PRINTING THEN WRITE( OUTFILE, 'FILE: ', MAINNAME); WRITE( OUTFILE, ' ':12, 'CROSS REFERENCE', ' PAGE ', LPAGE) END; (* header separator *) PLAINSKIP( 1); WRITE( OUTFILE, HEADERSEP); PLAINSKIP( HEADERMARGIN+1) END; (* update page counters, global and local (for included file) *) GPAGE := GPAGE + 1; LPAGE := LPAGE + 1 END END; (**************************************************************************) PROCEDURE STRIPSTRING( VAR S: BIGSTRING); (* strip leading and trailing blanks from S; maybe down to null string *) VAR A, B, L: INTEGER; BEGIN L := LENGTH( S); IF L > 0 THEN BEGIN A := SCAN( L, <>' ', S[ 1]); (* find first non-space *) IF A >= L THEN (* nothing but spaces in S *) S := '' ELSE (* find last non-space; extract middle *) BEGIN B := SCAN( -L, <>' ', S[ L]); S := COPY( S, A+1, L-A+B) END END END; (**************************************************************************) FUNCTION STRTON( S: BIGSTRING): INTEGER; (* small, crummy routine to convert string to integer *) (* assumes S stripped of leading and trailing blanks *) (* handles up to 3 digits, no sign; returns -1 on any error *) VAR N, I: INTEGER; ERR: BOOLEAN; BEGIN IF LENGTH( S) > 3 THEN ERR := TRUE ELSE BEGIN N := 0; I := 1; ERR := FALSE; REPEAT IF S[ I] IN [ '0'..'9'] THEN BEGIN N := N * 10 + ORD( S[ I]) - ORD( '0'); I := I + 1 END ELSE ERR := TRUE; UNTIL (I > LENGTH( S)) OR ERR; IF ERR THEN STRTON := -1 ELSE STRTON := N END END; (**************************************************************************) FUNCTION KEYHIT: BOOLEAN; (* if any key on terminal is hit, return true *) (* if nothing happening on kb, return false without ado *) {-----------------------------------following is commented out----- (* This version is for Pascal-100 (TM), the Pascal CPU for the S-100 bus *) (* manufactured by Digicomp Research *) (* with a Cromemco Tuart at ports 0 (control) and 1 (data) *) CONST CTLPORT = 0; (* which port tells *) RDABIT = 6; ACTIVELOW = FALSE; TYPE WORDBITS = PACKED ARRAY[ 0..15] OF BOOLEAN; VAR PORT: RECORD CASE INTEGER OF 0: (IADDR: INTEGER); 1: (ADDR: ^WORDBITS) END; BEGIN WITH PORT DO BEGIN IADDR := CTLPORT - 256; (* set the port pointer *) (* read the port, active low or high as appropriate *) IF ACTIVELOW THEN KEYHIT := NOT ADDR^[ RDABIT] ELSE KEYHIT := ADDR^[ RDABIT]; END END; ------------------------------------above is commented out---------} {-----------------------------------following is commented out----- (* This is a version for a module in the library *) EXTERNAL; ------------------------------------above is commented out---------} (* This is a version that does nothing; assumes nothing *) (* This is the active routine *) BEGIN KEYHIT := FALSE END; (* Boy, do we need conditional compilation !! *) (**************************************************************************) FUNCTION ESCAPEHIT (*** : BOOLEAN ***); (* looks for kb hit; if yes and escape, abort; else wait for another *) (* and look again for escape *) (* sets the global vbl ESCAPING as well as the function itself *) (* if ESCAPING is true to begin with, it will remain true regardless of *) (* keyboard activity or lack thereof *) BEGIN IF KEYHIT THEN (* somebody knocking *) BEGIN READ( KEYBOARD, C); (* read what's there *) IF C <> CHR( ESC) THEN BEGIN (* hold everything until another hit *) MSG( 'any key to continue; to quit', 2); READ( KEYBOARD, C); MSG( ' ', 2) END; IF C = CHR( ESC) THEN BEGIN MSG( ' again to quit PRXref; ', 2); WRITE( 'any other key to reinitialize'); READ( KEYBOARD, C); IF C = CHR( ESC) THEN EXIT( PRXREF); ESCAPING := TRUE END END; ESCAPEHIT := ESCAPING END; (*********************************************************) ======================================================================================== DOCUMENT :usus Folder:VOL08:archiver.text ======================================================================================== {Copyright 1980 by Stuart Lynne 1350 Clifton Ave. Coquitlam, British Columbia, Canada V3J 5K6 Permission granted to use for noncommercial purposes. All other rights reserved} { * Archiver * * Author: Stuart Lynne * * Date: August 22, 1980 * } {$I globals } segment procedure userprogram; const bufsize = 60; type blocktype = array [0..255] of integer; var lastblock, archlast, archsize: integer; command: char; initial: boolean; archname, volname: vid; Fi: file; function min (A, B: integer): integer; begin if A < B then min := A else min := B end; procedure archinitialize; var volinfo: directory; begin initial := false; unitread (4, volinfo, sizeof (volinfo), 2); archlast := volinfo[volinfo[0].dnumfiles].dlastblk; archsize := volinfo[0].deovblk; archname := volinfo[0].dvid; writeln; writeln ('The archive disk is ', archname, '.'); writeln ('It is ', archsize, ' blocks long and has ', archsize - archlast, ' blocks left for use.') end; procedure srceinitialize; var volinfo: directory; begin unitread (5, volinfo, sizeof (volinfo), 2); lastblock := volinfo[volinfo[0].dnumfiles].dlastblk; volname := volinfo[0].dvid; writeln; writeln ('Now archiving ',volname, ' which is ',lastblock, ' blocks long.') end; function tryagain: char; var C: char; begin writeln; write ('A(rchive, N(ew, Q(uit, D(irectory'); read (C); tryagain := C; writeln end; procedure transfer; var I, Count: integer; buf: array [1..bufsize] of blocktype; Fo: file; begin rewrite (Fo, concat ('#4:', volname, '.dsk')); Count := 0; while Count < lastblock do begin I := blockread (Fi, buf, min (lastblock - Count, bufsize)); if blockwrite (Fo, buf, I) <> I then begin close (Fo, purge); writeln ('No room on volume'); exit (transfer) end; Count := Count + i end; archlast := archlast + Count; close (Fo, lock); writeln (volname, ' has been archived.'); writeln ('There are ', archsize - archlast, ' blocks left on ', archname); end; procedure directory; var fname: string; begin write ('Directory of what disk'); readln (fname); if fname = end; begin writeln; writeln ('Archiver version 1.0'); writeln; writeln ('Archive disk on unit # 4.'); writeln ('Source disk on unit # 5.'); initial := true; repeat command := tryagain; if command in ['n', 'N'] then archinitialize else if initial then writeln ('N(ew archive disk please!') else if command in ['A', 'a'] then begin reset (Fi, '#5:'); srceinitialize; if (lastblock + archlast) < archsize then transfer else begin writeln (volname, ' will not fit on ', archname) end; close (Fi, normal) end else if command in ['D', 'd'] then directory until command in ['q', 'Q']; writeln; writeln ('Replace System Disk!'); readln end; begin end. ======================================================================================== DOCUMENT :usus Folder:VOL08:catalog.8.text ======================================================================================== CATALOG FOR VOLUME 8 -**- USUS LIBRARY More Software Tools and a Few Utilities. (updated 26 July 1981 -- changed from Newsletter listing) name blks description ARCHIVER.TEXT 10 Save & retrieve disk images. BANNER.TEXT CHAIN.TEXT 6 Chain to another program. CHAIN.1.TEXT 4 Demo programs... CHAIN.2.TEXT 4 COPYBLOCKS.TEXT 6 Copy blocks to a file by block number. CRMBLEV1.2.TEXT 14 Break up long files for editing with the UCSD editor. D.TEXT 20 Revised disk directory lister. DISKSORT.TEXT 12 Revised sample sort. ERROR.DATA.TEXT 4 Messages used by FILEUNIT. EXHALEV2.1.TEXT 6 Send data to remote port. INHALEV2.1.TEXT 8 Receive data from remote. FAST.SEEK.TEXT 10 Greatly speed SEEK procedure. FILEUNIT.TEXT 32 General-purpose file handling routines. GLOBAL.II0.TEXT 30 GLOBALS for UCSD system II.0. GLOBAL.III.TEXT 36 .....III.0. LINECOUNT.TEXT 10 Counts lines in text files or entire volumes. LISP.TEXT 28 Public-domain LISP interpreter. LISTER.TEXT 6 List text files. MAILER.DOC.TEXT 10 MAILER.TEXT 22 Mailing list facility; sounds NICE. MODEMV2.2.TEXT 8 Rework of program on Volume 2A. MULDIV.Z80.TEXT 6 Part of Z80.SEEK. PERUSEV4.6.TEXT 14 Look over a text file forwards & back; FAST! RECOVER.TEXT 6 Find program source text after zapping a directory. REM.TERM.TEXT 34 Hardware-independent communications utility. REM.UNIT.TEXT 32 One implementation of new USUS standard remote unit. SCREEN.TEXT 6 Western Digital screen control unit. SCREENUNIT.TEXT 10 Terminal-independent screen control from Volume 5. UNITS.DOC.TEXT 22 Documentation for FILEUNIT. VOLUME.8.TEXT 32 Documentation for the files on this disk. WRITERV7.2.TEXT 34 Nice text printer, updated from Volume 2A. Z80.SEEK.TEXT 8 Fast seek routine specific to Z-80's. NOTES: These files may be distributed to USUS members ONLY and may be used only for noncommercial purposes, unless written consent of the author is obtained, in which case author instructions prevail. All disk formats will contain the same material (minifloppies on two disks). This material has not been tested thoroughly; send bug reports and fixes to me and to the USUS Newsletter. Jim Gagne, USUS Library Chairman ======================================================================================== DOCUMENT :usus Folder:VOL08:chain.1.text ======================================================================================== program chain_1; procedure chain (S: string); external; begin writeln; writeln ('Hello there from Chain test program # 1'); chain ('Chain.2.code') end. ======================================================================================== DOCUMENT :usus Folder:VOL08:chain.2.text ======================================================================================== program chain_2; begin writeln; writeln ('Hello there from Chain test program # 2') end. ======================================================================================== DOCUMENT :usus Folder:VOL08:chain.text ======================================================================================== {Copyright 1980 by Stuart Lynne 1350 Clifton Ave. Coquitlam, British Columbia, Canada V3J 5K6 Permission granted to use for noncommercial purposes. All other rights reserved} { chainer } {$S+} { * * Chain * * Author: Stuart Lynne * } {$C Copyright (c) 1980, by Stuart Lynne. All rights reserved. } {$I globals} {L+} {D+} {L printer: } separate unit chainer; interface type seg_set = set of 0..15; sysp = ^ syscomrec; procedure Chain (S: string); procedure SysDate (var D: daterec); procedure syscomp (var S: sysp); implementation type intseg = array[1..15] of record address, refcount: integer end; procedure Chain (*S: string *); var dummy: integer; kind: filekind; begin state := linkandgo; userinfo.gotcode := true; if scantitle (S, userinfo.codevid, userinfo.codetid, dummy, kind) then; end; {$P} procedure SysDate (* var D: daterec *); begin D := thedate end; procedure syscomp (* var S: sysp *); begin S := syscom end; end; begin end. ======================================================================================== DOCUMENT :usus Folder:VOL08:copyblocks.text ======================================================================================== PROGRAM COPYBLOCKS; USES (*$U screenunit.code*)SCREENUNIT, (*$U fileunit.code*)FILEUNIT; {by George Schreyer} VAR I,J,K,L,M,N : INTEGER; DISKA,DISKB : FILE; VOLNAME,FILENAME : STRING; DATA : PACKED ARRAY [0..511] OF CHAR; BEGIN GETCRTINFO; GOTOXY(0,0); CRT(ERASEOS); WRITELN(' copyblocks version 1.0 13-Jun-81'); VER_SCREENUNIT; VER_FILEUNIT; WRITELN; WRITELN('Copyblocks transfers a group of blocks, probably a whole file'); writeln('which has for some reason dissappeared from the directory,'); WRITELN('from a file or volume to a text file. You must supply the'); WRITELN('absolute starting block from the beginning of the file or volume'); writeln('and the number of blocks which are to be transferred. '); OPNDSKREAD(DISKA,'name of source volume ?',VOLNAME,0,11); IF VOLNAME='' THEN EXIT(PROGRAM); OPNDSKWRT(DISKB,'Filename of output file ? ',FILENAME,0,13); IF FILENAME='' THEN EXIT(PROGRAM); WRITELN; WRITE('Blocknumber to start from ? '); READLN(I); WRITE('Number of blocks to copy ? '); READLN(J); FOR L:= I TO I+J-1 DO BEGIN K:=BLOCKREAD(DISKA,DATA,1,L); K:=BLOCKWRITE(DISKB,DATA,1); END; CLOSE(DISKB,LOCK); END. ======================================================================================== DOCUMENT :usus Folder:VOL08:crmblev1.2.text ======================================================================================== PROGRAM CRUMBLE; USES(*$U SCREENUNIT.CODE*) SCREENUNIT, (*$U FILEUNIT.CODE*) FILEUNIT; { by George Schreyer Program crumble will break a text file which is too large for the editor to handle in bite sized chunks. The program will first ask for the base file (the too big one) and then for a generic include file name, that is a name up to seven characters onto which it will append the suffix '.0 ... .N' where N is the number of the particular include file into which your code is going. The program will keep track of the size of each include file so that it itself won't get too large. After the program has copied the requested number of records (lines) it will display the current (approx) size in bytes and then ask if you want too stuff even more records into it or create a new include file to take the new lines. If you don't have a listing with line numbers on it try transferring about 300 lines at a time or eX)ecute WRITER and get a listing with numbers.} {Copyright 1980 by George Schreyer. All rights reserved} {Non commercial use is ok} CONST VERSION = 'crumble version 1.2 30-Apr-81'; VAR REC_COUNT : INTEGER; STOP_RECORD : INTEGER; START_RECORD : INTEGER; NUM_BYTES : INTEGER; GOTFILE : BOOLEAN; BASE_FILENAME : STRING; NAME_OK : BOOLEAN; FILENUM : INTEGER[2]; INCLUDE : TEXT; BASE : TEXT; INCLUDE_FILENAME : STRING; FILENAME : STRING; MORE : BOOLEAN; LAST_REC : INTEGER; STOP_NOW : BOOLEAN; REPLY : CHAR; MORE_DATA : BOOLEAN; POS_COLON : INTEGER; I : INTEGER; I_TRIED : BOOLEAN; IORESLT : INTEGER; PROCEDURE CLEAR_SCREEN; BEGIN GOTOXY(0,0); CRT(ERASEOS); END {CLEAR_SCREEN}; PROCEDURE CLEAR_EOL(X,Y : INTEGER); BEGIN GOTOXY(X,Y); CRT(ERASEOL); END; {clear_eol} PROCEDURE WARNING; VAR REPLY : CHAR; RECS_LEFT : INTEGER; BEGIN CLEAR_EOL(0,0); RECS_LEFT:=STOP_RECORD-REC_COUNT; WRITE('Your include file is 9/10 full and you have ',RECS_LEFT:4, ' records left to copy.'); CLEAR_EOL(0,1); WRITE('Are you sure that you wish to continue? (Y/N) '); READ(REPLY); IF REPLY <> 'Y' THEN BEGIN STOP_NOW:=TRUE; END ELSE MORE_DATA:=TRUE; END; {warning} PROCEDURE COPY; VAR LINE : STRING; BEGIN NUM_BYTES:=0; FOR REC_COUNT:=START_RECORD TO STOP_RECORD DO BEGIN LAST_REC:=REC_COUNT; READLN(BASE,LINE); IF EOF(BASE) THEN EXIT(COPY) ELSE BEGIN WRITELN(INCLUDE,LINE); WRITELN(LINE); NUM_BYTES:=LENGTH(LINE)+4+NUM_BYTES; IF (NUM_BYTES>15000) AND (NOT MORE_DATA) THEN WARNING; IF STOP_NOW THEN BEGIN EXIT(COPY); END; END; WRITELN(INCLUDE); END; END; {copy} PROCEDURE INITILIZE; BEGIN MORE:=FALSE; INCLUDE_FILENAME:=''; MORE_DATA:=FALSE; STOP_NOW:=FALSE; FILENUM:=0; START_RECORD:=1; STOP_RECORD:=0; FILENAME:=''; BASE_FILENAME:=''; NUM_BYTES:=0; END; {init} PROCEDURE GETRECORDS; BEGIN CLEAR_SCREEN; IF START_RECORD <> 1 THEN WRITELN('last record copied was ',LAST_REC); WRITELN; WRITE('please type in a'); IF START_RECORD >1 THEN WRITE(' new'); WRITELN(' record to copy up to '); WRITELN; WRITE('record number? '); READLN(STOP_RECORD); END; {getrecords} PROCEDURE INSERT_FILENUM; VAR FILENUM_STRING : STRING; TEMP_FILENAME : STRING; BEGIN TEMP_FILENAME:=FILENAME; STR(FILENUM,FILENUM_STRING); INSERT((CONCAT('.',FILENUM_STRING)), TEMP_FILENAME,(POS('.TEXT',FILENAME))); INCLUDE_FILENAME:=TEMP_FILENAME; END; {insert_filename} BEGIN {main program} GETCRTINFO; CLEARSCREEN; INITILIZE; WRITELN(' ',VERSION); VER_SCREENUNIT; VER_FILEUNIT; OPNDSKREAD(BASE,'file to be crumbled? ',BASE_FILENAME,0,13); IF BASE_FILENAME = '' THEN EXIT(PROGRAM); REPEAT {until include file open ok} REPEAT {until name_ok} CLEAR_SCREEN; GOTOXY(0,9); WRITE('Type the generic name of includes files. (7 chars max) '); READLN(FILENAME); IF LENGTH(FILENAME)=0 THEN EXIT(PROGRAM); POS_COLON:=POS(':',FILENAME); IF (POS('.TEXT',FILENAME)>8+POS_COLON) OR ((POS('.TEXT',FILENAME)=0) AND (LENGTH(FILENAME)>7+POS_COLON)) THEN NAME_OK:=FALSE ELSE NAME_OK:=TRUE; UNTIL NAME_OK; IF POS('.TEXT',FILENAME)=0 THEN FILENAME:=CONCAT(FILENAME,'.TEXT'); INSERT_FILENUM; REWRT_DISK(INCLUDE,INCLUDE_FILENAME,IORESLT,I_TRIED); IF (NOT I_TRIED) AND (IORESLT <> 0) THEN IO_ERROR(IORESLT, INCLUDE_FILENAME); UNTIL (I_TRIED AND (IORESLT=0)); CLOSE(INCLUDE); REPEAT {until eof(base)} REWRITE(INCLUDE,INCLUDE_FILENAME); REPEAT {until more=false} CLEAR_SCREEN; GETRECORDS; WRITELN; {don't delete this line} COPY; START_RECORD:=LAST_REC+1; IF NOT EOF(BASE) THEN BEGIN FOR I:=1 TO 7 DO CLEAR_EOL(0,I); GOTOXY(0,0); WRITELN('number of bytes transferred = ',NUM_BYTES); WRITELN; WRITELN('do you wish to T)ransfer more data into ', INCLUDE_FILENAME,','); WRITELN; WRITE('C)ontinue, or Q)uit with files saved? '); READ(REPLY); CLEAR_SCREEN; IF REPLY = 'Q' THEN BEGIN CLOSE(INCLUDE,LOCK); EXIT(PROGRAM); END; IF (REPLY = 'T') THEN BEGIN MORE:=TRUE; END ELSE BEGIN MORE:=FALSE; CLOSE(INCLUDE,LOCK); FILENUM:=FILENUM+1; INSERT_FILENUM; END; END {eof(base)} ELSE MORE:=FALSE; UNTIL NOT MORE; UNTIL EOF(BASE); CLOSE(BASE); CLOSE(INCLUDE,LOCK); END. ======================================================================================== DOCUMENT :usus Folder:VOL08:d.text ======================================================================================== PROGRAM DIR; {$I-,R-} { This program is for NONcommercial use only, without written permission from the authors. Jim Gagne, Datamed Research, 1433 Roscomare Road, Los Angeles, California 90024.} CONST Has40ColApple = false; ScreenWidth = 80; LastLine = 23; {last line no. on screen, starting from line 0.} MaxDirEnt = 77; UnusedFlag = -1; LastUnusedFlag = -2; TYPE DATEREC = PACKED RECORD MONTH: 0..12; DAY: 0..31; YEAR: 0..100 END; DIRRANGE = 0..MaxDirEnt; VID = STRING[7]; TID = STRING[15]; FILEKIND = (UNTYPED,XDISK,CODE,TEXT, INFO,DATA,GRAF,FOTO,SECUREDIR); DIRENTRY = RECORD DFIRSTBLK: INTEGER; DLASTBLK: INTEGER; CASE DFKIND:FILEKIND OF SECUREDIR,UNTYPED: (DVID:VID; DEOVBLK, DLOADTIME, DBLOCKS:INTEGER; DLASTBOOT:DATEREC); XDISK,CODE,TEXT,INFO,DATA, GRAF,FOTO: (DTID:TID; DLASTBYTE:1..512; DACCESS:DATEREC) END; DIRP = ^DIRECTORY; DIRECTORY = ARRAY[0..78] OF DIRENTRY; VAR I, RoomLeft, TotlEntries, TotlBlocks, TotlFiles, UnusedLines, FilesOnScrn, PrevBlk, TotFilesListed, DirLinesThatFit, StartLine: INTEGER; FoundSysFile, WantsInAlphaOrder: boolean; IdxArry: ARRAY [DIRRANGE] OF Integer; SysNames: string[120]; DIRX: DIRECTORY; PROCEDURE ALPHABETIZE_DIRECTORY; VAR I : integer; PROCEDURE NRQuickSort(First,Last:integer); {this procedure was taken from "PASCAL PROGRAMS FOR SCIENTISTS AND ENGINEERS" by Alan R. Miller, published by SYBEX. You ought to buy it, its a very good book} VAR Left,Right : ARRAY [1..20] OF integer; I,J,SP,MID : integer; Pivot : STRING; PROCEDURE Swap(VAR P,Q : integer); VAR HOLD : integer; BEGIN HOLD := P; P := Q; Q := HOLD END; BEGIN Left[1] := First; Right[1] := Last; 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 := DIRX[IdxArry[J]].DTID; MID := (I+J) DIV 2; IF (J-I) > 5 THEN IF ((DIRX[IdxArry[MID]].DTID < Pivot) AND (DIRX[IdxArry[MID]].DTID > DIRX[IdxArry[I]].DTID)) OR ((DIRX[IdxArry[MID]].DTID > Pivot) AND (DIRX[IdxArry[MID]].DTID < DIRX[IdxArry[I]].DTID)) THEN Swap(IdxArry[MID],IdxArry[J]) ELSE IF ((DIRX[IdxArry[I]].DTID < DIRX[IdxArry[MID]].DTID) AND (DIRX[IdxArry[I]].DTID > Pivot)) OR ((DIRX[IdxArry[I]].DTID > DIRX[IdxArry[MID]].DTID) AND (DIRX[IdxArry[I]].DTID < Pivot)) THEN Swap(IdxArry[I],IdxArry[J]); Pivot := DIRX[IdxArry[J]].DTID; WHILE I < J DO BEGIN WHILE DIRX[IdxArry[I]].DTID < Pivot DO I := I+1; J := J-1; WHILE (I < J) AND (Pivot < DIRX[IdxArry[J]].DTID) DO J := J-1; IF I < J THEN Swap(IdxArry[I],IdxArry[J]); END; J := Right[SP]; Swap(IdxArry[I],IdxArry[J]); IF (I-Left[SP]) >= (Right[SP] - I) THEN BEGIN 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; END; END; END; BEGIN FOR i := 1 TO TotlEntries DO BEGIN IdxArry[i] := i; WITH DIRX[i] DO IF Length (DTID) > 0 THEN BEGIN TotlFiles := TotlFiles + 1; RoomLeft := RoomLeft - DLASTBLK + DFIRSTBLK; END END; NRQuickSort(1,DIRX[0].DLOADTIME); SysNames := ''; END; PROCEDURE WriteDate (Date: DateRec); BEGIN WITH Date DO BEGIN WRITE(DAY:3,'-'); CASE MONTH OF 1: WRITE('Jan'); 2: WRITE('Feb'); 3: WRITE('Mar'); 4: WRITE('Apr'); 5: WRITE('May'); 6: WRITE('Jun'); 7: WRITE('Jul'); 8: WRITE('Aug'); 9: WRITE('Sep'); 10: WRITE('Oct'); 11: WRITE('Nov'); 12: WRITE('Dec'); END {case}; WRITE('-',YEAR:2); END {with}; END; PROCEDURE Initialize; VAR Unitnum, i, j: integer; chbuf : char; BEGIN WantsInAlphaOrder := true; FoundSysFile := false; UnusedLines := 0; Writeln( 'Type "-" if you want files listed in order present on disk (not alphabetized)' ); Write('...then the unit number for the directory you wish --> '); REPEAT Read (keyboard, chbuf); IF chbuf = '-' THEN BEGIN Write('-'); WantsInAlphaOrder := false END; UNTIL (chbuf IN ['4', '5', '9', '1']); Unitnum := ORD (chbuf) - ORD ('0'); IF Unitnum = 1 THEN BEGIN Write(Unitnum); REPEAT Read(keyboard,chbuf) UNTIL (chbuf IN ['0'..'2']); Unitnum := 10 + ORD(chbuf) - ORD('0') END; Write(Unitnum MOD 10); UNITREAD(UNITNUM,DIRX[0],2024,2); SysNames := 'SYSTEM: '; TotlFiles := 0; DirLinesThatFit := LastLine - 2; IF IORESULT <> 0 THEN BEGIN WRITELN('Unit No. ', Unitnum, ' is not on line.'); EXIT(DIR); END; FOR i := 0 TO MaxDirEnt DO IdxArry[i] := 0; TotlEntries := DIRX[0].DLOADTIME; i := 1; WHILE (Length(DIRX[i].DTID) = 0) AND (i < TotlEntries) DO i := i + 1; Gotoxy(0,LastLine); Writeln; Writeln; Writeln; Writeln; {clear screen} j := ScreenWidth - 44; IF Has40ColApple OR (j < 0) THEN j := 0; Gotoxy (j DIV 2, 1); WITH DIRX[0] DO BEGIN WRITELN ('Directory of Unit #', Unitnum, ' -**- Volume ', DVID,':'); RoomLeft := DBLOCKS- DIRX[i].DFIRSTBLOCK; TotlBlocks := DBLOCKS; END; IF WantsInAlphaOrder THEN AlphabetizeDirectory ELSE BEGIN TotlFiles := 0; PrevBlk := 10; i := 1; WHILE Length(DIRX[i].DTID) = 0 DO i := i + 1; FOR i := i TO TotlEntries DO WITH DIRX[i] DO IF Length(DTID) > 0 THEN BEGIN IF DFIRSTBLK > PrevBlk THEN BEGIN TotlFiles := TotlFiles + 1; IdxArry[TotlFiles] := UnusedFlag; UnusedLines := UnusedLines + 1; END; TotlFiles := TotlFiles + 1; IdxArry[TotlFiles] := i; PrevBlk := DLASTBLK; RoomLeft := RoomLeft - DLASTBLK + DFIRSTBLK END; IF PrevBlk < TotlBlocks - 1 THEN BEGIN TotlFiles := TotlFiles + 1; IdxArry[TotlFiles] := LastUnusedFlag; UnusedLines := UnusedLines + 1; END; END; END; PROCEDURE WriteDirEntries; VAR ch: char; i,j,k: integer; BEGIN FilesOnScrn := 0; TotFilesListed := 0; StartLine := 2; PrevBlk := 10; FOR i:= 1 TO MaxDirEnt DO IF IdxArry[i] <> 0 THEN BEGIN IF WantsInAlphaOrder THEN Gotoxy((FilesOnScrn DIV DirLinesThatFit)*27, (FilesOnScrn MOD DirLinesThatFit)+StartLine) ELSE Gotoxy((FilesOnScrn DIV DirLinesThatFit)*40, (FilesOnScrn MOD DirLinesThatFit)+StartLine); FilesOnScrn := FilesOnScrn + 1; TotFilesListed := TotFilesListed + 1; IF IdxArry[i] = LastUnusedFlag THEN Write(' < unused > ', TotlBlocks - PrevBlk:3, PrevBlk:16) ELSE IF IdxArry[i] = UnusedFlag THEN Write(' < unused > ', DIRX[IdxArry[i+1]].DFIRSTBLK - PrevBlk:3, PrevBlk:16) ELSE WITH DIRX[IdxArry[i]] DO BEGIN j := DLASTBLK-DFIRSTBLK; PrevBlk := DLASTBLK; WRITE(DTID,' ':16-LENGTH(DTID), j: 3, ' '); IF NOT WantsInAlphaOrder THEN BEGIN WriteDate(DACCESS); Write(DFIRSTBLK:5) END END {else}; IF (FilesOnScrn MOD DirLinesThatFit = 0) THEN IF (TotFilesListed < TotlFiles) AND ((WantsInAlphaOrder AND (FilesOnScrn = DirLinesThatFit * 3)) OR (NOT WantsInAlphaOrder AND (FilesOnScrn = DirLinesThatFit * 2))) THEN BEGIN j := ScreenWidth - 42; IF Has40ColApple OR (j < 0) THEN j := 0; GotoXY (j DIV 2, LastLine); Write ('tap to continue, to quit...'); REPEAT Read(keyboard,ch) UNTIL ch IN [' ',CHR(27)]; GotoXY(0,LastLine); Write(' ':screenWidth-2); IF ch = CHR(27) THEN EXIT(WriteDirEntries); k := TotlFiles - TotFilesListed; IF WantsInAlphaOrder THEN BEGIN j := k MOD 3; k := k DIV 3 END ELSE BEGIN j := k MOD 2; k := k DIV 2 END; IF j > 0 THEN k := k + 1; IF k > DirLinesThatFit THEN k := DirLinesThatFit; FilesOnScrn := 0; FOR j := 1 TO k+1 DO Writeln; StartLine := DirLinesThatFit - k +2; DirLinesThatFit := k; END; END {for} END; BEGIN Initialize; WriteDirEntries; IF FoundSysFile THEN BEGIN Gotoxy(0,LastLine -1); Write(SysNames) END; I := ScreenWidth - 52; IF Has40ColApple OR (I < 0) THEN I := 0; Gotoxy (I DIV 2, LastLine); I := TotlFiles - UnusedLines; IF I = 1 THEN Write ('1 file; ') ELSE Write (I,' files; '); Write (TotlBlocks - RoomLeft, ' blocks used, ', RoomLeft, ' remaining, ', TotlBlocks, ' total.'); END. ======================================================================================== DOCUMENT :usus Folder:VOL08:disksort.text ======================================================================================== (*[B+,I=1,L=n,P=1] <== Formatter Directives *) program disksort; const n = 1000; type shortstring = string[10]; stringarray = array [1.. n] of shortstring; datafile = file of shortstring; var liner: integer; buf: stringarray; a, b, c, d: datafile; era, erb, erc, erd: boolean; temp: shortstring; numruns: integer; numstrings: integer; procedure sort(l, r: integer); var i, j: integer; x, w: shortstring; begin i := l; j := r; x := buf[(i + j) div 2]; repeat while buf[i] < x do i := i + 1; while x < buf[j] do j := j - 1; if i <= j then begin w := buf[i]; buf[i] := buf[j]; buf[j] := w; i := i + 1; j := j - 1 end until i > j; if l < j then sort(l, j); if i < r then sort(i, r) end (*sort*); procedure distribute; var i: integer; procedure copyruns(var x, y: datafile); begin numstrings := 0; while (not (eof(x))) and (not (numstrings >= n)) do begin numstrings := numstrings + 1; buf[numstrings] := x ^; get(x) end; sort(1, numstrings); for i := 1 to numstrings do begin y ^ := buf[i]; put(y) end end (*copyruns*); begin (*distribute*) repeat copyruns(c, a); if not (eof(c)) then copyruns(c, b) until eof(c) end (*distribute*); procedure mergeruns(var a, b, c, d: datafile; var era, erb, erc, erd: boolean); var buf: shortstring; procedure copyrecord(var a, b: datafile); begin buf := a ^; get(a); b ^ := buf; put(b) end; procedure testendofrun(var a: datafile; var era: boolean); begin if eof(a) then era := true else era := buf > a ^ end; procedure mergeone(var a, b, c: datafile; var era, erb, erc: boolean); procedure copytail(var a, b: datafile; var era, erb: boolean); begin writeln('copytail'); while not era do begin copyrecord(a, b); testendofrun(a, era) end end (*copytail*); begin (*mergeone*) era := false; erb := false; writeln('mergeone'); repeat if a ^ < b ^ then begin copyrecord(a, c); testendofrun(a, era) end else begin copyrecord(b, c); testendofrun(b, erb) end until era or erb; if era then writeln('era'); if erb then writeln('erb'); copytail(a, c, era, erc); copytail(b, c, erb, erc); end (*mergeone*); procedure copyrest(var a, b, c: datafile; var era, erb, erc: boolean); begin writeln('copyrest'); while not eof(a) do begin repeat copyrecord(a, b); testendofrun(a, era) until era; numruns := numruns + 1; if not eof(a) then begin repeat copyrecord(a, c); testendofrun(a, era) until era; numruns := numruns + 1 end end end (*copyrest*); begin (*mergeruns*) repeat mergeone(a, b, c, era, erb, erc); numruns := numruns + 1; if not (eof(a) or eof(b)) then begin mergeone(a, b, d, era, erb, erd); numruns := numruns + 1 end until eof(a) or eof(b); if odd(numruns) then copyrest(a, d, c, era, erd, erc) else copyrest(a, c, d, era, erc, erd); if odd(numruns) then copyrest(b, d, c, erb, erd, erc) else copyrest(b, c, d, erb, erc, erd); writeln('NUMBER OF RUNS = ', numruns); end (*mergeruns*); begin (*disksort*) rewrite(a, 'file.a[120]'); rewrite(b, 'file.b[65]'); reset(c, 'rawdata'); writeln('distribute'); distribute; close(c, lock); repeat numruns := 0; writeln('Phase 1 started'); reset(a); reset(b); rewrite(c, 'file.c[120]'); rewrite(d, 'file.d[65]'); mergeruns(a, b, c, d, era, erb, erc, erd); if numruns <> 1 then begin numruns := 2; writeln('Phase 2 started'); close(a, purge); close(b, purge); rewrite(a, 'file.a[120]'); rewrite(b, 'file.b[65]'); reset(c); reset(d); mergeruns(c, d, a, b, erc, erd, era, erb); close(c, purge); close(d, purge) end until numruns = 1; close(c, lock); end (*disksort*). ======================================================================================== DOCUMENT :usus Folder:VOL08:error.data.text ======================================================================================== 10 file not found 7 bad file name 9 volume not found 3 illegal i/o request 100 Wild cards not allowed 101 Multiple files not allowed 8 no room on volume 14 bad input information 1 bad block or parity error (CRC) 12 file already open 13 file not open 17 illegal block 18 illegal buffer 5 volume went off line 2 illegal device # 4 data-com timeout 6 file lost in directory 11 duplicate directory entry 15 ring buffer overflow ======================================================================================== DOCUMENT :usus Folder:VOL08:exhalev2.1.text ======================================================================================== PROGRAM EXHALE; {Program Exhale outputs a text file to be sent to another computer. The program invokes the editor (in this case on a PR1ME 500) and places the editor in the input mode so that the remote computer thinks that a user is simply typing in the data from a terminal. The program then outputs the user specified UCSD file. When EOF is reached the program 'FILE's the program under the user specified name and returns to the UCSD command level.} {by George Schreyer} USES (*$U SCREENUNIT.CODE*)SCREENUNIT, (*$U FILEUNIT.CODE*)FILEUNIT; VAR MODEM_IN,MODEM_OUT,DISK :TEXT; JUNK,FILE_NAME,LINE_OF_DATA,OK :STRING; BEGIN GETCRTINFO; GOTOXY(0,0); CRT(ERASEOS); REWRITE(MODEM_OUT,'REMOUT:'); REWRITE(MODEM_IN,'REMIN:'); WRITELN(' exhale version 2.1 28 Apr 81'); VER_SCREENUNIT; VER_FILEUNIT; OPNDSKREAD(DISK,'Please type filename to be exhaled.- - >', FILE_NAME,0,13); IF FILENAME = '' THEN EXIT(PROGRAM); GOTOXY(0,5); WRITELN(MODEM_OUT,'ED'); READLN(MODEM_IN,JUNK); WHILE NOT EOF(DISK) DO BEGIN READLN(DISK,LINE_OF_DATA); IF LINE_OF_DATA<> '' THEN BEGIN WRITELN(MODEM_OUT,LINE_OF_DATA); WRITELN(LINE_OF_DATA); END; END; WRITELN(MODEM_OUT,CHR(13),'FILE ',FILE_NAME); {close file at host} CLOSE(DISK); CLOSE(MODEM_OUT); CLOSE(MODEM_IN); END. ======================================================================================== DOCUMENT :usus Folder:VOL08:fast.seek.text ======================================================================================== {Copyright 1980 by Stuart Lynne 1350 Clifton Ave. Coquitlam, British Columbia, Canada V3J 5K6 Permission granted to use for noncommercial purposes. All other rights reserved} { fast.seek } {$U-,S+} {$I globals } { * * Fast Seek * * Changes Copyright (c) 1980, by Stuart Lynne. All rights reserved. * * This is a recoded version of the UCSD Pascal Seek algorithm. It * is 50 to 100 % faster than the original. * * } {$C Copyright (c) 1980, by Stuart Lynne. All rights reserved.} (*----------------------------------------------------------*) SEPARATE UNIT Unit_Seek; INTERFACE PROCEDURE FSEEK(VAR F: FIB; RECNUM: INTEGER); IMPLEMENTATION Procedure Super (A, B: integer; var Block, Byte: integer); var A_Hi, A_Mid, A_Low, B_Hi, B_Mid, B_Low, Little_Total, A_Mid_B_Low, A_Low_B_Mid, A_Low_B_Low: integer; begin {of SUPER_DIV} A_Low := A Mod 32; B_Low := B Mod 32; A_Hi := A Div 1024; B_Hi := B Div 1024; A_Mid := (A mod 1024) DIV 32; B_Mid := (B mod 1024) DIV 32; A_Mid_B_Low := A_Mid * B_Low; A_Low_B_Mid := A_Low * B_Mid; A_Low_B_Low := A_Low * B_Low; Little_Total := (A_Mid_B_Low * 32 Mod 512) + (A_Low_B_Mid * 32 Mod 512) + (A_Low_B_Low Mod 512); Byte := Little_Total Mod 512; Block := A_Hi * B_Hi * 2048 + A_Hi * B_Mid * 64 + A_Hi * B_Low * 2 + A_Mid * B_Hi * 64 + A_MiD * B_MiD * 2 + A_Mid_B_Low Div 16 + A_Low * B_Hi * 2 + A_Low_B_Mid Div 16 + A_Low_B_Low Div 512 + Little_Total div 512; end {of Super}; PROCEDURE FSEEK(*VAR F: FIB; RECNUM: INTEGER*); LABEL 1; VAR BYTE,BLOCK,N: INTEGER; BEGIN SYSCOM^.IORSLT := INOERROR; IF F.FISOPEN THEN WITH F,FHEADER DO BEGIN IF (RECNUM < 0) OR NOT FSOFTBUF OR ((DFKIND = TEXTFILE) AND (FRECSIZE = 1)) THEN GOTO 1; (*NO SEEK ALLOWED*) { * Block := RECNUM*FRECSIZE DIV FBLKSIZE + 1; * Byte := RECNUM*FRECSIZE MOD FBLKSIZE; } Super (Recnum, Frecsize, Block, Byte); Block := Block + 1; IF BYTE = 0 THEN BEGIN BYTE := FBLKSIZE; BLOCK := BLOCK - 1; END; N := DLASTBLK-DFIRSTBLK; IF (BLOCK > N) OR ((BLOCK = N) AND (BYTE >= DLASTBYTE)) THEN BEGIN BLOCK := N; BYTE := DLASTBYTE END; IF BLOCK <> FNXTBLK THEN BEGIN IF FBUFCHNGD THEN BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE; UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1); IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END; IF (BLOCK <= FMAXBLK) AND (BYTE <> FBLKSIZE) THEN BEGIN UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+BLOCK-1); IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END END; IF FNXTBLK > FMAXBLK THEN BEGIN FMAXBLK := FNXTBLK; FMAXBYTE := FNXTBYTE END ELSE IF (FNXTBLK = FMAXBLK) AND (FNXTBYTE > FMAXBYTE) THEN FMAXBYTE := FNXTBYTE; FEOF := FALSE; FEOLN := FALSE; FREPTCNT := 0; IF FSTATE <> FJANDW THEN FSTATE := FNEEDCHAR; FNXTBLK := BLOCK; FNXTBYTE := BYTE END ELSE SYSCOM^.IORSLT := INOTOPEN; 1: END (*FSEEK*) ; END { PASCALIO } ; (*Dummy level 0 outerblock*) BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL08:fileunit.text ======================================================================================== {$S+} UNIT FILEUNIT; { George W. Schreyer 412 North Maria Ave. Redondo Beach, California, 90277 (213)-376-9348 This unit may be used for non-commercial purposes only. Any commercial use is prohibited without expressed written permission from the author. Except where noted this code is all original work. } INTERFACE USES (*$U SCREENUNIT.CODE*)SCREENUNIT; PROCEDURE VER_FILEUNIT; PROCEDURE REWRT_DISK (VAR FILEID : XFILE; VAR FILENAME : STRING; VAR IORESLT : INTEGER; VAR REWROTE : BOOLEAN); PROCEDURE RESET_DISK (VAR FILEID : XFILE; VAR FILENAME : STRING; VAR IORESLT : INTEGER); PROCEDURE OPNDSKREAD (VAR FILEID : TEXT; PROMPT : STRING; VAR FILENAME : STRING; X : INTEGER; Y : INTEGER); PROCEDURE OPNDSKWRT ( VAR FILEID : TEXT; PROMPT : STRING; VAR FILENAME : STRING; X : INTEGER; Y : INTEGER); PROCEDURE GET_FILE_DATE (VAR FILENAME : STRING; VAR DATE : STRING); PROCEDURE DIR; {*****************} IMPLEMENTATION {$R-} {$I-} {*****************} {This record discribes the structure of a UCSD directory. It was taken from Monaco and Soles' procedure DIR in volume 5 of the USUS library.} TYPE DATEREC = PACKED RECORD MONTH: 0..12; DAY: 0..31; YEAR: 0..100 END; DIRRANGE = 0..79; {this is set to 79 instead of 77 to make the record larger than 4 blocks. This allows the directory to be read with a blockread without memory allocation problems. The final two records (or parts of a record) cannot be accessed because DLOADTIME will never exceed 77.} VID = STRING[7]; TID = STRING[15]; FILEKIND = (UNTYPED,XDISK,CODE,TEXT, INFO,DATA,GRAF,FOTO,SECUREDIR); DIRENTRY = RECORD DFIRSTBLK: INTEGER; DLASTBLK: INTEGER; CASE DFKIND:FILEKIND OF SECUREDIR,UNTYPED: (DVID:VID; DEOVBLK, DLOADTIME, DBLOCKS:INTEGER; DLASTBOOT:DATEREC); XDISK,CODE,TEXT,INFO,DATA, GRAF,FOTO: (DTID:TID; DLASTBYTE:1..512; DACCESS:DATEREC) END; DIRECTORY = ARRAY[DIRRANGE] OF DIRENTRY; {***************} PROCEDURE VER_FILEUNIT; BEGIN WRITELN('uses fileunit version N 20-Jul-81'); END; {****************} PROCEDURE LEGAL_UNIT(VOLNAME : STRING; VAR BADUNIT : BOOLEAN); BEGIN BADUNIT:=FALSE; IF (VOLNAME <> '') AND (VOLNAME[LENGTH(VOLNAME)] = ':' ) THEN BEGIN IF VOLNAME <> ':' THEN BEGIN DELETE(VOLNAME,POS(':',VOLNAME),1); IF POS('#',VOLNAME) =1 THEN BEGIN DELETE(VOLNAME,1,1); IF (VOLNAME = '0') OR (VOLNAME = '1') OR (VOLNAME = '2') OR (VOLNAME = '3') OR (VOLNAME = '6') OR (VOLNAME = '7') OR (VOLNAME = '8') THEN BADUNIT:=TRUE; END ELSE IF (VOLNAME = 'CONSOLE') OR (VOLNAME = 'SYSTERM') OR (VOLNAME = 'GRAPHIC') OR {(VOLNAME = 'PRINTER') OR} (VOLNAME = 'REMIN') OR (VOLNAME = 'REMOUT') THEN BADUNIT := TRUE; END; END; END; PROCEDURE LEGALNAME (VAR FILENAME : STRING; VAR NAMEOK : BOOLEAN); VAR IORESLT : INTEGER; BADUNIT : BOOLEAN; TESTFILE : XFILE; BEGIN NAMEOK:=FALSE; BADUNIT:=FALSE; IF LENGTH(FILENAME)<>0 THEN BEGIN LEGAL_UNIT(FILENAME,BADUNIT); IF NOT BADUNIT THEN BEGIN IF (POS('?',FILENAME)<>0) OR (POS('=',FILENAME)<>0) OR (POS('$',FILENAME)<>0) THEN IO_ERROR(128,FILENAME) ELSE IF(POS(',',FILENAME)<>0) THEN IO_ERROR(129,FILENAME) ELSE BEGIN RESET(TESTFILE,FILENAME); IORESLT:=IORESULT; IF IORESLT<>7 THEN NAMEOK:=TRUE ELSE IO_ERROR(IORESLT,FILENAME); CLOSE(TESTFILE); END; END ELSE IO_ERROR(3,FILENAME); END; END; {legalname} {*****************} PROCEDURE ADD_TEXT (VAR FILENAME : STRING); BEGIN IF POS('.TEXT',FILENAME)=0 THEN BEGIN FILENAME:=CONCAT(FILENAME,'.TEXT'); END; END; {add_text} {*****************} PROCEDURE REMOVE_SPACES( VAR FILENAME : STRING); BEGIN REPEAT DELETE(FILENAME,POS(' ',FILENAME),1); UNTIL POS(' ',FILENAME)=0; END; {remove_spaces} {*****************} PROCEDURE GETFILNAME (VAR FILENAME : STRING; PROMPT : STRING; VAR X,Y : INTEGER; VAR GOTNAME : BOOLEAN); BEGIN GOTNAME:=FALSE; REPEAT GOTOXY(52,22); WRITE(' for directory'); GOTOXY(65,23); WRITE(' to leave'); GOTOXY(X,Y); WRITE(PROMPT,' '); READLN(FILENAME); GOTOXY(0,22); CRT(ERASEOS); GOTOXY(X,Y); CRT(ERASEOL); IF FILENAME='' THEN BEGIN GOTOXY(0,0); CRT(ERASEOS); END ELSE BEGIN IF FILENAME = ' ' THEN BEGIN GOTOXY(0,0); CRT(ERASEOS); DIR; X:=0; Y:=0; GETFILNAME(FILENAME,PROMPT,X,Y,GOTNAME); END; REMOVE_SPACES(FILENAME); LEGALNAME(FILENAME,GOTNAME); END; UNTIL GOTNAME OR (FILENAME = ''); END; {getfilname} {*****************} PROCEDURE REWRT_DISK{(VAR FILEID : XFILE; VAR FILENAME : STRING; VAR IORESLT : INTEGER; VAR REWROTE : BOOLEAN)}; VAR REPLY : CHAR; DATE : STRING; TEMP_NAME : STRING; BEGIN IORESLT:=0; REWROTE:=FALSE; IF FILENAME <> '' THEN BEGIN RESET(FILEID,FILENAME); IORESLT:=IORESULT; CLOSE(FILEID); IF IORESLT=0 THEN BEGIN GOTOXY(0,23); TEMP_NAME:=FILENAME; GET_FILE_DATE(TEMP_NAME,DATE); WRITE(CHR(7),TEMP_NAME,' dated ',DATE,' already exists. '); WRITE('Destroy it? (Y/N) '); READ(KEYBOARD,REPLY); GOTOXY(0,23); CRT(ERASEOL); IF REPLY IN [ 'Y','y'] THEN BEGIN REWRITE(FILEID,FILENAME); IORESLT:=IORESULT; REWROTE:=TRUE; END; END ELSE BEGIN REWRITE(FILEID,FILENAME); IORESLT:=IORESULT; REWROTE:=TRUE; END; END; END; {rewrt_disk} {*****************} PROCEDURE RESET_DISK{(VAR FILEID : XFILE; VAR FILENAME : STRING; VAR IORESLT : INTEGER)}; VAR TEMP_NAME : STRING; BEGIN TEMP_NAME:=FILENAME; RESET(FILEID,FILENAME); IORESLT:=IORESULT; IF IORESLT <> 0 THEN BEGIN ADD_TEXT(FILENAME); RESET(FILEID,FILENAME); IORESLT:=IORESULT; IF IORESLT <> 0 THEN FILENAME:=TEMP_NAME; END; END {reset_disk}; {*****************} PROCEDURE OPNDSKREAD {(VAR FILEID : TEXT; PROMPT : STRING; VAR FILENAME : STRING; X : INTEGER; Y : INTEGER)}; VAR NAMEOK :BOOLEAN; IORESLT :INTEGER; DATE :STRING; BEGIN IORESLT:=0; DATE:=''; REPEAT FILENAME:=''; GETFILNAME(FILENAME,PROMPT,X,Y,NAMEOK); IF NAMEOK THEN BEGIN RESET_DISK(FILEID,FILENAME,IORESLT); IF IORESLT <> 0 THEN IO_ERROR(IORESLT,FILENAME) ELSE GET_FILE_DATE(FILENAME,DATE); END ELSE FILENAME:=''; UNTIL (IORESLT = 0) OR (FILENAME = ''); END; {opndskread} {*****************} PROCEDURE OPNDSKWRT {( VAR FILEID : TEXT; PROMPT : STRING; VAR FILENAME : STRING; X : INTEGER; Y : INTEGER)}; VAR REWROTE : BOOLEAN; NAMEOK : BOOLEAN; IORESLT : INTEGER; DATE : STRING; BEGIN DATE:=''; REWROTE:=FALSE; REPEAT FILENAME:=''; GETFILNAME(FILENAME,PROMPT,X,Y,NAMEOK); IF NAMEOK THEN BEGIN ADD_TEXT(FILENAME); REWRT_DISK(FILEID,FILENAME,IORESLT,REWROTE); IF (IORESLT <> 0) THEN IO_ERROR(IORESLT,FILENAME) ELSE GET_FILE_DATE(FILENAME,DATE); END; UNTIL (REWROTE AND (IORESLT=0)) OR (FILENAME = ''); END; {opndskwrt} {****************} PROCEDURE GET_FILE_DATE {(VAR FILENAME : STRING; VAR DATE : STRING)}; VAR DIRX : DIRECTORY; POS_COLON : INTEGER; TEMP_NAME : STRING; VOL_ID : STRING; DIREC : XFILE; H,K,Q : INTEGER; MON : STRING; IO_OK : BOOLEAN; DAYSTRING : STRING; YEARSTRING: STRING; HI,LO : INTEGER; BADUNIT : BOOLEAN; MIS_MATCH : BOOLEAN; PROCEDURE DECODE_DATE(DAY,MONTH,YEAR:INTEGER); BEGIN CASE MONTH OF 1: MON:='Jan'; 2: MON:='Feb'; 3: MON:='Mar'; 4: MON:='Apr'; 5: MON:='May'; 6: MON:='Jun'; 7: MON:='Jul'; 8: MON:='Aug'; 9: MON:='Sep'; 10:MON:='Oct'; 11:MON:='Nov'; 12:MON:='Dec' END; STR(DAY,DAYSTRING); STR(YEAR,YEARSTRING); END; BEGIN {get_file_date} DATE:=''; Q:=0; MON:=''; DAYSTRING:=''; YEARSTRING:=''; LEGAL_UNIT(FILENAME,BADUNIT); IF (FILENAME <> '') AND (NOT BADUNIT) THEN BEGIN POS_COLON:=POS(':',FILENAME); IF POS('*',FILENAME) = 1 THEN BEGIN VOL_ID:='*'; IF LENGTH(FILENAME) = 1 THEN TEMP_NAME:='' ELSE BEGIN TEMP_NAME:=FILENAME; DELETE(TEMP_NAME,1,1); END; END ELSE BEGIN IF POS_COLON > 0 THEN BEGIN IF LENGTH(FILENAME) = 1 THEN BEGIN TEMP_NAME:=''; VOL_ID:=':'; END ELSE BEGIN IF POS_COLON = LENGTH(FILENAME) THEN BEGIN VOL_ID:=FILENAME; TEMP_NAME:=''; END ELSE BEGIN TEMP_NAME:=COPY(FILENAME,POS_COLON+1, LENGTH(FILENAME)-POS_COLON); VOL_ID:=COPY(FILENAME,1,POS_COLON); END; END; END ELSE BEGIN VOL_ID:=':'; TEMP_NAME:=FILENAME; END; END; RESET(DIREC,VOL_ID); FOR H:= 1 TO LENGTH(TEMP_NAME) DO IF TEMP_NAME[H] IN ['a'..'z'] THEN TEMP_NAME[H]:=CHR(ORD(TEMP_NAME[H])-32); IF IORESULT = 0 THEN BEGIN K:=BLOCKREAD(DIREC,DIRX,4,2); IF IORESULT = 0 THEN BEGIN IF FILENAME <> '' THEN BEGIN FOR K:=1 TO DIRX[0].DLOADTIME DO WITH DIRX[K] DO BEGIN MISMATCH:=FALSE; H:=0; REPEAT IF (DTID[H] = TEMP_NAME[H]) THEN H:=H+1 ELSE MISMATCH:=TRUE; UNTIL MIS_MATCH OR (H=LENGTH(DTID)); IF NOT MISMATCH THEN Q:=K; END; END; IF (VOL_ID = '*') AND (TEMP_NAME = '') THEN WITH DIRX[0].DLASTBOOT DO BEGIN DECODE_DATE(DAY,MONTH,YEAR); Q:=1; END ELSE WITH DIRX[Q].DACCESS DO DECODE_DATE(DAY,MONTH,YEAR); IF Q <> 0 THEN DATE:=CONCAT(DAYSTRING,'-',MON,'-', YEARSTRING); WITH DIRX[0] DO VOL_ID:=CONCAT(DVID,':'); FILENAME:=CONCAT(VOL_ID,TEMP_NAME); END; END; END; CLOSE(DIREC); END; {get_file_date} {****************} PROCEDURE DIR; TYPE POINTER_ARRAY = ARRAY [DIRRANGE] OF INTEGER; VAR DIRX : DIRECTORY; BADUNIT : BOOLEAN; ROW,COLUMN : INTEGER; VOLNAME : STRING; DIREC : XFILE; K,I: INTEGER; INDEX: POINTER_ARRAY; NAME_OK : BOOLEAN; PROCEDURE SWAP(VAR P,Q : INTEGER); VAR HOLD : INTEGER; BEGIN HOLD:=P; P:=Q; Q:=HOLD; END; PROCEDURE NR_QUICK_SORT(VAR DIRX : DIRECTORY; VAR INDEX : POINTER_ARRAY; FIRST,LAST:INTEGER); {this procedure was taken from "PASCAL PROGRAMS FOR SCIENTISTS AND ENGINEERS" by Alan R. Miller, published by SYBEX. You ought to buy it, its a very good book} VAR LEFT,RIGHT : ARRAY [1..20] OF INTEGER; I,J,SP,MID : INTEGER; PIVOT : STRING; BEGIN LEFT[1]:=FIRST; RIGHT[1]:=LAST; 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:=DIRX[INDEX[J]].DTID; MID:=(I+J) DIV 2; IF (J-I) > 5 THEN IF ((DIRX[INDEX[MID]].DTID < PIVOT) AND (DIRX[INDEX[MID]].DTID > DIRX[INDEX[I]].DTID)) OR ((DIRX[INDEX[MID]].DTID > PIVOT) AND (DIRX[INDEX[MID]].DTID < DIRX[INDEX[I]].DTID)) THEN SWAP(INDEX[MID],INDEX[J]) ELSE IF ((DIRX[INDEX[I]].DTID < DIRX[INDEX[MID]].DTID) AND (DIRX[INDEX[I]].DTID > PIVOT)) OR ((DIRX[INDEX[I]].DTID > DIRX[INDEX[MID]].DTID) AND (DIRX[INDEX[I]].DTID < PIVOT)) THEN SWAP(INDEX[I],INDEX[J]); PIVOT:=DIRX[INDEX[J]].DTID; WHILE I < J DO BEGIN WHILE DIRX[INDEX[I]].DTID < PIVOT DO I:=I+1; J:=J-1; WHILE (I < J) AND (PIVOT < DIRX[INDEX[J]].DTID) DO J:=J-1; IF I < J THEN SWAP(INDEX[I],INDEX[J]); END; J:=RIGHT[SP]; SWAP(INDEX[I],INDEX[J]); IF (I-LEFT[SP]) >= (RIGHT[SP] - I) THEN BEGIN 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; END; END; END; PROCEDURE ALPHABETIZE_DIRECTORY; VAR I : INTEGER; BEGIN FOR I:=1 TO DIRX[0].DLOADTIME DO INDEX[I]:=I; NR_QUICK_SORT(DIRX,INDEX,1,DIRX[0].DLOADTIME); END; PROCEDURE MAKE_LOWER_CASE( VAR STRG :STRING); VAR QQ : INTEGER; BEGIN FOR QQ:=1 TO LENGTH(STRG) DO IF STRG[QQ] IN ['A'..'Z'] THEN STRG[QQ]:=CHR(ORD(STRG[QQ])+32); END; PROCEDURE VOLUMES; VAR I,K : INTEGER; DISK : XFILE; VOLID,STRG : STRING; VOLNAME : STRING; DATE : STRING; BEGIN GOTOXY(0,5); FOR I:=4 TO 12 DO IF I IN [4,5,9,10,11,12] THEN BEGIN STR(I,STRG); VOLNAME:=CONCAT('#',STRG,':'); RESET(DISK,VOLNAME); IF IORESULT = 0 THEN BEGIN K:=BLOCKREAD(DISK,DIRX,4,2); IF IORESULT = 0 THEN BEGIN VOLID:=DIRX[0].DVID; MAKE_LOWER_CASE(VOLID); VOLID:=CONCAT(' ',VOLID,':'); WRITELN('#',I:2,VOLID); END; CLOSE(DISK); END; END; WRITELN; VOLID:='*'; GET_FILE_DATE(VOLID,DATE); WRITELN(' root volume is ',volid,' system date is ',date); VOLID:=':'; GET_FILE_DATE(VOLID,DATE); WRITELN('prefix volume is ',volid); END; BEGIN {dir} REPEAT REPEAT VOLNAME:=''; NAME_OK:=TRUE; GOTOXY(54,22); WRITE(' for volumes'); GOTOXY(65,23); WRITE(' to leave'); GOTOXY(0,3); WRITE('volume of directory to display ? '); READLN(VOLNAME); GOTOXY(0,0); CRT(ERASEOS); IF VOLNAME = '' THEN EXIT(DIR); IF VOLNAME = ' ' THEN VOLUMES; UNTIL VOLNAME <> ' '; REMOVE_SPACES(VOLNAME); IF (POS(':',VOLNAME) <> LENGTH(VOLNAME)) AND (VOLNAME <> '*') THEN VOLNAME:=CONCAT(VOLNAME,':'); LEGAL_UNIT(VOLNAME,BADUNIT); IF BADUNIT OR (VOLNAME='PRINTER:') THEN BEGIN GOTOXY(0,23); WRITE(CHR(7),'Unit ',VOLNAME,' has no directory'); NAME_OK:=FALSE; END; IF NAME_OK THEN BEGIN REMOVE_SPACES(VOLNAME); LEGALNAME(VOLNAME,NAME_OK); RESET(DIREC,VOLNAME); IF IORESULT <> 0 THEN BEGIN IO_ERROR(9,VOLNAME); NAME_OK:=FALSE; END; END; UNTIL NAME_OK; K:=BLOCKREAD(DIREC,DIRX,4,2); CLOSE(DIREC); ALPHABETIZE_DIRECTORY; GOTOXY(0,2); WITH DIRX[0] DO BEGIN MAKE_LOWER_CASE(DVID); WRITELN('vol = ',DVID,':'); END; ROW:=4; COLUMN:=0; FOR I:=1 TO DIRX[0].DLOADTIME DO BEGIN WITH DIRX[INDEX[I]] DO BEGIN GOTOXY(COLUMN,ROW); MAKE_LOWER_CASE(DTID); WRITE(DTID,' ':16-LENGTH(DTID)); ROW:=ROW+1; IF (ROW MOD 22 = 0) OR ((COLUMN =0) AND (ROW = 21)) THEN BEGIN COLUMN:=COLUMN+20; ROW:=2; END; END; END; END; END. ======================================================================================== DOCUMENT :usus Folder:VOL08:global.ii0.text ======================================================================================== (*$U-*) { This is an unpublished work copyright by The Regents of the University of California. This item is the property of SofTech MicroSystems Inc., and it may be used, copied, or distributed only as permitted in a written license from that company.} PROGRAM PASCALSYSTEM; (************************************************) (* *) (* UCSD PASCAL OPERATING SYSTEM *) (* *) (* RELEASE LEVEL: I.3 AUGUST, 1977 *) (* I.4 JANUARY, 1978 *) (* I.5 SEPTEMBER, 1978 *) (* II.0 FEBRUARY, 1978 BD *) (* *) (* WRITTEN BY ROGER T. SUMNER *) (* WINTER 1977 *) (* *) (* INSTITUTE FOR INFORMATION SYSTEMS *) (* UC SAN DIEGO, LA JOLLA, CA *) (* *) (* KENNETH L. BOWLES, DIRECTOR *) (* *) (************************************************) CONST MMAXINT = 32767; (*MAXIMUM INTEGER VALUE*) MAXUNIT = 12; (*MAXIMUM PHYSICAL UNIT # FOR UREAD*) MAXDIR = 77; (*MAX NUMBER OF ENTRIES IN A DIRECTORY*) VIDLENG = 7; (*NUMBER OF CHARS IN A VOLUME ID*) TIDLENG = 15; (*NUMBER OF CHARS IN TITLE ID*) MAXSEG = 15; (*MAX CODE SEGMENT NUMBER*) FBLKSIZE = 512; (*STANDARD DISK BLOCK LENGTH*) DIRBLK = 2; (*DISK ADDR OF DIRECTORY*) AGELIMIT = 300; (*MAX AGE FOR GDIRP...IN TICKS*) EOL = 13; (*END-OF-LINE...ASCII CR*) DLE = 16; (*BLANK COMPRESSION CODE*) NAME_LEN = 23; {Length of CONCAT(VIDLENG,':',TIDLENG)} FILL_LEN = 11; {Maximum # of nulls in FILLER} TYPE IORSLTWD = (INOERROR,IBADBLOCK,IBADUNIT,IBADMODE,ITIMEOUT, ILOSTUNIT,ILOSTFILE,IBADTITLE,INOROOM,INOUNIT, INOFILE,IDUPFILE,INOTCLOSED,INOTOPEN,IBADFORMAT, ISTRGOVFL); (*COMMAND STATES...SEE GETCMD*) CMDSTATE = (HALTINIT,DEBUGCALL, UPROGNOU,UPROGUOK,SYSPROG, COMPONLY,COMPANDGO,COMPDEBUG, LINKANDGO,LINKDEBUG); (*CODE FILES USED IN GETCMD*) SYSFILE = (ASSMBLER,COMPILER,EDITOR,FILER,LINKER); (*ARCHIVAL INFO...THE DATE*) DATEREC = PACKED RECORD MONTH: 0..12; (*0 IMPLIES DATE NOT MEANINGFUL*) DAY: 0..31; (*DAY OF MONTH*) YEAR: 0..100 (*100 IS TEMP DISK FLAG*) END (*DATEREC*) ; (*VOLUME TABLES*) UNITNUM = 0..MAXUNIT; VID = STRING[VIDLENG]; (*DISK DIRECTORIES*) DIRRANGE = 0..MAXDIR; TID = STRING[TIDLENG]; FULL_ID = STRING[NAME_LEN]; FILE_TABLE = ARRAY [SYSFILE] OF FULL_ID; FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE, INFOFILE,DATAFILE,GRAFFILE,FOTOFILE,SECUREDIR); DIRENTRY = PACKED RECORD DFIRSTBLK: INTEGER; (*FIRST PHYSICAL DISK ADDR*) DLASTBLK: INTEGER; (*POINTS AT BLOCK FOLLOWING*) CASE DFKIND: FILEKIND OF SECUREDIR, UNTYPEDFILE: (*ONLY IN DIR[0]...VOLUME INFO*) (FILLER1 : 0..2048; {for downward compatibility,13 bits} DVID: VID; (*NAME OF DISK VOLUME*) DEOVBLK: INTEGER; (*LASTBLK OF VOLUME*) DNUMFILES: DIRRANGE; (*NUM FILES IN DIR*) DLOADTIME: INTEGER; (*TIME OF LAST ACCESS*) DLASTBOOT: DATEREC); (*MOST RECENT DATE SETTING*) XDSKFILE,CODEFILE,TEXTFILE,INFOFILE, DATAFILE,GRAFFILE,FOTOFILE: (FILLER2 : 0..1024; {for downward compatibility} STATUS : BOOLEAN; {for FILER wildcards} DTID: TID; (*TITLE OF FILE*) DLASTBYTE: 1..FBLKSIZE; (*NUM BYTES IN LAST BLOCK*) DACCESS: DATEREC) (*LAST MODIFICATION DATE*) END (*DIRENTRY*) ; DIRP = ^DIRECTORY; DIRECTORY = ARRAY [DIRRANGE] OF DIRENTRY; (*FILE INFORMATION*) CLOSETYPE = (CNORMAL,CLOCK,CPURGE,CCRUNCH); WINDOWP = ^WINDOW; WINDOW = PACKED ARRAY [0..0] OF CHAR; FIBP = ^FIB; FIB = RECORD FWINDOW: WINDOWP; (*USER WINDOW...F^, USED BY GET-PUT*) FEOF,FEOLN: BOOLEAN; FSTATE: (FJANDW,FNEEDCHAR,FGOTCHAR); FRECSIZE: INTEGER; (*IN BYTES...0=>BLOCKFILE, 1=>CHARFILE*) CASE FISOPEN: BOOLEAN OF TRUE: (FISBLKD: BOOLEAN; (*FILE IS ON BLOCK DEVICE*) FUNIT: UNITNUM; (*PHYSICAL UNIT #*) FVID: VID; (*VOLUME NAME*) FREPTCNT, (* # TIMES F^ VALID W/O GET*) FNXTBLK, (*NEXT REL BLOCK TO IO*) FMAXBLK: INTEGER; (*MAX REL BLOCK ACCESSED*) FMODIFIED:BOOLEAN;(*PLEASE SET NEW DATE IN CLOSE*) FHEADER: DIRENTRY;(*COPY OF DISK DIR ENTRY*) CASE FSOFTBUF: BOOLEAN OF (*DISK GET-PUT STUFF*) TRUE: (FNXTBYTE,FMAXBYTE: INTEGER; FBUFCHNGD: BOOLEAN; FBUFFER: PACKED ARRAY [0..FBLKSIZE] OF CHAR)) END (*FIB*) ; (*USER WORKFILE STUFF*) INFOREC = RECORD SYMFIBP,CODEFIBP: FIBP; (*WORKFILES FOR SCRATCH*) ERRSYM,ERRBLK,ERRNUM: INTEGER; (*ERROR STUFF IN EDIT*) SLOWTERM,STUPID: BOOLEAN; (*STUDENT PROGRAMMER ID!!*) ALTMODE: CHAR; (*WASHOUT CHAR FOR COMPILER*) GOTSYM,GOTCODE: BOOLEAN; (*TITLES ARE MEANINGFUL*) WORKVID,SYMVID,CODEVID: VID; (*PERM&CUR WORKFILE VOLUMES*) WORKTID,SYMTID,CODETID: TID (*PERM&CUR WORKFILES TITLE*) END (*INFOREC*) ; (*CODE SEGMENT LAYOUTS*) SEGRANGE = 0..MAXSEG; SEGDESC = RECORD DISKADDR: INTEGER; (*REL BLK IN CODE...ABS IN SYSCOM^*) CODELENG: INTEGER (*# BYTES TO READ IN*) END (*SEGDESC*) ; (*DEBUGGER STUFF*) BYTERANGE = 0..255; TRICKARRAY = RECORD {Memory diddling for execerror} CASE BOOLEAN OF TRUE : (WORD : ARRAY [0..0] OF INTEGER); FALSE : (BYTE : PACKED ARRAY [0..0] OF BYTERANGE) END; MSCWP = ^ MSCW; (*MARK STACK RECORD POINTER*) MSCW = RECORD STATLINK: MSCWP; (*POINTER TO PARENT MSCW*) DYNLINK: MSCWP; (*POINTER TO CALLER'S MSCW*) MSSEG,MSJTAB: ^TRICKARRAY; MSIPC: INTEGER; LOCALDATA: TRICKARRAY END (*MSCW*) ; (*SYSTEM COMMUNICATION AREA*) (*SEE INTERPRETERS...NOTE *) (*THAT WE ASSUME BACKWARD *) (*FIELD ALLOCATION IS DONE *) SYSCOMREC = RECORD IORSLT: IORSLTWD; (*RESULT OF LAST IO CALL*) XEQERR: INTEGER; (*REASON FOR EXECERROR CALL*) SYSUNIT: UNITNUM; (*PHYSICAL UNIT OF BOOTLOAD*) BUGSTATE: INTEGER; (*DEBUGGER INFO*) GDIRP: DIRP; (*GLOBAL DIR POINTER,SEE VOLSEARCH*) LASTMP,STKBASE,BOMBP: MSCWP; MEMTOP,SEG,JTAB: INTEGER; BOMBIPC: INTEGER; (*WHERE XEQERR BLOWUP WAS*) HLTLINE: INTEGER; (*MORE DEBUGGER STUFF*) BRKPTS: ARRAY [0..3] OF INTEGER; RETRIES: INTEGER; (*DRIVERS PUT RETRY COUNTS*) EXPANSION: ARRAY [0..8] OF INTEGER; HIGHTIME,LOWTIME: INTEGER; MISCINFO: PACKED RECORD NOBREAK,STUPID,SLOWTERM, HASXYCRT,HASLCCRT,HAS8510A,HASCLOCK: BOOLEAN; USERKIND:(NORMAL, AQUIZ, BOOKER, PQUIZ); IS_FLIPT : BOOLEAN END; CRTTYPE: INTEGER; CRTCTRL: PACKED RECORD RLF,NDFS,ERASEEOL,ERASEEOS,HOME,ESCAPE: CHAR; BACKSPACE: CHAR; FILLCOUNT: 0..255; CLEARSCREEN, CLEARLINE: CHAR; PREFIXED: PACKED ARRAY [0..8] OF BOOLEAN END; CRTINFO: PACKED RECORD WIDTH,HEIGHT: INTEGER; RIGHT,LEFT,DOWN,UP: CHAR; BADCH,CHARDEL,STOP,BREAK,FLUSH,EOF: CHAR; ALTMODE,LINEDEL: CHAR; BACKSPACE,ETX,PREFIX: CHAR; PREFIXED: PACKED ARRAY [0..13] OF BOOLEAN END; SEGTABLE: ARRAY [SEGRANGE] OF RECORD CODEUNIT: UNITNUM; CODEDESC: SEGDESC END END (*SYSCOM*); MISCINFOREC = RECORD MSYSCOM: SYSCOMREC END; VAR SYSCOM: ^SYSCOMREC; (*MAGIC PARAM...SET UP IN BOOT*) GFILES: ARRAY [0..5] OF FIBP; (*GLOBAL FILES, 0=INPUT, 1=OUTPUT*) USERINFO: INFOREC; (*WORK STUFF FOR COMPILER ETC*) EMPTYHEAP: ^INTEGER; (*HEAP MARK FOR MEM MANAGING*) INPUTFIB,OUTPUTFIB, (*CONSOLE FILES...GFILES ARE COPIES*) SYSTERM,SWAPFIB: FIBP; (*CONTROL AND SWAPSPACE FILES*) SYVID,DKVID: VID; (*SYSUNIT VOLID & DEFAULT VOLID*) THEDATE: DATEREC; (*TODAY...SET IN FILER OR SIGN ON*) DEBUGINFO: ^INTEGER; (*DEBUGGERS GLOBAL INFO WHILE RUNIN*) STATE: CMDSTATE; (*FOR GETCOMMAND*) PL: STRING; (*PROMPTLINE STRING...SEE PROMPT*) IPOT: ARRAY [0..4] OF INTEGER; (*INTEGER POWERS OF TEN*) FILLER: STRING[FILL_LEN]; (*NULLS FOR CARRIAGE DELAY*) DIGITS: SET OF '0'..'9'; UNITABLE: ARRAY [UNITNUM] OF (*0 NOT USED*) RECORD UVID: VID; (*VOLUME ID FOR UNIT*) CASE UISBLKD: BOOLEAN OF TRUE: (UEOVBLK: INTEGER) END (*UNITABLE*) ; FILENAME : FILE_TABLE; (*-------------------------------------------------------------------------*) (* SYSTEM PROCEDURE FORWARD DECLARATIONS *) (* THESE ARE ADDRESSED BY OBJECT CODE... *) (* DO NOT MOVE WITHOUT CAREFUL THOUGHT *) PROCEDURE EXECERROR; FORWARD; PROCEDURE FINIT(VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER); FORWARD; PROCEDURE FRESET(VAR F: FIB); FORWARD; PROCEDURE FOPEN(VAR F: FIB; VAR FTITLE: STRING; FOPENOLD: BOOLEAN; JUNK: FIBP); FORWARD; PROCEDURE FCLOSE(VAR F: FIB; FTYPE: CLOSETYPE); FORWARD; PROCEDURE FGET(VAR F: FIB); FORWARD; PROCEDURE FPUT(VAR F: FIB); FORWARD; PROCEDURE XSEEK; FORWARD; FUNCTION FEOF(VAR F: FIB): BOOLEAN; FORWARD; FUNCTION FEOLN(VAR F: FIB): BOOLEAN; FORWARD; PROCEDURE FREADINT(VAR F: FIB; VAR I: INTEGER); FORWARD; PROCEDURE FWRITEINT(VAR F: FIB; I,RLENG: INTEGER); FORWARD; PROCEDURE XREADREAL; FORWARD; PROCEDURE XWRITEREAL; FORWARD; PROCEDURE FREADCHAR(VAR F: FIB; VAR CH: CHAR); FORWARD; PROCEDURE FWRITECHAR(VAR F: FIB; CH: CHAR; RLENG: INTEGER); FORWARD; PROCEDURE FREADSTRING(VAR F: FIB; VAR S: STRING; SLENG: INTEGER); FORWARD; PROCEDURE FWRITESTRING(VAR F: FIB; VAR S: STRING; RLENG: INTEGER); FORWARD; PROCEDURE FWRITEBYTES(VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER); FORWARD; PROCEDURE FREADLN(VAR F: FIB); FORWARD; PROCEDURE FWRITELN(VAR F: FIB); FORWARD; PROCEDURE SCONCAT(VAR DEST,SRC: STRING; DESTLENG: INTEGER); FORWARD; PROCEDURE SINSERT(VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER); FORWARD; PROCEDURE SCOPY(VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER); FORWARD; PROCEDURE SDELETE(VAR DEST: STRING; DELINX,DELLENG: INTEGER); FORWARD; FUNCTION SPOS(VAR TARGET,SRC: STRING): INTEGER; FORWARD; FUNCTION FBLOCKIO(VAR F: FIB; VAR A: WINDOW; I: INTEGER; NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN): INTEGER; FORWARD; PROCEDURE FGOTOXY(X,Y: INTEGER); FORWARD; (* NON FIXED FORWARD DECLARATIONS *) FUNCTION VOLSEARCH(VAR FVID: VID; LOOKHARD: BOOLEAN; VAR FDIR: DIRP): UNITNUM; FORWARD; PROCEDURE WRITEDIR(FUNIT: UNITNUM; FDIR: DIRP); FORWARD; FUNCTION DIRSEARCH(VAR FTID: TID; FINDPERM: BOOLEAN; FDIR: DIRP): DIRRANGE; FORWARD; FUNCTION SCANTITLE(FTITLE: STRING; VAR FVID: VID; VAR FTID: TID; VAR FSEGS: INTEGER; VAR FKIND: FILEKIND): BOOLEAN; FORWARD; PROCEDURE DELENTRY(FINX: DIRRANGE; FDIR: DIRP); FORWARD; PROCEDURE INSENTRY(VAR FENTRY: DIRENTRY; FINX: DIRRANGE; FDIR: DIRP); FORWARD; PROCEDURE HOMECURSOR; FORWARD; PROCEDURE CLEARSCREEN; FORWARD; PROCEDURE CLEARLINE; FORWARD; PROCEDURE PROMPT; FORWARD; FUNCTION SPACEWAIT(FLUSH: BOOLEAN): BOOLEAN; FORWARD; FUNCTION GETCHAR(FLUSH: BOOLEAN): CHAR; FORWARD; FUNCTION FETCHDIR(FUNIT:UNITNUM) : BOOLEAN; FORWARD; PROCEDURE COMMAND; FORWARD; ======================================================================================== DOCUMENT :usus Folder:VOL08:global.iii.text ======================================================================================== {$U-} (*************************************************************** * Copyright (c) Western Digital, Newport Beach, CA, 1981. * * This documentation is provided for information purposes * * only. Definitions may change in future versions of the * * Western Digital operating system. * ***************************************************************) {***NOTE added by J. Gagne: this file was originally in three parts: HEADER.TEXT, GLOBALS.TEXT, and FORWARDS.TEXT. They have been combined for brevity and clarity; points where new files began are noted. This portion was called HEADER.TEXT. } { **************************************************************** } { } { Copyright (c) 1979 Regents of the University of California. } { Permission to copy or distribute this software or documen- } { tation in hard or soft copy granted only by written license } { obtained from the Institute for Information Systems. } { } { **************************************************************** } program pascalsystem; { ********************************************** } { } { UCSD PASCAL OPERATING SYSTEM } { } { RELEASE LEVEL: I.3 AUGUST, 1977 } { I.4 JANUARY, 1978 } { I.5 SEPTEMBER, 1978 } { III.0 JANUARY, 1979 } { } { WRITTEN BY ROGER T. SUMNER } { WINTER 1977 } { } { INSTITUTE FOR INFORMATION SYSTEMS } { UC SAN DIEGO, LA JOLLA, CA } { } { KENNETH L. BOWLES, DIRECTOR } { } { ********************************************** } {***NOTE: This next section had been called GLOBALS.TEXT} const mmaxint = 32767; { maximum integer value } maxunit = 16; { maximum physical unit # for uread } maxdir = 77; { max number of entries in a directory } vidleng = 7; { number of chars in a volume id } tidleng = 15; { number of chars in title id } maxseg = 15; { max code segment number } fblksize = 512; { standard disk block length } dirblk = 2; { disk addr of directory } agelimit = 300; { max age for gdirp...in ticks } eol = 13; { end-of-line ...ASCII cr } dle = 16; { blank compression code } maxq = 79; { type-ahead queue index limit } maxqp1 = 80; { type-ahead queue length } maxretry = 10; { retry count for disk drivers } hiiopriority = 250; { kbddriver (serial in) processes } midiopriority = 245; { disk in/out, parallel out, serial out } lowiopriority = 240; { enabler process for kbddrivers } TYPE iorsltwd = (inoerror,ibadblock,ibadunit,ibadmode,itimeout, ilostunit,ilostfile,ibadtitle,inoroom,inounit, inofile,idupfile,inotclosed,inotopen,ibadformat, istrgovfl); { COMMAND STATES...SEE GETCMD } cmdstate = (haltinit,debugcall, uprognou,uproguok,sysprog, componly,compandgo,compdebug, linkandgo,linkdebug); { CODE FILES USED IN GETCMD } sysfile = (assmbler,compiler,editor,filer,linker); { ARCHIVAL INFO...THE DATE } daterec = packed record month: 0..12; { 0 IMPLIES DATE NOT MEANINGFUL } day: 0..31; { DAY OF MONTH } year: 0..100 { 100 IS TEMP DISK FLAG } end { DATEREC } ; { VOLUME TABLES } unitnum = 0..maxunit; vid = string[vidleng]; { DISK DIRECTORIES } dirrange = 0..maxdir; tid = string[tidleng]; filekind = (untypedfile,xdskfile,codefile,textfile, infofile,datafile,graffile,fotofile,securedir); direntry = record dfirstblk: integer; { FIRST PHYSICAL DISK ADDR } dlastblk: integer; { POINTS AT BLOCK FOLLOWING } case dfkind: filekind of securedir, untypedfile: { ONLY IN DIR[0]...VOLUME INFO } (dvid: vid; { NAME OF DISK VOLUME } deovblk: integer; { LASTBLK OF VOLUME } dnumfiles: dirrange; { NUM FILES IN DIR } dloadtime: integer; { TIME OF LAST ACCESS } dlastboot: daterec); { MOST RECENT DATE SETTING } xdskfile,codefile,textfile,infofile, datafile,graffile,fotofile: (dtid: tid; { TITLE OF FILE } dlastbyte: 1..fblksize; { NUM BYTES IN LAST BLOCK } daccess: daterec) { LAST MODIFICATION DATE } end { DIRENTRY } ; dirp = ^directory; directory = array [dirrange] of direntry; { FILE INFORMATION } closetype = (cnormal,clock,cpurge,ccrunch); windowp = ^window; window = packed array [0..0] of char; fibp = ^fib; fib = record fwindow: windowp; { USER WINDOW...F^, USED BY GET-PUT } feof,feoln: boolean; fstate: (fjandw,fneedchar,fgotchar); frecsize: integer; { IN BYTES...0=>BLOCKFILE, 1=>CHARFILE } case fisopen: boolean of true: (fisblkd: boolean; { FILE IS ON BLOCK DEVICE } funit: unitnum; { PHYSICAL UNIT # } fvid: vid; { VOLUME NAME } freptcnt, { # TIMES F^ VALID W/O GET } fnxtblk, { NEXT REL BLOCK TO IO } fmaxblk: integer; { MAX REL BLOCK ACCESSED } fmodified:boolean; { SET NEW DATE IN CLOSE } fheader: direntry; { COPY OF DISK DIR ENTRY } case fsoftbuf: boolean of { DISK GET-PUT STUFF } true: (fnxtbyte,fmaxbyte: integer; fbufchngd: boolean; fbuffer: packed array [0..fblksize] of char)) end { FIB } ; { USER WORKFILE STUFF } inforec = record symfibp,codefibp: fibp; { WORKFILES FOR SCRATCH } errsym,errblk,errnum: integer; { ERROR STUFF IN EDIT } slowterm,stupid: boolean; { STUDENT PROGRAMMER ID!! } altmode: char; { WASHOUT CHAR FOR COMPILER } gotsym,gotcode: boolean; { TITLES ARE MEANINGFUL } workvid,symvid,codevid: vid; { PERM&CUR WORKFILE VOLUMES } worktid,symtid,codetid: tid; { PERM&CUR WORKFILES TITLE } end { INFOREC } ; { SYSTEM COMMUNICATION AREA } { SEE INTERPRETERS...NOTE } { THAT WE ASSUME BACKWARD } { FIELD ALLOCATION IS DONE } syscomrec = record iorslt: iorsltwd; { RESULT OF LAST IO CALL } xeqerr: integer; { REASON FOR EXECERROR CALL } sysunit: unitnum; { PHYSICAL UNIT OF BOOTLOAD } rwtable: ^integer; { PASCAL res words for idsearch } gdirp: dirp; { GLOBAL DIR POINTER,SEE VOLSEARCH } diskinfo: packed record dseekrate: integer; {STEP RATE FOR DISK DRIVE} dreadrate: integer; {DISK READ COMMAND} dwriterate: integer;{DISK WRITE COMMAND} end; expansone: array [0..17] of integer; {spare} auxcrtinfo: packed record verdlaychar: char end; hightime,lowtime: integer; miscinfo: packed record nobreak,stupid,slowterm, hasxycrt,haslccrt,has8510a,hasclock: boolean; userkind:(normal, aquiz, booker, pquiz) end; crttype: integer; crtctrl: packed record rlf,ndfs,eraseeol,eraseeos,home,escape: char; backspace: char; fillcount: 0..255; clearscreen, clearline: char; prefixed: packed array [0..8] of boolean end; crtinfo: packed record width,height: integer; right,left,down,up: char; badch,chardel,stop,break,flush,eof: char; altmode,linedel: char; backspace,etx,prefix: char; prefixed: packed array [0..13] of boolean end end { SYSCOM }; miscinforec = record msyscom: syscomrec end; memlinkp = ^memlink; memlink = record nextavail: memlinkp; nwords: integer end { memlink } ; markp = ^marknode; marknode = record prevmark: markp; availlist: memlinkp end { marknode } ; byte = 0..255; integerp = ^integer; queue = packed array [0..maxq] of byte; bytearray = packed array [0..0] of byte; codeseg = record case boolean of true: (int: packed array [0..0] of integer); false: (byt: bytearray); end; sibp = ^sib; sibvec = array [0..0] of sibp; sib = record { segment info block } segbase: ^codeseg;{ memory address of seg } segleng: integer; { # words in segment } segrefs: integer; { active calls - microcode maintained } segaddr: integer; { absolute disk address } segunit: unitnum; { physical disk unit } prevsp: integerp;{ SP saved by getseg for relseg cut back } end { sib } ; mscwp = ^mscw; mscw = packed record { mark stack control word } msstat: mscwp; { lexical parent pointer } msdynl: mscwp; { ptr to caller's mscw } msipc: integer; { byte index in return code seg } msseg: byte; { seg # of caller code } msflag: byte end { mscw } ; semp = ^semtrix; tibp = ^tib; tib = record { Task Information Block } regs: packed record waitq: tibp; { QUEUE LINK FOR SEMAPHORES } prior: byte; { TASK'S CPU PRIORITY } flags: byte; { STATE FLAGS...NOT DEFINED YET } splow: integerp; { LOWER STACK POINTER LIMIT } spupr: integerp; { UPPER LIMIT ON STACK } sp: integerp; { ACTUAL TOP-OF-STACK POINTER } mp: mscwp; { ACTIVE PROCEDURE MSCW PTR } bp: mscwp; { BASE ADDRESSING ENVIRONMENT PTR } ipc: integer; { BYTE PTR IN CURRENT CODE SEG } segb: ^codeseg; { PTR TO SEG CURRENTLY RUNNING } hangp: semp; { WHICH TASK IS WAITING ON } xxx: integer; { NOT USED } sibs: ^sibvec { ARRAY OF SIBS FOR 128..255 } end { REGS } ; maintask: boolean; startmscw: mscwp end { TIB } ; semtrix = record case integer of 0: (sem: semaphore); 1: (fakesem: record count: integer; { outstanding signals } waitq: tibp { task queue } end); end { sem } ; ports = (a,b); statcmdrec = record case boolean of true : (command : integer); false : (status : packed array[0..7] of boolean); end; { for devices that use same reg for stat and cmd } whole = 0..maxint; paralrec = record porta : statcmdrec; portb : integer; portc : statcmdrec; pcontrol : integer; end; floppyrec = record fstatcom : statcmdrec; track : integer; sector : integer; data : integer; filler : array[0..3] of whole; { dma fields } dcontrol : integer; dstatus : statcmdrec; trcountl : integer; trcounth : integer; bufaddl : integer; bufaddh : integer; memex : integer; intid : integer end; serialrec = record data : integer; statsyndle : statcmdrec; control2 : integer; control1 : integer; filler : array[0..3] of integer; switch : statcmdrec; end; sercontrol = record readsem, writebell, writesem, havch, qlock : semaphore; (* wrlock : semtrix; *) front, rear : integer; chq : queue; serialtrix: record case integer of 0: (sdevadd: integer); 1: (serial: ^serialrec); end; end; decmax = integer[36]; longtrix = record case integer of 0: (intar: array [0..0] of integer); 1: (BCDar: packed array [0..0] of 0..15); end {longtrix}; memtrix = record case boolean of true: (addr: integer); false: (loc: integerp); end; VAR syscom: ^syscomrec; { MAGIC PARAM...SET UP IN BOOT } gfiles: array [0..5] of fibp; { GLOBAL FILES, 0=INPUT, 1=OUTPUT } userinfo: inforec; { WORK STUFF FOR COMPILER ETC } ostibp: tibp; { taskinfo block of op sys prog } emptyheap: ^integer; { HEAP MARK FOR MEM MANAGING } inputfib,outputfib, { CONSOLE FILES...GFILES ARE COPIES } systerm,swapfib: fibp; { CONTROL AND SWAPSPACE FILES } syvid,dkvid: vid; { SYSUNIT VOLID & DEFAULT VOLID } thedate: daterec; { TODAY...SET IN FILER OR SIGN ON } state: cmdstate; { FOR GETCOMMAND } heapinfo: record { heap management } lock: semaphore; topmark, heaptop: markp end { heapinfo } ; taskinfo: record { stuff for task management } lock: semaphore; taskdone: semaphore; ntasks: integer end { taskinfo } ; ipot: array [0..4] of integer; { INTEGER POWERS OF TEN } filler: string[41]; { NULLS FOR CARRIAGE DELAY } digits: set of '0'..'9'; pl: string; unitable: array [unitnum] of { 0 NOT USED } record uvid: vid; { VOLUME ID FOR UNIT } case uisblkd: boolean of true: (ueovblk: integer) end { unitable } ; filename: array [sysfile] of string[23]; topofsibs: ^integer; safediskmode : boolean; { if true, volsearch will not fetch new dir if gdirp matches unit table } {..........Variable access by system U- programs ends here..........} port : array [ports] of sercontrol; paraltrix : record case boolean of true : (pdevadd : integer); false : (parallel : ^paralrec); end; floppytrix : record case boolean of true : (fdevadd : integer); false : (floppy : ^floppyrec); end; dmasem, parsem, stst : semaphore; (* pariolock, diskiolock : semtrix; *) iolock, enableint : semaphore; sflag,fflag,wflag : boolean; { start/stop, flush, and waiting } enabletrix : memtrix; { for enabling interrupts } {***NOTE: The next section had been called FORWARDS.TEXT} { ------------------------------------------------------------------------- } { SYSTEM PROCEDURE FORWARD DECLARATIONS } { THESE ARE ADDRESSED BY OBJECT CODE... } { DO NOT MOVE WITHOUT CAREFUL THOUGHT } segment procedure userprog; forward; segment procedure syscode; forward; segment procedure cspcode; forward; segment procedure syscode; segment procedure printerror (var xeqerr: integer; iorslt: integer); forward; segment procedure initialize; forward; segment procedure getcmd(lastst: cmdstate; var nextst: cmdstate); forward; segment procedure debugger(var xeqerr: integer; theseg,theproc, theipc, theptr: integer); forward; procedure execerror(err: integer); forward; procedure finit(var f: fib; window: windowp; recwords: integer); forward; procedure freset(var f: fib); forward; procedure fopen(var f: fib; var ftitle: string; fopenold: boolean; junk: fibp); forward; procedure fclose(var f: fib; ftype: closetype); forward; procedure fget(var f: fib); forward; procedure fput(var f: fib); forward; procedure fseek(var f: fib; recnum: integer); forward; function feof(var f: fib): boolean; forward; function feoln(var f: fib): boolean; forward; procedure freadint(var f: fib; var i: integer); forward; procedure fwriteint(var f: fib; i,rleng: integer); forward; procedure freadreal(var f: fib; var x: real); forward; procedure fwritereal(var f: fib; x: real; w, d: integer); forward; procedure freadchar(var f: fib; var ch: char); forward; procedure fwritechar(var f: fib; ch: char; rleng: integer); forward; procedure freadstring(var f: fib; var s: string; sleng: integer); forward; procedure fwritestring(var f: fib; var s: string; rleng: integer); forward; procedure fwritebytes(var f: fib; var a: window; rleng,aleng: integer); forward; procedure freadln(var f: fib); forward; procedure fwriteln(var f: fib); forward; procedure sconcat(var dest,src: string; destleng: integer); forward; procedure sinsert(var src,dest: string; destleng,insinx: integer); forward; procedure scopy(var src,dest: string; srcinx,copyleng: integer); forward; procedure sdelete(var dest: string; delinx,delleng: integer); forward; function spos(var target,src: string): integer; forward; function fblockio(var f: fib; var a: window; inx: integer; nblocks,rblock: integer; doread: boolean): integer; forward; procedure fgotoxy(x,y: integer); forward; { NON FIXED FORWARD DECLARATIONS } function volsearch(var fvid: vid; lookhard: boolean; var fdir: dirp): unitnum; forward; procedure writedir(funit: unitnum; fdir: dirp); forward; function dirsearch(var ftid: tid; findperm: boolean; fdir: dirp): dirrange; forward; function scantitle(ftitle: string; var fvid: vid; var ftid: tid; var fsegs: integer; var fkind: filekind): boolean; forward; procedure delentry(finx: dirrange; fdir: dirp); forward; procedure insentry(var fentry: direntry; finx: dirrange; fdir: dirp); forward; procedure homecursor; forward; procedure clearscreen; forward; procedure clearline; forward; procedure prompt; forward; function spacewait(flush: boolean): boolean; forward; function getchar(flush: boolean): char; forward; procedure command; forward; process enabler; forward; process bellprocess (lport: ports); forward; process kbddriver (lport: ports; funit: integer); forward; ======================================================================================== DOCUMENT :usus Folder:VOL08:linecount.text ======================================================================================== PROGRAM LINECOUNTER; {by Sandy and George Schreyer} {use this program to do a very fast line count of one or several files. you must make a text file of the filenames that you wish to count if you want to count more than one file at a time} USES (*$U SCREENUNIT.CODE*)SCREENUNIT, (*$U FILEUNIT.CODE*) FILEUNIT, (*$U PRINTRUNIT.CODE*)PRINTERUNIT; VAR DIRF:TEXT; {Directory file} DISK:FILE; {Text file to be line-counted} FILENAME:STRING; {Name of text file} LINES:INTEGER; {Number of lines in one text file} PRNT:TEXT; {Output to printer} TRANSACTION:CHAR; {What program is to do} PROCEDURE DO_COUNT; { Count the lines of text file FILENAME. The answer is LINES. } VAR POSITION,INDEX,BLOCKS,DATA_LEFT : INTEGER; DATA : PACKED ARRAY[0..17407] OF CHAR; {$R-} BEGIN LINES:=0; INDEX:=0; WRITELN('counting ... ',FILENAME); BLOCKS:=BLOCKREAD(DISK,DATA,34,2); DATA_LEFT:=512*BLOCKS; REPEAT POSITION:=SCAN(DATA_LEFT,=CHR(13),DATA[INDEX]); LINES:=SUCC(LINES); INDEX:=INDEX+POSITION+1; DATA_LEFT:=DATA_LEFT-POSITION; UNTIL DATA_LEFT <= 0; LINES:=LINES-1; END {DO_COUNT}; {$R+} PROCEDURE COUNT_ONE; { Count the number of lines in one file. } BEGIN OPNDSKREAD(DISK,'Count lines in which text file? ',FILENAME,0,5); IF FILENAME='' THEN EXIT(COUNT_ONE); GOTOXY(0,0); CRT(ERASEOS); WRITELN; DO_COUNT; WRITELN; WRITELN('Your file ',FILENAME,' has ',LINES,' lines.'); CLOSE(DISK,LOCK); END {COUNT_ONE}; PROCEDURE COUNT_MANY; { Count the number of lines in a group of files. } VAR DATE:STRING; DIREOF:BOOLEAN; DIR_NAME:STRING; IORSLT:INTEGER; STAR:STRING; TOT_LINES:INTEGER; BEGIN OPNDSKREAD(DIRF,'What is the name of your directory? ',DIR_NAME,0,5); IF DIR_NAME='' THEN EXIT(COUNT_MANY); TOT_LINES:=0; PAGE(PRNT); WRITELN(PRNT,'Line counts for directory ',DIR_NAME); STAR:='*'; GET_FILE_DATE(STAR,DATE); WRITELN(PRNT,' on ',DATE); WRITELN(PRNT); WRITELN(PRNT); GOTOXY(0,0); CRT(ERASEOS); REPEAT READLN(DIRF,FILENAME); DIREOF:=EOF(DIRF); IF (NOT DIREOF) AND (FILENAME<>'') THEN BEGIN {$I-} RESET(DISK,FILENAME); IORSLT:=IORESULT; {$I+} IF IORSLT<>0 THEN WRITELN(PRNT,FILENAME,' can not be opened.') ELSE BEGIN DO_COUNT; FILENAME:=CONCAT(FILENAME,' '); WRITELN(PRNT,COPY(FILENAME,1,30),LINES:10); TOT_LINES:=TOT_LINES+LINES; WAIT_FOR_DC1; END; END; CLOSE(DISK,LOCK); UNTIL DIREOF; WRITELN(PRNT); WRITELN(PRNT,'TOTAL',' ':25,TOT_LINES:10); CLOSE(DIRF,LOCK); END {COUNT_MANY}; BEGIN {LINECOUNTER} INITPT; GETCRTINFO; REWRITE(PRNT,'PRINTER:'); GOTOXY(0,0); CRT(ERASEOS); WRITELN('LINE COUNTER version 2 22-Jul-81'); WRITELN; VER_SCREENUNIT; VER_FILEUNIT; VER_PRTUNIT; REPEAT GOTOXY(0,15); WRITELN('A) Count lines in one file'); WRITELN('B) Count lines for all files in directory'); WRITELN; WRITELN('Q) Quit'); REPEAT GOTOXY(0,12); WRITE('Enter letter of desired menu item: '); READ(TRANSACTION); UNTIL TRANSACTION IN ['A','B','Q','a','b','q']; GOTOXY(0,0); CRT(ERASEOS); CASE (TRANSACTION) OF 'A','a': COUNT_ONE; 'B','b': COUNT_MANY; 'Q','q': ; END {case}; GOTOXY(0,0); CRT(ERASEOS); UNTIL TRANSACTION IN ['Q','q']; END. {LINECOUNTER} ======================================================================================== DOCUMENT :usus Folder:VOL08:lisp.text ======================================================================================== (* NTIS LISP interpreter by L. A. Cox, Jr. and W. P. Taylor of the Lawrence Livermore Laboratory, modified for UCSD Pascal by David Mundie. NTIS #UCRL-52417. *) {$G+} program lisp; label 1,2; const maxnodes = 100; type alfa = string[10]; inputsymbol = (atom,period,lparen,rparen); rsrvdwrds = (replhsym,repltsym,headsym, tailsym,eqsym,quotesym,atomsym,condsym,labelsym, lambdasym,copysym,appendsym,concsym,conssym); statustype = (unmarked,left,right,marked); symbexpptr = ^symbolicExpression; symbolicExpression = record status: statustype; next: symbexpptr; case anatom:boolean of true: (name: alfa; case isareservedword: boolean of true: (ressym: rsrvdwrds)); false: (head,tail: symbexpptr) end; var lookaheadsym,sym: inputsymbol; errorflag: boolean; id: alfa; alreadypeeked: boolean; ch:char; ptr: symbexpptr; freelist,nodelist,alist: symbexpptr; nilnode,tnode: symbolicExpression; resword: rsrvdwrds; reserved: boolean; reswords: array [rsrvdwrds] of alfa; freenodes,numberofgcs: integer; procedure error(number: integer); forward; procedure garbageman; procedure mark(list:symbexpptr); var father,son,current: symbexpptr; begin father := nil; current := list; son := current; while current <> nil do with current^ do case status of unmarked: if anatom then status := marked else if (head^.status <> unmarked) or (head=current) then if (tail^.status <>unmarked) or (tail = current) then status := marked else begin status := right; son := tail; tail := father; father := current; current := son end else begin status := left; son := head; head := father; father := current; current := son end; left: if tail^.status <> unmarked then begin status := marked; father := head; head := son; son := current end else begin status := right; current := tail; tail := head; head := son; son := current end; right: begin status := marked; father := tail; tail := son; son := current end; marked: current := father end end; {mark} procedure collectfreenodes; var temp: symbexpptr; begin writeln('number of free nodes before collection = ', freenodes:1,'.'); freelist := nil; freenodes := 0; temp := nodelist; while temp <> nil do begin if temp^.status <> unmarked then temp^.status := unmarked else begin freenodes := freenodes + 1; temp^.head := freelist; freelist := temp end; temp := temp^.next end; writeln('Nodes free after collection = ',freenodes:1,'.') end; begin {garbageman} numberofgcs := numberofgcs + 1; writeln; writeln('Garbage collection.'); writeln; mark(alist); if ptr <> nil then mark(ptr); collectfreenodes end; procedure pop(var sptr:symbexpptr); begin if freelist = nil then begin writeln('Not enough space to evaluate.'); exit(lisp) end; freenodes := freenodes - 1; sptr := freelist; freelist := freelist^.head end; procedure backupinput; begin alreadypeeked := true; lookaheadsym := sym; sym := lparen end; procedure nextsym; var i: integer; begin if alreadypeeked then begin sym := lookaheadsym; alreadypeeked := false end else begin while ch = ' ' do begin if eoln then writeln; read(ch); end; if ch in ['(','.',')'] then begin case ch of '(': sym := lparen; '.': sym := period; ')': sym := rparen end; if eoln then writeln; read(ch); end else begin sym := atom; id := ' '; i := 0; repeat i := i + 1; if i < 11 then id[i] := ch; if eoln then writeln; read(ch); until ch in [' ','(','.',')']; resword := replhsym; while (id<>reswords[resword]) and (resword<>conssym) do resword := succ(resword); reserved := id = reswords[resword] end end end; procedure readexpr( var sptr: symbexpptr); var nxt: symbexpptr; begin pop(sptr); nxt := sptr^.next; case sym of rparen,period: error(1); atom: with sptr^ do begin anatom := true; name := id; isareservedword := reserved; if reserved then ressym := resword end; lparen: with sptr^ do begin nextsym; if sym = period then error(2) else if sym = rparen then sptr^ := nilnode else begin anatom := false; readexpr(head); nextsym; if sym = period then begin nextsym; readexpr(tail); nextsym; if sym<>rparen then error(4) end else begin backupinput; readexpr(tail) end end end {with} end; {case} sptr^.next := nxt end; procedure printname(name: alfa); begin write(name,' ') end; procedure printexpr(sptr: symbexpptr); label 1; begin if sptr^.anatom then printname(sptr^.name) else begin write('('); 1: with sptr^ do begin printexpr(head); if tail^.anatom and (tail^.name = 'nil ') then write(') ') else if tail^.anatom then begin write(' . '); printexpr( tail ); write(') ') end else begin sptr := tail; goto 1 end end end end; {printexpr} function eval(e,alist:symbexpptr):symbexpptr; var temp,carofe,caarofe: symbexpptr; function replaceh(sptr1,sptr2:symbexpptr):symbexpptr; begin if sptr1^.anatom then error(5) else sptr1^.head := sptr2; replaceh := sptr1 end; function replacet(sptr1,sptr2: symbexpptr):symbexpptr; begin if sptr1^.anatom then error(6) else sptr1^.tail := sptr2; replacet := sptr1 end; function head(sptr: symbexpptr):symbexpptr; begin if sptr^.anatom then error(7) else head := sptr^.head end; function tail(sptr:symbexpptr):symbexpptr; begin if sptr^.anatom then error(8) else tail := sptr^.tail end; function cons(sptr1,sptr2:symbexpptr):symbexpptr; var temp:symbexpptr; begin pop(temp); temp^.anatom := false; temp^.head := sptr1; temp^.tail := sptr2; cons := temp; writeln('cons') end; function copy(sptr:symbexpptr):symbexpptr; var temp,nxt: symbexpptr; begin if sptr^.anatom then begin pop(temp); nxt := temp^.next; temp^ := sptr^; temp^.next := nxt; copy := temp; writeln('copy') end else copy := cons(copy(sptr^.head),copy(sptr^.tail)) end; function append(sptr1,sptr2: symbexpptr): symbexpptr; begin if sptr1^.anatom then if sptr1^.name <> 'nil ' then error(9) else append := sptr2 else append := cons(copy(sptr1^.head),append(sptr1^.tail,sptr2)) end; function conc(sptr1:symbexpptr):symbexpptr; var sptr2,nilptr: symbexpptr; begin if sym <> rparen then begin nextsym; readexpr(sptr2); nextsym; conc := cons(sptr1,conc(sptr2)) end else if sym = rparen then begin new(nilptr); with nilptr^ do begin anatom := true; name := 'nil ' end; conc := cons(sptr1,nilptr) end else error(10) end; function eqq(sptr1,sptr2: symbexpptr):symbexpptr; var temp,nxt: symbexpptr; begin pop(temp); nxt := temp^.next; if sptr1^.anatom and sptr2^.anatom then if sptr1^.name = sptr2^.name then temp^ := tnode else temp^ := nilnode else if sptr1 = sptr2 then temp^ := tnode else temp^ := nilnode; eqq := temp end; function atom(sptr: symbexpptr):symbexpptr; var temp,nxt: symbexpptr; begin pop(temp); writeln('atom'); nxt := temp^.next; if sptr^.anatom then temp^:=tnode else temp^ := nilnode; temp^.next := nxt; atom := temp end; function lookup(key,alist: symbexpptr):symbexpptr; var temp: symbexpptr; begin temp := eqq(head(head(alist)),key); if temp^.name = 't ' then lookup := tail(head(alist)) else lookup := lookup(key,tail(alist)) end; function bindargs(names,values:symbexpptr):symbexpptr; var temp,temp2: symbexpptr; begin if names^.anatom and (names^.name = 'nil ') then bindargs := alist else begin temp := cons(head(names),eval(head(values),alist)); temp2 := bindargs(tail(names),tail(values)); bindargs := cons(temp,temp2) end end; function evcon(condpairs: symbexpptr):symbexpptr; var temp: symbexpptr; begin temp := eval(head(head(condpairs)),alist); if temp^.anatom and (temp^.name = 'nil ') then evcon := evcon(tail(condpairs)) else evcon := eval(head(tail(head(condpairs))),alist) end; begin {eval} writeln('EVAL'); if e^.anatom then eval := lookup(e,alist) else begin carofe := head(e); if carofe^.anatom then if not carofe^.isareservedword then eval := eval(cons(lookup(carofe,alist),tail(e)),alist) else case carofe^.ressym of labelsym,lambdasym: error(3); quotesym: eval := head(tail(e)); atomsym: eval := atom(eval(head(tail(e)),alist)); eqsym: eval := eqq(eval(head(tail(e)),alist), eval(head(tail(tail(e))),alist)); headsym: eval := head(eval(head(tail(e)),alist)); tailsym: eval := tail(eval(head(tail(e)),alist)); conssym: eval := cons(eval(head(tail(e)),alist), eval(head(tail(tail(e))),alist)); condsym: eval := evcon(tail(e)); concsym:; appendsym: eval := append(eval(head(tail(e)),alist), eval(head(tail(tail(e))),alist)); replhsym: eval := replaceh(eval(head(tail(e)),alist), eval(head(tail(tail(e))),alist)); repltsym: eval := replacet(eval(head(tail(e)),alist), eval(head(tail(tail(e))),alist)); end {case} else begin caarofe := head(carofe); if caarofe^.anatom and caarofe^.isareservedword then if not(caarofe^.ressym in [labelsym,lambdasym]) then error(12) else case caarofe^.ressym of labelsym: begin temp := cons(cons(head(tail(carofe)), head(tail(tail(carofe)))),alist); eval := eval(cons(head(tail(tail(carofe))), tail(e)),temp) end; lambdasym: begin temp := bindargs(head(tail(carofe)),tail(e)); eval := eval(head(tail(tail(carofe))),temp) end end {case} else eval := eval(cons(eval(carofe,alist),tail(e)),alist) end end end; {eval} procedure initialize; var i: integer; temp,nxt: symbexpptr; begin alreadypeeked := false; read(ch); numberofgcs := 0; freenodes := maxnodes; with nilnode do begin anatom := true; next := nil; name := 'nil '; status := unmarked; isareservedword := false end; with tnode do begin anatom := true; next := nil; name := 't '; status := unmarked; isareservedword := false end; freelist := nil; for i := 1 to maxnodes do begin new(nodelist); nodelist^.next := freelist; nodelist^.head := freelist; nodelist^.status := unmarked; freelist := nodelist end; reswords[replhsym] := 'replaceh '; reswords[repltsym] := 'replacet '; reswords[headsym ] := 'car '; reswords[tailsym ] := 'cdr '; reswords[copysym ] := 'copy '; reswords[appendsym]:= 'append '; reswords[concsym ] := 'conc '; reswords[conssym ] := 'cons '; reswords[eqsym] := 'eq '; reswords[quotesym] := 'quote '; reswords[atomsym] := 'atom '; reswords[condsym] := 'cond '; reswords[labelsym] := 'label '; reswords[lambdasym]:= 'lambda '; pop(alist); alist^.anatom := false; alist^.status := unmarked; pop(alist^.tail); nxt := alist^.tail^.next; alist^.tail^ := nilnode; alist^.tail^.next := nxt; pop(alist^.head); with alist^.head^ do begin anatom := false; status := unmarked; pop(head); nxt := head^.next; head^ := nilnode; head^.next := nxt; pop(tail); nxt := tail^.next; tail^ := nilnode; tail^.next := nxt end; pop(temp); temp^.anatom := false; temp^.status := unmarked; temp^.tail := alist; alist := temp; pop(alist^.head); with alist^.head^ do begin anatom := false; status := unmarked; pop(head); nxt := head^.next; head^ := tnode; head^.next := nxt; pop(tail); nxt := tail^.next; tail^ := tnode; tail^.next := nxt end end; procedure showexpr; begin printexpr(eval(ptr,alist)) end; procedure error; begin writeln; writeln('Error number ',number); errorflag := true; if number = 11 then exit(lisp) else if number in [1,2,4] then exit(readexpr) else if number in [3,12,5,6,7,8,9,10] then exit(showexpr) end; begin {lisp} writeln('***eval '); initialize; nextsym; readexpr(ptr); readln; writeln; while not ptr^.anatom or (ptr^.name <>'fin ') do begin writeln; writeln(' *value* '); showexpr; 1: errorflag := false; writeln; writeln; if eof(input) then error(11); ptr := nil; garbageman; writeln; writeln; writeln(' *eval* '); nextsym; readexpr(ptr); if errorflag then goto 1; readln; writeln end; writeln('Total number of garbage collections',numberofgcs); writeln('Free nodes left on exit ',freenodes) end. ======================================================================================== DOCUMENT :usus Folder:VOL08:lister.text ======================================================================================== {Copyright 1980 by Stuart Lynne 1350 Clifton Ave. Coquitlam, British Columbia, Canada V3J 5K6 Permission granted to use for noncommercial purposes. All other rights reserved} {$I globals} segment procedure userprogram; var lineno, pageno: integer; dy, yr: integer; mth: string[10]; line: string[255]; comment: string[40]; finame, foname: string[20]; Fi, Fo: text; procedure set_month; begin with thedate do begin dy := day; yr := year; case month of 1: mth := 'January'; 2: mth := 'Febuary'; 3: mth := 'March'; 4: mth := 'April'; 5: mth := 'May'; 6: mth := 'June'; 7: mth := 'July'; 8: mth := 'August'; 9: mth := 'September'; 10: mth := 'October'; 11: mth := 'November'; 12: mth := 'December' end end end; procedure pageject; begin pageno := pageno + 1; lineno := 0; page (Fo); writeln (Fo, 'File: ''', finame, '''', '':17-length(finame), comment, '':46-length(comment), mth, ' ', dy:2, ', 19', yr:2, '':11-length(mth), 'pg.', pageno:3); writeln (Fo) end; function check: boolean; const FF = 12; var S: string[1]; begin S := ' '; S[1] := chr (FF); check := (pos ('$P', line) <> 0) or (pos ('.pag', line) = 1) or (pos (S, line) <> 0) end; begin setmonth; writeln; writeln ('File Lister'); write ('What file? '); readln (finame); finame := concat (finame, '.text'); write ('To where? '); readln (foname); write ('Comment? '); readln (comment); reset (Fi, finame); rewrite (Fo, foname); pageno := 0; lineno := 0; while not eof (Fi) do begin readln (Fi, line); if ((lineno mod 60) = 0) or check then pageject; writeln (Fo, line); lineno := lineno + 1 end; page (Fo) end; begin end. ======================================================================================== DOCUMENT :usus Folder:VOL08:mailer.doc.text ======================================================================================== MAILER DOCUMENTATION MAILER is a simple mailing-list maintenance program. It creates and updates two fundamental data structures: (1) a file of mailing records with fields for name, street, city, state, zipcode, and phone number; and (2) an unbalanced binary tree of keys, used to sort the records and to locate a given record in the file. The keys may be any of the fields in the mailing records, at the user's discretion. When entered, the program prompts for the name of the file to be handled. If the file doesn't exist, the program creates one, and initializes all its records to empty. It then prompts for the field which is to be used to sort and search the file. Once this initialization is done, the user is given a prompt line with seven options: A(dd M(odify P(rint F(ile N(ewsort S(et Q(uit The use of these seven options is as follows. ADD: Permits the user to add a new record to the file. MODIFY: Allows modification of an existing record. The user is asked for a target string, and the tree of keys is searched for a match. Matching is done by substrings, so the string need not be complete; "Kirk", for example, will match "Kirkwood" and "Kirkstein". The record numbers and keys of all matches are displayed; if more than one record is found, the user is prompted for a particular record number. Then the record may be modified on a field-by-field basis. Two special inputs are recognized: leaves the given field unchanged, while skips the rest of the record. Note: MODIFY can be used simply to examine a given record by entering as the first response. PRINT produces a printout of the mailing list to an arbitrary textfile, sorted according to the key field in effect at the time. The user may choose to print only a subset of the file, by entering one of three options: ALL prints everything in the file; ONLY prints only those records whose keyfields contain the user-specified target string; EXCEPT prints everything except those records whose keyfields contain the user-specified target strings. For example, specifying "ONLY" and the target string "CA", if the state keyfield is in effect, will list only those records whose state is California. Not all fields of the record need be printed; see the SET option. NOTE: Names may be entered last-name-first, to aid alphabetization, but they will be printed out first-name-first. Thus "Mundie, David" is printed out as "David Mundie". FILE closes the current address file, and opens a new one. NEWSORT is used to change the field used for sorting and accessing records. For example, if the fields are currently being sorted by name, the user may type N(ewsort, then Z(ip to sort them by zipcode. SET is used to set the print fields used by PRINT. The default is to print everything except the phone number. The new set of fields to be printed is specified by entering a string containing the appropriate letters; for example, entering 'np' will cause PRINT only to print out the name and the phone number. QUIT, obviously, is used to exit the program. -NOTE- No explicit provision is made for deleting records. The same effect, however, can be had by MODIFYing the records to contain a special field, such as @. PRINTing with an except '@' option will ignore deleted records; they may be reused by a MODIFY using '@' as the target. ======================================================================================== DOCUMENT :usus Folder:VOL08:mailer.text ======================================================================================== (*[B+, E=3, G=1, I=1, L=1, P=1, W=1-75] FORMATTER DIRECTIVES*) program mailer; const stringlength = 25; maxentries = 100; type shortstring = string[stringlength]; index = 0.. maxentries; entry = record name, street, city, phone: shortstring; state: string[2]; zipcode: string[8] end; field = (nam, str, cit, pho, sta, zip); fieldset = set of field; pointer = ^ node; node = record key: shortstring; number: index; left, right: pointer end; var topentry: index; keyfield: field; adds: file of entry; printfields: fieldset; heap: ^ integer; root: pointer; empty: string; modified: boolean; function upper(ch: char): char; begin if ch in ['a' .. 'z'] then upper := chr(ord(ch) - 32) else upper := ch end (*upper*); function f(ch: char): field; begin case ch of 'N': f := nam; 'S': f := str; 'C': f := cit; 'P': f := pho; 'T': f := sta; 'Z': f := zip end (*CASE*); end (*f*); procedure saferead(var thestring: string; len: integer); var s: string; begin readln(s); while length(s) > len do begin writeln('Max of ', len, ' characters; re-enter: '); write('|': len + 1, chr(141)); readln(s) end; thestring := s end (*saferead*); procedure initfield(var fld: field); var ch: char; begin repeat write('Sort by N(ame S(treet C(ity P(hone sT(ate Z(ip: '); read(ch); writeln; ch := upper(ch); until ch in ['N', 'S', 'C', 'P', 'T', 'Z']; fld := f(ch) end (*initfield*); procedure initset(var fs: fieldset); var s: string; i: integer; begin fs := []; repeat writeln('Enter a string with desired field codes;'); write('N(ame S(treet C(ity P(hone sT(ate Z(ip: '); readln(s); for i := 1 to length(s) do if upper(s[i]) in ['N', 'S', 'C', 'P', 'T', 'Z'] then fs := fs + [f(upper(s[i]))] until fs <> [] end (*initset*); procedure initfile; var i: index; addsname: string; begin close(adds, lock); write('Name of address file: '); readln(addsname); (*$I-*) reset(adds, addsname); (*$I+*) if ioresult > 0 then begin rewrite(adds, addsname); writeln('Creating new file ', addsname, '.'); for i := 0 to maxentries do begin seek(adds, i); adds ^.name := empty; put(adds) end end (*if*) end (*initfile*); procedure key(keyfield: field; ent: entry; n: index); var s: shortstring; procedure enter(var p: pointer); begin if p = nil then begin new(p); p ^.key := s; p ^.number := n; writeln(p ^.number, ' ', p ^.key); p ^.left := nil; p ^.right := nil end else if s < p ^.key then enter(p ^.left) else enter(p ^.right) end (*enter*); begin (*key*) case keyfield of nam: s := ent.name; str: s := ent.street; cit: s := ent.city; sta: s := ent.state; zip: s := ent.zipcode; pho: s := ent.phone end (*case*); enter(root) end (*key*); procedure initkeys; begin (*initkeys*) release(heap); writeln; writeln('Sorting...'); writeln; root := nil; topentry := 0; reset(adds); seek(adds, 0); get(adds); while adds ^.name <> empty do begin key(keyfield, adds ^, topentry); topentry := topentry + 1; seek(adds, topentry); get(adds); end (*while*); writeln; modified := false end (*initkeys*); procedure addarecord; begin if topentry >= maxentries then begin writeln('File full.'); exit(addarecord) end; seek(adds, topentry); with adds ^ do begin write('Name: '); saferead(name, stringlength); write('Street: '); saferead(street, stringlength); write('City: '); saferead(city, stringlength); write('State: '); saferead(state, 2); write('Zipcode: '); saferead(zipcode, 8); write('Phone: '); saferead(phone, stringlength); end; key(keyfield, adds ^, topentry); put(adds); topentry := topentry + 1 end (*addarecord*); procedure printrecords; var searchmode: (all, only, except); ch: char; target, foutname: string; fout: text; function wanted(s: string): boolean; begin case searchmode of all: wanted := true; only: wanted := pos(target, s) <> 0; except: wanted := pos(target, s) = 0 end (*CASE*) end (*wanted*); procedure printone(number: index); procedure print(s: string); var i: integer; lastname: string; begin i := pos(',', s); if i in [0, length(s)] then writeln(fout, s) else begin lastname := copy(s, 1, i - 1); delete(s, 1, i); while (s[1] = ' ') and (length(s) > 1) do delete(s, 1, 1); writeln(fout, s, ' ', lastname) end end (*print*); begin (*printone*) seek(adds, number); get(adds); with adds ^ do begin if nam in printfields then print(name); if str in printfields then writeln(fout, street, ' '); if cit in printfields then write(fout, city, ' '); if sta in printfields then write(fout, state, ' '); if zip in printfields then write(fout, zipcode); if printfields * [cit, sta, zip] <> [] then writeln; if pho in printfields then writeln(phone); writeln end end (*printone*); procedure postorder(p: pointer); begin if p <> nil then begin postorder(p ^.left); if wanted(p ^.key) then printone(p ^.number); postorder(p ^.right) end; end (*postorder*); begin (*printrecords*) write('Output file: '); readln(foutname); rewrite(fout, foutname); repeat write('A(ll O(nly E(xcept: '); read(ch); writeln; ch := upper(ch); until ch in ['A', 'O', 'E']; case ch of 'A': searchmode := all; 'O': searchmode := only; 'E': searchmode := except end (*CASE*); if ch in ['O', 'E'] then begin write('Target: '); readln(target) end; writeln; if modified then initkeys; postorder(root); close(fout, lock) end (*printrecords*); procedure modifyarecord; var entrynum, count: index; target: string; procedure preorder(p: pointer); begin if p <> nil then begin if pos(target, p ^.key) <> 0 then begin count := count + 1; writeln(p ^.number, ' ', p ^.key); entrynum := p ^.number end; preorder(p ^.left); preorder(p ^.right) end end (*preorder*); procedure change(entrynum: index); const esc = 24; var s: shortstring; buf: entry; procedure exitmod; begin adds ^ := buf; seek(adds, entrynum); put(adds); exit(modifyarecord) end (*exitmod*); procedure modone(prompt: string; f: field; var old: string; len: integer) ; var s: string; ch: char; begin write('New ', prompt, ': '); get(input); if input ^ = chr(esc) then begin read(ch); writeln; exitmod end; saferead(s, len); if s = '' then exit(modone) else if s[1] = chr(esc) then exitmod else begin old := s; if f = keyfield then modified := true end end (*modone*); begin (*change*) seek(adds, entrynum); get(adds); buf := adds ^; with buf do begin writeln('Name: ', name); writeln('Street: ', street); writeln('City state zip: ', city, ' ', state, ' ', zipcode); writeln('Phone: ', phone); writeln; modone('name', nam, name, stringlength); modone('street', str, street, stringlength); modone('city', cit, city, stringlength); modone('state', sta, state, 2); modone('zip', zip, zipcode, 8); modone('phone', pho, phone, stringlength); exitmod end end (*change*); begin (*modifyarecord*) count := 0; write('Target: '); readln(target); preorder(root); if count = 0 then writeln('Not in file.') else begin if count > 1 then begin write('Specify record number: '); readln(entrynum) end; change(entrynum) end end (*modifyarecord*); procedure doacommand; var com: char; begin repeat write('A(dd M(odify F(ilechange P(rint N(ewsort S(et Q(uit: '); read(com); writeln; com := upper(com); case com of 'A': addarecord; 'M': modifyarecord; 'N': begin initfield(keyfield); initkeys end; 'P': printrecords; 'F': begin initfiles; initkeys end; 'Q': begin close(adds, lock); exit(mailer) end; 'S': initset(printfields); end (*CASE*) until false end (*doacommand*); begin (*mailer*) mark(heap); empty := ' '; empty[1] := chr(0); initfile; initfield(keyfield); initkeys; printfields := [nam .. cit, sta, zip]; repeat doacommand until false end (*mailer*). ======================================================================================== DOCUMENT :usus Folder:VOL08:modemv2.2.text ======================================================================================== PROGRAM MODEM; {Program Modem magically turns your expensive computer into a lowly dumb terminal. I believe that this program may be processor dependant on a PDP-11 as it uses the UNITBUSY function. The users manual for the version II.0 system says that UNITBUSY is only implemented on DEC computers. Since UNITBUSY is the heart of this nearly trivial program, if you havn't got it then you're simply out of luck (SOL). Modem has been tested up to 300 baud with an LSI-11 and it works fine. Timing tests indicate that it might work at over 1200 baud but it has not been tested there. When running with no work to do it loops at over 1300 loops/second. It loops at 770 loops/second when the modem port is receiving data at 30 cps. Since the user cannot type at more than 10 cps, the program would probably loop fast enough to handle 1200 baud (120 cps). To use it you need a modem connected to the REMIN: and REMOUT: ports. These are addresses of 177520 thru 177526 and a vector of 120 for typical PDP- 11. The program enters a loop and trys to read a character from either the the KEYBOARD: or REMIN:. If one is not found it checks the other port. When one is found it checks for special characters and usually sends it to REMOUT: or CONSOLE: respectivly. Control-C from the console halts the program. Line feeds from the modem are ignored as the system inserts one. Nulls cannot be sent out and are ignored if recieved. Modem will not generate any spurious characters when started or stopped. Breaks cannot be generated as they cannot be represented as a character. Half duplex could be handled by doing the UNITREAD and UNITBUSY from port 1 instead of port 2. Written 14-Nov-80 by George Schreyer} VAR DATA_IN,DATA_OUT :PACKED ARRAY[0..1] OF CHAR; CONTINUE : BOOLEAN; BEGIN CONTINUE:=TRUE; DATA_OUT[0]:=CHR(0); DATA_IN[0]:=CHR(0); WRITELN; WRITELN('modem version 2.2 30-Apr-81 Type CNTL-C when finished'); UNITCLEAR(2); UNITCLEAR(7); WHILE CONTINUE DO BEGIN IF NOT UNITBUSY(2) THEN BEGIN UNITREAD(2,DATA_OUT[0],1,,1); IF DATA_OUT[0] = CHR(3) THEN BEGIN CONTINUE:=FALSE; END ELSE BEGIN IF DATA_OUT[0] <> CHR(0) THEN UNITWRITE(8,DATA_OUT[0],1,,1); END; END; IF NOT UNITBUSY(7) THEN BEGIN UNITREAD(7,DATA_IN[0],1,,1); IF (DATA_IN[0]<>CHR(10)) AND (DATA_IN[0]<>CHR(0)) THEN UNITWRITE(1,DATA_IN[0],1,,1); END; END; END. ======================================================================================== DOCUMENT :usus Folder:VOL08:muldiv.z80.text ======================================================================================== ; muldiv.text ; ; This procedure is specifically designed to meet the needs of the ; UCSD Pascal Seek Algorithm by calculating the block and byte offset ; given the record number, and the record size. ; ; Copyright (c) 1980, by Stuart Lynne. All rights reserved. ; ; ;Procedure MULDIV - BLOCK:=(RECNUM*RECSIZ) DIV 512; ; - BYTE :=(RECNUM*RECSIZ) MOD 512; ;PROCEDURE MULDIV(VAR BYTE:INTEGER;VAR BLOCK:INTEGER;REC,SIZ:INTEGER); .PROC MULDIV,4 POP IX ;Save return POP HL POP DE ;Get Size and record # CALL MUL ;HLDE:= HL*DE LD A,L ;Assume 24 bit max result POP HL ;HL-> destination for block # PUSH DE ;Save remainder for byte SRL A ; RR D ;LD div 2 = Block # LD (HL),D INC HL LD (HL),A POP DE ;Get remainder LD A,1 AND D ;Mask out lower 9 bits (512) POP HL ;HL=> destination of BYTE LD (HL),E INC HL LD (HL),A JP (IX) ;Return ;Multiply routine ;unsigned HLDE = HL*DE MUL: PUSH AF PUSH BC LD A,17. LD C,L LD B,H LD HL,0 MUL1 OR A ;Clear carry RR H RR L RR D RR E JP NC,MUL2 ADD HL,BC MUL2 DEC A JP NZ,MUL1 POP BC POP AF RET .END ======================================================================================== DOCUMENT :usus Folder:VOL08:perusev4.6.text ======================================================================================== (*$I-*) (*$R-*) program perusepage; USES (*$U SCREENUNIT.CODE*)SCREENUNIT, (*$U FILEUNIT.CODE*)FILEUNIT; {*****************} CONST VERSION = 'peruse version 4.6 13-Jul-81'; MAXBYTES = 18431; (* G.W. Schreyer Peruse is an update of Monaco's original version in Volume 2A of the USUS library, however it is so heavily modified that only the 'program perusepage', 'begin' and 'end.' of his original code remains. This version incorporates several units to handle the error free opening of the source file. The units may be over-kill for this little program, but they sure are easy to use. See FILEUNIT.DOC for a discription of the units. The program runs about ten to fifteen times faster than the original. It reads up the whole file in one chunk and uses SCAN to count out 22 lines. It then dumps the whole 22 lines to the screen with one unitwrite. I believe this is the way the editor does its page function as peruse goes just as fast as the editor. Also like the editor, there is a size limit to the file which can be perused. I set it at 36 blocks (with the header page) as this is the largest file which the editor on my system can read. If you can use more (and have the memory avaiable!) then change the blockread statement and the declaration for the packed array accordingly. The read function uses an incredibly large amount of time to execute, so invoking that function to read characters one at a time is very costly. Writes go much quicker, but still they waste a fair amount of time so the unitwrite significantly speeds things along. Of course, these 'features' are non- standard so that this program can only be used in the UCSD system. This version will back up in the file by 44 lines then it will display 22 lines if you should desire it. There is a perversity in the DLE expansion when using unitwrites in my system. I don't know if this is a general problem, or just specific to my particular computer (SCREENTEST says that there is a problem with the DLE expansion). Lines which have leading blanks and are spaced with the DLE expansion are spaced one too few spaces. If some lines use the DLE expansion and some lines are padded with leading blanks, the columns won't line up. I believe that this is problem with the operating system because the same thing happens when do a T)ransfer to the console with the F)iler. If you want to you may convert all of the lines padded with leading blanks to the DLE expansion. Go into the editor and enter A)djust mode. Then step thru the file with the down arrow (repeat factors work). This will convert each line without moving it. It may also make the file smaller, so if you are running out if room, you can conserve a little space this way. Peruse will also open a device and read 36 blocks starting at any block you choose. This allows you to look through a disk for a lost text file and see it in a readable format faster than PATCH can do it. Use this feature in conjunction with RECOVER and to see if a unused region on the disk is the file that you want. But be carful, if you read in a code file, you will see garbage. Some of that garbage may put your terminal into some weird mode and anything may happen. It is best to reset your terminal after such an occurance or the operating system may not work right.*) VAR i,K,BLOCK :INTEGER; SOURCE :FILE; CHARARRAY :PACKED ARRAY [0..MAXBYTES] OF CHAR; FILENAME :STRING; MAXBLOCKS :INTEGER; CH :CHAR; ARRAYSIZE :INTEGER; INDEX :INTEGER; ANCHOR :INTEGER; POSITION : INTEGER; BLOCKS : INTEGER; NEWFILE :BOOLEAN; PROCEDURE SKIP_HEADER; BEGIN IF POS('.TEXT',FILENAME) <> 0 THEN BEGIN BLOCKS:=34; BLOCK:=2 END ELSE BEGIN BLOCKS:=36; BLOCK:=0; END; END; PROCEDURE BACKUP; BEGIN IF INDEX > 1 THEN INDEX:=INDEX-2; FOR I:=1 TO 44 DO BEGIN POSITION:=SCAN(-1*INDEX,=CHR(13),CHARARRAY[INDEX]); INDEX:=INDEX + POSITION-1; IF INDEX < 0 THEN INDEX := 0; END; IF INDEX > 0 THEN INDEX:=INDEX+1; END; begin GETCRTINFO; FILENAME:=''; GOTOXY(0,0); FILLCHAR(CHARARRAY,SIZEOF(CHARARRAY),CHR(0)); CRT(ERASEOS); WRITELN(' ',VERSION); VER_SCREENUNIT; VER_FILEUNIT; REPEAT I := 0; BLOCK:=0; OPNDSKREAD(SOURCE,'enter file or volume to be perused - -> ',FILENAME,0,10); GOTOXY(0,0); CRT(ERASEOS); IF FILENAME='' THEN EXIT(PROGRAM); NEWFILE:=FALSE; IF (POS(':',FILENAME) = LENGTH(FILENAME)) OR (FILENAME = '*') THEN BEGIN MAXBLOCKS:=SIZEOF(CHARARRAY) DIV 512; GOTOXY(10,12); WRITE('read how many blocks (',MAXBLOCKS,' max) ? '); READLN(BLOCKS); GOTOXY(0,12); CRT(ERASEOL); IF BLOCKS <> 0 THEN BEGIN IF (BLOCKS < 0 ) OR (BLOCKS > MAXBLOCKS) THEN BLOCKS := MAXBLOCKS; GOTOXY(10,12); WRITE('read ',BLOCKS,' blocks starting at block ? '); READLN(BLOCK); IF BLOCK < 0 THEN BEGIN BLOCKS:=0; BLOCK:=0; END; END ELSE BLOCKS :=0; GOTOXY(0,0); CRT(ERASEOS); END ELSE SKIP_HEADER; WRITELN; K:=BLOCKREAD(SOURCE,CHARARRAY,BLOCKS,BLOCK); CLOSE(SOURCE); ARRAYSIZE:=512*K; INDEX:=0; REPEAT ANCHOR:=INDEX; FOR I:=1 TO 22 DO BEGIN POSITION:=SCAN(ARRAYSIZE-INDEX,=CHR(13),CHARARRAY[INDEX]); INDEX:=POSITION+INDEX+1; END; UNITWRITE(1,CHARARRAY[ANCHOR],INDEX-ANCHOR,,1); GOTOXY(0,0); CRT(ERASEOL); WRITE('M)ore, B)ack-up, N)ew file or Q)uit ? '); READ(KEYBOARD,CH); GOTOXY(0,0); CRT(ERASEOS); WRITELN; CASE CH OF 'Q','q' : EXIT(PROGRAM); 'B','b' : BACKUP; 'M','m' : ; 'N','n' : NEWFILE:=TRUE; END; UNTIL ((INDEX >= ARRAYSIZE)) OR NEWFILE; UNTIL NOT NEWFILE; end. ======================================================================================== DOCUMENT :usus Folder:VOL08:recover.text ======================================================================================== PROGRAM RECOVER; USES (*$U screenunit.code*)SCREENUNIT, (*$U fileunit.code*)FILEUNIT; {by George Schreyer} VAR NUM,I,P,J,K,X,Y : INTEGER; NUM_BLOCKS : INTEGER; DISK : FILE; VOLNAME :STRING; DATA : PACKED ARRAY[0..511] OF CHAR; PR : TEXT; procedure instructions; begin writeln; writeln('Recover scans all the blocks on the specified volume for'); writeln('programs. It looks for the reserved word ''PROGRAM'' in the'); writeln('first 30 bytes of each block and prints the program name and'); writeln('number of the start of where the header block should be if it'); writeln('finds the reserved word. As it is, it won''t find units but'); writeln('that is easily changed if necessary.'); writeln('Use PERUSE or PATCH to examine the data at each potential'); writeln('location to find the most recent version'); end; BEGIN GETCRTINFO; GOTOXY(0,0); CRT(ERASEOS); WRITELN(' recover version 1.0 13-Jun-81'); ver_screenunit; ver_fileunit; instructions; REWRITE(PR,'PRINTER:'); OPNDSKREAD(DISK,'Volume to scan for programs ? ',VOLNAME,0,16); IF VOLNAME='' THEN EXIT(PROGRAM); PAGE(PR); gotoxy(0,0); crt(eraseos); writeln('searching ... '); i:=0; while not eof(disk) do BEGIN K:=BLOCKREAD(DISK,DATA,1,I); P:=SCAN(30,='P',DATA[0]); IF P < 31 THEN IF (DATA[P+1] = 'R') AND (DATA[P+2] = 'O') AND (DATA[P+3] = 'G') AND (DATA[P+4] = 'R') AND (DATA[P+5] = 'A') AND (DATA[P+6] = 'M') THEN BEGIN X:=1; WRITE('Program '); WRITE(PR,'Program '); REPEAT IF DATA[P+6+X] <> ';' THEN begin WRITE(PR,DATA[P+6+X]); WRITE(DATA[P+6+X]); end; X:=X+1; UNTIL (DATA[P+6+X] = ';') OR (X > 20); WRITELN(PR,' exists at block ',I-2); WRITELN(' exists at block ',I-2); END; i:=i+1; END; END. ======================================================================================== DOCUMENT :usus Folder:VOL08:rem.term.text ======================================================================================== PROGRAM TERMINAL ; {$S+} {xL PRINTER: } (* COPYRIGHT 1980, 1981 BY ROBERT W. PETERSON. ALL RIGHTS RESERVED. THIS PROGRAM TALKS TO THE REMIN: AND REMOUT: AND HAS THE FOLLOWING CAPABILITIES: 1. DUMB TERMINAL EMULATION. 2. LOGGING TO A FILE THE TEXT RECEIVED. 3. TRANSMITTING DOWN THE LINE A FILE. 4. ECHOING OR NOT ECHOING THE CHARACTERS TYPED/TRANSMITTED. 5. SELECTING THE NAME OF THE LOG FILE DYNAMICALLY. 6. TRANSMITTING A PREDEFINED LOGON SEQUENCE TO REMOUT: IN ADDITION, THIS PROGRAM IS OPTIONALLY VIDEOTEXT COMPATIBLE. *) USES {$U TI.UNIT.CODE } REMUNIT ; CONST ARROW_DOWN = 139 ; ARROW_LEFT = 8 ; ARROW_RIGHT = 138 ; ARROW_UP = 137 ; BACKSPACE = 8 ; CLEAR_EOLN = 141 ; CLEAR_EOS = 152 ; CLEAR_SCREEN = 12 ; CR = 13 ; ESCAPE = 27 ; FORMFEED = 12 ; HOME_CURSOR = 130 ; KB = 2 ; LINEFEED = 10 ; LOGLIMIT = 20000 ; PRINTER = 6 ; REMIN = 7 ; REMOUT = 8 ; RUBOUT = 127 ; SCREENDEPTH = 24 ; VERSION = ' VERSION 1.02 9 June 81 USUS remote unit/911 CRT'; VAR C : CHAR ; DONE : BOOLEAN ; ECHO : BOOLEAN ; FILTERCONTROL : BOOLEAN ; FILTERSET : SET OF CHAR ; LOGARRAY : PACKED ARRAY [ 0 .. LOGLIMIT ] OF CHAR ; LOGFILE : TEXT ; LOGFILENAME : STRING[ 30 ] ; LOGINDEX : 0 .. LOGLIMIT ; LOGON1 : STRING ; LOGON2 : STRING ; LOGOPEN : BOOLEAN ; LOGPROMPT : CHAR ; LOGTEXT : BOOLEAN ; NEARLY : 0 .. LOGLIMIT ; VIDEOTEXT : BOOLEAN ; PROCEDURE LOGIT( C : CHAR ) ; BEGIN IF ORD( C ) IN [BACKSPACE, RUBOUT] THEN IF LOGINDEX > 0 THEN LOGINDEX := LOGINDEX - 1 ELSE { NULL STATEMENT } ELSE LOGARRAY[ LOGINDEX ] := C ; IF LOGINDEX = NEARLY THEN BEGIN WRITELN ; WRITELN( ' ***> CURRENTLY AT 80% OF LOG SPACE <***' ) ; WRITELN ; END ; IF LOGINDEX >= LOGLIMIT THEN BEGIN WRITELN ; WRITELN( ' >* LOGLIMIT EXCEEDED *< ', CHR(7), CHR(7) ) ; WRITELN ; LOGINDEX := 0 ; END ELSE LOGINDEX := LOGINDEX + 1 ; END ; PROCEDURE DISPLAY( C : CHAR ) ; VAR ORD_C : INTEGER ; PROCEDURE V_GOTOXY ; VAR C : CHAR ; X : INTEGER ; Y : INTEGER ; BEGIN REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_KBSTAT THEN BEGIN C := CR_GETKB ; EXIT( DISPLAY ) ; END ; C := CR_GETREM ; Y := ORD( C ) - 31 ; REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_KBSTAT THEN BEGIN C := CR_GETKB ; EXIT( DISPLAY ) ; END ; C := CR_GETREM ; X := ORD( C ) - 31 ; GOTOXY( X, Y ) ; END ; { V_GOTOXY } BEGIN IF VIDEOTEXT AND (C = CHR( ESCAPE ) ) THEN BEGIN REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_KBSTAT THEN BEGIN C := CR_GETKB ; EXIT( DISPLAY ) ; END ; C := CR_GETREM ; ORD_C := 0 ; CASE C OF 'm', 'l' : ; { Wide character/Normal character } 'A' : ORD_C := ARROW_UP ; { Up arrow } 'B' : ORD_C := ARROW_DOWN ; { Down arrow } 'C' : ORD_C := ARROW_RIGHT ; { Right arrow } 'D' : ORD_C := ARROW_LEFT ; { Left arrow } 'H' : ORD_C := HOME_CURSOR ; { Home } 'K' : ORD_C := CLEAR_EOLN ; { Clear to end of line } 'J' : ORD_C := CLEAR_EOS ; { Clear to end of screen } 'j' : ORD_C := CLEAR_SCREEN ; { Clear screen } 'Y' : V_GOTOXY ; { VIDEOTEXT's GOTOXY } END ; { CASE ORD_C OF } IF ORD_C <> 0 THEN WRITE( CHR( ORD_C ) ) ; END ELSE BEGIN ORD_C := ORD( C ) ; IF ORD_C > RUBOUT THEN C := CHR( ORD_C - (RUBOUT + 1) ) ; IF FILTERCONTROL THEN IF C IN FILTERSET THEN C := CHR( 0 ) ; IF C <> CHR( LINEFEED ) THEN WRITE( C ) ; IF LOGTEXT THEN LOGIT( C ) ; END ; END ; FUNCTION QUESTION( PROMPT : STRING ) : BOOLEAN ; VAR C : CHAR ; BEGIN WRITELN ; WRITELN ; WRITE ( PROMPT, '(Y or N)?' ) ; REPEAT READ( KEYBOARD, C ) ; UNTIL C IN [ 'y', 'n', 'Y', 'N' ] ; WRITE( C ) ; QUESTION := C IN ['y', 'Y'] ; END ; PROCEDURE OPTIONS ; BEGIN FILTERCONTROL := QUESTION( 'DO YOU WISH TO FILTER CONTROL CHARACTERS' ) ; LOGTEXT := QUESTION( 'DO YOU WISH TO LOG THE TEXT' ) ; ECHO := QUESTION( 'DO YOU WISH TO ECHO THE KEYBOARD' ) ; VIDEOTEXT := QUESTION( 'DO YOU WISH TO RESPOND TO VIDEOTEXT CONTROL CODES' ) ; WRITELN ; WRITELN ; WRITELN ; END ; PROCEDURE INITIALIZE ; VAR AUTOLOGON : BOOLEAN ; B : BOOLEAN ; C : CHAR ; HAVEDIAL : BOOLEAN ; HAVEREM : BOOLEAN ; RESULT : CR_BAUD_RESULT ; BEGIN WRITELN ; WRITELN( 'TERMINAL PROGRAM.', VERSION ) ; WRITELN( 'COPYRIGHT 1980, 1981 BY ROBERT W. PETERSON' ) ; WRITELN( 'BYTES AVAILABLE = ', MEMAVAIL * 2 ) ; WRITELN( 'LOG BUFFER = ', LOGLIMIT ) ; DONE := FALSE ; FILTERSET := [ CHR( 0 ) .. CHR( BACKSPACE-1 ), CHR( BACKSPACE+1 ) .. CHR( CR-1 ), CHR( CR+1 ) .. CHR( 31 ), CHR( RUBOUT ) ] ; NEARLY := (LOGLIMIT DIV 100) * 80 ; WRITELN ; IF QUESTION('Is a suitable attention character') THEN C := CHR( 5 ) ELSE REPEAT B := FALSE ; REPEAT WRITE( 'What character will be used? ' ) ; WHILE NOT CR_KBSTAT DO ; C := CR_GETKB ; WRITELN( '<', ORD( C ), '>' ) ; IF C IN [' '..'~'] THEN WRITELN( 'You cannot use a displayable character') ELSE B := QUESTION( 'Is this correct' ) ; UNTIL B ; UNTIL NOT (C IN [' '..'~']) ; WRITELN ; LOGON1 := '' ; LOGON2 := LOGON1 ; CR_COMMINIT( CR_ORIG, C, HAVEREM, HAVEDIAL ) ; IF NOT HAVEREM THEN BEGIN WRITELN( ' REMOTE not supported in current environment.' ) ; WRITELN( ' Program is terminating.' ) ; EXIT( TERMINAL ) ; END ; OPTIONS ; CR_SETCOMMUNICATIONS( TRUE, TRUE, 300, 7, 1, CR_ORIG, '990/5', RESULT ) ; WRITELN ; WRITELN( 'Proceed when connection has been made.' ) ; CR_ANSWER ; WRITELN ; WRITELN ; END ; PROCEDURE CLOSELOG ; VAR RESULT : INTEGER ; BEGIN IF LOGOPEN THEN BEGIN CLOSE( LOGFILE, LOCK ) ; RESULT := IORESULT ; WRITE( LOGFILENAME ) ; IF RESULT = 0 THEN WRITELN(' HAS BEEN CLOSED.' ) ELSE WRITELN(' FAILED TO CLOSE. IORESULT = ', RESULT ) ; END ; END ; PROCEDURE SETLOGFILENAME ; VAR RESULT : INTEGER ; BEGIN WRITELN ; CLOSELOG ; (*$I-*) REPEAT WRITELN ; WRITE ( 'WHAT IS THE NEW LOG FILENAME? ') ; READLN ( LOGFILENAME ) ; IF (LOGFILENAME = 'PRINTER:') OR (LOGFILENAME = 'CONSOLE:') OR (LOGFILENAME = 'printer:') OR (LOGFILENAME = 'console:') THEN RESULT := 1 ELSE BEGIN RESET ( LOGFILE, LOGFILENAME ) ; RESULT := IORESULT ; END ; IF RESULT = 0 THEN BEGIN CLOSE( LOGFILE, LOCK ) ; RESULT := 1 ; WRITELN ; WRITELN( LOGFILENAME, ' EXISTS!' ) ; END ELSE IF LENGTH( LOGFILENAME ) > 0 THEN BEGIN WRITE( 'OPEN OF ', LOGFILENAME, ' ' ) ; REWRITE( LOGFILE, LOGFILENAME ) ; RESULT := IORESULT ; LOGOPEN := RESULT = 0 ; IF NOT LOGOPEN THEN WRITELN( ' FAILED. REWRITE RESULT = ', RESULT ) ELSE WRITELN( ' WAS SUCCESSFUL.' ) ; END ; UNTIL LOGOPEN OR (LENGTH( LOGFILENAME ) = 0 ) ; WRITELN ; (*$I+*) END ; PROCEDURE CLEARLOG ; BEGIN IF QUESTION( 'CLEAR LOG: ARE YOU SURE' ) THEN LOGINDEX := 0 END ; PROCEDURE SAVELOG ; CONST BLANK = ' ' ; RETURNCHAR = 13 ; VAR C : CHAR ; I : 0 .. LOGLIMIT ; LINECOUNT : INTEGER ; LINESPERPAGE : INTEGER ; RESULT : INTEGER ; TILDE : CHAR ; TRASH : CHAR ; UNITFILE : BOOLEAN ; WRITTEN : BOOLEAN ; BEGIN WRITELN ; TILDE := '~' ; IF NOT LOGOPEN THEN BEGIN WRITELN( 'THE LOG FILE IS NOT OPEN!' ) ; WRITELN ; EXIT( SAVELOG ) ; END ; WRITELN( 'THERE ARE ', LOGINDEX, ' CHARACTERS IN THE LOG.'); UNITFILE := (LOGFILENAME = 'CONSOLE:') OR (LOGFILENAME = 'PRINTER:') OR (LOGFILENAME = 'console:') OR (LOGFILENAME = 'printer:') ; IF UNITFILE THEN BEGIN IF (LOGFILENAME = 'PRINTER:') OR (LOGFILENAME = 'printer:') THEN LINESPERPAGE := 32767 ELSE LINESPERPAGE := SCREENDEPTH - 2 ; PAGE( LOGFILE ) ; WRITELN( 'WRITING LOG TO ', LOGFILENAME ) END ELSE BEGIN WRITELN( 'WRITING LOG (', LOGFILENAME, ').' ) ; WRITE ( ' ':11 ) ; END ; LINECOUNT := 0 ; FOR I := 0 TO LOGINDEX-1 DO BEGIN C := LOGARRAY[ I ] ; IF (C >= BLANK) AND (C <= TILDE) THEN BEGIN WRITTEN := TRUE ; WRITE( LOGFILE, C ) ; END ELSE IF C = CHR( RETURNCHAR ) THEN IF WRITTEN THEN IF UNITFILE THEN BEGIN WRITELN( LOGFILE ) ; IF LINECOUNT >= LINESPERPAGE THEN BEGIN WRITE( 'PRESS ANY KEY TO CONTINUE' ) ; REPEAT UNTIL CR_KBSTAT ; TRASH := CR_GETKB ; LINECOUNT := 0 ; PAGE( LOGFILE ) ; END ELSE LINECOUNT := LINECOUNT + 1 ; END ELSE BEGIN IF LINECOUNT >= 50 THEN BEGIN WRITELN ; WRITE( ' ':11 ) ; LINECOUNT := 1 ; END ELSE LINECOUNT := LINECOUNT + 1 ; WRITE( '.' ) ; WRITELN( LOGFILE ) ; END ; RESULT := IORESULT ; IF RESULT <> 0 THEN BEGIN WRITELN ; WRITELN( 'BAD RETURN IN SAVELOG: ', RESULT ) ; WRITELN( 'TERMINATING LOG SAVE' ) ; WRITELN ; EXIT( SAVELOG ) ; END ; END ; (* FOR *) WRITELN ; CLEARLOG ; (*$I+*) END ; PROCEDURE SENDLOGON ; VAR I : 0 .. LOGLIMIT ; BEGIN WRITELN ; WRITELN( 'TRANSMITTNG LOGON' ) ; FOR I := 1 TO LENGTH( LOGON1 ) DO BEGIN CR_PUTREM( LOGON1[ I ] ) ; REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_REMSTAT THEN DISPLAY( CR_GETREM ) ; END ; CR_PUTREM( CHR(13) ) ; (* CR *) REPEAT IF CR_REMSTAT THEN BEGIN C := CR_GETREM ; DISPLAY( C ) ; END ELSE C := CHR( 0 ) ; UNTIL (C = LOGPROMPT) OR CR_KBSTAT ; FOR I := 1 TO LENGTH( LOGON2 ) DO CR_PUTREM( LOGON2[ I ] ) ; CR_PUTREM( CHR(13) ) ; (* CR *) END ; PROCEDURE DUMPFILE ; CONST CR = 13 ; LF = 10 ; VAR I : INTEGER ; LINEFEED : BOOLEAN ; LOGSTATUS : BOOLEAN ; PACE : BOOLEAN ; READBUFFER : STRING ; RESULT : INTEGER ; WAIT_CHARACTER : CHAR ; WAIT_CR : BOOLEAN ; XMITFILE : TEXT ; XMITNAME : STRING ; PROCEDURE DUMPIT ; BEGIN WRITELN ; WRITELN( 'TRANSMITTING ', XMITNAME ) ; WRITELN( 'USE ^E TO ABORT TRANSMISSION' ) ; WHILE NOT EOF( XMITFILE ) DO BEGIN READLN( XMITFILE, READBUFFER ) ; FOR I := 1 TO LENGTH( READBUFFER ) DO BEGIN IF NOT CR_CARRIER THEN BEGIN WRITELN ; WRITELN( 'LOST CARRIER. TRANSMITTING ABORTED.' ) ; EXIT( DUMPIT ) ; END ; CR_PUTREM( READBUFFER[ I ] ) ; IF PACE THEN REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_REMSTAT THEN DISPLAY( CR_GETREM ) ; END ; CR_PUTREM( CHR( CR ) ) ; IF LINEFEED THEN CR_PUTREM( CHR( LF ) ) ; IF WAIT_CR THEN REPEAT IF CR_REMSTAT THEN BEGIN C := CR_GETREM ; DISPLAY( C ) ; END ELSE C := CHR( 0 ) ; UNTIL (C = WAIT_CHARACTER) OR CR_KBSTAT ; IF CR_KBSTAT THEN IF CR_GETKB = CR_ATTENCHAR THEN EXIT( DUMPIT ) ; END END ; BEGIN (*$I-*) LOGSTATUS := LOGTEXT ; WRITELN ; WRITELN( 'DUMP A FILE TO REMOUT:' ) ; WRITELN( 'To quit, enter an empty filename.' ) ; WRITELN ; LOGTEXT := FALSE ; { TURN OFF LOGGING } LINEFEED := QUESTION( 'TRANSMIT LINEFEED AFTER EACH CARRIAGE RETURN ' ) ; PACE := QUESTION( 'WAIT FOR EACH CHARACTER TO BE ECHOED ' ) ; WAIT_CR := QUESTION( 'WAIT FOR A RETURNED CHARACTER AFTER EACH LINE ' ) ; IF WAIT_CR THEN REPEAT WRITELN ; WRITE( 'ENTER THE CHARACTER TO WAIT FOR:' ) ; READ( KEYBOARD, WAIT_CHARACTER ) ; IF EOLN THEN WAIT_CHARACTER := CHR( CR ) ; IF WAIT_CHARACTER IN [' '..'~'] THEN WRITELN( WAIT_CHARACTER ) ELSE WRITELN( '<', ORD(WAIT_CHARACTER), '>' ) ; UNTIL QUESTION( 'IS THIS THE CORRECT CHARACTER ' ) ELSE WAIT_CHARACTER := CHR( 0 ) ; REPEAT WRITELN ; WRITE ( 'WHAT IS THE TRANSMIT FILENAME? ') ; READLN ( XMITNAME ) ; IF LENGTH( XMITNAME ) <> 0 THEN BEGIN RESET ( XMITFILE, CONCAT( XMITNAME, '.TEXT' ) ) ; RESULT := IORESULT ; IF RESULT = 0 THEN BEGIN DUMPIT ; WRITE( XMITNAME, ' COMPLETED.' ) ; END ELSE BEGIN RESET ( XMITFILE, XMITNAME ) ; RESULT := IORESULT ; IF RESULT = 0 THEN BEGIN DUMPIT ; WRITE( XMITNAME, ' COMPLETED.' ) ; END ELSE BEGIN WRITELN ; WRITELN( 'CANNOT FIND ', XMITNAME ) ; END ; END ; END ; UNTIL (LENGTH( XMITNAME ) = 0 ) ; (*$I+*) LOGTEXT := LOGSTATUS ; { Restore original logging status } END ; PROCEDURE MENU ; CONST OUTPUTLOGON = '5' ; QUIT = '6' ; RETURNTOTERMINAL = '8' ; VAR GOOD : BOOLEAN ; O : CHAR ; BEGIN REPEAT WRITELN ; WRITELN( 'TERMINAL PROGRAM. ', VERSION ) ; WRITELN( 'COPYRIGHT 1980, 1981 BY ROBERT W. PETERSON' ) ; IF LOGTEXT THEN WRITELN( 'TOTAL LOG SPACE = ', LOGLIMIT, '. SPACE USED = ', LOGINDEX, ' (', LOGINDEX DIV (LOGLIMIT DIV 100), '%)' ) ; WRITELN( '1. SET OPTIONS' ) ; WRITELN( '2. SELECT LOG FILENAME' ) ; WRITELN( '3. SAVE LOG' ) ; WRITELN( '4. RESET (CLEAR) LOG' ) ; WRITELN( '5. SEND LOGON STRING' ) ; WRITELN( '6. QUIT TERMINAL PROGRAM' ) ; WRITELN( '7. TRANSMIT FILE' ) ; WRITELN( '8. QUIT OPTIONS' ) ; WRITELN( '9. REINITIALIZE' ) ; WRITELN ; WRITE ( 'SELECT OPTION NUMBER:' ) ; READ ( O ) ; GOOD := O IN [ '1' .. '9' ] ; IF GOOD THEN CASE O OF '1' : OPTIONS ; '2' : SETLOGFILENAME ; '3' : SAVELOG ; '4' : CLEARLOG ; OUTPUTLOGON : SENDLOGON ; QUIT: DONE := TRUE ; '7' : DUMPFILE ; RETURNTOTERMINAL : ; '9' : INITIALIZE ; END ; UNTIL O IN [ OUTPUTLOGON, RETURNTOTERMINAL, QUIT, '7' ] ; WRITELN ; END ; BEGIN LOGINDEX := 0 ; LOGOPEN := FALSE ; INITIALIZE ; REPEAT IF CR_KBSTAT THEN BEGIN C := CR_GETKB ; IF C = CR_ATTENCHAR THEN BEGIN MENU ; IF NOT (CR_CARRIER OR DONE) THEN CR_ANSWER ; END ELSE BEGIN CR_PUTREM( C ) ; IF ECHO THEN DISPLAY( C ) ; END ; END ; IF NOT CR_CARRIER THEN BEGIN WRITELN ; WRITELN('LOST CARRIER'); WRITELN ; MENU ; IF NOT (CR_CARRIER OR DONE) THEN CR_ANSWER ; END ELSE IF CR_REMSTAT THEN DISPLAY( CR_GETREM ) ; UNTIL DONE ; IF LOGINDEX > 0 THEN BEGIN WRITELN ; WRITE ( 'You have ', LOGINDEX, ' characters in the log which have not' ); WRITELN( ' been written to disk.'); IF QUESTION( 'Do you wish to write the log ' ) THEN BEGIN IF NOT LOGOPEN THEN SETLOGFILENAME ; SAVELOG ; END ; END ; CLOSELOG ; CR_COMMQUIT ; END. ======================================================================================== DOCUMENT :usus Folder:VOL08:rem.unit.text ======================================================================================== program AUNIT ; { This is REMUNIT for a TI-990 } {xL printer: } {$S+} unit REMUNIT ; interface {============== Copyright Notice =============================================} {$c Copyright 1980, 1981 by Robert W. Peterson } {============== Copyright Notice =============================================} { This is a separate compilation unit intended to stand between application code and a communications line. Implementation of this unit follows the specifications and suggestions set out in the January 1981 draft of the USUS remote unit specification. This unit is designed to interface to the following model codes: DS1 DS2 990 990/4 990/5 990/10 990/12 This unit assumes the compiler understands and the BIOS (or SBIOS) implements UNITSTATUS in the standard manner. } type CR_DIALRESULT = ( CR_OFF_HOOK, CR_DIALERROR, CR_NOAUTODIAL ) ; CR_BAUD_RESULT = ( CR_BAD_PARAMETER, CR_BAD_RATE, CR_RATE_SET_OK, CR_SELECT_NOT_SUPPORTED ) ; CR_WHOAMI = ( CR_ORIG, CR_ANS ) ; CR_REM_PORT = packed record PART1 : integer ; PART2 : integer ; end ; { T_REM_PORT } var CR_ATTENCHAR : char ; CR_CURRENT_PORT : CR_REM_PORT ; { Initialization and termination. } procedure CR_COMMINIT( DIR : CR_WHOAMI ; ATTENTION_CHARACTER : char ; var REMOTE_EXISTS : boolean ; var DIALER_EXISTS : boolean ) ; procedure CR_COMMQUIT ; { Input status. } function CR_KBSTAT : boolean ; function CR_REMSTAT : boolean ; { Input/Output operations. } function CR_GETKB : char ; function CR_GETREM : char ; procedure CR_PUTREM( C : char ) ; { Control procedures. } procedure CR_ANSWER ; procedure CR_BREAK ; function CR_CARRIER : boolean ; function CR_CLEARTOSEND : boolean ; procedure CR_DELAY( TENTHS : integer ) ; procedure CR_DIAL( NUMBER : string ; WAITCHAR : char ; var RESULT : CR_DIALRESULT ) ; procedure CR_HOOK( ON_HOOK : boolean ) ; procedure CR_SETADDRESS( HIGHADDR : integer ; LOWADDR : integer ; VECTOR : integer ) ; procedure CR_SETCOMMUNICATIONS( PARITY : boolean ; EVEN : boolean ; RATE : integer ; CHARBITS : integer ; STOPBITS : integer ; DIR : CR_WHOAMI ; MODEL : string ; var RESULT : CR_BAUD_RESULT ) ; implementation const DEFAULT_RATE = 300 ; DEFAULT_MODE = TRUE ; { Default is with parity enabled. } DEFAULT_PARITY = TRUE ; { Default is even parity enabled. } DEFAULT_CHARBITS = 7 ; { Default to 7 data bits. } DEFAULT_STOPBITS = 2 ; { Default to 2 stop bits. } KB_UNIT = 2 ; REMIN_UNIT = 7 ; REMOUT_UNIT = 8 ; TIMER = 500 ; type T_CLOCK = record case boolean of { NOTE: TI uses binary representation for long integers. } true : ( ticks : integer[ 4 ] ) ; false : ( hitime : integer ; lotime : integer ) ; end ; { case } TRICK = packed record case integer of 1 : ( A : packed array[ 0..80 ] of char ) ; 2 : ( S : string[ 80 ] ) ; 3 : ( I : integer ; J : integer ) ; 4 : ( L : array [0 .. 39] of integer ) ; 5 : ( B : array [0 .. 39] of boolean ) ; 6 : ( C : packed record CHARL : char ; CHARR : char ; end ) ; end ; { P } var BAUD_SETTABLE : boolean ; CONTROL : integer ; CURRENT_BAUD : integer ; MODEL_ID : string ; OFF_HOOK : boolean ; { -------------------------------------------------------------------------- } { EXTERNAL PROCEDURES } { -------------------------------------------------------------------------- } procedure CLEARBIT( I : integer ) ; external ; procedure LOADCRU ( I : integer ; J : integer ) ; external ; procedure SETBASE ( I : integer ) ; external ; procedure SETBIT ( I : integer ) ; external ; { -------------------------------------------------------------------------- } { CONTROL PROCEDURES } { -------------------------------------------------------------------------- } procedure CR_ANSWER ; var WAITING : boolean ; begin WAITING := true ; while WAITING do begin WAITING := not CR_CARRIER ; if WAITING then if CR_KBSTAT then WAITING := CR_GETKB <> CR_ATTENCHAR ; end ; OFF_HOOK := not WAITING ; if not WAITING then begin unitclear( REMIN_UNIT ) ; unitclear( REMOUT_UNIT ) ; end ; end ; { CR_ANSWER } procedure CR_BREAK ; const BASE_5 = { 1740H } 5952 ; { This is the base address. } BREAK_5 = 17 ; { This is the bit number. } begin if (MODEL_ID = '990/5') or (MODEL_ID = 'DS2') then begin SETBASE ( BASE_5 ) ; SETBIT ( BREAK_5 ) ; CLEARBIT( BREAK_5 ) ; end ; end ; function CR_CARRIER{: boolean}; var P : TRICK ; begin unitstatus( REMIN_UNIT, P.L, 0 ) ; CR_CARRIER := P.B[1] ; OFF_HOOK := P.B[1] ; end ; { CR_CARRIER } function CR_CLEARTOSEND {: boolean } ; begin CR_CLEARTOSEND := CR_CARRIER ; end ; { CR_CLEARTOSEND } procedure CR_DELAY{ TENTHS : integer } ; { Purpose: delay 0.1 seconds for each tenth requested. } var clock : T_CLOCK ; I : integer ; target : integer[ 4 ] ; begin if TIMER <= 1 then exit( CR_DELAY ) ; I := TIMER ; time( CLOCK.HITIME, CLOCK.LOTIME ) ; TARGET := CLOCK.TICKS + 6 * TENTHS ; { 6 is 0.1 * 60 ticks/second } repeat I := I - 1 ; time( CLOCK.HITIME, CLOCK.LOTIME ) ; until (I = 0) or (CLOCK.TICKS >= TARGET) ; end ; { CR_DELAY } procedure CR_DIAL{ NUMBER : string ; var RESULT : CR_DIALRESULT } ; begin RESULT := CR_NOAUTODIAL ; end ; { DIAL } procedure CR_HOOK{ ON_HOOK : boolean } ; begin OFF_HOOK := not ON_HOOK ; end ; { CR_HOOK } { -------------------------------------------------------------------------- } { STATUS PROCEDURES } { -------------------------------------------------------------------------- } function CR_KBSTAT {: boolean} ; var P : TRICK ; begin unitstatus( KB_UNIT, P.S, 1 ) ; CR_KBSTAT := (P.I > 0) ; end ; { CR_KBSTAT } function CR_REMSTAT {: boolean} ; var P : TRICK ; begin unitstatus( REMIN_UNIT, P.S, 1 ) ; CR_REMSTAT := P.I > 0 ; end ; { CR_REMSTAT } { -------------------------------------------------------------------------- } { INPUT/OUTPUT OPERATIONS } { -------------------------------------------------------------------------- } procedure IOERR( UNIT_NUM, ERR : integer ) ; begin if ERR <> 0 then begin writeln ; writeln( 'UNIT = ', UNIT_NUM:1, ' IOERROR = ', ERR:4, ' ' ) ; writeln ; end ; end ; { IOERR } function CR_GETKB {: char} ; var ARAY : TRICK ; begin repeat until CR_KBSTAT ; unitread( KB_UNIT, ARAY.A, 1 ) ; CR_GETKB := ARAY.A[0] ; IOERR( KB_UNIT, ioresult ) ; end ; function CR_GETREM {: char} ; var P : TRICK ; begin (*----------------------- DELETED -------------------------------------- repeat until REMSTAT ; ----------------------------------------------------------------------*) unitread( REMIN_UNIT, P.A, 1, 0, CONTROL ) ; CR_GETREM := P.A[0] ; (*----------------------- DELETED -------------------------------------- IOERR( REMIN_UNIT, ioresult ) ; ----------------------------------------------------------------------*) end ; { CR_GETREM } procedure CR_PUTREM{ C : char } ; var P : TRICK ; begin if CR_CARRIER then begin P.A[0] := C ; unitwrite( REMOUT_UNIT, P.A, 1, 0, CONTROL ) ; IOERR( REMOUT_UNIT, ioresult ) ; end ; end ; { CR_PUTREM } { -------------------------------------------------------------------------- } { INITIALIZATION/TERMINATION } { -------------------------------------------------------------------------- } procedure CR_SETADDRESS{ HIGHADDR : integer ; LOWADDR : integer ; VECTOR : integer } ; begin with CR_CURRENT_PORT do begin PART1 := HIGHADDR ; PART2 := LOWADDR ; end ; end ; { CR_SETADDRESS } procedure CR_SETCOMMUNICATIONS{ PARITY : boolean ; EVEN : boolean ; RATE : integer ; CHARBITS : integer ; STOPBITS : integer ; DIR : CR_WHOAMI ; MODEL : string ; var RESULT : CR_BAUD_RESULT } ; procedure SETDS1 ; const CRUBASE = 0 ; { Plug P6; P7 = 352 } LOADRG = 8 ; var BAUD_WORD : INTEGER ; begin MODEL_ID := MODEL ; if PARITY then if EVEN then CONTROL := 16396 else begin RESULT := CR_BAD_PARAMETER ; exit( SETDS1 ) ; end else CONTROL := 12 ; SETBASE(CRUBASE); if RATE = 9600 then BAUD_WORD := 2048 else if RATE = 4800 then BAUD_WORD := 2304 else if RATE = 2400 then BAUD_WORD := 2560 else if RATE = 1200 then BAUD_WORD := 2816 else if RATE = 600 then BAUD_WORD := 3072 else if RATE = 300 then BAUD_WORD := 3328 else if RATE = 150 then BAUD_WORD := 7168 else if RATE = 110 then BAUD_WORD := -31232 else if RATE = 75 then BAUD_WORD := 3840 else begin RESULT := CR_BAD_RATE ; exit( SETDS1 ) ; end ; SETBIT(LOADRG); LOADCRU(BAUD_WORD,8); CLEARBIT(LOADRG); RESULT := CR_RATE_SET_OK ; BAUD_SETTABLE := true ; end ; { SET1 } procedure SET990_5 ;{ Set the 990/5's second RS-232 port's baud rate. } const BASE = { >1740 } 5952 ; BAUD_BIT_COUNT = 12 ; B110 = { >0638 } 1592 ; B300 = { >04D0 } 1232 ; B1200 = { >01A1 } 417 ; B2400 = { >00D0 } 208 ; B4800 = { >0068 } 104 ; B9600 = { >0034 } 52 ; B19200 = { >001A } 26 ; MODE_BIT_COUNT = 8 ; MODE_TRANSPARENT = { >4B00 } 19200 ;{ 2 stop bits, no parity, 4Mhz, 8 data bits } MODE_EVEN_PARITY = { >AA00 } -22016 ;{ 1 stop bit, even parity, 4Mhz, 7 data bits } MODE_ODD_PARITY = { >BA00 } -17920 ;{ 1 stop bit, odd parity, 4Mhz, 7 data bits } RESET_PORT = 31 ; TIMER_BIT = 13 ; var BAUD : integer ; begin MODEL_ID := MODEL ; RESULT := CR_RATE_SET_OK ; if RATE = 110 then BAUD := B110 else if RATE = 300 then BAUD := B300 else if RATE = 1200 then BAUD := B1200 else if RATE = 2400 then BAUD := B2400 else if RATE = 4800 then BAUD := B4800 else if RATE = 9600 then BAUD := B9600 else if RATE = 19200 then BAUD := B19200 else begin RESULT := CR_BAD_RATE ; exit( SET990_5 ) ; { Get out if not a valid speed. } end ; SETBASE( BASE ) ; { Set base address of second /5 port. } SETBIT ( RESET_PORT ) ; { Reset the port. } if PARITY then begin CONTROL := 12 ; LOADCRU( MODE_TRANSPARENT, MODE_BIT_COUNT ) ;{ Set for transparent mode. } end else if EVEN then begin CONTROL := 16396 ; LOADCRU( MODE_EVEN_PARITY, MODE_BIT_COUNT ) ;{ Set for even parity (IMS). } end else begin CONTROL := 12 ; LOADCRU( MODE_ODD_PARITY, MODE_BIT_COUNT ) ;{ Set for odd parity. } end ; CLEARBIT( TIMER_BIT ) ; { Turn off the timer. } LOADCRU( BAUD, BAUD_BIT_COUNT ) ;{ Set the baud rate. } SETBIT ( 16 ) ; { Misc. settings } SETBIT ( 18 ) ; CLEARBIT( 19 ) ; CLEARBIT( 20 ) ; CLEARBIT( 21 ) ; BAUD_SETTABLE := true ; end ; { SET5 } procedure SET990 ; begin if PARITY then if EVEN then CONTROL := 16396 else CONTROL := 12 else CONTROL := 12 ; RESULT := CR_RATE_SET_OK ; end ; { SET990 } begin MODEL_ID := '' ; BAUD_SETTABLE := false ; RESULT := CR_SELECT_NOT_SUPPORTED ; if MODEL = 'DS1' then SETDS1 else if (MODEL = 'DS2') OR (MODEL = '990/5') then SET990_5 else if length( MODEL )>2 then if (copy(MODEL,1,3) = '990') then SET990 else CONTROL := 12 ; end ; { CR_SETCOMMUNICATIONS } procedure NOT_IMPLEMENTED( UNIT_NUM : integer ; var NOT_THERE : boolean ) ; var RESULT : integer ; begin unitclear( UNIT_NUM ) ; RESULT := ioresult ; if RESULT <> 0 then begin writeln ; writeln ; if RESULT = 9 then begin writeln( 'Unit ', UNIT_NUM, ' not implemented!' ) ; end else begin writeln( 'Error in UNITCLEAR(', UNIT_NUM, ') : ', RESULT ) ; end ; NOT_THERE := true ; end else NOT_THERE := false ; end ; procedure CR_COMMINIT{ DIRECTION : CR_WHOAMI ; ATTENTION_CHARACTER : char ; var REMOTE_EXISTS : boolean ; var DIALER_EXISTS : boolean } ; var RESULT : CR_BAUD_RESULT ; UNIT_NOT_THERE : boolean ; begin { Set no auto-dial. } DIALER_EXISTS := false ; { Check that the required units are implemented. } REMOTE_EXISTS := true ; NOT_IMPLEMENTED( REMIN_UNIT, UNIT_NOT_THERE ) ; if UNIT_NOT_THERE then begin REMOTE_EXISTS := false ; exit( CR_COMMINIT ) ; end ; NOT_IMPLEMENTED( REMOUT_UNIT, UNIT_NOT_THERE ) ; if UNIT_NOT_THERE then begin REMOTE_EXISTS := false ; exit( CR_COMMINIT ) ; end ; MODEL_ID := '' ; OFF_HOOK := false ; BAUD_SETTABLE := false ; CR_ATTENCHAR := ATTENTION_CHAR ; CR_SETCOMMUNICATIONS( DEFAULT_MODE, DEFAULT_PARITY, DEFAULT_RATE, DEFAULT_CHARBITS, DEFAULT_STOPBITS, DIR, MODEL_ID, RESULT ) ; end ; procedure CR_COMMQUIT ; var RESULT : CR_BAUD_RESULT ; begin OFF_HOOK := false ; if BAUD_SETTABLE then CR_SETCOMMUNICATIONS( DEFAULT_PARITY, DEFAULT_MODE, DEFAULT_RATE, DEFAULT_CHARBITS, DEFAULT_STOPBITS, CR_ORIG, MODEL_ID, RESULT ) ; end; end. ======================================================================================== DOCUMENT :usus Folder:VOL08:screen.text ======================================================================================== {$s+} {$i header } {$i globals } {$i forwards } unit screencontrol; interface type months = 0..12; days = 0..31; years = 0..99; procedure home; procedure cleareos; procedure cleareol; procedure date (var m: months; var d: days; var y: years); function screenwidth: integer; function screenheight: integer; implementation procedure home; begin homecursor; end; procedure cleareos; var c: char; begin with syscom^ do begin if crtctrl.eraseeos <> chr(0) then begin if crtctrl.prefixed[3] then begin c := crtctrl.escape; unitwrite(1,c,1,,4); {no DLE expansion} end; write(crtctrl.eraseeos); if length(filler) > 0 then write(filler); end; end; end {cleareos}; procedure cleareol; begin clearline; end; procedure date {var m: months; var d: days; var y: years}; begin m := thedate.month; d := thedate.day; y := thedate.year; end; function screenwidth {: integer}; begin screenwidth := syscom^.crtinfo.width; end; function screenheight {: integer}; begin screenheight := syscom^.crtinfo.height; end; end {screencontrol}; begin { syscode } end; begin { pascal system } end. ======================================================================================== DOCUMENT :usus Folder:VOL08:screenunit.text ======================================================================================== UNIT SCREENUNIT; INTERFACE {these declarations must be global} TYPE XFILE = FILE; CRTCOMMAND = (ERASEOS,ERASEOL,UP,DOWN,RIGHT,LEFT,LEADIN); VAR CRTINFO: PACKED ARRAY[CRTCOMMAND] OF CHAR; PREFIXED: ARRAY[CRTCOMMAND] OF BOOLEAN; PROCEDURE GETCRTINFO; PROCEDURE CRT ( C : CRTCOMMAND ); PROCEDURE VER_SCREENUNIT; PROCEDURE IO_ERROR( IORESLT : INTEGER; FILENAME : STRING); PROCEDURE BAD_IO(VAR FILEID :XFILE; FILENAME :STRING; IORESLT :INTEGER; RSET :BOOLEAN; VAR IO_OK :BOOLEAN); IMPLEMENTATION (*$I-*) (*$R-*) {**************} PROCEDURE VER_SCREENUNIT; BEGIN WRITELN('uses screenunit version 5 18-Jul-81'); END; PROCEDURE GETCRTINFO; {adapted from Roger Soles version in the USUS library} TYPE BYTE = PACKED ARRAY[0..7] OF BOOLEAN; SWITCH = (CH,BOOL); DUMMY = RECORD CASE SWITCH OF CH : (CH_VAL : CHAR); BOOL : (BOOL_VAL : BYTE); END; VAR BITS : BYTE; BLOCK: PACKED ARRAY[0..511] OF CHAR; K: INTEGER; DISK : XFILE; DUM : DUMMY; BEGIN RESET(DISK,'*SYSTEM.MISCINFO'); IF IORESULT = 0 THEN K := BLOCKREAD(DISK,BLOCK,1) ELSE WRITE('can''t find *SYSTEM.MISCINFO'); CLOSE(DISK); IF K=1 THEN BEGIN DUM.CH_VAL:=BLOCK[72]; BITS:=DUM.BOOL_VAL; CRTINFO[LEADIN] := BLOCK[62]; PREFIXED[LEADIN] := FALSE; CRTINFO[ERASEOS] := BLOCK[64]; PREFIXED[ERASEOS] := BITS[3]; CRTINFO[ERASEOL] := BLOCK[65]; PREFIXED[ERASEOL] := BITS[2]; CRTINFO[RIGHT] := BLOCK[66]; PREFIXED[RIGHT] := BITS[1]; CRTINFO[UP] := BLOCK[67]; PREFIXED[UP] := BITS[0]; CRTINFO[LEFT] := BLOCK[68]; PREFIXED[LEFT] := BITS[5]; CRTINFO[DOWN] := CHR(10); PREFIXED[DOWN] := FALSE; END; END; PROCEDURE CRT{C: CRTCOMMAND }; {adapted from Roger Soles version in the USUS library. Call GETCRTINFO before using this procedure.} BEGIN IF PREFIXED[C] THEN UNITWRITE(1,CRTINFO[LEADIN],1,0,12); UNITWRITE(1,CRTINFO[C],1,0,12); END; PROCEDURE IO_ERROR{( IORESLT : INTEGER; FILENAME : STRING)}; type entry = record number : integer; message : packed array[0..21] of char; end; var buff : array[0..21] of entry; disk : xfile; k : integer; BEGIN IF IORESLT<>0 THEN BEGIN GOTOXY(0,22); WRITE(CHR(7)); WRITELN('I/O Error on ',FILENAME); reset(disk,'*errordata'); k:=blockread(disk,buff,1); close(disk); write('ioresult = ',ioreslt); gotoxy(0,23); if k = 1 then for k:=1 to 20 do if ioreslt = buff[k].number then unitwrite(1,buff[k].message,22,,1); END; END; {io_error} {*****************} PROCEDURE BAD_IO{(VAR FILEID :XFILE; FILENAME :STRING; IORESLT :INTEGER; RSET :BOOLEAN; VAR IO_OK :BOOLEAN)}; VAR CH : CHAR; GOTFILE : BOOLEAN; BEGIN IF IORESLT = 0 THEN IO_OK:=TRUE ELSE BEGIN GOTOXY(0,22); CRT(ERASEOS); IO_OK:=FALSE; IO_ERROR(IORESLT,FILENAME); GOTOXY(48,22); WRITE('type L)ock to close and exit or'); GOTOXY(48,23); WRITE(' to '); IF RSET THEN WRITE('reset and '); WRITE('continue'); READ(KEYBOARD,CH); IF (CH='L') OR (CH='l') THEN BEGIN CLOSE(FILEID,LOCK); EXIT(PROGRAM); END ELSE IF RSET THEN BEGIN CLOSE(FILEID); RESET(FILEID,FILENAME); END; GOTOXY(0,22); CRT(ERASEOS); END; END; {bad_i/o} END. {screenunit} ======================================================================================== DOCUMENT :usus Folder:VOL08:units.doc.text ======================================================================================== {This file describes three units which are extensively used in the other programs on this disk. They are FILEUNIT, SCREENUNIT, and PRINTERUNIT. Unit FILEUNIT is a collection of procedures intended to aid in the error free opening of files for input and output. The procedures are very modular so that use and modification of the unit is straight-forward. OPENDSKREAD and OPNDSKWRT are the most general procedures. They act as "one-liner" file openers in the calling program. These procedures are the normal entry point to this unit and they in turn call other procedures to actually do the work. The parameters they require are the fileid (type text or file), a prompt string, and the x and y coordinates (type integer) where the prompt string is to be displayed on the console. They will return the filename (type string) that was actually opened or a null string if no file was opened. OPNDSKWRT always opens a text file. If you want any other kind of file, then call REWRT_DISK directly. Procedure GETFILNAME is a routine which is called by OPNDSKREAD and OPNDSKWRT. This procedure actually outputs the prompt and reads a filename. It then calls REMOVE_SPACES to (naturally) remove any spaces. It then calls LEGALNAME to check for the occurance of any illegal characters. GETFILNAME will continue to loop until LEGALNAME says that the filename is is legal in its construction. GETFILENAME then returns the legal filename to OPNDSKREAD or OPNDSKWRT. The boolean GOTNAME indicates a valid name. GETFILNAME will allow the user to look through his directorys if desired. To do this, it calls DIR. Procedure LEGALNAME actually tries to reset the file and if the operating system says that the name is legal (IORESULT=7), it exits. If the name is not legal the procedure IO_ERROR is called to display an error message at the bottom of the screen and then it exits to GETFILNAME with a boolean variable indicating whether or not the name was legal. If the name was legal and the file existed it is now open, so LEGALNAME closes the file so that later procedures won't get confused. Procedure LEGALUNIT checks for legal volume names. It is used by DIR, GET_FILE_DATE, and LEGALNAME. This procedure prevents the possibility of reading from REMOUT: for example and causing the system to hang. One exception is made. The user is allowed to reference PRINTER: ( but not #6:) to allow the printer to be opened for output instead of a file. You can, of course, use this loophole to intentally screw up the system, but I couldn't think of a better way to do it. Procedure IO_ERROR, in SCREENUNIT, simply displays an entry from the table of I/O error messages which is found the UCSD System Users Guide. It is helpful in determining the actual cause of the error. If no error is indicated when this procedure is called (IORESULT=0), then the procedure exits to the caller with no action. To save codefile space, the text of the messages are contained in a structured file on disk instead of in-line in the procedure. While this method is slower, it is one block smaller in each program in which FILEUNIT is used. The disk file is named ERRORDATA and if not present, the value of IORESULT is displayed instead. There are some extra error messages and corresponding values of IORESULT in the file. These are for additional error messages than the UCSD system has because FILEUNIT is more picky about characters in filenames than the system. The new values of IORESULT start at 128 so that there will (probably) never be a conflict in the numbering. Procedures RESET_DISK and REWRT_DISK actually do the work of opening a file. These procedures are declared to be global so that they may be called directly by the user in the case where a good filename is already known. RESET_DISK tries to reset the file with the filename as is and if successful it exits with the value of ioresult. If it is not successful it calls ADD_TEXT to append '.TEXT' to the filename (only if it doesn't have a '.TEXT' extension) and tries again. If it is successful it leaves the file open and exits with the new filename and the value of ioresult. If the reset fails a second time, it then exits with a non-zero ioresult. REWRT_DISK first tries to reset the file to see if it already exists and if so it prompts the user to be sure that he really wants to rewrite an existing file. If the user says yes it goes ahead and rewites the file and the previous file of the same name is forever lost. If the file to be rewritten is not found it is then rewritten. The variable REWROTE is then set true to indicate that an attempt was made. If any errors occur in rewriting the file then the procedure exits with the value if ioresult. OPNDSKWRT detects the value of ioresult, calls IO_ERROR to disply a message and then calls GETFILNAME to get another name. If the rewrite was successful then the file is left open for use by the calling program and REWRT_DISK exits with the filename actually opened and IORESLT=0. It is the users responsibility to close and lock the file when he is through writing to it. An isolated procedure ,BAD_IO (also found in SCREENUNIT), exists which is not used in the opening of files. This procedure is used with the I/O statements used in reading or writing files. It receives as parameters the fileid, the filename, a boolean (RSET), and IORESULT. It passes back out the boolean IO_OK to indicate if the value of IORESULT was zero or not. If IORESULT was non-zero it calls IO_ERROR to display the type of error and prompt for a course of action. The action taken depends on the value of RSET. If RSET is true the file can be reset to start over at the beginning. If RSET is false then the file will not be reset. This allows the user who has been keeping track of the exact blocks he has been accessing to restart at the beginning of the block where the error occured. If the user feels that the error was fatal to his program he, can immediatly EXIT(PROGRAM). This procedure should be used in conjunction with I/O checking ( the (*$I-*) ) compiler option and a repeat loop around the read or write startment in question. For example, if a file was opened sucessfully and the user pulls out the floppy before it has been completely read, this procedure will allow the user to re-insert the disk and continue without a run- time error which would normally bomb the program. If the file was being written, and the user elects to exit the program, BAD_IO closes his file with the LOCK option so that whatever was already written is saved. Procedure DIR will display the contents of a directory on one screen. Only the filenames are shown as this procedure is intended to aid in the selection of a file to be opened by OPNDSKREAD and OPNDSKWRT. The procedure is a combination of Monaco's and Gagne's work on Volume 5 and a neat quicksort procedure taken from a SYBEX book by Alan Miller. Procedure GET_FILE_DATE will get the date of the last update of any file on any disk. You pass it the file name and it passes back the date and the filename with the volume id of the volume prefixed. If you pass it a string variable containing a star(*), it will pass back the volume id of the root volume and the current system date. If you pass it the volume id of any other volume or a non-existant filename, a null string will be returned for the date. GET_FILE_DATE is declared to be global so that is can be called by the user. Some degree of terminal independance is possible by the use of two procedures by Roger Soles. These procedures, GETCRTINFO and CRT (found in SCREENUNIT), were taken from the unit UNIT.GOOD found on Volume 5 of the USUS library. If you have a standard size screen, no screen formatting changes are required to the unit. SCREENUNIT must be compiled and available before FILEUNIT is compiled. No attempt has been made to accomadate terminals with screens smaller than 80 x 24. Since many of the procedures write messages to absolute screen positions, major surgery may be required to make the unit fit a smaller-than-standard format. GETCRTINFO has been slightly modified to allow the direct access to individual bits in a given byte. Note that the name, revision number, and date of last revision is in a procedure called VER_FILEUNIT. When this procedure is called, the version number and last revision date are written to the screen, so that the unit can identify itself. This is also done in SCREENUNIT and PRINTERUNIT. If you update the unit, remember to update the version and date. This unit is rather large. You will find that it will make even the most trivial program at least fourteen (count 'em 14) blocks long, but as the saying goes, "there ain't no free lunch". If you have any comments, suggestions, or improvements concerning the unit, I would appreciate hearing them. George Schreyer 412 North Maria Ave. Redondo Beach, Ca. 90277 (213-376-9348) P.S. This unit has been tested and works on version 4 of the UCSD system. EXCEPT, you must add a dummy termination section to the SCREENUNIT as shown BEGIN ***; END. or the EXIT(PROGRAM) in BAD_IO will do some mighty strange things. I understand that this is a genuine bug and will be fixed. ======================================================================================== DOCUMENT :usus Folder:VOL08:volume.8.text ======================================================================================== DOCUMENTATION FOR VOLUME 8 -- USUS LIBRARY 26 July 1981 Here, at last, is a collection of software tools that I've been receiving over the last year, since the inception of USUS. These programs look good to me, by and large, but I have by no means had the time to try them all. So this volume is a sort of "review volume" released to the membership at large. Please send bug reports to me AND to Keith Schillington, the Newsletter editor, so that they can be published. Simple bugs will be both published and repaired on future disks--look at the date of a file if you have learned of a bug and want to know if we've already fixed it. Note that some of the files have changed from those listed in the Newsletter, since I've rearranged things to accommodate George Schreyer's latest versions of things. I'm including documentation from several sources below; my comments are in brackets. Jim Gagne, Chairman, USUS Library Datamed Research, Inc. 1433 Roscomare Road Los Angeles, CA 90024 SUBMISSIONS FROM GEORGE SCHREYER LINECOUNT.....This a very fast linecounter. It runs at about 600 lines per second on my LSI-11. [George's wife Sandy uses LINECOUNT to measure productivity in lines of code per day, by counting lines on each file in a directory list stored in a textfile. BUG: don't allow LINECOUNT to clear the screen until you've had a chance to read the answer.] COPYBLOCKS....This copys a region on a disk to a file to allow for the recovery of a lost program. I wrote it to recover a file which my wife lost by overwriting it with the version II editor. RECOVER.......Recover searches each block of a volume to look for lost programs. It identifies each location where the lost program might still exist. Copyblocks is then used to transfer those blocks to a file. [This is a very simple program that looks for the word "PROGRAM", all in caps, in the first block. Suggestion: At least make it case-insensitive; you might also have it look for the structure of the segment tables in the first block of code files.] CRMBLEV1.2....This one will break a file that is too large for the editor into smaller pieces. I use it to processes programs which I have taken from other computers via INHALE. It is slow but effective. WRITERV7.2....A substantially reworked version of the original. It uses blockreads and unitwrites and runs much faster. I believe that this version is bullet-proof; try and see if you can make it blow up. The original version was found in the USUS library. It will list your files with a banner page, which makes a listing easier to find in a pile of listings (and they do seem to pile up). It will also list include files in-line if desired and number lines and pages. It can optionally maintain a data file on your root volume with the latest date and a set of standard form parameters. Version 7.2 will get the date from your system disk automatically. If you choose to maintain a data file of form parameters the program will initialize one for you at the end of the first run. Built in (but changable at run-time) defaults will be used for the first run. The program has been tested with version IV.0 and it works fine, however because version IV does the actual unit linking at run-time, the time overhead of the system getting all the units together is excessive (as much as 15 secs with "high-performance" floppies and about 5 secs with a hard disk). PERUSEV4.4....A faster version of peruse. It will allow you to back up 44 lines at a time if you want. It is also bullet-proof. MODEMV2.2.....Basically the same as before but a little cleaner. NOTE: this program depends upon UNITBUSY and thus runs only on the PDP-11 systems. UNITS.DOC.....Documentation for FILEUNIT. FILEUNIT......This is a unit I wrote to allow error-free handling of files and general I/O. It works very well and it is used in most of the other programs on this disk. I believe that this does the same function as GETFILE in UNIT.GOOD [USUS Library, Volume 5 --see alse CRTINPUT in the save volume], but it is more general and does error checking and recovery for general I/O also. This unit also containes reworked versions of DIR.TEXT and GETDATE. DIR can be called from a user program and displays the filenames only in four columns. GET_FILE_DATE can get the date from the system disk or the date of the last update of any file on any disk. It also prefixes the filename with the actual volume id even if the id name is not supplied. SCREENUNIT....This is just the procedures GETCRTINFO and CRT from UNIT.GOOD. PRINTRUNIT....[I omitted this file to save room; it is called by some of George's other programs but does nothing but prevent his buffer from overflowing and is specific to PDP-11's. Delete any references to the following procedures: PROCEDURE VER_PRTUNIT; {write a note of which version} PROCEDURE INITPT; {initialize the unit} PROCEDURE WAIT_FOR_DC1; {called when you've dumped some text & are worried your buffer may overflow}] ERROR.DATA....This is a data file for Fileunit. Its use is optional. I hope that you find these programs interesting. Sincerely, George W. Schreyer P.S. I received Version IV.0 and all of these programs have been tested with it. Everything works as before, except much slower. I have mixed feelings about the new version. It is much easier to update programs which use units, but the run-time overhead is a killer. I would hate to be strictly floppy bound. It takes as much as 15 seconds to simply eX)ecute a program which uses a few units. Further there doesn't seem to be any way to permanantly link in a unit to avoid the time lag. Also, with all the system swapping, just using the system involves a lot of waiting, even with a hard disk! Even the compiler runs about 30% slower. Also the system seems to die mysterious deaths after some segment errors and won't work properly until after a real hard boot. I am sticking with version II until things improve considerably. [NOTE: we discussed this on the phone; George's problem is that he's using 4 units, each in a different file, causing a dozen file and directory accesses each time he runs just to find out where the units are he wants to load. Solution: use the SYSTEM.LIBRARY for frequently used routines.] PROGRAMS FROM STUART LYNN ARCHIVER......this program will store a disk image in a file. This allows you to set up an Archive disk with several disk images, for backup purposes. It is most useful on large disks ( > 1000 blocks) when your directory space is used up before the data space. Before archiving a disk remove all extraneous files and krunch. To restore an archived disk image use the filer to transfer the file to a blank disk. ie. T Archive:Backup.dsk #4: where Archive is the name of the archive disk, and Backup was the name of the original disk. [This program appears to have something left out and won't compile as is, though I believe what's missing is not essential. Try it without the offending statement and see; meanwhile watch the Newsletter.] CHAIN.........this procedure will tell the operating system to start up another program when the currently running program is finished. See Chain.1 and Chain.2 for example of use.(Note: you have to have the source for the system globals for archiver,chainer and fast.seek/z80.seek) FAST SEEK, Z80.SEEK......these procedures are the same as the original UCSD intrinsics but are substantially faster. MULDIV.Z80....Z80 code for Z80.SEEK PROGRAMS FROM DAVID MUNDIE MAILER........is a substitute I propose for Frank's mailing list program. It is along the same basic lines, but I think it is an improvement. For one thing, you don't have to worry about leaving space free after the file--I had a hard time making a disk-file to contain the output on Frank's program; the two files kept growing together. It also allows selecting certain fields to be printed, eliminates the need for the key field, etc. etc.--I had already made most of the suggestions to you. See MAILER.DOC. LISP..........I am including even though I don't think it is fully debugged, just 'cause you mentioned it. I haven't put the comments back in, so it wouldn't be very easy to follow without the NTIS listing. DISKSORT......is my best effort at a reasonable sort program. The QUICKSORT program on volume 5 disappointed me somewhat, since it is not a "disk" sort at all, at least as I understand the term. Mine is based on Arbib and Alagic's algorithm (in The Design of Well- structured and Correct Programs, or whatever the name of their book is), and is, I think, a four-way balanced merge sort. It expects a user-supplied file "raw.data", consisting of string[10]'s, up to 120 blocks' worth. But the program is intended as a model only, and would be easy to change to handle other data structures and larger files. I'm not an expert on disk sorts; if you get a better program, let me know. SUBMISSIONS FROM BOB PETERSON Chairman, Communications SIG and the new USUS president REM.UNIT......This is an implementation of the draft proposed standard UCSD system remote unit, of January 1981 (which was recently revised slightly and accepted by the Communications SIG as the standard interface for communications equipment). Its purpose is to put all hardware-dependent features of interprocessor communications in one spot, and then to provide a standard interface to each system, so that communications software will work with any system. See the newsletter for details on the relatively minor changes required to bring REM.UNIT up to the new standard. REM.TERM......This is Bob's implementation of Teletalker; others are available from Volition Systems and Bowles' TeleSoftware. Bob's program is hardware independent, because it relies on the REM.UNIT above. It allows the UCSD system to act as a "dumb" remote terminal, as well as saving a part or all of a session in a text file, or sending a previously created text file. Several options are noted in the text of the program. One issue never really resolved by any of the Teletalkers I've seen is that if you transmit many characters nonstop on Telemail, on occasion it hangs up briefly, and if you then keep sending characters, it dies. This is especially a problem during system purge time (1AM to 6AM Eastern time), though it rarely happens at 300 baud. The Bowles program counteracts the problem some by checking for echo character by character, and stopping the transmission if echo ceases. This helps, but transmission rate suffers and the problem is still not solved. MY ONE ADDITION TO THE LIBRARY D.............Several people have sent in "updates" or "corrections" to DIR, the directory-listing program I wrote that was contained on Volume 5. Frankly, I liked the original better than any of the modifications. DIR did have several problems: the UNITREAD read in too many bytes (2048 rather than 2024, the actual size of the directory), causing this disk access to write over the program and crash or act weirdly. Also, the simple sort I used takes up to six seconds to alphabetize the directory if it contains 77 entries. The way I listed files that did not fit on the first screenful was lousy, and I found that listing unused blocks on the bottom was not useful. Finally, several people with Apples reformatted the prompts so that they would fit on their screens. D now addresses most of the above issues: a) not only was the UNITREAD corrected, but (to allow BLOCKREAD, if you wish to read a directory by Volume ID) I extended the size of the buffer, which now holds four full blocks; b) D now uses a quicksort contributed by George Schreyer; c) files that do not fit on the screen are written cleanly at the bottom, separated from the previous page by a blank line, so that the maximum amount of material still appears on the screen; and d) I've improved the prompts somewhat for those with Apples with 40-column screens. An additional feature is that you can list files two ways: alphabetically (in 3 columns; Apple users convert to 4 if you wish), for searching for a file name, or in physical order on the disk, noting unused blocks in the areas where they appear, for disk space management. MISCELLANY GLOBAL.II0 GLOBAL.III....II.0 and III.0 Globals, donated to the Library by SofTech Microsystems and both SofTech and Western Digital, respectively. For those who do not know the significance of GLOBALS, here is a brief note (though an article in the Newsletter is really required...any takers?): GLOBALS is the file included in the compilation of any UCSD system software, and is not a program but the declarations of the global operating system data types, variables, and procedures. It allows you to access these features of the operating system directly. So, for instance, if you know how, you can access memory-resident features such as terminal-driver characters, the system date, the name of the root and prefix volumes, the workfile, etc. However, there are many pitfalls in the use of GLOBALS. First, they are subtly different in several UCSD releases (particularly II.1, III.0, and the variations of the UCSD system implemented by IBS, among others). IV.0, in particular, bears NO relationship with the files here. So programs that depend heavily upon GLOBALS are likely to perform poorly on various systems, unless they are recompiled with the correct version of GLOBALS. Second, and more important to most of us, as a rule one must compile with the {$U-} compiler option set. Again, one needs several pages of documentation to understand the many otherwise nondocumented exceptions to normal compiler operation that are called into force by compiling with {$U-}. SCREEN........This is the Western Digital screen control unit, which may work without modification on most other UCSD p-systems. Don't fiddle with it except to change the include file calls to just GLOBAL.III, reflecting my condensation of the three files. ======================================================================================== DOCUMENT :usus Folder:VOL08:writerv7.2.text ======================================================================================== {$R-} {$S+} {$I-} PROGRAM WRITER; USES (*$U SCREENUNIT.CODE*)SCREENUNIT, (*$U FILEUNIT.CODE*)FILEUNIT, (*$U PRINTRUNIT.CODE*) PRINTERUNIT; CONST VERSION = 'WRITER version 7.2 18-Jul-81'; {Program Writer will print your files in a pretty format among other things. (See WRITER.DOC.TEXT for details) This version was modified from the Version 1.0 distributed by USUS. Version 2.0 was done by Sandy Schreyer. All subsequent versions were done by George Schreyer. This program containes printer dependant code (for a TI 820 printer) which can be found in procedures INITWRTPAGE, BANNER and WRAP_UP_WRTPAGE. The procedures GETCRTINFO and CRT (from the USUS library, Volume 5) are used to allow terminal independance, however the program assumes a 24 line by 80 column display so modifications will be necessary in various places for smaller displays to prevent wrap-around or undesired scrolling. The procedures are found in the unit SCREENUNIT. The unit FILEUNIT is used to aid in the error-free opening and reading of files. I believe that the program is klutz-proof, and I dare you to make it generate a run time error. This version containes machine dependant code, found only in PRINTRUNIT, to sense the condition of the printer. The code was necessary because this version of writer runs so fast that it overfills the buffer of my printer. The earlier versions with READLN and WRITELN statements run at about 92 cps on an LSI-11. The new version runs at about 370 cps, a speed improvement of about a factor of four. The extra speed makes this kludge is necessary to interface the UCSD operating system to a serial printer. If you don't have an pdp-11 type computer this patch won't work, just delete all references to PRINTRUNIT and cross your fingers. If you have a parallel printer then this code is totally unnecessary anyway.} TYPE BLOCK = FILE; VAR INP : FILE; {main file} INC : FILE; {include files} FILENAME : STRING ; Q:INTEGER; FORM_CHANGE : BOOLEAN; IO_OK: BOOLEAN; INP_NEXT_BLOCK : INTEGER; INC_NEXT_BLOCK : INTEGER; INLINE : CHAR; PR:TEXT; DISKA:TEXT; DATE : STRING ; COPIES:INTEGER; DOUBLESPACE : CHAR ; PAPERSIZE : INTEGER ; SEQUENCE:CHAR; LEFTMARGIN : INTEGER ; TOPMARGIN : INTEGER ; ENDLINES : INTEGER ; EXPANDED_PRINT : CHAR; NOTES : STRING; DISK_DATA : BOOLEAN; DATE_CHANGE : BOOLEAN; WRITERDATA : STRING; LPI : INTEGER; FILE_DATE : STRING; { * * * * * * * * * * } PROCEDURE GETDATA; VAR REPLY :CHAR; COMMAND : CHAR; PROCEDURE SHIFT_UP (VAR CH : CHAR); BEGIN IF CH IN ['a'..'z'] THEN CH := CHR(ORD(CH)-32); END; PROCEDURE CARRYOUT ; VAR NEWDATE:STRING ; TEMP : INTEGER; PROCEDURE SETMARGIN(VAR MARGIN:INTEGER); VAR TEMP:INTEGER; BEGIN TEMP:=MARGIN; READLN(MARGIN); IF (MARGIN < 1) OR (MARGIN > PAPERSIZE) THEN MARGIN:=TEMP; END {setmargin}; BEGIN {carryout} CASE COMMAND OF 'D' : BEGIN WRITE ('date today? ' ) ; READLN ( NEWDATE ) ; IF NEWDATE <> '' THEN DATE := NEWDATE ; DATE_CHANGE:=TRUE; END ; 'F' : BEGIN CLOSE(INP); OPNDSKREAD(INP,'file to write? - - > ',FILENAME,5,15); CLOSE(INP); GET_FILE_DATE(FILENAME,FILE_DATE); IF (FILE_DATE = '') OR (LENGTH(FILENAME)=POS(':',FILENAME)) THEN FILENAME:=''; END; 'C' : BEGIN REPEAT WRITE('# of copies? '); READLN(COPIES); IF COPIES < 1 THEN COPIES:=1; UNTIL IORESULT=0; END; 'M' : BEGIN WRITELN('Banner message? (63 characters maximum)'); READLN(NOTES); IF LENGTH(NOTES)>63 THEN BEGIN DELETE(NOTES,64,(LENGTH(NOTES)-63)); END; END; 'L' : BEGIN WRITE('Left margin? '); SETMARGIN(LEFTMARGIN); IF LEFTMARGIN < 2 THEN LEFTMARGIN:=2; FORM_CHANGE:=TRUE; END; 'Q' : EXIT(WRITER); 'I' : BEGIN REPEAT WRITE('do you wish include files printed in-line? (Y/N) '); READ(INLINE); SHIFT_UP(INLINE); GOTOXY(0,0); CRT(ERASEOS); UNTIL INLINE IN ['Y','N']; FORM_CHANGE:=TRUE; END; 'W' : BEGIN REPEAT WRITE('Do you want E)xpanded, N)ormal or' ,' C)ompressed print ? '); READ(EXPANDED_PRINT); SHIFT_UP(EXPANDED_PRINT); GOTOXY(0,0); CRT(ERASEOS); UNTIL EXPANDED_PRINT IN ['E','N','C']; FORM_CHANGE:=TRUE; END; 'T' : BEGIN WRITE('Top margin? '); SETMARGIN(TOPMARGIN); FORM_CHANGE:=TRUE; END; 'B' : BEGIN WRITE('Bottom margin? '); SETMARGIN(ENDLINES); FORM_CHANGE:=TRUE; END; 'P' : BEGIN TEMP:=PAPERSIZE; REPEAT WRITE ( 'what is your papersize? ' ) ; READLN (PAPERSIZE ) ; UNTIL IORESULT=0; FORM_CHANGE:=TRUE; IF (PAPERSIZE<1) OR (PAPERSIZE>66) THEN PAPERSIZE:=TEMP; END; 'S' : BEGIN REPEAT WRITE('do you want doublespaces (Y or N)? '); READ(DOUBLESPACE); SHIFT_UP(DOUBLESPACE); UNTIL DOUBLESPACE IN ['Y','N']; REPEAT GOTOXY(0,0); CRT(ERASEOS); WRITE('do you want S)ix or E)ight lines per inch?'); READ(REPLY); SHIFT_UP(REPLY); UNTIL REPLY IN ['S','E']; IF REPLY='E' THEN LPI:=8 ELSE LPI:=6; FORM_CHANGE:=TRUE; END; 'N' : REPEAT WRITE('do you want line numbers (Y or N)? '); READ(SEQUENCE); SHIFT_UP(SEQUENCE); FORM_CHANGE:=TRUE; UNTIL (SEQUENCE='Y') OR (SEQUENCE='N'); END { CASE } ; END { CARRYOUT } ; PROCEDURE MENU; BEGIN WRITELN('WRITER: D(ate, F(ilename, C(opies, L(eft margin, T(op ', 'margin, B(ottom margin,'); WRITELN(' P(apersize, S(pacing, print W(idth,', ' N(umbers, Q(uit, G(o,'); WRITELN(' I(nclude files, banner M(essage'); WRITELN; WRITELN('date: ',DATE); WRITELN('left margin: ',LEFTMARGIN); WRITELN('top margin: ',TOPMARGIN); WRITELN('bottom margin: ',ENDLINES); WRITE('doublespaces: '); IF DOUBLESPACE = 'Y' THEN WRITELN('yes') ELSE WRITELN('no'); WRITE('numbers: '); IF SEQUENCE = 'Y' THEN WRITELN('yes') ELSE WRITELN('no'); WRITELN('papersize: ',PAPERSIZE); WRITELN('copies: ',COPIES); WRITE('print width: '); CASE EXPANDED_PRINT OF 'n','N' : WRITELN('normal'); 'e','E' : WRITELN('expanded'); 'c','C' : WRITELN('compressed'); END; WRITELN('lines per inch: ',LPI); WRITE('include files: '); IF INLINE = 'Y' THEN WRITELN('yes') ELSE WRITELN('no'); WRITELN('banner message: ',NOTES); WRITE('filename: ',FILENAME); IF FILENAME <> '' THEN WRITELN(' dated ',FILE_DATE) ELSE WRITELN; END; {menu} BEGIN {getdata} RESET(INP,FILENAME); IF IORESULT <> 0 THEN OPNDSKREAD(INP,'file to write? - - - > ' ,FILENAME,0,15); CLOSE(INP); IF FILENAME = '' THEN EXIT(PROGRAM); GET_FILE_DATE(FILENAME,FILE_DATE); IF (FILE_DATE = '') OR (LENGTH(FILENAME)=POS(':',FILENAME)) THEN FILENAME :=''; GOTOXY(0,0); CRT(ERASEOS); REPEAT IF FILENAME = '' THEN WRITELN(CHR(7),'No file') ELSE WRITELN; WRITELN; MENU; WRITELN; WRITE('Command ? '); READ(COMMAND); SHIFT_UP(COMMAND); GOTOXY(0,0); CRT(ERASEOS); CARRYOUT; GOTOXY(0,0); CRT(ERASEOS); UNTIL (COMMAND IN ['G','g']) AND (FILENAME <> ''); IF DISK_DATA THEN BEGIN IF FORM_CHANGE THEN BEGIN GOTOXY(0,0); CRT(ERASEOS); GOTOXY(0,12); WRITE('Do you wish to make form changes permanent? (Y/N)'); READ(REPLY); GOTOXY(0,0); CRT(ERASEOS); IF REPLY <> 'Y' THEN FORM_CHANGE:=FALSE; END; END; CLOSE(INP); END {getdata}; { * * * * * * * * * * } PROCEDURE INITIALIZE ; VAR T1:INTEGER; PROCEDURE SETVARS ; VAR STAR : STRING; BEGIN {setvars} STAR:='*'; LPI:=6; DATE:=' '; LEFTMARGIN := 10 ; TOPMARGIN:=4; ENDLINES:=4; DOUBLESPACE:='N'; SEQUENCE:='Y'; PAPERSIZE:=51; COPIES:=1; INLINE:='N'; EXPANDED_PRINT:='N'; FILENAME:='*SYSTEM.WRK.TEXT'; IF DISK_DATA THEN BEGIN RESET(DISKA,WRITERDATA); IF IORESULT=0 THEN BEGIN READLN(DISKA,DATE); READLN(DISKA,LEFTMARGIN); READLN(DISKA,EXPANDED_PRINT); READLN(DISKA,LPI); READLN(DISKA,TOPMARGIN); READLN(DISKA,ENDLINES); READLN(DISKA,PAPERSIZE); READLN(DISKA,DOUBLESPACE); READLN(DISKA,INLINE); READLN(DISKA,SEQUENCE); END; CLOSE(DISKA); END; GET_FILE_DATE(STAR,DATE); END {SETVARS}; BEGIN {initialize} GETCRTINFO; DISK_DATA:=TRUE; FILE_DATE:=''; WRITERDATA:='*WRITERDATA'; DATE_CHANGE:=FALSE; NOTES:=''; FORM_CHANGE:=FALSE; GOTOXY(0,0); CRT(ERASEOS); WRITELN; FOR T1:=1 TO 79 DO WRITE('*'); WRITELN ; WRITELN ; WRITELN ( ' WELCOME TO ',VERSION ) ; WRITELN ; FOR T1:=1 TO 79 DO WRITE('*'); WRITELN; VER_SCREENUNIT; VER_FILEUNIT; VER_PRTUNIT; UNITCLEAR(6); IF IORESULT <> 0 THEN BEGIN WRITELN; WRITE('printer not on-line at port #6'); EXIT(PROGRAM); END; REWRITE(PR,'PRINTER:'); INITPT; WAIT_FOR_DC1; SETVARS; END {initialize}; PROCEDURE WRITE_DATA; VAR TEMP_STR : STRING; BEGIN IF DISK_DATA THEN BEGIN TEMP_STR:=DATE; IF NOT FORM_CHANGE THEN BEGIN RESET(DISKA,WRITERDATA); IF IORESULT=0 THEN BEGIN READLN(DISKA,DATE); READLN(DISKA,LEFTMARGIN); READLN(DISKA,EXPANDED_PRINT); READLN(DISKA,LPI); READLN(DISKA,TOPMARGIN); READLN(DISKA,ENDLINES); READLN(DISKA,PAPERSIZE); READLN(DISKA,DOUBLESPACE); READLN(DISKA,INLINE); READLN(DISKA,SEQUENCE); END; CLOSE(DISKA); END; DATE:=TEMP_STR; IF DATE_CHANGE OR FORM_CHANGE THEN BEGIN REWRITE(DISKA,WRITERDATA); IF IORESULT = 0 THEN BEGIN WRITELN(DISKA,DATE); WRITELN(DISKA,LEFTMARGIN); WRITELN(DISKA,EXPANDED_PRINT); WRITELN(DISKA,LPI); WRITELN(DISKA,TOPMARGIN); WRITELN(DISKA,ENDLINES); WRITELN(DISKA,PAPERSIZE); WRITELN(DISKA,DOUBLESPACE); WRITELN(DISKA,INLINE); WRITELN(DISKA,SEQUENCE); END; END; CLOSE(DISKA,LOCK); END; END; {write_data} PROCEDURE WRTPAGE; VAR LINE:PACKED ARRAY[0..132] OF CHAR; DATAI,DATA: PACKED ARRAY[0..511] OF CHAR; S,PAGE_SIZE : INTEGER; K,N,J,MARGINLINES : INTEGER ; LINECNT:INTEGER; PAGENUMBER : INTEGER ; INC_NAME : STRING; MARGINSPACES : INTEGER ; LINESLEFT : INTEGER; INCLUDE : BOOLEAN; BLANK_STRING : STRING; PROCEDURE INITWRTPAGE; PROCEDURE BANNER; VAR I : INTEGER; BEGIN BLANK_STRING:=' '; WRITE(PR,CHR(27),'PA\'); {sets 6 lpi} PAGE(PR); WRITE(PR,CHR(27),'PI',CHR(27),'\'); {set 5 cpi} FOR I:= 1 TO 5 DO WRITE(PR,CHR(10)); WRITELN(PR,BLANK_STRING:10,FILENAME); WRITELN(PR); WRITELN(PR,BLANK_STRING:10,'listing date is ',DATE); WRITELN(PR); WRITELN(PR,BLANK_STRING:10,'last updated on ',FILE_DATE); WRITELN(PR); IF LENGTH(NOTES)>44 THEN WRITELN(PR,CHR(27),'PD\',BLANK_STRING:33,CHR(27), 'PJ',CHR(27),'\',NOTES) {sets 16.5 cpi, moves 33 spaces, then sets 8.25 cpi} ELSE WRITELN(PR,BLANK_STRING:10,NOTES); WRITE(PR,CHR(27),'PC\'); {sets 10 cpi} END; {banner} BEGIN {initwtrpage} INCLUDE:=FALSE; PAGE_SIZE:=PAPERSIZE-ENDLINES-TOPMARGIN-2; IF LPI=8 THEN PAGE_SIZE:=(4*PAGE_SIZE) DIV 3; IF DOUBLE_SPACE = 'Y' THEN PAGE_SIZE:=PAGE_SIZE DIV 2; WRITELN; WRITE ( 'printing ... ',FILENAME ) ; WRITE(PR,CHR(27),CHR(91),CHR(49),CHR(59),PAPERSIZE,CHR(114)); {this mess sets the top margin a line 1 if it isn't there already} {and sets bottom margin to papersize} BANNER; CASE EXPANDED_PRINT OF 'E' : WRITE(PR,CHR(27),'PJ',CHR(27),'\'); {sets 8.5 cpi} 'N' : WRITE(PR,CHR(27),'PC\'); {sets 10 cpi} 'C' : WRITE(PR,CHR(27),'PD\') {sets 16.5 cpi} END; IF LPI=8 THEN WRITE(PR,CHR(27),'PH',CHR(27),'\'); {sets 8 lpi} WRITELN; END; {initwrtpage} PROCEDURE SKIP_HEADER(VAR SOURCE : BLOCK; FILENAME : STRING; VAR NEXT_BLOCK : INTEGER); BEGIN IF POS('.TEXT',FILENAME) <> 0 THEN NEXT_BLOCK:=2 ELSE NEXT_BLOCK:=0; END; {skip_header} PROCEDURE WRAP_UP_WRTPAGE; BEGIN CLOSE(INP); WRITE(PR,CHR(27),'PA\'); {sets 6 lpi} WRITE(PR,CHR(27),'PC\'); {resets printer to 10 cpi} WRITE(PR,CHR(27),CHR(91),CHR(52),CHR(59),PAPERSIZE-4,CHR(114)); {resets margins to top=4, bottom=papersize-4 in case Writer isn't used next} END; {wrap_up_wrtpage} PROCEDURE NUMBERS; VAR SPACE : PACKED ARRAY[0..1] OF CHAR; Z : INTEGER; BEGIN SPACE[0]:=CHR(32); Z:=LEFTMARGIN+4; IF SEQUENCE = 'Y' THEN BEGIN Z:=Z-4; LINECNT:=LINECNT+1; WRITE(PR,LINECNT:4); IF INCLUDE AND (INLINE='Y') THEN BEGIN Z:=Z-1; WRITE(PR,'+'); END; END; FOR K:=1 TO Z DO UNITWRITE(6,SPACE[0],1,,1); END; {numbers} PROCEDURE NEWPAGE; BEGIN LINESLEFT := PAGE_SIZE; WAIT_FOR_DC1; PAGE(PR); PAGENUMBER := PAGENUMBER + 1 ; FOR MARGINLINES:=1 TO TOPMARGIN DO WRITELN(PR); WRITELN(PR,FILENAME:25,'-':3,PAGENUMBER,'- listing date ' ,DATE,' last updated ',FILE_DATE); WRITELN(PR); END; {newpage} PROCEDURE PRINT_A_LINE ; VAR Q : INTEGER; PROCEDURE GET_INCLUDE; VAR NAME : PACKED ARRAY[0..24] OF CHAR; X,R : INTEGER; GOTFILE:BOOLEAN; IORESLT : INTEGER; STR : STRING; INC_DATE : STRING; BEGIN R:=0; STR:=' '; INC_NAME:=''; REPEAT NAME[R]:=LINE[Q+5+R]; R:=SUCC(R); UNTIL NAME[R-1] = '*'; FOR X:=0 TO R-2 DO BEGIN STR[1]:=NAME[X]; INC_NAME:=CONCAT(INC_NAME,STR); END; REPEAT CLOSE(INC); RESET_DISK(INC,INC_NAME,IORESLT); BAD_IO(INC,INC_NAME,IORESLT,TRUE,IO_OK); UNTIL IO_OK; SKIP_HEADER(INC,INC_NAME,INC_NEXT_BLOCK); INCLUDE:=TRUE; WRITELN; WRITELN('printing ... ',INC_NAME); GET_FILE_DATE(INC_NAME,INC_DATE); WAIT_FOR_DC1; IF DOUBLE_SPACE = 'Y' THEN WRITELN(PR); WRITELN(PR,BLANK_STRING:LEFTMARGIN+4,INC_NAME, ' last updated on ',INC_DATE); LINESLEFT:=LINESLEFT-1; END; {get_include} BEGIN {print_a_line} WAIT_FOR_DC1; NUMBERS; FOR Q:=0 TO S-1 DO IF LINE[Q] <> CHR(12) THEN UNITWRITE(6,LINE[Q],1,,1); S:=0; FOR Q:=0 TO 3 DO BEGIN IF (LINE[Q+0] = '(') AND (LINE[Q+1] = '*') AND (LINE[Q+2] = '$') THEN BEGIN IF (LINE[Q+3] = 'I') AND (LINE[Q+4] <> '-') AND (LINE[Q+4] <> '+') THEN IF (NOT INCLUDE) AND (INLINE = 'Y') THEN GET_INCLUDE; IF LINE[Q+3] = 'P' THEN NEWPAGE; END END; IF LINESLEFT = 1 THEN NEWPAGE ELSE BEGIN IF DOUBLESPACE = 'Y' THEN WRITELN (PR) ; LINESLEFT := LINESLEFT - 1 ; END; END; {print_a_line} BEGIN {wrtpage} INITWRTPAGE; REPEAT RESET(INP,FILENAME); BAD_IO(INP,FILENAME,IORESULT,FALSE,IO_OK); UNTIL IO_OK; SKIP_HEADER(INP,FILENAME,INP_NEXT_BLOCK); PAGENUMBER := 0 ; LINECNT:=0; S:=0; NEWPAGE; WHILE NOT EOF (INP) DO BEGIN J:=0; REPEAT K:=BLOCKREAD(INP,DATA,1,INP_NEXT_BLOCK); BAD_IO(INP,FILENAME,IORESULT,FALSE,IO_OK); UNTIL IO_OK; INP_NEXT_BLOCK:=SUCC(INP_NEXT_BLOCK); WHILE J < 512 DO BEGIN IF NOT INCLUDE THEN BEGIN IF DATA[J] <> CHR(0) THEN BEGIN LINE[S]:=DATA[J]; S:=SUCC(S); END; IF DATA[J] = CHR(13) THEN PRINT_A_LINE; J:=SUCC(J); END ELSE BEGIN WHILE NOT EOF(INC) DO BEGIN N:=0; REPEAT K:=BLOCKREAD(INC,DATAI,1,INC_NEXT_BLOCK); BAD_IO(INC,INC_NAME,IORESULT,FALSE,IO_OK); UNTIL IO_OK; INC_NEXT_BLOCK := SUCC(INC_NEXT_BLOCK); WHILE N < 512 DO BEGIN IF DATAI[N] <> CHR(0) THEN BEGIN LINE[S]:=DATAI[N]; S:=SUCC(S); END; IF DATAI[N] = CHR(13) THEN PRINT_A_LINE; N:=SUCC(N); END; END; CLOSE(INC); INCLUDE:=FALSE; WRITELN; WRITELN('printing ... ',FILENAME); END; END; END; WRAP_UP_WRTPAGE; END; { wrtpage } BEGIN {writer} INITIALIZE; GETDATA; FOR Q:=1 TO COPIES DO WRTPAGE; WRITE_DATA; END. ======================================================================================== DOCUMENT :usus Folder:VOL09:adv.doc.text ======================================================================================== ADVENTURE. The history of this version of adventure has been lost, and I am unable to credit the originator. This program was converted to UCSD Pascal from a PL/1 version found on our local computer system. This version was obviously converted from a Fortran version (it said so in the comments) but any history was not indicated. If you need assistance with this program, you can write me. My address is: Michael R. Turner 1622 Colonial Way Frederick Md. 21701 (301)-663-9181 GETTING STARTED. The steps required to run adventure are: 1). Compile ADVINIT.TEXT. File needed is: ADVINIT.TEXT 2). Compile ADV.TEXT. Files needed are: ADV.TEXT ADVSUBS.TEXT ADVVERB.TEXT 3). Run ADVINIT to build the required files for Adventure. Files needed are: ADVS1.TEXT ADVS2.TEXT ADVS3.TEXT ADVS4.TEXT ADVS5.TEXT ADVS6.TEXT ADVS7.TEXT ADVS8.TEXT ADVS9.TEXT ADVS10.TEXT ADVS11.TEXT ADVINIT.CODE There are two output files produced by ADVINIT: ADVMSGS[79] ADVDATA[23] Insure that there are at least 102 free contiguous blocks on the prefix disk. ADVINIT creates the msg file completely before opening the data file. That way ADVINIT will work ok if exactly 102 free blocks are available. 4). Build an ADV.MISCINFO file. This is nothing more than a text file with two numbers in it.The format is HEIGHT WIDTH. (eg. 24 80) If you are an APPLE user using the 24x40 screen, this is not necessary (see Notes, below). 5). The only files needed to run adventure are: ADVDATA ADVMSGS ADV.CODE Move these files to an appropriate disk if necessary. 6). Be prepared to spend hours exploring the cave. Try not to look at the source or the messages until all of adventuredom pays tribute to you, Oh Grand Master Adventurer! Notes: There is a save game feature. Try SAVE. You might like it. The program asks for your name, but any identifier can be used as long as it is valid for a filename. Each save file requires 6 blocks. The system clock is used to initialize the random number generator. If the value returned by the TIME function is zero, then the user is prompted for a number to start the random number generator. The system MISCINFO is not used because the APPLE sets the screen width to 80 on the 40 char screen. Flipping side to side may be OK during editing, but not during ADVenture. Also, The program defaults are such that APPLE users do not need an ADV.MISCINFO. ADV.TEXT has {$S+} to allow it to compile on most machines. ============================================================== PROGRAM-SECTION. ADV.TEXT............The adventure program. ADVSUBS.TEXT........Include file of adventure program. ADVVERB.TEXT........ "" ADVINIT.TEXT.......Initialization program. This program reads ADVS1 through ADVS11 and produces ADVDATA and ADVMSGS. These files must be on the default disk in order to run the adventure program. ============================================================== DATA-FILES-SECTION. ADV.MISCINFO........Sample miscinfo for adventure. ASVS1.TEXT..........Long form descriptions. Each line contains a location number, a space, and a line of text. The set of adjacent lines whose numbers are X form the long description of location X. ADVS2.TEXT..........Short form descriptions. Same format as ADVS1.TEXT. Not all places have short descriptions. ADVS3.TEXT..........Travel Table. Each line contains a location number (X), a condition value (M), a second location number (N), and a list of motion numbers from ADVS4.TEXT. Each motion represents a verb which will take you to N if you are at X. M and N are interpreted as follows: If N<=300 location to go to. If 300500 Message N-500 is to be issued. Meanwhile, M specifies the condition of motion. If M=0 Unconditional. If 0 0. If 400 1. If 500 2. Etc. If the condition is not met, then the next *DIFFERENT* 'destination' value is used (Unless it fails to meet *ITS* conditions, in which case the next is found, etc). Typically, the next destination will be for one of the same verbs, so that its only use is as the alternate destination for those verbs. For instance: 15 110 22 29 31 34 35 23 43 15 0 14 45 says that from location 15, any of the verbs (29,31,...,43) will take you to 22 if you are carrying object 10. Otherwise, they or verb 45 will take you to location 14. 11 303 8 49 11 0 9 50 says that from 11, 49 takes him to 8 unless the PROP(3)=0. In that case, 49 takes you to 9. Verb 50 always takes you to 9. ADVS4.TEXT..........Vocabulary Each line contains a number and a five letter word. Let M=N DIV 1000. If M=0. The word is a motion verb used in ADVS3.TEXT. If M=1. The word is an object. If M=2. The word is an action word (eg ATTACK). If M=3. Special case word. N MOD 1000 is an index into ADVS6.TEXT messages. ADVS5.TEXT..........Object descriptions. Each line contains a number and a message. If 1<=N<=100, it is the 'INVENTORY' message for object N. Otherwise N should be 000,100,200 etc and the message is the description of the preceding object when its property value is N DIV 100. The N DIV 100 is used to destinguish from multiple messages from multi-line messages. Properties that produce no message must be given a null message. ADVS6.TEXT..........Miscellaneous messages. Same format as ADVS1,ADVS2 and ADVS5, except that the numbers are not related to anything. (Except for special verbs in ADVS4). ADVS7.TEXT..........Object locations. Each line contains an object number and its initial location (zero if none) and a second location (also zero if none). If the object is immovable, the second location is set to -1. If the object has two locations (eg GRATE), the second location field is set to the second location and is assumed to be immovable. ADVS8.TEXT..........Action defaults. Each line contains an 'ACTION-VERB' number and the index (into ADVS6) of the default message for the verb. ADVS9.TEXT..........Liquid Assetts, etc. Each line contains a number (N) and up to 20 location numbers. Bit N (where 0 is the units bit) is set in COND(LOC) for each loc given. The bits currently assigned are: 0 Light 1 If bit 2 is on; 1=oil,0=water. 2 Liquid asset, set bit 1. 3 Pirate doesn't go here unless following player. The other bits are used to indicate areas of interest to the hint routines: 4 Trying to get into the cave. 5 Trying to catch the bird. 6 Trying to deal with the snake. 7 Lost in maze. 8 Pondering the dark room. 9 At witts end. COND(LOC) is set to 2, overriding all other bits, if LOC has forced motion. ADVS10.TEXT.........Player class messages. Each line contains a number N and a message describing the classification of the player. The scoring section selects the appropriate message. A message applies to a players whose scores are higher than the previous N but not higher than this N. ADVS11.TEXT.........Hints. Each line contains a hint number corresponding to the COND(LOC) bits (see ADVS9), the number of turns he must be at the right LOC(s) before triggering the hint, the points deducted for the hint, the message number of the question (from ADVS6) and the message number of the hint (also from ADVS6). Hint numbers 1-3 are no usable as the COND(LOC) bits 1-3 are otherwise assigned. ======================================================================================== DOCUMENT :usus Folder:VOL09:adv.miscinfo ======================================================================================== 16 64 FIRST NUMBER IS HEIGHT SECOND IS WIDTH ======================================================================================== DOCUMENT :usus Folder:VOL09:adv.text ======================================================================================== {$S+} PROGRAM ADVENTURE; CONST VERSION = 5; KEYS = 1; LAMP = 2; GRATE = 3; CAGE = 4; ROD = 5; ROD2 = 6; STEPS = 7; BIRD = 8; DOOR = 9; PILLOW = 10; SNAKE = 11; FISSURE = 12; TABLET = 13; CLAM = 14; OYSTER = 15; MAGAZINE = 16; DWARF = 17; KNIFE = 18; FOOD = 19; BOTTLE = 20; WATER = 21; OIL = 22; PLANT = 24; PLANT2 = 25; AXE = 28; MIRROR = 23; DRAGON = 31; CHASM = 32; TROLL = 33; TROLL2 = 34; BEAR = 35; MESSAGE = 36; VEND_MACHINE = 38; BATTERY = 39; NUGGET = 50; COINS = 54; CHEST = 55; EGGS = 56; TRIDENT = 57; VASE =58; EMERALD = 59; PYRAMID = 60; PEARL = 61; RUG = 62; CHAIN = 64; SPICES = 63; CAVE = 67; BACK = 8; LOOK = 57; NULL = 21; ENTRANCE = 64; DEPRESSION = 63; SAY = 3; LOCK = 6; THROW = 17; FIND = 19; INVENTORY = 20; MAXTRS = 64; MAXDIE = 3; MAXHLD = 6; DALTLC = 18; TYPE CH512 = PACKED ARRAY[1..512] OF CHAR; CHAR6 = PACKED ARRAY[1..6] OF CHAR; ARYS = RECORD CASE BOOLEAN OF FALSE : (DBLK : CH512); TRUE : (TRAVEL : ARRAY[1..750] OF INTEGER; TRAVEL2 : ARRAY[1..750] OF INTEGER; TRAVEL3 : ARRAY[1..750] OF INTEGER; ATAB : ARRAY[1..300] OF STRING[5]; KTAB : ARRAY[1..300] OF INTEGER; LTEXT : ARRAY[1..150] OF INTEGER; STEXT : ARRAY[1..150] OF INTEGER; KEY : ARRAY[1..150] OF INTEGER; PLAC : ARRAY[1..100] OF INTEGER; FIXD : ARRAY[1..100] OF INTEGER; PTEXT : ARRAY[1..100] OF INTEGER; ACTSPK : ARRAY[1..35] OF INTEGER; RTEXT : ARRAY[1..205] OF INTEGER; CTEXT : ARRAY[1..12] OF INTEGER; CVAL : ARRAY[1..12] OF INTEGER; HINTS : ARRAY[1..20,1..4] OF INTEGER) END; VARYS = RECORD CASE BOOLEAN OF FALSE : (DBLK : CH512); TRUE : (COND : ARRAY[1..150] OF INTEGER; ABB : ARRAY[1..150] OF INTEGER; ATLOC : ARRAY[1..150] OF INTEGER; PLACE : ARRAY[1..100] OF INTEGER; FIXED : ARRAY[1..100] OF INTEGER; LINK : ARRAY[1..200] OF INTEGER; PROP : ARRAY[1..100] OF INTEGER; HINTLC : ARRAY[1..20] OF INTEGER; HINTED : ARRAY[1..20] OF BOOLEAN; DSEEN : ARRAY[1..6] OF BOOLEAN; DLOC : ARRAY[1..6] OF INTEGER; ODLOC : ARRAY[1..6] OF INTEGER; TK : ARRAY[1..20] OF INTEGER) END; VBLS = RECORD CASE BOOLEAN OF FALSE : (DBLK : CH512); TRUE : (HLDING,LOC,OLDLOC : INTEGER; OLDLC2,CLOCK1,CLOCK2 : INTEGER; CHLOC,CHLOC2,TALLY,TALLY2 : INTEGER; DFLAG,DTOTAL,FOOBAR,TURNS : INTEGER; VERB,OBJ,LIMIT,IWEST,KNFLOC : INTEGER; ABBNUM,DKILL,NUMDIE,DETAIL : INTEGER; PANIC,CLOSING,CLOSED,WZDARK : BOOLEAN; VERSION : INTEGER; PASSWORD : STRING[20]) END; VAR NEWLOC,RESTART,I,J,K,KK,K2 : INTEGER; MAXSCORE,TVCOND,ATTACK,STICK : INTEGER; FOO,SCORE,HINT,SPK : INTEGER; BONUS,SEED : INTEGER; RESUME,OK,SKIPIT,STEAL : BOOLEAN; GAVEUP,YEA,SKIPDWARF,ALLDONE,HE_DIED,PIT : BOOLEAN; NEWLOCSET,LMWARN,SKIPDESCRIBE : BOOLEAN; HNTSIZ,CLSSES : INTEGER; ARY : ^ARYS; VARY : ^VARYS; VBL : ^VBLS; LINE,TERMWIDTH,TERMHIGHT : INTEGER; KKWORD,WD1,WD2 : STRING[5]; WD1X,WD2X : STRING; ACHAR : STRING[1]; TESTPW : STRING[20]; NAMEOFUSER : STRING[40]; INFILE : FILE; MSGFILE : FILE OF CHAR6; PROCEDURE READINIT(VAR BFR:CH512;NUM:INTEGER); BEGIN { READINIT } NUM:=(NUM+511) DIV 512; IF NUM<>BLOCKREAD(INFILE,BFR,NUM) THEN BEGIN WRITE('ERROR READING ARRAY FILE'); EXIT(ADVENTURE); END; END; { READINIT } PROCEDURE INITIALIZE; VAR I,J,K,X : INTEGER; ININFO : TEXT; PROCEDURE INITP2; VAR I,J : INTEGER; BEGIN { INITP2} TIME(I,J); IF J=0 THEN J:=I; WHILE J=0 DO BEGIN WRITELN('NO CLOCK.'); WRITELN('PLEASE ENTER A NUMBER FROM 1 TO 32767 '); READ(J); WRITELN; END; IF (J MOD 2)=0 THEN J:=J+1; SEED:=J; LINE:=1; VARY^.DLOC[1]:=19; VARY^.DLOC[2]:=27; VARY^.DLOC[3]:=33; VARY^.DLOC[4]:=44; VARY^.DLOC[5]:=64; VARY^.DLOC[6]:=114; VBL^.CHLOC:=114; VBL^.CHLOC2:=140; VBL^.ABBNUM:=5; BONUS:=0; VBL^.OLDLOC:=0; VBL^.OLDLC2:=0; RESTART:=0; KK:=0; VBL^.TALLY:=0; VBL^.TALLY2:=0; TVCOND:=0; VBL^.DKILL:=0; VBL^.DFLAG:=0; VBL^.DTOTAL:=0; ATTACK:=0; STICK:=0; VBL^.KNFLOC:=0; MAXSCORE:=0; VBL^.FOOBAR:=0; VBL^.TURNS:=0; VBL^.VERB:=0; VBL^.OBJ:=0; VBL^.IWEST:=0; FOO:=0; VBL^.NUMDIE:=0; SCORE:=0; VBL^.DETAIL:=0; VBL^.HLDING:=0; SPK:=0; OK:=FALSE; SKIPIT:=FALSE; STEAL:=FALSE; VBL^.PANIC:=FALSE; VBL^.CLOSING:=FALSE; VBL^.CLOSED:=FALSE; VBL^.WZDARK:=FALSE; GAVEUP:=FALSE; SKIPDWARF:=FALSE; ALLDONE:=FALSE; LMWARN:=FALSE; SKIPDESCRIBE:=FALSE; ALLDONE:=FALSE; HE_DIED:=FALSE; SKIPDWARF:=FALSE; PIT:=FALSE; NEWLOCSET:=FALSE; KKWORD:=''; WD1:=''; WD2:=''; WD1X:=''; WD2X:=''; ACHAR:=' '; END; { INITP2} BEGIN {INITIALIZE} { READ IN ARRAYS } {$I-} RESET(ININFO,'ADV.MISCINFO'); {$I+} IF IORESULT=0 THEN BEGIN READ(ININFO,TERMHIGHT,TERMWIDTH); CLOSE(ININFO); END ELSE BEGIN TERMHIGHT:=24;{DEFAULT FOR APPLE} TERMWIDTH:=40; END; RESET(INFILE,'ADVDATA'); RESET(MSGFILE,'ADVMSGS'); NEW(ARY); READINIT(ARY^.DBLK,SIZEOF(ARYS)); NEW(VARY); READINIT(VARY^.DBLK,SIZEOF(VARYS)); CLOSE(INFILE); NEW(VBL); INITP2; CLSSES:=0; FOR I:=1 TO 12 DO IF ARY^.CTEXT[I]<>0 THEN CLSSES:=I; FOR I:=4 TO 20 DO IF ARY^.HINTS[I,1]<>0 THEN HNTSIZ:=I; FOR X:=50 TO 64 DO IF ARY^.PTEXT[X]<>0 THEN VBL^.TALLY:=VBL^.TALLY - VARY^.PROP[X]; FOR I:=1 TO 300 DO IF ARY^.ATAB[I]='' THEN BEGIN ARY^.ATAB[I]:=' '; ARY^.ATAB[I,1]:=CHR(255); ARY^.ATAB[I,2]:=CHR(I DIV 256); ARY^.ATAB[I,3]:=CHR(I MOD 256); END; END; {INITIALIZE} {$I ADVSUBS.TEXT} PROCEDURE GETNEWCOMMAND; VAR W1FLAG,DONE : BOOLEAN; INLINE : STRING; BEGIN { GETNEWCOMMAND } IF VBL^.CLOSED THEN BEGIN IF (VARY^.PROP[OYSTER]<0) AND TOTING(OYSTER) THEN PSPEAK(OYSTER,1); FOR I:=1 TO 100 DO IF TOTING(I) AND (VARY^.PROP[I]<0) THEN VARY^.PROP[I]:=-1-VARY^.PROP[I]; END; LINE:=1; WD1:=''; WD2:=''; WD1X:=''; WD2X:=''; VBL^.WZDARK:=DARK; IF (VBL^.KNFLOC>0) AND (VBL^.KNFLOC<>VBL^.LOC) THEN VBL^.KNFLOC:=0; I:=RAN(1); REPEAT READLN(INLINE); INLINE:=CONCAT(INLINE,' :'); WHILE INLINE[1]=' ' DO DELETE(INLINE,1,1); UNTIL INLINE<>':'; W1FLAG:=FALSE; DONE:=FALSE; REPEAT ACHAR:=COPY(INLINE,1,1); DELETE(INLINE,1,1); IF ACHAR=' ' THEN BEGIN DONE:=W1FLAG; W1FLAG:=TRUE END ELSE IF W1FLAG THEN IF LENGTH(WD2)=5 THEN WD2X:=CONCAT(WD2X,ACHAR) ELSE WD2:=CONCAT(WD2,ACHAR) ELSE IF LENGTH(WD1)=5 THEN WD1X:=CONCAT(WD1X,ACHAR) ELSE WD1:=CONCAT(WD1,ACHAR) UNTIL DONE; END; { GETNEWCOMMAND } PROCEDURE DOWHATHESAYS; {$I ADVVERB.TEXT} PROCEDURE ANALANOBJ; PROCEDURE ASKWHATTODO; BEGIN {ASKWHATTODO} IF WD2<>'' THEN BEGIN RESTART:=1; EXIT(ANALANOBJ); END; IF VBL^.VERB<>0 THEN BEGIN ANALATVERB; EXIT(ANALANOBJ); END; WRITELN('WHAT DO YOU WANT TO DO WITH THE ',WD1,WD1X); RESTART:=1; EXIT(DOWHATHESAYS); END; {ASKWHATTODO} BEGIN { ANALANOBJ } VBL^.OBJ:=K; IF (VARY^.FIXED[K]=VBL^.LOC) OR HERE(K) THEN ASKWHATTODO; IF K=GRATE THEN BEGIN IF (VBL^.LOC=1) OR (VBL^.LOC=4) OR (VBL^.LOC=7) THEN K:=DEPRESSION; IF (VBL^.LOC>9) AND (VBL^.LOC<15) THEN K:=ENTRANCE; IF K<>GRATE THEN BEGIN SET_NEW_LOC; EXIT(ANALANOBJ); END; END; IF K=DWARF THEN FOR I:=1 TO 5 DO IF (VARY^.DLOC[I]=VBL^.LOC) AND (VBL^.DFLAG>=2) THEN ASKWHATTODO; IF ((LIQ=K) AND HERE(BOTTLE)) OR (K=LIQLOC(VBL^.LOC)) THEN ASKWHATTODO; IF (VBL^.OBJ=PLANT) AND AT(PLANT2) AND (VARY^.PROP[PLANT2]=0) THEN BEGIN VBL^.OBJ:=PLANT2; ASKWHATTODO; END; IF (VBL^.OBJ=KNIFE) AND (VBL^.KNFLOC=VBL^.LOC) THEN BEGIN VBL^.KNFLOC:=-1; SPEAK(ARY^.RTEXT[116]); END ELSE IF (VBL^.OBJ=ROD) AND HERE(ROD2) THEN BEGIN VBL^.OBJ:=ROD2; ASKWHATTODO; END ELSE IF ((VBL^.VERB=FIND) OR (VBL^.VERB=INVENTORY)) AND (WD2='') THEN ASKWHATTODO ELSE WRITELN('I SEE NO ',WD1,WD1X,' HERE.'); SKIPDWARF:=TRUE; SKIPDESCRIBE:=TRUE; EXIT(DOWHATHESAYS); END; { ANALANOBJ } PROCEDURE ANALAVERB; BEGIN { ANALAVERB } VBL^.VERB:=K; SPK:=ARY^.ACTSPK[VBL^.VERB]; IF (WD2<>'') AND (VBL^.VERB<>SAY) THEN BEGIN RESTART:=1; EXIT(ANALAVERB); END; IF VBL^.VERB=SAY THEN IF WD2='' THEN ANALANITVERB ELSE ANALATVERB ELSE IF VBL^.OBJ=0 THEN ANALANITVERB ELSE ANALATVERB; END; { ANALAVERB } PROCEDURE CLOSE1; BEGIN {CLOSE1} VARY^.PROP[GRATE]:=0; VARY^.PROP[FISSURE]:=0; FOR I:=1 TO 6 DO VARY^.DSEEN[I]:=FALSE; MOVE(TROLL,0); MOVE(TROLL+100,0); MOVE(TROLL2,ARY^.PLAC[TROLL]); MOVE(TROLL2+100,VARY^.FIXED[TROLL]); JUGGLE(CHASM); IF VARY^.PROP[BEAR]<>3 THEN DESTROY(BEAR); VARY^.PROP[CHAIN]:=0; VARY^.FIXED[CHAIN]:=0; VARY^.PROP[AXE]:=0; VARY^.FIXED[AXE]:=0; SPEAK(ARY^.RTEXT[129]); VBL^.CLOCK1:=-1; VBL^.CLOSING:=TRUE; END; {CLOSE2} PROCEDURE CLOSE2; BEGIN {CLOSE2} VARY^.PROP[BOTTLE]:=PUT(BOTTLE,115,1); VARY^.PROP[PLANT]:=PUT(PLANT,115,0); VARY^.PROP[OYSTER]:=PUT(OYSTER,115,0); VARY^.PROP[LAMP]:=PUT(LAMP,115,0); VARY^.PROP[ROD]:=PUT(ROD,115,0); VARY^.PROP[DWARF]:=PUT(DWARF,115,0); VBL^.LOC:=115; VBL^.OLDLOC:=115; NEWLOC:=115; FOO:=PUT(GRATE,116,0); VARY^.PROP[SNAKE]:=PUT(SNAKE,116,1); VARY^.PROP[BIRD]:=PUT(BIRD,116,1); VARY^.PROP[CAGE]:=PUT(CAGE,116,0); VARY^.PROP[ROD2]:=PUT(ROD2,116,0); VARY^.PROP[PILLOW]:=PUT(PILLOW,116,0); VARY^.PROP[MIRROR]:=PUT(MIRROR,115,0); VARY^.FIXED[MIRROR]:=116; FOR I:=1 TO 100 DO IF TOTING(I) THEN DESTROY(I); SPEAK(ARY^.RTEXT[132]); VBL^.CLOSED:=TRUE; EXIT(DOWHATHESAYS); END; {CLOSE2} BEGIN { DOWHATHESAYS } IF VBL^.FOOBAR>0 THEN VBL^.FOOBAR:=-VBL^.FOOBAR ELSE VBL^.FOOBAR:=0; VBL^.TURNS:=VBL^.TURNS+1; K:=SAY; IF (VBL^.VERB=SAY) AND (WD2<>'') THEN VBL^.VERB:=0; IF VBL^.VERB<>SAY THEN BEGIN IF (VBL^.TALLY=0) AND (VBL^.LOC>=15) AND (VBL^.LOC<>33) THEN VBL^.CLOCK1:=VBL^.CLOCK1-1; IF VBL^.CLOCK1=0 THEN CLOSE1 ELSE IF VBL^.CLOCK1<0 THEN VBL^.CLOCK2:=VBL^.CLOCK2-1; IF VBL^.CLOCK2=0 THEN CLOSE2 ELSE BEGIN IF VARY^.PROP[LAMP]=1 THEN VBL^.LIMIT:=VBL^.LIMIT-1; IF (VBL^.LIMIT<=30) AND HERE(BATTERY) AND (VARY^.PROP[BATTERY]=0) AND HERE(LAMP) THEN BEGIN SPEAK(ARY^.RTEXT[188]); VARY^.PROP[BATTERY]:=1; IF TOTING(BATTERY) THEN DROP(BATTERY,VBL^.LOC); VBL^.LIMIT:=VBL^.LIMIT+2500; LMWARN:=FALSE; END ELSE IF VBL^.LIMIT=0 THEN BEGIN VBL^.LIMIT:=-1; VARY^.PROP[LAMP]:=0; IF HERE(LAMP) THEN SPEAK(ARY^.RTEXT[184]); END ELSE IF (VBL^.LIMIT<0) AND (VBL^.LOC<=8) THEN BEGIN SPEAK(ARY^.RTEXT[185]); ALLDONE:=TRUE; GAVEUP:=TRUE; EXIT(DOWHATHESAYS); END ELSE IF VBL^.LIMIT<=30 THEN BEGIN IF NOT LMWARN AND HERE(LAMP) THEN BEGIN LMWARN:=TRUE; SPK:=187; IF VARY^.PLACE[BATTERY]=0 THEN SPK:=183; IF VARY^.PROP[BATTERY]=1 THEN SPK:=189; SPEAK(ARY^.RTEXT[SPK]); END; END; K:=43; {WHERE?} IF LIQLOC(VBL^.LOC)=WATER THEN K:=70; IF (WD1='ENTER') AND ((WD2='STREA') OR (WD2='WATER')) THEN BEGIN SPEAK(ARY^.RTEXT[K]); SKIPDWARF:=TRUE; SKIPDESCRIBE:=TRUE; END ELSE REPEAT RESTART:=0; IF (WD1='ENTER') AND (WD2<>'') THEN BEGIN WD1:=WD2; WD1X:=WD2X; WD2:=''; END ELSE BEGIN IF ((WD1='WATER') OR (WD1='OIL')) AND ((WD2='PLANT') OR (WD2='DOOR')) THEN IF AT(VOCAB(WD2,1)) THEN WD2:='POUR'; END; IF WD1='WEST' THEN BEGIN VBL^.IWEST:=VBL^.IWEST+1; IF VBL^.IWEST=10 THEN SPEAK(ARY^.RTEXT[17]); END; I:=VOCAB(WD1,-1); IF I=-1 THEN BEGIN SPK:=60; IF PERCENT(20) THEN SPK:=61; IF PERCENT(20) THEN SPK:=13; SPEAK(ARY^.RTEXT[SPK]); RESTART:=1; EXIT(DOWHATHESAYS); END ELSE BEGIN K:=I MOD 1000; CASE (I DIV 1000) OF 0 : SET_NEW_LOC; 1 : ANALANOBJ; 2 : ANALAVERB; 3 : BEGIN SKIPDWARF:=TRUE; SKIPDESCRIBE:=TRUE; IF K<>0 THEN SPEAK(ARY^.RTEXT[K]); END; END; IF RESTART<>0 THEN BEGIN WD1:=WD2; WD1X:=WD2X; WD2:=''; END; END; UNTIL RESTART=0; { SHORT RESTART } END; END; END; { DOWHATHESAYS } PROCEDURE REINCARNATION; BEGIN { REINCARNATION } IF HE_DIED THEN BEGIN IF PIT THEN BEGIN SPEAK(ARY^.RTEXT[23]); VBL^.OLDLC2:=VBL^.LOC; END; IF VBL^.CLOSING THEN BEGIN SPEAK(ARY^.RTEXT[131]); VBL^.NUMDIE:=VBL^.NUMDIE+1; END ELSE BEGIN YEA:=YES(81+(VBL^.NUMDIE*2),82+(VBL^.NUMDIE*2),54); VBL^.NUMDIE:=VBL^.NUMDIE+1; IF (VBL^.NUMDIE<>MAXDIE) AND YEA THEN BEGIN HE_DIED:=FALSE; { SAVED! } SKIPDWARF:=TRUE; VARY^.PLACE[WATER]:=0; VARY^.PLACE[OIL]:=0; IF TOTING(LAMP) THEN VARY^.PROP[LAMP]:=0; FOR J:=100 DOWNTO 1 DO IF TOTING(J) THEN BEGIN K:=VBL^.OLDLC2; IF J=LAMP THEN K:=1; DROP(J,K); END; VBL^.LOC:=3; VBL^.OLDLOC:=VBL^.LOC; END; END; END; END; { REINCARNATION } PROCEDURE ENDGAME; BEGIN { ENDGAME } SCORE:=GETSCORE(FALSE); WRITELN; WRITE('YOU SCORED ',SCORE,' OUT OF A POSSIBLE ',MAXSCORE); IF TERMWIDTH<64 THEN WRITELN; IF VBL^.TURNS=1 THEN KKWORD:='.' ELSE KKWORD:='S.'; WRITELN(' USING ',VBL^.TURNS,' TURN',KKWORD); FOR I:=1 TO CLSSES DO IF ARY^.CVAL[I]>=SCORE THEN BEGIN SPEAK(ARY^.CTEXT[I]); IF I=CLSSES THEN BEGIN WRITE('TO ACHIEVE THE NEXT HIGHER RATING WOULD '); IF TERMWIDTH<64 THEN WRITELN; WRITELN('BE A NEAT TRICK!'); WRITELN; WRITELN('CONGRATULATIONS'); END ELSE BEGIN K:=ARY^.CVAL[I]+1-SCORE; KKWORD:='S.'; IF K=1 THEN KKWORD:='.'; WRITE('TO ACHIEVE THE NEXT HIGHER RATING, YOU NEED '); IF TERMWIDTH<64 THEN WRITELN; WRITELN(K,' MORE POINT',KKWORD); END; I:=CLSSES; { EXIT THIS MESS } END; END; { ENDGAME } BEGIN { ADVENTURE } INITIALIZE; VARY^.HINTED[3]:=YES(65,1,0); IF VARY^.HINTED[3] THEN RESUME:=FALSE ELSE RESUME:=YES(201,0,0); IF RESUME THEN BEGIN NAMEANDPW; {$I-} RESET(INFILE,NAMEOFUSER); IF IORESULT<>0 THEN {$I+} BEGIN WRITELN('SORRY, YOU DO NOT HAVE A SAVED GAME'); RESUME:=FALSE; END ELSE BEGIN READINIT(VARY^.DBLK,SIZEOF(VARYS)); READINIT(VBL^.DBLK,SIZEOF(VBLS)); CLOSE(INFILE); IF TESTPW<>VBL^.PASSWORD THEN BEGIN WRITE('INCORRECT PASSWORD'); EXIT(ADVENTURE); END; IF VERSION<>VBL^.VERSION THEN BEGIN IF VERSION>VBL^.VERSION THEN WRITE('OLD SAVE FILE - NEW ') ELSE WRITE('NEW SAVE FILE - OLD '); WRITE('ADVENTURE. SORRY.'); EXIT(ADVENTURE); END; END; VBL^.LIMIT:=MAX(VBL^.LIMIT,150); { GIVE HIM SOME TIME} END; IF NOT RESUME THEN BEGIN VBL^.LOC:=1; VBL^.CLOCK1:=30; VBL^.CLOCK2:=50; IF VARY^.HINTED[3] THEN VBL^.LIMIT:=1000 ELSE VBL^.LIMIT:=330; END; NEWLOC:=VBL^.LOC; REPEAT REPEAT IF SKIPDWARF THEN SKIPDWARF:=FALSE ELSE BEGIN TESTCLOSE; VBL^.LOC:=NEWLOC; IF VBL^.LOC<>0 THEN IF NOT FORCED(VBL^.LOC) AND NOT BITSET(NEWLOC,3) THEN IF VBL^.DFLAG=0 THEN IF VBL^.LOC>=15 THEN VBL^.DFLAG:=1 ELSE ELSE DWARFSTUFF; END; NEWLOCSET:=FALSE; IF NOT HE_DIED THEN BEGIN IF SKIPDESCRIBE THEN SKIPDESCRIBE:=FALSE ELSE BEGIN WRITELN; DESCRIBE_CURRENT_LOCATION; END; IF NOT HE_DIED AND NOT NEWLOCSET THEN BEGIN VBL^.VERB:=0; VBL^.OBJ:=0; RESTART:=0; REPEAT IF RESTART<>2 THEN BEGIN CHECKHINTS; GETNEWCOMMAND; END; RESTART:=0; DOWHATHESAYS; UNTIL RESTART=0; {LONG RESTART} END; END; UNTIL HE_DIED OR ALLDONE; { MAIN LOOP } REINCARNATION; UNTIL HE_DIED OR ALLDONE; { NO MORE RE-INCARNATIONS} ENDGAME; END. ======================================================================================== DOCUMENT :usus Folder:VOL09:advinit.text ======================================================================================== PROGRAM BUILDINIT; TYPE CHAR6 = PACKED ARRAY[1..6] OF CHAR; ARYS = RECORD CASE BOOLEAN OF FALSE : ( DBLK : PACKED ARRAY[1..512] OF CHAR); TRUE : (TRAVEL : ARRAY[1..750] OF INTEGER; TRAVEL2 : ARRAY[1..750] OF INTEGER; TRAVEL3 : ARRAY[1..750] OF INTEGER; ATAB : ARRAY[1..300] OF STRING[5]; KTAB : ARRAY[1..300] OF INTEGER; LTEXT : ARRAY[1..150] OF INTEGER; STEXT : ARRAY[1..150] OF INTEGER; KEY : ARRAY[1..150] OF INTEGER; PLAC : ARRAY[1..100] OF INTEGER; FIXD : ARRAY[1..100] OF INTEGER; PTEXT : ARRAY[1..100] OF INTEGER; ACTSPK : ARRAY[1..35] OF INTEGER; RTEXT : ARRAY[1..205] OF INTEGER; CTEXT : ARRAY[1..12] OF INTEGER; CVAL : ARRAY[1..12] OF INTEGER; HINTS : ARRAY[1..20,1..4] OF INTEGER) END; VARYS = RECORD CASE BOOLEAN OF FALSE : ( DBLK : PACKED ARRAY[1..512] OF CHAR); TRUE : (COND : ARRAY[1..150] OF INTEGER; ABB : ARRAY[1..150] OF INTEGER; ATLOC : ARRAY[1..150] OF INTEGER; PLACE : ARRAY[1..100] OF INTEGER; FIXED : ARRAY[1..100] OF INTEGER; LINK : ARRAY[1..200] OF INTEGER; PROP : ARRAY[1..100] OF INTEGER; HINTLC : ARRAY[1..20] OF INTEGER; HINTED : ARRAY[1..20] OF BOOLEAN; DSEEN : ARRAY[1..6] OF BOOLEAN; DLOC : ARRAY[1..6] OF INTEGER; ODLOC : ARRAY[1..6] OF INTEGER; TK : ARRAY[1..20] OF INTEGER) END; VAR MSGNDX,SEG,CLASSES,RECNUM,I,J,K,COUNT : INTEGER; ACHAR : CHAR; ARY : ^ARYS; VARY : ^VARYS; MSGFILE : FILE OF CHAR6; SAVEMSG : STRING[10]; INFILE : TEXT; OUTFILE : FILE; PROCEDURE DROP(OBJECT,WHERE:INTEGER); BEGIN WITH VARY^ DO BEGIN IF OBJECT>100 THEN FIXED[OBJECT-100]:=WHERE ELSE PLACE[OBJECT]:=WHERE; IF WHERE>0 THEN BEGIN LINK[OBJECT]:=ATLOC[WHERE]; ATLOC[WHERE]:=OBJECT; END; END; END; PROCEDURE BLIP; BEGIN {BLIP} IF COUNT=50 THEN BEGIN COUNT:=0; WRITELN; WRITE(' .'); END ELSE WRITE('.'); COUNT:=COUNT+1; END; {BLIP} PROCEDURE BLIPER(MSG:STRING); BEGIN COUNT:=0; WRITELN; WRITE(MSG); END; PROCEDURE PUTMSG(MSG:STRING;SAME:BOOLEAN); VAR I : INTEGER; BEGIN { PUTMSG } IF LENGTH(MSG)=0 THEN MSG:=' '; IF SAME THEN BEGIN IF LENGTH(SAVEMSG)<>0 THEN RECNUM:=RECNUM-1; MSG:=CONCAT(SAVEMSG,MSG); SAVEMSG:=''; END ELSE BEGIN IF SAVEMSG<>'' THEN BEGIN WHILE LENGTH(SAVEMSG)<5 DO SAVEMSG:=CONCAT(SAVEMSG,' '); PUTMSG(' ',TRUE); END; MSGFILE^[1]:=CHR(ORD(MSGFILE^[1])+128); END; WHILE LENGTH(MSG)>=6 DO BEGIN PUT(MSGFILE); { PUT LAST MESSAGE } FOR I:=1 TO 6 DO MSGFILE^[I]:=MSG[I]; DELETE(MSG,1,6); RECNUM:=RECNUM+1; END; SAVEMSG:=MSG; IF LENGTH(SAVEMSG)<>0 THEN RECNUM:=RECNUM+1; END; { PUTMSG } PROCEDURE TXTREAD; VAR LAST,I : INTEGER; MSGTXT : STRING[128]; PROCEDURE PART1; BEGIN {PART1} IF ARY^.LTEXT[MSGNDX]=0 THEN ARY^.LTEXT[MSGNDX]:=RECNUM; END; {PART1} PROCEDURE PART2; BEGIN {PART2} IF ARY^.STEXT[MSGNDX]=0 THEN ARY^.STEXT[MSGNDX]:=RECNUM; END; {PART2} PROCEDURE PART5; BEGIN {PART5} IF (MSGNDX>0) AND (MSGNDX<=100) THEN IF ARY^.PTEXT[MSGNDX]=0 THEN ARY^.PTEXT[MSGNDX]:=RECNUM; END; {PART5} PROCEDURE PART6; BEGIN {PART6} IF ARY^.RTEXT[MSGNDX]=0 THEN ARY^.RTEXT[MSGNDX]:=RECNUM; END; {PART6} PROCEDURE PART10; BEGIN {PART10} CLASSES:=CLASSES+1; IF ARY^.CTEXT[CLASSES]=0 THEN ARY^.CTEXT[CLASSES]:=RECNUM; ARY^.CVAL[CLASSES]:=MSGNDX; END; {PART10} BEGIN {TXTREAD} LAST:=32761; REPEAT READ(INFILE,MSGNDX); BLIP; IF NOT EOF(INFILE) THEN BEGIN IF NOT EOLN(INFILE) THEN READ(INFILE,ACHAR); { ONE BLANK DELIMETER } CASE SEG OF 1 : PART1; 2 : PART2; 5 : PART5; 6 : PART6; 10 : PART10; END; READLN(INFILE,MSGTXT); PUTMSG(MSGTXT,MSGNDX=LAST); LAST:=MSGNDX; END; UNTIL EOF(INFILE); IF LENGTH(SAVEMSG)>0 THEN BEGIN WHILE LENGTH(SAVEMSG)<5 DO SAVEMSG:=CONCAT(SAVEMSG,' '); PUTMSG(' ',TRUE); END; CLOSE(INFILE); END; PROCEDURE SEGMENT1; BEGIN { SEGMENT1 } BLIPER(''); RESET(INFILE,'ADVS1.TEXT'); SEG:=1; TXTREAD; END; { SEGMENT1 } PROCEDURE SEGMENT2; BEGIN { SEGMENT2 } BLIPER(''); RESET(INFILE,'ADVS2.TEXT'); SEG:=2; TXTREAD; END; { SEGMENT2 } PROCEDURE SEGMENT3; VAR TVINDEX,INDEX,TRVL,TVCOND,VOIB : INTEGER; BEGIN { SEGMENT3 } TVINDEX:=1; BLIPER(''); RESET(INFILE,'ADVS3.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE,INDEX); BLIP; IF NOT EOLN(INFILE) THEN BEGIN READ(INFILE,TVCOND,TRVL); IF ARY^.KEY[INDEX]=0 THEN ARY^.KEY[INDEX]:=TVINDEX ELSE ARY^.TRAVEL[TVINDEX-1]:=-ARY^.TRAVEL[TVINDEX-1]; WHILE NOT EOLN(INFILE) DO BEGIN READ(INFILE,VOIB,ACHAR); ARY^.TRAVEL[TVINDEX]:=VOIB; ARY^.TRAVEL2[TVINDEX]:=TRVL; ARY^.TRAVEL3[TVINDEX]:=TVCOND; TVINDEX:=TVINDEX+1; END; ARY^.TRAVEL[TVINDEX-1]:=-ARY^.TRAVEL[TVINDEX-1]; READLN(INFILE); END; END; CLOSE(INFILE); END; { SEGMENT3 } PROCEDURE SEGMENT4; VAR WORDNUM,NUMBER : INTEGER; BEGIN { SEGMENT4 } WORDNUM:=1; BLIPER(''); RESET(INFILE,'ADVS4.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE,NUMBER); BLIP; IF NOT EOLN(INFILE) THEN BEGIN READ(INFILE,ACHAR); READLN(INFILE,ARY^.ATAB[WORDNUM]); ARY^.KTAB[WORDNUM]:=NUMBER; WORDNUM:=WORDNUM+1; END; END; CLOSE(INFILE); END; { SEGMENT4 } PROCEDURE SEGMENT5; BEGIN { SEGMENT5 } BLIPER(''); RESET(INFILE,'ADVS5.TEXT'); SEG:=5; TXTREAD; END; { SEGMENT5 } PROCEDURE SEGMENT6; BEGIN { SEGMENT6 } BLIPER(''); RESET(INFILE,'ADVS6.TEXT'); SEG:=6; TXTREAD; END; { SEGMENT6 } PROCEDURE SEGMENT7; VAR ILOC1,ILOC2,OBJECT : INTEGER; BEGIN { SEGMENT7 } BLIPER(''); RESET(INFILE,'ADVS7.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE,OBJECT); BLIP; IF NOT EOLN(INFILE) THEN BEGIN READLN(INFILE,ILOC1,ILOC2); ARY^.PLAC[OBJECT]:=ILOC1; ARY^.FIXD[OBJECT]:=ILOC2; END; END; CLOSE(INFILE); END; { SEGMENT7 } PROCEDURE SEGMENT8; VAR VOIB,MSGNUM : INTEGER; BEGIN { SEGMENT8 } BLIPER(''); RESET(INFILE,'ADVS8.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE,VOIB); BLIP; IF NOT EOLN(INFILE) THEN BEGIN READLN(INFILE,MSGNUM); ARY^.ACTSPK[VOIB]:=MSGNUM; END; END; CLOSE(INFILE); END; { SEGMENT8 } PROCEDURE SEGMENT9; VAR I,TEMP,COND,LOC : INTEGER; BEGIN { SEGMENT9 } BLIPER(''); RESET(INFILE,'ADVS9.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE,COND); BLIP; TEMP:=1; FOR I:=1 TO COND DO TEMP:=TEMP*2; IF NOT EOLN(INFILE) THEN WHILE NOT EOLN(INFILE) DO BEGIN READ(INFILE,LOC,ACHAR); VARY^.COND[LOC]:=VARY^.COND[LOC]+TEMP; END; READLN(INFILE); END; CLOSE(INFILE); END; { SEGMENT9 } PROCEDURE SEGMENTA; BEGIN { SEGMENTA } BLIPER(''); RESET(INFILE,'ADVS10.TEXT'); SEG:=10; TXTREAD; END; { SEGMENTA } PROCEDURE SEGMENTB; VAR HINT,TURNS,POINTS,QUES,ANS : INTEGER; BEGIN { SEGMENTB } BLIPER(''); RESET(INFILE,'ADVS11.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE,HINT); BLIP; IF NOT EOLN(INFILE) THEN BEGIN READLN(INFILE,TURNS,POINTS,QUES,ANS); ARY^.HINTS[HINT,1]:=TURNS; ARY^.HINTS[HINT,2]:=POINTS; ARY^.HINTS[HINT,3]:=QUES; ARY^.HINTS[HINT,4]:=ANS; END; END; CLOSE(INFILE); END; { SEGMENTB } PROCEDURE LINKUP; VAR K,I : INTEGER; BEGIN {LINKUP} BLIP; WITH ARY^,VARY^ DO FOR I:=1 TO 150 DO BEGIN IF (LTEXT[I]=0) OR (KEY[I]=0) THEN ELSE BEGIN K:=KEY[I]; IF TRAVEL[K]=1 THEN COND[I]:=2; END; END; BLIP; WITH ARY^ DO FOR I:=100 DOWNTO 1 DO BEGIN IF FIXD[I]>0 THEN BEGIN DROP(I+100,FIXD[I]); DROP(I,PLAC[I]); END; END; BLIP; WITH ARY^ DO FOR I:=100 DOWNTO 1 DO BEGIN VARY^.FIXED[I]:=FIXD[I]; IF (PLAC[I]<>0) AND (FIXD[I]<=0) THEN DROP(I,PLAC[I]); END; BLIP; WITH ARY^,VARY^ DO FOR I:=50 TO 64 DO BEGIN IF PTEXT[I]<>0 THEN PROP[I]:=-1; END; END; {LINKUP} BEGIN NEW(ARY); FILLCHAR(ARY^.DBLK,SIZEOF(ARYS),CHR(0)); { ZERO ARRAYS } NEW(VARY); FILLCHAR(VARY^.DBLK,SIZEOF(VARYS),CHR(0)); { ZERO ARRAYS } CLASSES:=0; RECNUM:=1; COUNT:=0; REWRITE(MSGFILE,'ADVMSGS'); MSGFILE^:='MSGFIL'; {WILL BE PUT } SAVEMSG:=''; SEGMENT1; {LONG DESCRIPTIONS} SEGMENT2; {SHORT DESCRIPTIONS} SEGMENT3; {TRAVEL OPTIONS} SEGMENT4; {WORD TABLE} SEGMENT5; {OBJECT PROPERTIES} SEGMENT6; {MISC MESSAGES} SEGMENT7; {OBJECT LOCATIONS} SEGMENT8; {VERB DEFAULT ACTIONS} SEGMENT9; {LIQUID ASSETS} SEGMENTA; {PLAYER CLASS MESSAGES} SEGMENTB; {HINTS} LINKUP; {BUILD MISC ARRAYS} PUTMSG('EXTMSG',FALSE); PUT(MSGFILE); {PURGE LAST BUFFER} CLOSE(MSGFILE,LOCK); WRITELN; WRITELN('WRITING ADVDATA'); REWRITE(OUTFILE,'ADVDATA'); I:=(SIZEOF(ARYS) + 511) DIV 512; IF I<>BLOCKWRITE(OUTFILE,ARY^.DBLK,I) THEN BEGIN WRITELN('ERROR WRITING FILE'); EXIT(BUILDINIT); END; I:=(SIZEOF(VARYS) + 511) DIV 512; IF I<>BLOCKWRITE(OUTFILE,VARY^.DBLK,I) THEN BEGIN WRITELN('ERROR WRITING FILE'); EXIT(BUILDINIT); END; CLOSE(OUTFILE,LOCK); WRITELN('FILE CREATED'); END. ======================================================================================== DOCUMENT :usus Folder:VOL09:advs1.text ======================================================================================== 1 YOU ARE STANDING AT THE END OF A ROAD BEFORE A SMA 1 LL BRICK BUILDING. AROUND YOU IS A FOREST. A SMA 1 LL STREAM FLOWS OUT OF THE BUILDING AND DOWN A GUL 1 LY. 2 YOU HAVE WALKED UP A HILL, STILL IN THE FOREST. T 2 HE ROAD SLOPES BACK DOWN THE OTHER SIDE OF THE HIL 2 L. THERE IS A BUILDING IN THE DISTANCE. 3 YOU ARE INSIDE A BUILDING, A WELL HOUSE FOR A LARG 3 E SPRING. 4 YOU ARE IN A VALLEY IN THE FOREST BESIDE A STREAM 4 TUMBLING ALONG A ROCKY BED. 5 YOU ARE IN OPEN FOREST, WITH A DEEP VALLEY TO ONE 5 SIDE. 6 YOU ARE IN OPEN FOREST NEAR BOTH A VALLEY AND A RO 6 AD. 7 AT YOUR FEET ALL THE WATER OF THE STREAM SPLASHES 7 INTO A 2 INCH SLIT IN THE ROCK. DOWNSTREAM THE ST 7 REAMBED IS BARE ROCK. 8 YOU ARE IN A 20 FOOT DEPRESSION FLOORED WITH BARE 8 DIRT. SET INTO THE DIRT IS A STRONG STEEL GRATE M 8 OUNTED IN CONCRETE. A DRY STREAMBED LEADS INTO TH 8 E DEPRESSION. 9 YOU ARE IN A SMALL CHAMBER BENEATH A 3X3 STEEL GRA 9 TE TO THE SURFACE. A LOW CRAWL OVER COBBLES LEADS 9 INWARD TO THE WEST. 10 YOU ARE CRAWLING OVER COBBLES IN A LOW PASSAGE. T 10 HERE IS A DIM LIGHT AT THE END OF THE PASSAGE. 11 YOU ARE IN A DEBRIS ROOM FILLED WITH STUFF WASHED 11 IN FROM THE SURFACE. A LOW WIDE PASSAGE WITH COBB 11 LES BECOMES PLUGGED WITH MUD AND DEBRIS HERE, BUT 11 AN AWKWARD CANYON LEADS UPWARD AND WEST. A NOTE O 11 N THE WALL SAYS 'MAGIC WORD XYZZY'. 12 YOU ARE IN AN AWKWARD SLOPING EAST/WEST CANYON. 13 YOU ARE IN A SPLENDID CHAMBER THIRTY FEET HIGH. T 13 HE WALLS ARE FROZEN RIVERS OF ORANGE STONE. AN AW 13 KWARD CANYON AND A GOOD PASSAGE EXIT FROM EAST AND 13 WEST SIDES OF THE CHAMBER. 14 AT YOUR FEET IS A SMALL PIT BREATHING TRACES OF WH 14 ITE MIST. AN EAST PASSAGE ENDS HERE EXCEPT FOR A 14 SMALL CRACK LEADING ON. 15 YOU ARE AT ONE END OF A VAST HALL STRETCHING FORWA 15 RD OUT OF SIGHT TO THE WEST. THERE ARE OPENINGS T 15 O EITHER SIDE. NEARBY, A WIDE STONE STAIRCASE LEA 15 DS DOWNWARD. THE HALL IS FILLED WITH WISPS OF WHI 15 TE MIST SWAYING TO AND FRO 15 ALMOST AS IF ALIVE. A COLD WIND BLOWS UP THE STA 15 IRCASE. THERE IS A PASSAGE AT THE TOP OF A DOME B 15 EHIND YOU. 16 THE CRACK IS FAR TOO SMALL FOR YOU TO FOLLOW. 17 YOU ARE ON THE EAST BANK OF A FISSURE SLICING CLEA 17 R ACROSS THE HALL. THE MIST IS QUITE THICK HERE, 17 AND THE FISSURE IS TOO WIDE TO JUMP. 18 THIS IS A LOW ROOM WITH A CRUDE NOTE ON THE WALL. 18 THE NOTE SAYS,'YOU WON'T GET IT UP THE STEPS'. 19 YOU ARE IN THE HALL OF THE MOUNTAIN KING, WITH PAS 19 SAGES OFF IN ALL DIRECTIONS. 20 YOU ARE AT THE BOTTOM OF THE PIT WITH A BROKEN NEC 20 K. 21 YOU DIDN'T MAKE IT. 22 THE DOME IS UNCLIMBABLE. 23 YOU ARE AT THE WEST END OF THE TWOPIT ROOM. THERE 23 IS A LARGE HOLE IN THE WALL ABOVE THE PIT AT THIS 23 END OF THE ROOM. 24 YOU ARE AT THE BOTTOM OF THE EASTERN PIT IN THE TW 24 OPIT ROOM. THERE IS A SMALL POOL OF OIL IN ONE CO 24 RNER OF THE PIT. 25 YOU ARE AT THE BOTTOM OF THE WESTERN PIT IN THE TW 25 OPIT ROOM. THERE IS A LARGE HOLE IN THE WALL ABOU 25 T 25 FEET ABOVE YOU. 26 YOU CLAMBER UP THE PLANT AND SCURRY THROUGH THE HO 26 LE AT THE TOP. 27 YOU ARE ON THE WEST SIDE OF THE FISSURE IN THE HAL 27 L OF MISTS. 28 YOU ARE IN A LOW N/S PASSAGE AT A HOLE IN THE FLOO 28 R. THE HOLE GOES DOWN TO AN E/W PASSAGE. 29 YOU ARE IN THE SOUTH SIDE CHAMBER. 30 YOU ARE IN THE WEST SIDE CHAMBER OF THE HALL OF TH 30 E MOUNTAIN KING. A PASSAGE CONTINUES WEST AND UP 30 HERE. 31 32 YOU CAN'T GET BY THE SNAKE. 33 YOU ARE IN A LARGE ROOM, WITH A PASSAGE TO THE SOU 33 TH, A PASSAGE TO THE WEST, AND A WALL OF BROKEN RO 33 CK TO THE EAST. THERE IS A LARGE 'Y2' ON A ROCK I 33 N THE ROOM'S CENTER. 34 YOU ARE IN A JUMBLE OF ROCK, WITH CRACKS EVERWHERE 34 . 35 YOU'RE AT A LOW WINDOW OVERLOOKING A HUGE PIT, WHI 35 CH EXTENDS UP OUT OF SIGHT. A FLOOR IS INDISTINCT 35 LY VISIBLE OVER 50 FEET BELOW. TRACES OF WHITE MI 35 ST COVER THE FLOOR OF THE PIT, BECOMING THICKER TO 35 THE RIGHT. 35 MARKS IN THE DUST AROUND THE WINDOW WOULD SEEM T 35 O INDICATE 35 THAT SOMEONE HAS BEEN HERE RECENTLY. DIRECTLY AC 35 ROSS THE PIT FROM YOU AND 25 FEET AWAY THERE IS A 35 SIMILAR WINDOW LOOKING INTO A LIGHTED ROOM. A SHA 35 DOWY FIGURE CAN BE SEEN THERE PEERING BACK AT YOU. 36 YOU ARE IN A DIRTY BROKEN PASSAGE. TO THE EAST IS 36 A CRAWL. TO THE WEST IS A LARGE PASSAGE. ABOVE 36 YOU IS A HOLE TO ANOTHER PASSAGE. 37 YOU ARE ON THE BRINK OF A SMALL CLEAN CLIMBABLE PI 37 T, A CRAWL LEADS WEST. 38 YOU ARE IN THE BOTTOM OF A SMALL PIT WITH A LITTLE 38 STREAM, WHICH ENTERS AND EXITS THROUGH TINY SLITS 38 . 39 YOU ARE IN A LARGE ROOM FULL OF DUSTY ROCKS. THER 39 E IS A BIG HOLE IN THE FLOOR. THERE ARE CRACKS EV 39 ERYWHERE, AND A PASSAGE LEADING EAST. 40 YOU HAVE CRAWLED THROUGH A VERY LOW WIDE PASSAGE P 40 ARALLEL TO AND NORTH OF THE HALL OF MISTS. 41 YOU ARE AT THE WEST END OF THE HALL OF MISTS. A L 41 OW WIDE CRAWL CONTINUES WEST AND ANOTHER GOES NORT 41 H. TO THE SOUTH IS A LITTLE PASSAGE 6 FEET OFF TH 41 E FLOOR. 42 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 42 LIKE. 43 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 43 LIKE. 44 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 44 LIKE. 45 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 45 LIKE. 46 DEAD END. 47 DEAD END. 48 DEAD END. 49 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 49 LIKE. 50 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 50 LIKE. 51 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 51 LIKE. 52 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 52 LIKE. 53 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 53 LIKE. 54 DEAD END. 55 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 55 LIKE. 56 DEAD END. 57 YOU ARE ON THE BRINK OF A THIRTY FOOT PIT WITH A M 57 ASSIVE ORANGE COLUMN DOWN ONE WALL. YOU COULD CLI 57 MB DOWN HERE BUT YOU COULD NOT GET BACK UP. THE M 57 AZE CONTINUES AT THIS LEVEL. 58 DEAD END. 59 YOU HAVE CRAWLED THROUGH A VERY LOW WIDE PASSAGE P 59 ARALLEL TO AND NORTH OF THE HALL OF MISTS. 60 YOU ARE AT THE EAST END OF A VERY LONG HALL APPARE 60 NTLY WITHOUT SIDE CHAMBERS. TO THE EAST A LOW WID 60 E CRAWL SLANTS UP. TO THE NORTH A ROUND TWO FOOT 60 HOLE SLANTS DOWN. 61 YOU ARE AT THE WEST END OF A VERY LONG FEATURELESS 61 HALL. THE HALL JOINS UP WITH A NARROW NORTH/SOUT 61 H PASSAGE. 62 YOU ARE AT A CROSSROADS OF A HIGH N/S PASSAGE AND 62 A LOW E/W ONE. 63 DEAD END. 64 YOU ARE AT A COMPLEX JUNCTION. A LOW HANDS AND KN 64 EES PASSAGE FROM THE NORTH JOINS A HIGHER CRAWL FR 64 OM THE EAST TO MAKE A WALKING PASSAGE GOING WEST. 64 THERE IS ALSO A LARGE ROOM ABOVE. THE AIR IS DAM 64 P HERE. 65 YOU ARE IN BEDQUILT, A LONG EAST/WEST PASSAGE WITH 65 HOLES EVERYWHERE. TO EXPLORE AT RANDOM SELECT NO 65 RTH, SOUTH, UP, OR DOWN. 66 YOU ARE IN A ROOM WHOSE WALLS RESEMBLE SWISS CHESE 66 . OBVIOUS PASSAGES GO WEST, EAST, NE, AND NW. PA 66 RT OF THE ROOM IS OCCUPIED BY A LARGE BEDROCK BLOC 66 K. 67 YOU ARE AT THE EAST END OF THE TWOPIT ROOM. THE F 67 LOOR HERE IS LITTERED WITH THIN ROCK SLABS, WHICH 67 MAKE IT EASY TO DESCEND THE PITS. THERE IS A PATH 67 HERE BYPASSING THE PITS TO CONNECT PASSAGES FROM 67 EAST AND WEST. 67 THERE ARE HOLES ALL OVER, BUT THE ONLY BIG ONE I 67 S ON THE WALL DIRECTLY OVER THE WEST PIT WHERE YOU 67 CAN'T GET TO IT. 68 YOU ARE IN A LARGE LOW CIRCULAR CHAMBER WHOSE FLOO 68 R IS AN IMMENSE SLAB FALLEN FROM THE CEILING (SLAB 68 ROOM). EAST AND WEST THERE ONCE WERE LARGE PASSA 68 GES, BUT THEY ARE NOW FILLED WITH BOULDERS. LOW S 68 MALL PASSAGES GO NORTH AND SOUTH, 68 AND THE SOUTH ONE QUICKLY BENDS WEST AROUND THE B 68 OULDERS. 69 YOU ARE IN A SECRET N/S CANYON ABOVE A LARGE ROOM. 70 YOU ARE IN A SECRET N/S CANYON ABOVE A SIZABLE PAS 70 SAGE. 71 YOU ARE IN A SECRET CANYON AT A JUNCTION OF THREE 71 CANYONS, BEARING NORTH, SOUTH, AND SE. THE NORTH 71 ONE IS AS TALL AS THE OTHER TWO COMBINED. 72 YOU ARE IN A LARGE LOW ROOM. CRAWLS LEAD NORTH SE 72 , AND SW. 73 DEAD END CRAWL. 74 YOU ARE IN A SECRET CANYON WHICH HERE RUNS E/W. I 74 T CROSSES OVER A VERY TIGHT CANYON 15 FEET BELOW. 74 IF YOU GO DOWN YOU MAY NOT BE ABLE TO GET BACK UP 74 . 75 YOU ARE AT A WIDE PLACE IN A VERY TIGHT N/S CANYON 75 . 76 THE CANYON HERE BECOMES TOO TIGHT TO GO FURTHER SO 76 UTH. 77 YOU ARE IN A TALL E/W CANYON. A LOW TIGHT CRAWL G 77 OES 3 FEET NORTH AND SEEMS TO OPEN UP. 78 THE CANYON RUNS INTO A MASS OF BOULDERS -- DEAD EN 78 D. 79 THE STREAM FLOWS OUT THROUGH A PAIR OF 1 FOOT DIAM 79 ETER SEWER PIPES. IT WOULD BE ADVISABLE TO USE TH 79 E EXIT. 80 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 80 LIKE. 81 DEAD END. 82 DEAD END. 83 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 83 LIKE. 84 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 84 LIKE. 85 DEAD END. 86 DEAD END. 87 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL A 87 LIKE. 88 YOU ARE IN A LONG, NARROW CORRIDOR STRETCHING OUT 88 OF SIGHT TO THE WEST. AT THE EASTERN END IS A WHO 88 LE THROUGH WHICH YOU CAN SEE A PROFUSION OF LEAVES 88 . 89 THERE IS NOTHING HERE TO CLIMB. USE 'UP' OR 'OUT' 89 TO LEAVE THE PIT. 90 YOU HAVE CLIMBED UP THE PLANT AND OUT OF THE PIT. 91 YOU ARE AT THE TOP OF A STEEP INCLINE ABOVE A LARG 91 E ROOM. YOU COULD CLIMB DOWN HERE, BUT YOU WOULD 91 NOT BE ABLE TO CLIMB UP. THERE IS A PASSAGE LEADI 91 NG BACK TO THE NORTH. 92 YOU ARE IN THE GIANT ROOM. THE CEILING HERE IS TO 92 O HIGH UP FOR YOUR LAMP TO SHOW IT. CAVERNOUS PAS 92 SAGES LEAD EAST, NORTH, AND SOUTH. ON THE WEST WA 92 LL IS SCRAWLED THE INSCRIPTION, 'FEE FIE FOE FOO' 92 (SIC). 93 THE PASSAGE HERE IS BLOCKED BY A RECENT CAVE-IN. 94 YOU ARE AT ONE END OF AN IMMENSE NORTH/SOUTH PASSA 94 GE. 95 YOU ARE IN A MAGNIFICIENT CAVERN WITH A RUSHING ST 95 REAM, WHICH CASCADES OVER A SPARKLING WATERFALL IN 95 TO A ROARING WHIRLPOOL WHICH DISAPEARS THROUGH A H 95 OLE IN THE FLOOR. PASSAGES EXIT TO THE SOUTH AND 95 WEST. 96 YOU ARE IN THE SOFT ROOM. THE WALLS ARE COVERED W 96 ITH HEAVY CURTAINS, THE FLOOR WITH A THICK PILE CA 96 RPET. MOSS COVERS THE CEILING. 97 THIS THE ORIENTAL ROOM. ANCIENT ORIENTAL CAVE DRA 97 WINGS COVER THE WALLS. A GENTLY SLOPING PASSAGE L 97 EADS UPWARD TO THE NORTH, ANOTHER PASSAGE LEADS SE 97 , AND A HANDS AND KNEES CRAWL LEADS WEST. 98 YOU ARE FOLLOWING A WIDE PATH AROUND THE OUTER EDG 98 E OF A LARGE CAVERN. FAR BELOW, THROUGH A HEAVY W 98 HITE MIST, STRANGE SPLASHING NOISES CAN BE HEARD. 98 THE MIST RISES UP THROUGH A FISSURE IN THE CEILIN 98 G. 98 THE PATH EXITS TO THE SOUTH AND WEST. 99 YOU ARE IN AN ALCOVE. A SMALL NW PATH SEEMS TO WI 99 DEN AFTER A SHORT DISTANCE. AN EXTREMLY TIGHT TUN 99 NEL LEADS EAST. IT LOOKS LIKE A VERY TIGHT SQUEEZ 99 E. AN EERIE LIGHT CAN BE SEEN AT THE OTHER END. 100 YOU'RE IN A SMALL CHAMBER LIT BY AN EERIE GREEN LI 100 GHT. AN EXTREMELY NARROW TUNNEL EXITS TO THE WEST 100 . A DARK CORRIDOR LEADS NE. 101 YOU'RE IN THE DARK-ROOM. A CORRIDOR LEADING SOUTH 101 IS THE ONLY EXIT. 102 YOU ARE IN AN ARCHED HALL. A CORAL PASSAGE ONCE C 102 ONTUINED UP AND EAST FROM HERE, BUT IS NOW BLOCKED 102 BY DEBRIS. THE AIR SMELLS OF SEA WATER. 103 YOU'RE IN A LARGE ROOM CARVED OUT OF SEDIMENTARY R 103 OCK. THE FLOOR AND WALLS ARE LITTERED WITH BITS O 103 F SHELLS IMBEDDED IN THE STONE. A SHALLOW PASSAGE 103 PROCEEDS DOWNWARD, AND A SOMEWHAT STEEPER ONE LEA 103 DS UP. 103 A LOW HANDS AND KNEES PASSAGE ENTERS FROM THE SO 103 UTH. 104 YOU ARE IN A LONG SLOPING CORRIDOR WITH RAGGED SHA 104 RP WALLS. 105 YOU ARE IN A CUL-DE-SAC ABOUT EIGHT FEET ACROSS. 106 YOU ARE IN AN ANTEROOM LEADING TO A LARGE PASSAGE 106 TO THE EAST. SMALL PASSAGES GO WEST AND UP. THE 106 REMNANTS OF RECENT DIGGING ARE EVIDENT. A SIGN IN 106 MIDAIR HERE SAYS 'CAVE UNDER CONSTRUCTION BEYOND 106 THIS POINT. 106 PROCEED AT OWN RISK. (WITT CONSTRUCTION COMPANY) 106 ' 107 YOU ARE IN A MAZE OF TWISTY LITTLE PASSAGES, ALL D 107 IFFERENT. 108 YOU ARE AT WITT'S END. PASSAGES LEAD OFF IN *ALL* 108 DIRECTIONS. 109 YOU ARE IN A NORTH/SOUTH CANYON ABOUT 25 FEET ACRO 109 SS. THE FLOOR IS COVERED BY WHITE MIST SEEPING IN 109 FROM THE NORTH. THE WALLS EXTEND UPWARD FOR WELL 109 OVER 100 FEET. SUSPENDED FROM SOME UNSEEN POINT 109 FAR ABOVE YOU, 109 AN ENORMOUS TWO-SIDED MIRROR 109 IS HANGING PARALLEL TO AND MIDWAY BETWEEN THE CAN 109 YON WALLS. (THE MIRROR IS OBVIOUSLY PROVIDED FOR 109 THE USE OF THE DWARVES, WHO AS YOU KNOW, ARE EXTRE 109 MELY VAIN.) A SMALL WINDOW CAN BE SEEN IN EITHER 109 WALL, SOME FIFTY FEET UP. 110 YOU'R AT A LOW WINDOW OVERLOOKING A HUGE PIT, WHIC 110 H EXTENDS UP OUT OF SIGHT. A FLOOR IS INDISTINCTL 110 Y VISIBLE OVER 50 FEET BELOW. TRACES OF WHITE MIS 110 T COVER THE FLOOR OF THE PIT, BECOMING THICKER TO 110 THE LEFT. 110 MARKS IN THE DUST AROUND THE WINDOW WOULD SEEM 110 TO INDICATE THAT SOMEONE HAS BEEN HERE RECENTLY. 110 DIRECTLY ACROSS THE PIT FROM YOU AND 25 FEET AWAY 110 THERE IS A SIMILAR WINDOW LOOKING INTO A LIGHTED 110 ROOM. A SHADOWY FIGURE CAN BE SEEN PEERING BACK A 110 T YOU. 111 A LARGE STALACTITE EXTENDS FROM THE ROOF AND ALMOS 111 T REACHES THE FLOOR BELOW. YOU COULD CLIMB DOWN I 111 T, AND JUMP FROM IT TO THE FLOOR,BUT HAVING DONE S 111 O YOU WOULD BE UNABLE TO REACH IT TO CLIMB BACK UP 111 . 112 YOU ARE IN A LITTLE MAZE OF TWISTING PASSAGES, ALL 112 DIFFERENT. 113 YOU ARE AT THE EDGE OF A LARGE UNDERGROUND RESERVO 113 IR. AN OPAQUE CLOUD OF WHITE MIST FILLS THE ROOM 113 AND RISES RAPIDLY UPWARD. THE LAKE IS FED BY A ST 113 REAM, WHICH TUMBLES OUT OF A HOLE IN THE WALL ABOU 113 T 10 FEET OVERHEAD AND SPLASHES 113 NOISILY INTO THE WATER SOMEWHERE WITHIN THE MIST. 113 THE ONLY PASSAGE GOES BACK TOWARD THE SOUTH. 114 DEAD END. 115 YOU ARE AT THE NORTHEAST END OF AN IMMENSE ROOM, E 115 VEN LARGER THAN THE GIANT ROOM. IT APPEARS TO BE 115 A REPOSITORY FOR THE ADVENTURE PROGRAM. MASSIVE T 115 ORCHES FAR OVERHEAD BATHE THE ROOM WITH SMOKY YELL 115 OW LIGHT. 115 SCATTERED ABOUT YOU CAN BE SEEN A NUMBER OF BOTT 115 LES (ALL OF THEM EMPTY), 115 A NURSERY OF YOUNG BEANSTALKS MURMURING QUIETLY, 115 A BED OF OYSTERS, A BUNDLE OF BLACK RODS WITH RUST 115 Y STARS ON THEIR ENDS, AND A COLLECTION OF BRASS L 115 ANTERNS. OFF TO ONE SIDE A GREAT MANY DWARVES ARE 115 SLEEPING ON THE FLOOR, SNORING LOUDLY. A SIGN NE 115 ARBY READS 'DO NOT DISTURB DWARVES.' AN IMMENSE M 115 IRROR IS HANGING AGAINST ONE WALL, AND STRETCHES T 115 O THE OTHER END OF THE ROOM, 115 WHERE VARIOUS OTHER SUNDRY OBJECTS CAN BE GLIMPSE 115 D DIMLY IN THE DISTANCE. 116 YOU ARE AT THE SOUTHWEST END OF THE REPOSITORY. T 116 O ONE SIDE IS A PIT FULL OF FIERCE GREEN SNAKES. 116 ON THE OTHER SIDE IS A ROW OF SMALL WICKER CAGES, 116 EACH OF WHICH CONTAINS A LITTLE SULKING BIRD. 116 IN ONE CORNER IS A BUNDLE OF BLACK RODS WITH RUS 116 TY MARKS ON THEIR ENDS. 116 A LARGE NUMBER OF VELVET PILLOWS ARE SCATTERED A 116 BOUT ON THE FLOOR. A VAST MIRROR STRETCHES OFF TO 116 THE NORTHEAST. AT YOUR FEET IS A LARGE STEEL GRA 116 TE, NEXT TO WHICH IS A SIGN WHICH READS, 'TREASURE 116 VAULT. KEYS IN MAIN OFFICE.' 117 YOU ARE ON ONE SIDE OF A LARGE, DEEP CHASM. A HEA 117 VY WHITE MIST RISING UP FROM BELOW OBSCURES ALL VI 117 EW OF THE FAR SIDE. A SW PATH LEADS AWAY FROM THE 117 CHASM INTO A WINDING CORRIDOR. 118 YOU ARE IN A LONG WINDING CORRIDOR SLOPING OUT OF 118 SIGHT IN BOTH DIRECTIONS. 119 YOU ARE IN A SECRET CANYON WHICH EXITS TO THE NORT 119 H AND EAST. 120 YOU ARE IN A SECRET CANYON WHICH EXITS TO THE NORT 120 H AND EAST. 121 YOU ARE IN A SECRET CANYON WHICH EXITS TO THE NORT 121 H AND EAST. 122 YOU ARE ON THE FAR SIDE OF THE CHASM. A NE PATH L 122 EADS AWAY FROM THE CHASM ON THIS SIDE. 123 YOU'RE IN A LONG EAST/WEST CORRIDOR. A FAINT RUMB 123 LING NOISE CAN BE HEARD IN THE DISTANCE. 124 THE PATH FORKS HERE. THE LEFT FORK LEADS NORTHEAS 124 T. A DULL RUMBLING SEEMS TO GET LOUDER IN THAT DI 124 RECTION. THE RIGHT FORK LEADS SOUTHEAST DOWN A GE 124 NTLE SLOPE. THE MAIN CORRIDOR ENTERS FROM THE WES 124 T. 125 THE WALLS ARE QUITE WARM HERE. FROM THE NORTH CAN 125 BE HEARD A STEADY ROAR, SO LOUD THAT THE ENTIRE C 125 AVE SEEMS TO BE TREMBLING. ANOTHER PASSAGE LEADS 125 SOUTH, AND A LOW CRAWL GOES EAST. 126 YOU ARE ON THE EDGE OF A BREATH TAKING VIEW. FAR 126 BELOW YOU IS AN ACTIVE VOLCANO, FROM WHICH GREAT G 126 OUTS OF MOULTEN LAVA COME SURGING OUT, CASCADING B 126 ACK DOWN INTO THE DEPTHS. 126 THE GLOWING ROCK FILLS THE FARTHEST REACHES OF T 126 HE CAVERN WITH A BLOOD-RED GLARE, GIVING EVERYTHIN 126 G AN EERIE, MACABRE APPEARANCE. 126 THE AIR IS FILLED WITH FLICKERING SPARKS OF ASH 126 AND A HEAVY SMELL OF BRIMSTONE. THE WALLS ARE HOT 126 TO THE TOUCH, AND THE THUNDERING OF THE VOLCANO D 126 ROWNS OUT ALL OTHER SOUNDS. 126 EMBEDDED IN THE JAGGED ROOF FAR OVERHEAD ARE MYR 126 IAD TWISTED FORMATIONS COMPOSED OF PURE WHITE ALAB 126 ASTER, WHICH SCATTER THE MURKY LIGHT INTO SINISTER 126 APPARITIONS UPON THE WALLS. 126 TO ONE SIDE IS A DEEP GORGE, FILLED WITH A BIZAR 126 RE CHAOS OF TORTURED ROCK WHICH SEEMS TO HAVE BEEN 126 CRAFTED BY THE DEVIL HIMSELF. 126 AN IMMENSE RIVER OF FIRE CRASHES OUT FROM THE DE 126 PTHS OF THE VOLCANO, BURNS ITS WAY THROUGH THE GOR 126 GE, AND PLUMMETS INTO A BOTTOMLESS PIT FAR OFF TO 126 YOUR LEFT. TO THE RIGHT, 126 AN IMMENSE GEYSER OF BLISTERING STEAM ERUPTS CONT 126 INUOUSLY FROM A BARREN ISLAND IN THE CENTER OF A S 126 ULPHOROUS LAKE, WHICH BUBBLES OMINOUSLY. THE FAR 126 RIGHT WALL IS AFLAME WITH AN INCANDESCENCE OF ITS 126 OWN, 126 WHICH LENDS AN ADDITIONAL INFERNAL SPLENDOR TO TH 126 E ALREADY HELLISH SCENE. A DARK FOREBODING PASSAG 126 E EXITS TO THE SOUTH. 127 YOU ARE IN A SMALL CHAMBER FILLED WITH LARGE BOULD 127 ERS. THE WALLS ARE VERY WARM, CAUSING THE AIR IN 127 THE ROOM TO BE ALMOST STIFLING FROM THE HEAT. THE 127 ONLY EXIT IS A CRAWL HEADING WEST, THROUGH WHICH 127 IS COMING LOW RUMBLING. 128 YOU ARE WALKING ALONG A GENTLY SLOPING NORTH/SOUTH 128 PASSAGE LINED WITH ODDLY SHAPED LIMESTONE FORMATI 128 ONS. 129 YOU ARE STANDING AT THE ENTRANCE TO A LARGE, BARRE 129 N ROOM. A SIGN POSTED ABOVE THE ENTRANCE READS 'C 129 AUTION. BEAR IN ROOM.' 130 YOU ARE IN A BARREN ROOM. THE CENTER OF THE ROOM 130 IS COMPLETELY EMPTY EXCEPT FOR SOME DUST. MARKS I 130 N THE DUST LEAD AWAY TOWARD THE FAR END OF THE ROO 130 M. THE ONLY EXIT IS THE WAY YOU CAME IN. 131 YOU ARE IN A MAZE OF TWISTING LITTLE PASSAGES, ALL 131 DIFFERENT. 132 YOU ARE IN A LITTLE MAZE OF TWISTY PASSAGES, ALL D 132 IFFERENT. 133 YOU ARE IN A TWISTING MAZE OF LITTLE PASSAGES, ALL 133 DIFFERENT. 134 YOU ARE IN A TWISTING LITTLE MAZE OF PASSAGES, ALL 134 DIFFERENT. 135 YOU ARE IN A TWISTY LITTLE MAZE OF PASSAGES, ALL D 135 IFFERENT. 136 YOU ARE IN A TWISTY MAZE OF LITTLE PASSAGES, ALL D 136 IFFERENT. 137 YOU ARE IN A LITTLE TWISTY MAZE OF PASSAGES, ALL D 137 IFFERENT. 138 YOU ARE IN A MAZE OF LITTLE TWISTING PASSAGES, ALL 138 DIFFERENT. 139 YOU ARE IN A MAZE OF LITTLE TWISTY PASSAGES, ALL D 139 IFFERENT. 140 DEAD END. ======================================================================================== DOCUMENT :usus Folder:VOL09:advs10.text ======================================================================================== 85 YOU ARE OBVIOUSLY A RANK AMATEUR. BETTER LUCK 85 NEXT TIME. 115 YOUR SCORE QUALIFIES YOU AS A NOVICE ADVENTURER. 155 YOU HAVE ACHIEVED THE RATING: "EXPERIENCED ADVENTURER". 190 YOU MAY NOW CONSIDER YOURSELF A "SEASONED ADVENTURER". 240 YOU HAVE REACHED "JUNIOR MASTER" STATUS. 280 YOUR SCORE PUTS YOU IN MASTER ADVENTURER CLASS C. 315 YOUR SCORE PUTS YOU IN MASTER ADVENTURER CLASS B. 345 YOUR SCORE PUTS YOU IN MASTER ADVENTURER CLASS A. 350 ALL OF ADVENTUREDOM GIVES TRIBUTE TO YOU, ADVENTURER 350 GRANDMASTER. ======================================================================================== DOCUMENT :usus Folder:VOL09:advs11.text ======================================================================================== 4 4 2 62 63 5 5 2 18 19 6 8 2 20 21 7 75 4 176 177 8 25 5 178 179 9 20 3 180 181 ======================================================================================== DOCUMENT :usus Folder:VOL09:advs2.text ======================================================================================== 1 YOU'RE AT END OF ROAD AGAIN. 2 YOU'RE AT HILL IN ROAD. 3 YOU'RE INSIDE BUILDING. 4 YOU'RE IN VALLEY. 5 YOU'RE IN FOREST. 6 YOU'RE IN FOREST. 7 YOU'RE AT SLIT IN STREAMBED. 8 YOU'RE OUTSIDE GRATE. 9 YOU'RE BELOW THE GRATE. 10 YOU'RE IN COBBLE CRAWL. 11 YOU'RE IN DEBRIS ROOM. 13 YOU'RE IN BIRD CHAMBER. 14 YOU'RE AT TOP OF SMALL PIT. 15 YOU'RE IN HALL OF MISTS. 17 YOU'RE ON EAST BANK OF FISSURE. 18 YOU'RE IN NUGGET OF GOLD ROOM. 19 YOU'RE IN HALL OF MT KING. 23 YOU'RE AT WEST END OF TWOPIT ROOM. 24 YOU'RE IN EAST PIT. 25 YOU'RE IN WEST PIT. 33 YOU'RE AT 'Y2'. 35 YOU'RE AT WINDOW ON PIT. 36 YOU'RE IN DIRTY PASSAGE. 39 YOU'RE IN DUSTY ROCK ROOM. 41 YOU'RE AT WEST END OF HALL OF MISTS. 57 YOU'RE AT BRINK OF PIT. 60 YOU'RE AT EAST END OF LONG HALL. 61 YOU'RE AT WEST END OF LONG HALL. 64 YOU'RE AT COMPLEX JUNCTION. 66 YOU'RE IN SWISS CHEESE ROOM. 67 YOU'RE AT EAST END OF TWOPIT ROOM. 68 YOU'RE IN SLAB ROOM. 71 YOU'RE AT JUNCTION OF THREE SECRET CANYONS. 74 YOU'RE IN SECRET E/W CANYON ABOVE TIGHT CANYON. 88 YOU'RE IN NARROW CORRIDOR. 91 YOU'RE AT STEEP INCLINE ABOVE LARGE ROOM. 92 YOU'RE IN GIANT ROOM. 95 YOU'RE IN CAVERN WITH WATERFALL. 96 YOU'RE IN SOFT ROOM. 97 YOU'RE IN ORIENTAL ROOM. 98 YOU'RE IN MISTY CAVERN. 99 YOU'RE IN ALCOVE. 100 YOU'RE IN PLOVER ROOM. 101 YOU'RE IN DARK ROOM. 102 YOU'RE IN ARCHED HALL. 103 YOU'RE IN SHELL ROOM. 106 YOU'RE IN ANTEROOM. 108 YOU'RE AT WITT'S END. 109 YOU'RE IN MIRROR CANYON. 110 YOU'RE AT WINDOW ON PIT. 111 YOU'RE AT TOP OF STALACTITE. 113 YOU'RE AT RESERVOIR. 115 YOU'RE AT NE END. 116 YOU'RE AT SW END. 117 YOU'RE ON SW SIDE OF CHASM. 118 YOU'RE IN SLOPING CORRIDOR. 122 YOU'RE ON NE SIDE OF CHASM. 123 YOU'RE IN CORRIDOR. 124 YOU'RE AT FORK IN PATH. 125 YOU'RE AT JUNCTION WITH WARM WALLS. 126 YOU'RE AT BREATH TAKING VIEW. 127 YOU'RE IN CHAMBER OF BOULDERS. 128 YOU'RE IN LIMESTONE PASSAGE. 129 YOU'RE IN FRONT OF BARREN ROOM. 130 YOU'RE IN BARREN ROOM. ======================================================================================== DOCUMENT :usus Folder:VOL09:advs3.text ======================================================================================== 1 0 2 2 44 29 1 0 3 3 12 19 43 1 0 4 5 13 14 46 30 1 0 5 6 45 43 1 0 8 63 2 0 1 2 12 7 43 45 30 2 0 5 6 45 46 3 0 1 3 11 32 44 3 0 11 62 3 0 33 65 3 0 79 5 14 4 0 1 4 12 45 4 0 5 6 43 44 29 4 0 7 5 46 30 4 0 8 63 5 0 4 9 43 30 5 50 5 6 7 45 5 0 6 6 5 0 5 44 46 6 0 1 2 45 6 0 4 9 43 44 30 6 0 5 6 46 7 0 1 12 7 0 4 4 45 7 0 5 6 43 44 7 0 8 5 15 16 46 7 0 595 60 14 30 8 0 5 6 43 44 46 8 0 1 12 8 0 7 4 13 45 8 303 9 3 19 30 8 0 593 3 9 303 8 11 29 9 0 593 11 9 0 10 17 18 19 44 9 0 14 31 9 0 11 51 10 0 9 11 20 21 43 10 0 11 19 22 44 51 10 0 14 31 11 303 8 63 11 0 9 64 11 0 10 17 18 23 24 43 11 0 12 25 19 29 44 11 0 3 62 11 0 14 31 12 303 8 63 12 0 9 64 12 0 11 30 43 51 12 0 13 19 29 44 12 0 14 31 13 303 8 63 13 0 9 64 13 0 11 51 13 0 12 25 43 13 0 14 23 31 44 14 303 8 63 14 0 9 64 14 0 11 51 14 0 13 23 43 14 150 20 30 31 34 14 0 15 30 14 0 16 33 44 15 0 18 36 46 15 0 17 7 38 44 15 0 19 10 30 45 15 150 22 29 31 34 35 23 43 15 0 14 29 15 0 34 55 16 0 14 1 17 0 15 38 43 17 312 596 39 17 412 21 7 17 412 597 41 42 44 69 17 0 27 41 18 0 15 38 11 45 19 0 15 10 29 43 19 311 28 45 36 19 311 29 46 37 19 311 30 44 7 19 0 32 45 19 35 74 49 19 211 32 49 19 0 74 66 20 0 0 1 21 0 0 1 22 0 15 1 23 0 67 43 42 23 0 68 44 61 23 0 25 30 31 23 0 648 52 24 0 67 29 11 25 0 23 29 11 25 724 31 56 25 0 26 56 26 0 88 1 27 312 596 39 27 412 21 7 27 412 597 41 42 43 69 27 0 17 41 27 0 40 45 27 0 41 44 28 0 19 38 11 46 28 0 33 45 55 28 0 36 30 52 29 0 19 38 11 45 30 0 19 38 11 43 30 0 62 44 29 31 524 89 1 31 0 90 1 32 0 19 1 33 0 3 65 33 0 28 46 33 0 34 43 53 54 33 0 35 44 33 159 302 71 33 0 100 71 34 0 33 30 55 34 0 15 29 35 0 33 43 55 35 0 20 39 36 0 37 43 17 36 0 28 29 52 36 0 39 44 36 0 65 70 37 0 36 44 17 37 0 38 30 31 56 38 0 37 56 29 11 38 0 595 60 14 30 4 5 39 0 36 43 23 39 0 64 30 52 58 39 0 65 70 40 0 41 1 41 0 42 46 29 23 56 41 0 27 43 41 0 59 45 41 0 60 44 17 42 0 41 29 42 0 42 45 42 0 43 43 42 0 45 46 42 0 80 44 43 0 42 44 43 0 44 46 43 0 45 43 44 0 43 43 44 0 48 30 44 0 50 46 44 0 82 45 45 0 42 44 45 0 43 45 45 0 46 43 45 0 47 46 45 0 87 29 30 46 0 45 44 11 47 0 45 43 11 48 0 44 29 11 49 0 50 43 49 0 51 44 50 0 44 43 50 0 49 44 50 0 51 30 50 0 52 46 51 0 49 44 51 0 50 29 51 0 52 43 51 0 53 46 52 0 50 44 52 0 51 43 52 0 52 46 52 0 53 29 52 0 55 45 52 0 86 30 53 0 51 44 53 0 52 45 53 0 54 46 54 0 53 44 11 55 0 52 44 55 0 55 45 55 0 56 30 55 0 57 43 56 0 55 29 11 57 0 13 30 56 57 0 55 44 57 0 58 46 57 0 83 45 57 0 84 43 58 0 57 43 11 59 0 27 1 60 0 41 43 29 17 60 0 61 44 60 0 62 45 30 52 61 0 60 43 61 0 62 45 61 100 107 46 62 0 60 44 62 0 63 45 62 0 30 43 62 0 61 46 63 0 62 46 11 64 0 39 29 56 59 64 0 65 44 70 64 0 103 45 74 64 0 106 43 65 0 64 43 65 0 66 44 65 80 556 46 65 0 68 61 65 80 556 29 65 50 70 29 65 0 39 29 65 60 556 45 65 75 72 45 65 0 71 45 65 80 556 30 65 0 106 30 66 0 65 47 66 0 67 44 66 80 556 46 66 0 77 25 66 0 96 43 66 50 556 50 66 0 97 72 67 0 66 43 67 0 23 44 42 67 0 24 30 31 68 0 23 46 68 0 69 29 56 68 0 65 45 69 0 68 30 61 69 331 120 46 69 0 119 46 69 0 109 45 69 0 113 75 70 0 71 45 70 0 65 30 23 70 0 111 46 71 0 65 48 71 0 70 46 71 0 110 45 72 0 65 70 72 0 118 49 72 0 73 45 72 0 97 48 73 0 72 46 17 11 74 0 19 43 74 331 120 44 74 0 121 44 74 0 75 30 75 0 76 46 75 0 77 45 76 0 75 45 77 0 75 43 77 0 78 44 77 0 66 45 17 78 0 77 46 79 0 3 1 80 0 42 45 80 0 80 44 46 80 0 81 43 81 0 80 44 11 82 0 44 46 11 83 0 57 46 83 0 84 43 83 0 85 44 84 0 57 45 84 0 83 44 84 0 114 50 85 0 83 43 11 86 0 52 29 11 87 0 45 29 30 88 0 25 30 56 43 88 0 20 39 88 0 92 44 27 89 0 25 1 90 0 23 1 91 0 95 45 73 23 91 0 72 30 56 92 0 88 46 92 0 93 43 92 0 94 45 93 0 92 46 27 11 94 0 92 46 27 23 94 309 95 45 3 73 94 0 611 45 95 0 94 46 11 95 0 92 27 95 0 91 44 96 0 66 44 11 97 0 66 48 97 0 72 44 17 97 0 98 29 45 73 98 0 97 46 72 98 0 99 44 99 0 98 50 73 99 0 301 43 23 99 0 100 43 100 0 301 44 23 11 100 0 99 44 100 159 302 71 100 0 33 71 100 0 101 47 22 101 0 100 46 71 11 102 0 103 30 74 11 103 0 102 29 38 103 0 104 30 103 114 618 46 103 115 619 46 103 0 64 46 104 0 103 29 74 104 0 105 30 105 0 104 29 11 105 0 103 74 106 0 64 29 106 0 65 44 106 0 108 43 107 0 131 46 107 0 132 49 107 0 133 47 107 0 134 48 107 0 135 29 107 0 136 50 107 0 137 43 107 0 138 44 107 0 139 45 107 0 61 30 108 95 556 43 45 46 47 48 49 50 29 30 108 0 106 43 108 0 626 44 109 0 69 46 109 0 113 45 75 110 0 71 44 110 0 20 39 111 0 70 45 111 40 50 30 39 56 111 50 53 30 111 0 45 30 112 0 131 49 112 0 132 45 112 0 133 43 112 0 134 50 112 0 135 48 112 0 136 47 112 0 137 44 112 0 138 30 112 0 139 29 112 0 140 46 113 0 109 46 11 109 114 0 84 48 115 0 116 49 116 0 115 47 116 0 593 30 117 0 118 49 117 233 660 41 42 69 47 117 332 661 41 117 0 303 41 117 332 21 39 117 0 596 39 118 0 72 30 118 0 117 29 119 0 69 45 11 119 0 653 43 7 120 0 69 45 120 0 74 43 121 0 74 43 11 121 0 653 45 7 122 0 123 47 122 233 660 41 42 69 49 122 0 303 41 122 0 596 39 122 0 124 77 122 0 126 28 122 0 129 40 123 0 122 44 123 0 124 43 77 123 0 126 28 123 0 129 40 124 0 123 44 124 0 125 47 36 124 0 128 48 37 30 124 0 126 28 124 0 129 40 125 0 124 46 77 125 0 126 45 28 125 0 127 43 17 126 0 125 46 23 11 126 0 124 77 126 0 610 30 39 127 0 125 44 11 17 127 0 124 77 127 0 126 28 128 0 124 45 29 77 128 0 129 46 30 40 128 0 126 28 129 0 128 44 29 129 0 124 77 129 0 130 43 19 40 3 129 0 126 28 130 0 129 44 11 130 0 124 77 130 0 126 28 131 0 107 44 131 0 132 48 131 0 133 50 131 0 134 49 131 0 135 47 131 0 136 29 131 0 137 30 131 0 138 45 131 0 139 46 131 0 112 43 132 0 107 50 132 0 131 29 132 0 133 45 132 0 134 46 132 0 135 44 132 0 136 49 132 0 137 47 132 0 138 43 132 0 139 30 132 0 112 48 133 0 107 29 133 0 131 30 133 0 132 44 133 0 134 47 133 0 135 49 133 0 136 43 133 0 137 45 133 0 138 50 133 0 139 48 133 0 112 46 134 0 107 47 134 0 131 45 134 0 132 50 134 0 133 48 134 0 135 43 134 0 136 30 134 0 137 46 134 0 138 29 134 0 139 44 134 0 112 49 135 0 107 45 135 0 131 48 135 0 132 30 135 0 133 46 135 0 134 43 135 0 136 44 135 0 137 49 135 0 138 47 135 0 139 50 135 0 112 29 136 0 107 43 136 0 131 44 136 0 132 29 136 0 133 49 136 0 134 30 136 0 135 46 136 0 137 50 136 0 138 48 136 0 139 47 136 0 112 45 137 0 107 48 137 0 131 47 137 0 132 46 137 0 133 30 137 0 134 29 137 0 135 50 137 0 136 45 137 0 138 49 137 0 139 43 137 0 112 44 138 0 107 30 138 0 131 43 138 0 132 47 138 0 133 29 138 0 134 44 138 0 135 45 138 0 136 46 138 0 137 48 138 0 139 49 138 0 112 50 139 0 107 49 139 0 131 50 139 0 132 43 139 0 133 44 139 0 134 45 139 0 135 30 139 0 136 48 139 0 137 29 139 0 138 46 139 0 112 47 140 0 112 45 11 ======================================================================================== DOCUMENT :usus Folder:VOL09:advs4.text ======================================================================================== 1016 'SPEL 3051 ? 29 ABOVE 3050 ABRA 3050 ABRAC 42 ACROS 29 ASCEN 2012 ATTAC 26 AWKWA 1028 AXE 8 BACK 40 BARRE 1052 BARS 1039 BATTE 1024 BEANS 1035 BEAR 16 BED 70 BEDQU 1008 BIRD 2023 BLAST 2023 BLOWU 1020 BOTTL 1055 BOX 2028 BREAK 2026 BRIEF 54 BROKE 12 BUILD 1004 CAGE 2010 CALM 25 CANYO 1040 CARPE 2001 CARRY 2001 CATCH 67 CAVE 73 CAVER 1064 CHAIN 2003 CHANT 1032 CHASM 1055 CHEST 1014 CLAM 56 CLIMB 2006 CLOSE 18 COBBL 1054 COINS 7 CONTI 2011 CONTI 33 CRACK 17 CRAWL 69 CROSS 30 D 22 DARK 51 DEBRI 63 DEPRE 30 DESCE 57 DESCR 2023 DETON 2014 DEVOU 1051 DIAMO 3066 DIG 2002 DISCA 2029 DISTU 35 DOME 1009 DOOR 30 DOWN 5 DOWNS 30 DOWNW 1031 DRAGO 1029 DRAWI 2015 DRINK 2002 DROP 2002 DUMP 1017 DWARF 1017 DWARV 43 E 43 EAST 2014 EAT 1056 EGG 1056 EGGS 1059 EMERA 3 ENTER 64 ENTRA 57 EXAMI 3066 EXCAV 11 EXIT 2011 EXPLO 2008 EXTIN 2025 FEE 3001 FEE 2021 FEED 2025 FIE 3002 FIE 2012 FIGHT 1027 FIGUR 2022 FILL 2019 FIND 1012 FISSU 58 FLOOR 2025 FOE 3003 FOE 2011 FOLLO 2025 FOO 3004 FOO 1019 FOOD 6 FORES 77 FORK 7 FORWA 2002 FREE 3079 FUCK 2025 FUM 3005 FUM 2001 GET 1037 GEYSE 27 GIANT 2011 GO 1050 GOLD 2011 GOTO 1003 GRATE 13 GULLY 1021 H2O 38 HALL 1002 HEADL 3051 HELP 2 HILL 2012 HIT 3050 HOCUS 52 HOLE 12 HOUSE 2023 IGNIT 19 IN 3142 INFO 3142 INFOR 19 INSID 2020 INVEN 19 INWAR 1016 ISSUE 1020 JAR 1053 JEWEL 39 JUMP 2001 KEEP 1001 KEY 1001 KEYS 2012 KILL 1018 KNIFE 1018 KNIVE 1002 LAMP 1002 LANTE 11 LEAVE 36 LEFT 2007 LIGHT 2006 LOCK 57 LOOK 3068 LOST 24 LOW 1038 MACHI 1016 MAGAZ 76 MAIN 1036 MESSA 1058 MING 1023 MIRRO 3069 MIST 1040 MOSS 2003 MUMBL 45 N 47 NE 1056 NEST 45 NORTH 2005 NOTHI 21 NOWHE 1050 NUGGE 21 NULL 50 NW 2008 OFF 76 OFFIC 1022 OIL 2007 ON 7 ONWAR 2004 OPEN 3050 OPENS 72 ORIEN 11 OUT 32 OUTDO 11 OUTSI 41 OVER 1015 OYSTE 23 PASSA 1061 PEARL 1062 PERSI 1010 PILLO 1030 PIRAT 31 PIT 2010 PLACA 1024 PLANT 1025 PLANT 1060 PLATI 71 PLOVE 65 PLUGH 3050 POCUS 1058 POTTE 2013 POUR 2011 PROCE 2027 PURUS 1060 PYRAM 2018 QUIT 1019 RATIO 2027 READ 2002 RELEA 75 RESER 8 RETRE 8 RETUR 37 RIGHT 2 ROAD 15 ROCK 1005 ROD 1006 ROD 59 ROOM 2016 RUB 1062 RUG 2011 RUN 46 S 2030 SAVE 2003 SAY 2024 SCORE 48 SE 66 SECRE 3050 SESAM 1027 SHADO 2009 SHAKE 1058 SHARD 2028 SHATT 3050 SHAZA 74 SHELL 1052 SILVE 2003 SING 61 SLAB 61 SLABR 2012 SLAY 60 SLIT 2028 SMASH 1011 SNAKE 46 SOUTH 1016 SPELU 1063 SPICE 10 STAIR 1026 STALA 2001 STEAL 34 STEPS 1007 STEPS 3139 STOP 14 STREA 2012 STRIK 20 SURFA 2030 SUSPE 49 SW 3147 SWIM 2009 SWING 1013 TABLE 2001 TAKE 2010 TAME 2017 THROW 2017 TOSS 2001 TOTE 57 TOUCH 2011 TRAVE 1055 TREAS 3064 TREE 3064 TREES 1057 TRIDE 1033 TROLL 1034 TROLL 23 TUNNE 2011 TURN 29 U 2004 UNLOC 29 UP 4 UPSTR 29 UPWAR 2003 UTTER 9 VALLE 1058 VASE 1010 VELVE 1038 VENDI 28 VIEW 1037 VOLCA 44 W 2029 WAKE 2011 WALK 53 WALL 1021 WATER 2009 WAVE 44 WEST 2019 WHERE 62 XYZZY 55 Y2 ======================================================================================== DOCUMENT :usus Folder:VOL09:advs5.text ======================================================================================== 1 SET OF KEYS 0 THERE ARE SOME KEYS ON THE GROUND HERE. 2 BRASS LANTERN 0 THERE IS A SHINY BRASS LAMP NEARBY. 100 THERE IS A LAMP SHINING NEARBY. 3 *GRATE 0 THE GRATE IS LOCKED. 100 THE GRATE IS OPEN. 4 WICKER CAGE 0 THERE IS A SMALL WICKER CAGE DISCARDED NEARBY. 5 BLACK ROD 0 A THREE FOOT BLACK ROD WITH A RUSTY STAR ON AN END 0 LIES NEARBY. 6 BLACK ROD 0 A THREE FOOT BLACK ROD WITH A RUSTY MARK ON AN END 0 LIES NEARBY. 7 *STEPS 0 ROUGH STONE STEPS LEAD DOWN THE PIT. 100 ROUGH STONE STEPS LEAD UP THE DOME. 8 LITTLE BIRD IN CAGE 0 A CHEERFUL LITTLE BIRD IS SITTING HERE SINGING. 100 THERE IS A LITTLE BIRD IN THE CAGE. 9 *RUSTY DOOR 0 THE WAY NORTH IS BARRED BY A MASSIVE, RUSTY, IRON 0 DOOR. 100 THE WAY NORTH LEADS THROUGH A MASSIVE, RUSTY, IRON 100 DOOR. 10 VELVET PILLOW 0 A VELVET PILLOW LIES ON THE FLOOR. 11 *SNAKE 0 A HUGE GREEN FIERCE SNAKE BARS THE WAY. 100 12 *FISSURE 0 100 A CRYSTAL BRIDGE NOW SPANS THE FISSURE. 200 THE CRYSTAL BRIDGE HAS VANISHED. 13 *STONE TABLET 0 A MASSIVE STONE TABLET IMBEDDED IN THE WALL READS 0 'CONGRATULATIONS ON BRINGING LIGHT INTO THE DARK-R 0 OOM. 14 GIANT CLAM >GRUNT.< 0 THERE IS AN ENORMOUS CLAM HERE WITH ITS SHELL TIGH 0 TLY CLOSED. 15 GIANT OYSTER >GROAN<. 0 THERE IS AN ENORMOUS OYSTER HERE WITH ITS SHELL TI 0 GHTLY CLOSED. 100 INTERESTING. THERE SEEMS TO BE SOMETHING WRITTEN 100 ON THE UNDERSIDE OF THE OYSTER. 16 'SPELUNKER TODAY' 0 THERE ARE A FEW RECENT ISSUES OF 'SPELUNKER TODAY' 0 MAGAZINE HERE. 19 TASTY FOOD 0 THERE IS FOOD HERE. 20 SMALL BOTTLE 0 THERE IS A BOTTLE OF WATER HERE. 100 THERE IN AN EMPTY BOTTLE HERE. 200 THERE IS A BOTTLE OF OIL HERE. 21 WATER IN THE BOTTLE 22 OIL IN THE BOTTLE 23 MIRROR 0 24 PLANT 0 THERE IS A TINY LITTLE PLANT IN THE PIT, MURMURMIN 0 G WATER, WATER,... 100 THE PLANT SPURTS INTO FURIOUS GROWTH FOR A FEW SEC 100 ONDS. 200 THERE IS A TWELVE FOOT TALL BEANSTALK STRETCHING U 200 P OUT OF THE PIT, BELLOWING WATER!! WATER!! 300 THE PLANT GROWS EXPLOSIVELY, ALMOST FILLING THE BO 300 TTOM OF THE PIT. 400 THERE IS A GIGANTIC BEANSTALK STRETCHING ALL THE W 400 AY UP TO THE HOLE. 500 YOU'VE OVER WATERED THE PLANT. IT'S SHIRVELING UP 500 . IT'S, IT'S... 25 *PHONY PLANT 0 100 THE TOP OF A TWELVE FOOT TALL BEANSTALK IS POKING 100 OUT OF THE WEST PIT. 200 THERE IS A HUGE BEANSTALK GROWING OUT OF THE WEST 200 PIT UP TO THE HOLE. 26 *STALACTITE 0 27 *SHADOWY FIGURE 0 THE SHADOWY FIGURE SEEMS TO BE TRYING TO ATTRACT Y 0 OUR ATTENTION. 28 DWARF'S AXE 0 THERE IS A LITTLE AXE HERE. 100 THERE IS A LITTLE AXE LYING BESIDE THE BEAR. 29 *CAVE DRAWINGS 0 30 *PIRATE 0 31 *DRAGON 0 A HUGE GREEN DRAGON BARS THE WAY. 100 CONGRATULATIONS. YOU HAVE JUST VANQUISHED A DRAGO 100 N WITH YOUR BARE HANDS. (UNBELIEVABLE, ISN'T IT?) 200 THE BODY OF A HUGE GREEN DEAD DRAGON IS LYING OFF 200 TO ONE SIDE. 32 *CHASM 0 A RICKETY WOODEN BRIDGE EXTENDS ACROSS THE CHASM, 0 VANISHING INTO THE MIST ON THE OTHER SIDE. A SIGN 0 POSTED ON THE BRIDGE READS, 'STOP. PAY TROLL.' 100 THE WRECKAGE OF A BRIDGE (AND A DEAD BEAR) CAN BE 100 SEEN AT THE BOTTOM OF THE CHASM. 33 *TROLL 0 A BURLY TROLL STANDS BY THE BRIDGE AND INSISTS THA 0 T YOU THROW HIM A TREASURE BEFORE YOU MAY CROSS. 100 THE TROLL STEPS OUT FROM BENEATH THE BRIDGE AND BL 100 OCKS YOUR WAY. 200 34 *PHONY TROLL 0 THE TROLL IS NOWHERE TO BE SEEN. 35 0 THERE IS A FEROCIOUS CAVE BEAR EYING YOU FROM THE 0 FAR END OF THE ROOM. 100 THERE IS A GENTLE CAVE BEAR SITTING PLACIDLY IN ON 100 E CORNER. 200 THERE IS A CONTENTED LOOKING BEAR WANDERING ABOUT 200 NEARBY. 300 36 *2ND MAZE MSG 0 THERE IS A MESSAGE SCRAWLED IN THE DUST IN A FLOWE 0 RY SCRIPT, READING 'THIS IS NOT THE MAZE WHERE THE 0 PIRATE LEAVES HIS TREASURE CHEST'. 37 *VOLCANO 0 38 *VENDING MACHINE 0 THERE IS A MASSIVE VENDING MACHINE HERE. THE INST 0 RUCTIONS ON IT READ 'DROP COINS HERE TO RECEIVE FR 0 ESH BATTERIES'. 39 BATTERIES 0 THERE ARE FRESH BATTERIES HERE. 100 SOME WORN OUT BATTERIES HAVE BEEN DISCARDED NEARBY 100 . 40 *CARPET/MOSS 0 50 LARGE GOLD NUGGET 0 THERE IS A LARGE SPARKLING NUGGET OF GOLD HERE! 51 SEVERAL DIAMONDS 0 THERE ARE DIAMONDS HERE! 52 BARS OF SILVER 0 THERE ARE BARS OF SILVER HERE! 53 PRECIOUS JEWELRY 0 THERE IS PRECIOUS JEWELRY HERE! 54 RARE COINS 0 THERE ARE MANY COINS HERE! 55 TREASURE CHEST 0 THE PIRATE'S TREASURE CHEST IS HERE! 56 GOLDEN EGGS 0 THERE IS A LARGE NEST HERE, FULL OF GOLDEN EGGS! 100 THE NEST OF GOLDEN EGGS HAS VANISHED. 200 DONE. 57 JEWELED TRIDENT 0 THERE IS A JEWEL ENCRUSTED TRIDENT HERE! 58 MING VASE 0 THERE IS A DELICATE, PRECIOUS MING VASE HERE! 100 THE VASE IS NOW RESTING, DELICATLY, ON A VELVET PI 100 LLOW. 200 THE FLOOR IS LITTERED WITH WORTHLESS SHARDS OF POT 200 TERY. 300 THE MING VASE DROPS WITH A DELICATE CRASH. 59 EGG SIZED EMERALD 0 THERE IS A EMERALD HERE THE SIZE OF A PLOVER'S EGG 0 ! 60 PLATINUM PYRAMID 0 THERE IS A PLATINUM PYRAMID HERE, 8 INCHES ON A SI 0 DE! 61 GLISTENING PEARL 0 OFF TO ONE SIDE LIES A GLISTENING PEARL! 62 PERSIAN RUG 0 THERE IS A PERSIAN RUG SPREAD OUT ON THE FLOOR! 100 THE DRAGON IS SPRAWLED OUT ON A PERSIAN RUG. 63 RARE SPICES 0 THERE ARE RARE SPICES HERE! 64 GOLDEN CHAIN 0 THERE IS A GOLDEN CHAIN LYING IN A HEAP ON THE FLO 0 OR. 100 THE BEAR IS LOCKED TO THE WALL WITH A GOLDEN CHAIN 100 . 200 THERE IS A GOLDEN CHAIN LOCKED TO THE WALL. ======================================================================================== DOCUMENT :usus Folder:VOL09:advs6.text ======================================================================================== 1 SOMEWHERE NEARBY IS COLOSSAL CAVE, WHERE OTHERS HA 1 VE FOUND FORTUNES IN TREASURE AND GOLD, THOUGH IT 1 IS RUMORED THAT SOME WHO ENTER ARE NEVER SEEN AGAI 1 N. MAGIC IS SAID TO WORK IN THE CAVE. 1 I WILL BE YOUR EYES AND HANDS. DIRECT ME WITH C 1 OMMANDS OF ONE OR TWO WORDS. 1 I SHOULD WARN YOU THAT I LOOK AT ONLY THE FIRST 1 FIVE LETTERS OF EACH WORD, SO THAT YOU'LL HAVE TO 1 ENTER 'NORTHEAST' AS 'NE' TO DISTINGUISH IT FROM ' 1 NORTH'. (SHOULD YOU GET STUCK, TYPE 'HELP' FOR SO 1 ME GENERAL HINTS. 2 A LITTLE DWARF WITH A BIG KNIFE BLOCKS YOUR WAY. 3 A LITTLE DWARF JUST WALKED AROUND A CORNER, SAW YO 3 U, THREW A LITTLE AXE AT YOU WHICH MISSED, CURSED, 3 AND RAN AWAY. 4 THERE IS A THREATENING LITTLE DWARF IN THE ROOM WI 4 TH YOU. 5 ONE SHARP NASTY KNIFE IS THROWN AT YOU. 6 NONE OF THEM HIT YOU. 7 ONE OF THEM GETS YOU. 8 A HOLLOW VOICE SAYS 'PLUGH'. 9 THERE IS NO WAY TO GO IN THAT DIRECTION. 10 I AM UNSURE HOW YOU ARE FACING. USE COMPASS POINT 10 S OR NEARBY OBJECTS. 11 I DON'T KNOW IN FROM OUT HERE. USE COMPASS POINTS 11 OR NAME SOMETHING IN THE GENERAL DIRECTION YOU WA 11 NT TO GO. 12 I DON'T KNOW HOW TO APPLY THAT WORD HERE. 13 I DON'T UNDERSTAND THAT. 14 I'M GAME. WOULD YOU CARE TO EXPLAIN HOW? 15 SORRY, BUT I AM NOT ALLOWED TO GIVE MORE DETAIL. 15 I WILL REPEAT THE LONG DESCRIPTION OF YOUR LOCATIO 15 N. 16 IT IS NOW PITCH DARK. IF YOU PROCEED YOU WILL LIK 16 ELY FALL INTO A PIT. 17 IF YOU PREFER, SIMPLY TYPE W RATHER THAN WEST. 18 ARE YOU TRYING TO CATCH THE BIRD? 19 THE BIRD IS FRIGHTENED NOW AND YOU CANNOT CATCH IT 19 NO MATTER WHAT YOU TRY. PERHAPS YOU MIGHT TRY LA 19 TER. 20 ARE YOU TRYING TO SOMEHOW DEAL WITH THE SNAKE? 21 YOU CAN'T KILL THE SNAKE, OR DRIVE IT AWAY, OR AVO 21 ID IT, OR ANYTHING LIKE THAT. THERE IS A WAY TO G 21 ET BY, BUT YOU DON'T HAVE THE NECESSARY RESOURCES 21 RIGHT NOW. 22 DO YOU REALLY WANT TO QUIT NOW? 23 YOU FELL INTO A PIT AND BROKE EVERY BONE IN YOUR B 23 ODY. 24 YOU ARE ALREADY CARRYING IT. 25 YOU CAN'T BE SERIOUS. 26 THE BIRD WAS UNAFRAID WHEN YOU ENTERED, BUT AS YOU 26 APPROACH IT BECOMES DISTURBED AND YOU CAN'T CATCH 26 IT. 27 YOU CAN CATCH THE BIRD, BUT YOU CANNOT CARRY IT. 28 THERE IS NOTHING HERE WITH A LOCK. 29 YOU AREN'T CARRYING IT. 30 THE LITTLE BIRD ATTACKS THE GREEN SNAKE, AND IN AN 30 ASTOUNDING FLURRY DRIVES THE SNAKE AWAY. 31 YOU HAVE NO KEYS. 32 IT HAS NO LOCK. 33 I DON'T KNOW HOW TO LOCK OR UNLOCK SUCH A THING. 34 IT WAS ALREADY LOCKED. 35 THE GRATE IS NOW LOCKED. 36 THE GRATE IS NOW UNLOCKED. 37 IT WAS ALREADY UNLOCKED. 38 YOU HAVE NO SOURCE OF LIGHT. 39 YOUR LAMP IS NOW ON. 40 YOUR LAMP IS NOW OFF. 41 THERE IS NO WAY TO GET PAST THE BEAR TO UNLOCK THE 41 CHAIN, WHICH IS PROBABLY JUST AS WELL. 42 NOTHING HAPPENS. 43 WHERE? 44 THERE IS NOTHING HERE TO ATTACK. 45 THE LITTLE BIRD IS NOW DEAD. ITS BODY DISAPPEARS. 46 ATTACKING THE SNAKE BOTH DOESN'T WORK AND IS VERY 46 DANGEROUS. 47 YOU KILLED A LITTLE DWARF. 48 YOU ATTACK A LITTLE DWARF, BUT HE DODGES OUT OF TH 48 E WAY. 49 WITH WHAT? YOUR BARE HANDS? 50 GOOD TRY, BUT THAT IS AN OLD WORN OUT MAGIC WORD. 51 I KNOW OF PLACES, ACTIONS, AND THINGS. MOST OF MY 51 VOCABULARY DESCRIBES PLACES AND IS USED TO MOVE Y 51 OU THERE. TO MOVE, TRY WORDS LIKE FOREST, BUILDIN 51 G, DOWNSTREAM, ENTER, EAST, WEST, NORTH, SOUTH, UP 51 , OR DOWN. 51 I KNOW ABOUT A FEW SPECIAL OBJECTS, LIKE A BLACK 51 ROD HIDDEN IN THE CAVE. 51 THESE OBJECTS CAN BE MANIPULATED USING SOME OF T 51 HE ACTION WORDS THAT I KNOW. USUALLY YOU WILL NEE 51 D TO GIVE BOTH THE OBJECT AND ACTION WORD (IN EITH 51 ER ORDER), BUT SOMETIMES I CAN INFER THE OBJECT FR 51 OM 51 THE VERB ALONE. SOME OBJECTS ALSO IMPLY VERBS; I 51 N PARTICULAR, 'INVENTORY' IMPLIES 'TAKE INVENTORY' 51 , WHICH CAUSES ME TO GIVE YOU A LIST OF WHAT YOU A 51 RE CARRYING. THE OBJECTS HAVE SIDE EFFECTS; FOR I 51 NSTANCE, THE ROD SCARES THE BIRD. 51 USUALLY PEOPLE HAVING TROUBLE MOVING JUST NEED T 51 O TRY A FEW MORE WORDS. USUALLY PEOPLE TRYING UNS 51 UCCESFULLY TO MANIPULATE AN OBJECT ARE ATTEMPTING 51 SOMETHING BEYOND THEIR (OR MY) CAPABILITIES AND SH 51 OULD TRY A COMPLETELY 51 DIFFERENT TACK. TO SPEED THE GAME YOU CAN SOMETI 51 MES MOVE LONG DISTANCES WITH A SINGLE WORD. FOR E 51 XAMPLE, 'BUILDING' USUALLY GETS YOU TO THE BUILDIN 51 G FROM ANYWHERE ABOVE GROUND EXCEPT WHEN LOST IN T 51 HE FOREST. 51 ALSO, NOTE THAT CAVE PASSAGES TURN A LOT, AND TH 51 AT LEAVING A ROOM TO THE NORTH DOES NOT GUARANTEE 51 ENTERING THE NEXT ROOM FROM THE SOUTH. GOOD LUCK. 52 IT MISSES. 53 IT GETS YOU. 54 OK 55 YOU CAN'T UNLOCK THE KEYS. 56 YOU HAVE CRAWLED AROUND IN SOME LITTLE HOLES AND W 56 OUND UP BACK IN THE MAIN PASSAGE. 57 I DON'T KNOW WHERE THE CAVE IS, BUT HEREABOUTS NO 57 STREAM CAN RUN ON THE SURFACE FOR LONG. I WOULD T 57 RY THE STREAM. 58 I NEED MORE DETAILED INSTRUCTIONS TO DO THAT. 59 I CAN ONLY TELL YOU WHAT YOU SEE AS YOU MOVE ABOUT 59 AND MANIPULATE THINGS. I CANNOT TELL YOU WHERE R 59 EMOTE THINGS ARE. 60 I DON'T KNOW THAT WORD. 61 WHAT? 62 ARE YOU TRYING TO GET INTO THE CAVE? 63 THE GRATE IS VERY SOLID AND HAS A HARDENED STEEL L 63 OCK. YOU CANNOT ENTER WITHOUT A KEY, AND THERE AR 63 E NO KEYS NEARBY. I WOULD RECOMMEND LOOKING ELSEW 63 HERE FOR THE KEYS. 64 THE TREES OF THE FOREST ARE LARGE HARDWOOD OAK AND 64 MAPLE, WITH AN OCCASIONAL GROVE OF PINE OR SPRUCE 64 . THERE IS QUITE A BIT OF UNDER GROWTH, LARGLY BI 64 RCH AND ASH SAPLINGS PLUS NON DESCRIPT BUSHES OF V 64 ARIOUS SORTS. 64 THIS TIME OF YEAR VISIBILITY IS QUITE RESTRICTED 64 BY ALL THE LEAVES, BUT TRAVEL IS QUITE EASY IF YO 64 U DETOUR AROUND THE SPRUCE AND BERRY BUSHES. 65 WELCOME TO ADVENTURE... WOULD YOU LIKE INSTRUCTION 65 S? 66 DIGGING WITHOUT A SHOVEL IS QUITE IMPRACTICAL. EV 66 EN WITH A SHOVEL PROGRESS IS UNLIKELY. 67 BLASTING REQUIRES DYNAMITE. 68 I'M AS CONFUSED AS YOU ARE. 69 MIST IS A WHITE VAPOR, USUALLY WATER, SEEN FROM TI 69 ME TO TIME IN CAVERNS. IT CAN BE FOUND ANYWHERE, 69 BUT IS FREQUENTLY A SIGN OF A DEEP PIT LEADING DOW 69 N TO WATER. 70 YOUR FEET ARE NOW WET. 71 I THINK I JUST LOST MY APPETITE. 72 THANK YOU, IT WAS DELICIOUS. 73 YOU HAVE TAKEN A DRINK FROM THE STREAM. THE WATER 73 TASTES STRONGLY OF MINERALS, BUT IS NOT UNPLEASAN 73 T. IT IS EXTREMELY COLD. 74 THE BOTTLE OF WATER IS NOW EMPTY. 75 IT'S AN ELECTRIC LAMP AND RUBBING IT IS NOT PARTIC 75 ULARLY REWARDING. ANYWAY, NOTHING HAPPENS. 76 PECULIAR. NOTHING UNEXPECTED HAPPENS. 77 YOUR BOTTLE IS EMPTY AND THE GROUND AT YOUR FEET I 77 S WET. 78 YOU CAN'T POUR THAT. 79 FUCK YOURSELF! KEEP THAT UP AND YOU'RE ON YOUR OW 79 N. 80 WHICH WAY? 81 OH DEAR, YOU SEEM TO HAVE GOTTEN YOURSELF KILLED. 81 I MIGHT BE ABLE TO HELP YOU OUT, BUT I'VE NEVER R 81 EALLY DONE THIS KIND OF THING BEFORE. DO YOU WANT 81 ME TO TRY TO REINCARNATE YOU? 82 ALL RIGHT. BUT DON'T BLAME ME IF SOMETHING GOES W 82 R..... YOU ARE ENGULFED IN A CLOU 82 D OF ORANGE SMOKE. COUGHING AND GASPING, YOU EMER 82 GE FROM THE CLOUD AND FIND.... 83 YOU CLUMSY OAF! YOU'VE DONE IT AGAIN. I DON'T KN 83 OW HOW LONG I CAN KEEP THIS UP. DO YOU WANT ME TO 83 TRY REINCARNATING YOU AGAIN? 84 OKAY, NOW WHERE DID I PUT MY ORANGE SMOKE?.... 84 >POOF< EVERYTHING DISAPPEARS IN A DE 84 NSE CLOUD OF ORANGE SMOKE. 85 NOW YOU'VE REALLY DONE IT. I'M OUT OF ORANGE SMOK 85 E. YOU DON'T EXPECT ME TO DO A DECENT REINCARNATI 85 ON WITHOUT ORANGE SMOKE, DO YOU? 86 OKAY, IF YOU'RE SO SMART DO IT YOURSELF. I'M LEAV 86 ING. 91 SORRY, BUT I NO LONGER SEEM TO REMEMBER HOW IT WAS 91 YOU GOT HERE. 92 YOU CAN'T CARRY ANYTHING MORE. YOU'LL HAVE TO DRO 92 P SOMETHING FIRST. 93 YOU CAN'T GO THROUGH A LOCKED STEEL GRATE. 94 I BELIEVE WHAT YOU WANT IS RIGHT HERE WITH YOU. 95 YOU DON'T FIT THROUGH A TWO-INCH SLIT. 96 I RESPECTFULLY SUGGEST YOU GO ACROSS THE BRIDGE IN 96 STEAD OF JUMPING. 97 THERE IS NO WAY ACROSS THE FISSURE. 98 YOU'RE NOT CARRYING ANYTHING. 99 YOU ARE CURRENTLY HOLDING THE FOLLOWING: 100 IT'S NOT HUNGRY (IT'S MERELY PININ' FOR THE FJORDS 100 ). BESIDES, YOU HAVE NO BIRD SEED. 101 THE SNAKE HAS NOW DEVOURED YOUR BIRD. 102 THERE'S NOTHING HERE IT WANTS TO EAT (EXCEPT PERHA 102 PS YOU). 103 FOOL, DWARVES EAT ONLY COAL. NOW YOU'VE MADE HIM 103 *REALLY* MAD. 104 YOU HAVE NOTHING IN WHICH TO CARRY IT. 105 YOUR BOTTLE IS ALREADY FULL. 106 THERE IS NOTHING HERE WITH WHICH TO FILL THE BOTTL 106 E. 107 YOUR BOTTLE IS NOW FULL OF WATER. 108 YOUR BOTTLE IS NOW FULL OF OIL. 109 YOU CAN'T FILL THAT. 110 DON'T BE RIDICULOUS. 111 THE DOOR IS EXTREMELY RUSTY AND REFUSES TO OPEN. 112 THE PLANT INDIGNANTLY SHAKES THE OIL OFF ITS LEAVE 112 S AND ASKS, 'WATER'? 113 THE HINGES ARE QUITE THROUGHLY RUSTED NOW AND WON' 113 T BUDGE. 114 THE OIL HAS FREED UP THE HINGES SO THAT THE DOOR W 114 ILL NOW MOVE, THOUGH IT REQUIRES SOME EFFORT. 115 THE PLANT HAS EXCEPTIONLY DEEP ROOTS AND CANNOT BE 115 PULLED FREE. 116 THE DWARVE'S KNIVES VANISH AS THEY STRIKE THE WALL 116 S OF THE CAVE. 117 SOMETHING YOU'RE CARRYING WON'T FIT THROUGH THE TU 117 NNEL WITH YOU. YOU'D BEST TAKE INVENTORY AND DROP 117 SOMETHING. 118 YOU CAN'T FIT THIS FIVE-FOOT CLAM THROUGH THAT LIT 118 TLE PASSAGE. 119 YOU CAN'T FIT THIS FIVE-FOOT OYSTER THROUGH THAT L 119 ITTLE PASSAGE. 120 I ADVISE YOU TO PUT DOWN THE CLAM BEFORE OPENING I 120 T. (STRAIN). 121 I ADVISE YOU TO PUT DOWN THE OYSTER BEFORE OPENING 121 IT. (WRENCH). 122 YOU DON'T HAVE ANYTHING STRONG ENOUGH TO OPEN THE 122 CLAM. 123 YOU DON'T HAVE ANYTHING STRONG ENOUGH TO OPEN THE 123 OYSTER. 124 A GLISTENING PEARL FALLS OUT OF THE CLAM AND ROLLS 124 AWAY. GOODNESS, THIS MUST REALLY BE AN OYSTER. 124 (I NEVER WAS ANY GOOD AT IDENTIFYING BIVALVES.) W 124 HATEVER IT IS, IT HAS NOW SNAPPED SHUT AGAIN. 125 THE OYSTER CREAKS OPEN, REVEALING NOTHING BUT OYST 125 ER INSIDE. IT PROMPTLY SNAPS SHUT AGAIN. 126 YOU HAVE CRAWLED AROUND IN SOME LITTLE HOLES AND F 126 OUND YOUR WAY BLOCKED BY A RECENT CAVE-IN. YOU AR 126 E NOW IN THE MAIN PASSAGE. 127 THERE ARE FAINT RUSTLING NOISES FROM THE DARKNESS 127 BEHIND YOU. 128 OUT FROM THE SHADOWS BEHIND YOU POUNCES A BEARDED 128 PIRATE. 'HAR, HAR' HE CHORTLES, 'I'LL JUST TAKE A 128 LL THIS BOOTY AND HIDE IT AWAY WITH ME CHEST DEEP 128 IN THE MAZE.' HE SNATCHES YOUR TREASURE AND 128 VANISHES INTO THE GLOOM. 129 A SEPUCHRAL VOICE REVERBRATING THROUGH THE CAVE, S 129 AYS, 'CAVE CLOSING SOON. ALL ADVENTURERS EXIT THR 129 OUGH MAIN OFFICE.' 130 A MYSTERIOUS RECORDED VOICE GROANS INTO LIFE AND A 130 NNOUNCES 'THIS EXIT IS CLOSED. PLEASE LEAVE VIA M 130 AIN OFFICE'. 131 IT LOOKS AS THOUGH YOU'RE DEAD. WELL, SEEING AS H 131 OW IT'S SO CLOSE TO CLOSING TIME ANYWAY, I THINK I 131 'LL JUST CALL IT A DAY. 132 THE SEPULCHRAL VOICE INTONES, 'THE CAVE IS NOW CLO 132 SED.' AS THE ECHOES FADE, THERE IS A BLINDING FLA 132 SH OF LIGHT (AND A SMALL PUFF OF ORANGE SMOKE). A 132 S YOUR EYES REFOCUS, YOU LOOK AROUND AND FIND.... 133 THERE IS A LOUD EXPLOSION, AND A TWENTY-FOOT HOLE 133 APPEARS IN THE FAR WALL, BURYING THE DWARVES IN TH 133 E RUBBLE. YOU MARCH THROUGH THE HOLE AND FIND YOU 133 RSELF IN THE MAIN OFFICE, 133 WHERE A CHEERING BAND OF FRIENDLY ELVES CARRY THE 133 CONQUERING ADVENTURER OFF INTO THE SUNSET. 134 THERE IS A LOUD EXPLOSION, AND A TWENTY-FOOT HOLE 134 APPEARS IN THE FAR WALL, BURYING THE SNAKES IN THE 134 RUBBLE. A RIVER OF MOLTEN LAVA POURS IN THROUGH 134 THE HOLE, DESTROYING EVERYTHING IN ITS PATH, INCLU 134 DING YOU. 135 THERE IS A LOUD EXPLOSION, AND YOU ARE SUDDENLY SP 135 LASHED ACROSS THE WALLS OF THE ROOM. 136 THE RESULTING RUCKUS HAS AWAKENED THE DWARVES. TH 136 ERE ARE NOW SEVERAL THREATENING LITTLE DWARVES IN 136 THE ROOM WITH YOU. MOST OF THEM THROW KNIVES AT Y 136 OU. ALL OF THEM GET YOU. 137 OH, LEAVE THE POOR UNHAPPY BIRD ALONE. 138 I DARESAY WHATEVER YOU WANT IS AROUND HERE SOMEWHE 138 RE. 139 I DON'T KNOW THE WORD 'STOP'. USE QUIT' IF YOU WA 139 NT TO GIVE UP. 140 YOU CAN'T GET THERE FROM HERE. 141 YOU ARE BEING FOLLOWED BY A VERY LARGE, TAME BEAR. 143 DO YOU INDEED WISH TO QUIT NOW? 144 THERE IS NOTHING HERE WITH WHICH TO FILL THE VASE. 145 THE SUDDEN CHANGE IN TEMPERATURE HAS DELICATELY SH 145 ATTERED THE VASE. 146 IT IS BEYOND YOUR POWER TO DO THAT. 147 I DON'T KNOW HOW. 148 IT IS TOO FAR UP FOR YOU TO REACH. 149 YOU KILLED A LITTLE DWARF. THE BODY VANISHES IN A 149 CLOUD OF GREASY BLACK SMOKE. 150 THE SHELL IS VERY STRONG AND IS IMPERVIOUS TO ATTA 150 CK. 151 WHAT'S THE MATTER, CAN'T YOU READ? NOW YOU'D BEST 151 START OVER. 152 THE AXE BOUNCES HARMLESSLY OFF THE DRAGON'S THICK 152 SCALES. 153 THE DRAGON LOOKS RATHER NASTY. YOU'D BEST NOT TRY 153 TO GET BY. 154 THE LITTLE BIRD ATTACKS THE GREEN DRAGON AND IN AN 154 ASTOUNDING FLURRY GETS BURNT TO A CINDER. THE AS 154 HES BLOW AWAY. 155 ON WHAT? 156 OKAY, FROM NOW ON I'LL ONLY DESCRIBE A PLACE IN FU 156 LL THE FIRST TIME YOU COME TO IT. TO GET THE FULL 156 DESCRIPTION, SAY 'LOOK'. 157 TROLLS ARE CLOSE RELATIVES WITH THE ROCK AND HAVE 157 SKIN AS TOUGH AS THAT OF A RHINOCEROS. THE TROLL 157 FENDS OFF YOUR BLOWS EFFORTLESSLY. 158 THE TROLL DEFTLY CATCHES THE AXE, EXAMINES IT CARE 158 FULLY, AND TOSSES IT BACK, DECLARING, 'GOOD WORKMA 158 NSHIP, BUT IT'S NOT VALUABLE ENOUGH.' 159 THE TROLL CATCHES YOUR TREASURE AND SCURRIES AWAY 159 OUT OF SIGHT. 160 THE TROLL REFUSES TO LET YOU CROSS. 161 THERE IS NO LONGER ANY WAY ACROSS THE CHASM. 162 JUST AS YOU REACH THE OTHER SIDE, THE BRIDGE BUCKL 162 ES BENEATH THE WEIGHT OF THE BEAR, WHICH WAS STILL 162 FOLLOWING YOU AROUND. YOU SCRABBLE DESPERATELY F 162 OR SUPPORT, BUT AS THE BRIDGE COLLAPSES YOU STUMBL 162 E BACK AND FALL INTO THE CHASM. 163 THE BEAR LUMBERS TOWARD THE TROLL, WHO LETS OUT A 163 STARTLED SHRIEK AND SCURRIES AWAY. THE BEAR SOON 163 GIVES UP THE PURSUIT AND WANDERS BACK. 164 THE AXE MISSES AND LANDS NEAR THE BEAR WHERE YOU C 164 AN'T GET AT IT. 165 WITH WHAT? YOUR BARE HANDS? AGAINST *HIS* BEAR H 165 ANDS?? 166 THE BEAR IS CONFUSED; HE ONLY WANTS TO BE YOUR FRI 166 END. 167 FOR CRYING OUT LOUD, THE POOR THING IS ALREADY DEA 167 D. 168 THE BEAR EAGERLY WOLFS DOWN YOUR FOOD, AFTER WHICH 168 HE SEEMS TO CALM DOWN CONSIDERABLY AND EVEN BECOM 168 ES RATHER FRIENDLY. 169 THE BEAR IS STILL CHAINED TO THE WALL. 170 THE CHAIN IS STILL LOCKED. 171 THE CHAIN IS NOW UNLOCKED. 172 THE CHAIN IS NOW LOCKED. 173 THERE IS NOTHING HERE TO WHICH THE CHAIN CAN BE LO 173 CKED. 174 THERE IS NOTHING HERE TO EAT. 175 DO YOU WANT THE HINT? 176 DO YOU NEED HELP GETTING OUT OF THE MAZE? 177 YOU CAN MAKE THE PASSAGES LOOK LESS ALIKE BY DROPP 177 ING THINGS. 178 ARE YOU TRYING TO EXPLORE BEYOND THE PLOVER ROOM? 179 THERE IS A WAY TO EXPLORE THAT REGION WITHOUT HAVI 179 NG TO WORRY ABOUT FALLING INTO A PIT. NONE OF THE 179 OBJECTS AVAILABLE IS IMMEDIATELY USEFULL IN DISCO 179 VERING THE SECRET. 180 DO YOU NEED HELP GETTING OUT OF HERE? 181 DON'T GO WEST. 182 GLUTTONY IS NOT ONE OF THE TROLL'S VICES. AVARICE 182 , HOWEVER, IS. 183 YOUR LAMP IS GETTING DIM. YOU'D BEST START WRAPPI 183 NG THIS UP, UNLESS YOU CAN FIND SOME FRESH BATTERI 183 ES. I SEEM TO RECALL THERE'S A VENDING MACHINE IN 183 THE MAZE. BRING SOME COINS WITH YOU. 184 YOUR LAMP HAS RUN OUT OF POWER. 185 THERE'S NOT MUCH POINT IN WANDERING AROUND OUT HER 185 E, AND YOU CAN'T EXPLORE THE CAVE WITHOUT A LAMP. 185 SO LET'S JUST CALL IT A DAY. 186 THERE ARE FAINT RUSTLING NOISES FROM THE DARKNESS 186 BEHIND YOU. AS YOU TURN TOWARD THEM, THE BEAM OF 186 YOUR LAMP FALLS ACROSS A BEARDED PIRATE. HE IS CA 186 RRYING A LARGE CHEST. 'SHIVER ME TIMBERS.' HE CR 186 IES, 'I'VE BEEN SPOTTED. 186 I'D BEST HIE MESELF OFF TO THE MAZE TO HIDE ME C 186 HEST.' WITH THAT, HE VANISHES INTO THE GLOOM. 187 YOUR LAMP IS GETTING DIM. YOU'D BEST GO BACK FOR 187 THOSE BATTERIES. 188 YOUR LAMP IS GETTING DIM. I'M TAKING THE LIBERTY 188 OF REPLACING THE BATTERIES. 189 YOUR LAMP IS GETTING DIM, AND YOU'RE OUT OF SPARE 189 BATTERIES. YOU'D BEST START WRAPPING THIS UP. 190 I'M AFRAID THE MAGAZINE IS WRITTEN IN DWARVISH. 191 'THIS IS NOT THE MAZE WHERE THE PIRATE LEAVES HIS 191 CHEST.' 192 HMMM, THIS LOOKS LIKE A CLUE, WHICH MEANS IT'LL CO 192 ST YOU TEN POINTS TO READ IT. SHOULD I GO AHEAD A 192 ND READ IT ANYWAY? 193 IT SAYS, 'THERE IS SOMETHING STRANGE ABOUT THIS PL 193 ACE, SUCH THAT ONE OF THE WORDS I'VE ALWAYS KNOWN 193 NOW HAS A NEW EFFECT.' 194 IT SAYS THE SAME THING IT DID BEFORE. 195 I'M AFRAID I DON'T UNDERSTAND. 196 CONGRATULATIONS ON BRINGING LIGHT INTO THE DARK-RO 196 OM. 197 YOU STRIKE THE MIRROR A RESOUNDING BLOW, WHEREUPON 197 IT SHATTERS INTO A MYRIAD TINY FRAGMENTS. 198 YOU HAVE TAKEN THE VASE AND HURLED IT DELICATELY T 198 O THE GROUND. 199 YOU PROD THE NEAREST DWARF, WHO WAKES UP GRUMPILY, 199 TAKES ONE LOOK AT YOU, CURSES, AND GRABS FOR HIS 199 AXE. 200 IS THIS ACCEPTABLE? 201 ARE YOU RESUMING AN EARLIER ADVENTURE? ======================================================================================== DOCUMENT :usus Folder:VOL09:advs7.text ======================================================================================== 1 3 0 2 3 0 3 8 9 4 10 0 5 11 0 6 0 0 7 14 15 8 13 0 9 94 -1 10 96 0 11 19 -1 12 17 27 13 101 -1 14 103 0 15 0 0 16 106 0 17 0 -1 18 0 0 19 3 0 20 3 0 21 0 0 22 0 0 23 109 -1 24 25 -1 25 23 67 26 111 -1 27 35 110 28 0 0 29 97 -1 30 0 0 31 119 121 32 117 122 33 117 122 34 0 0 35 130 -1 36 0 -1 37 126 -1 38 140 -1 39 0 0 40 96 -1 41 0 0 42 0 0 43 0 0 44 0 0 45 0 0 46 0 0 47 0 0 48 0 0 49 0 0 50 18 0 51 27 0 52 28 0 53 29 0 54 30 0 55 0 0 56 92 0 57 95 0 58 97 0 59 100 0 60 101 0 61 0 0 62 119 121 63 127 0 64 130 -1 65 0 0 66 0 0 67 0 0 68 0 0 69 0 0 70 0 0 71 0 0 72 0 0 73 0 0 74 0 0 75 0 0 76 0 0 77 0 0 78 0 0 79 0 0 80 0 0 81 0 0 82 0 0 83 0 0 84 0 0 85 0 0 86 0 0 87 0 0 88 0 0 89 0 0 90 0 0 91 0 0 92 0 0 93 0 0 94 0 0 95 0 0 96 0 0 97 0 0 98 0 0 99 0 0 100 0 0 ======================================================================================== DOCUMENT :usus Folder:VOL09:advs8.text ======================================================================================== 1 24 2 29 3 0 4 33 5 0 6 33 7 38 8 38 9 42 10 14 11 43 12 110 13 29 14 110 15 73 16 75 17 29 18 13 19 59 20 59 21 174 22 109 23 67 24 13 25 147 26 155 27 195 28 146 29 110 30 13 31 13 32 0 33 0 34 0 35 0 ======================================================================================== DOCUMENT :usus Folder:VOL09:advs9.text ======================================================================================== 0 1 2 3 4 5 6 7 8 9 10 0 100 115 116 126 1 16 20 21 22 24 26 31 32 40 59 1 79 89 90 2 1 3 4 7 24 38 95 113 3 46 47 48 54 56 58 82 85 86 122 3 123 124 125 126 127 128 129 130 4 8 5 13 6 19 7 42 43 44 45 46 47 48 49 50 51 7 52 53 54 55 56 80 81 82 86 87 8 99 100 101 9 108 ======================================================================================== DOCUMENT :usus Folder:VOL09:advsubs.text ======================================================================================== { SUBROUTINES FOR ADVENTURE } PROCEDURE NAMEANDPW; VAR ACHR : CHAR; ACHAR : STRING[1]; BEGIN { NAMENADPW } WRITELN('ENTER YOUR NAME PLEASE.'); READLN(NAMEOFUSER); WRITELN('ENTER YOUR PASSWORD '); READ(KEYBOARD,ACHR); ACHAR:=' '; TESTPW:=''; WHILE NOT EOLN(KEYBOARD) DO BEGIN ACHAR[1]:=ACHR; IF 8=ORD(ACHR) THEN IF LENGTH(TESTPW)>0 THEN BEGIN DELETE(TESTPW,LENGTH(TESTPW),1); WRITE(CHR(8),' ',CHR(8)); END ELSE ELSE BEGIN WRITE('X'); TESTPW:=CONCAT(TESTPW,ACHAR); END; READ(KEYBOARD,ACHR); END; NAMEOFUSER:=CONCAT(NAMEOFUSER,'.AVSV'); END; { NAMEANDPW } FUNCTION GETSCORE(SCORECMD:BOOLEAN) : INTEGER; VAR I,K,SCORE : INTEGER; BEGIN {GETSCORE} MAXSCORE:=0; SCORE:=0; FOR I:=50 TO MAXTRS DO IF ARY^.PTEXT[I]<>0 THEN BEGIN IF I=CHEST THEN K:=14 ELSE IF I>CHEST THEN K:=16 ELSE K:=12; IF (VARY^.PROP[I]>=0) THEN SCORE:=SCORE+2; IF (VARY^.PLACE[I]=3) AND (VARY^.PROP[I]=0) THEN SCORE:=SCORE+K-2; MAXSCORE:=MAXSCORE+K; END; SCORE:=SCORE+(MAXDIE-VBL^.NUMDIE)*10; MAXSCORE:=MAXSCORE+MAXDIE*10; IF VBL^.DFLAG<>0 THEN SCORE:=SCORE+25; MAXSCORE:=MAXSCORE+25; IF NOT (GAVEUP OR SCORECMD) THEN SCORE:=SCORE+4; MAXSCORE:=MAXSCORE+4; IF VBL^.CLOSING THEN SCORE:=SCORE+25; MAXSCORE:=MAXSCORE+25; CASE BONUS OF 0 : SCORE:=SCORE+10; 135 : SCORE:=SCORE+25; 134 : SCORE:=SCORE+30; 133 : SCORE:=SCORE+45; END; MAXSCORE:=MAXSCORE+45; IF VARY^.PLACE[MAGAZINE]=108 THEN SCORE:=SCORE+1; MAXSCORE:=MAXSCORE+1; SCORE:=SCORE+2; MAXSCORE:=MAXSCORE+2; FOR I:=1 TO HNTSIZ DO IF VARY^.HINTED[I] THEN SCORE:=SCORE-ARY^.HINTS[I,2]; GETSCORE:=SCORE; END; {GETSCORE} FUNCTION TOTING(OBJECT:INTEGER):BOOLEAN; BEGIN {TOTING} TOTING:=(VARY^.PLACE[OBJECT]=-1); END; {TOTING} FUNCTION AT(OBJECT:INTEGER):BOOLEAN; BEGIN {AT} AT:=(VARY^.PLACE[OBJECT]=VBL^.LOC) OR (VARY^.FIXED[OBJECT]=VBL^.LOC); END; {AT} FUNCTION MIN(I,J:INTEGER):INTEGER; BEGIN {MIN} IF JI THEN MAX:=J ELSE MAX:=I; END; {MAX} FUNCTION RAN(NUM:INTEGER):INTEGER; VAR TEMP : INTEGER; TEMP2 : REAL; BEGIN {RAN} TEMP:=SEED*899; IF TEMP<0 THEN TEMP:=TEMP+32767+1; TEMP2:=(TEMP-1)/32767.0; RAN:=TRUNC(TEMP2*NUM); SEED:=TEMP; END; {RAN} FUNCTION PERCENT(I:INTEGER):BOOLEAN; BEGIN {PERCENT} PERCENT:=(RAN(100)=WORD THEN J:=K-1; UNTIL I>J; IF K>1 THEN IF ARY^.ATAB[K-1]=WORD THEN K:=K-1; {FIND FIRST WORD} VOCAB:=-1; IF ARY^.ATAB[K]=WORD THEN VOCAB:=ARY^.KTAB[K]; IF WHAT>=0 THEN BEGIN WHILE (ARY^.ATAB[K]=WORD) AND (WHAT<>(ARY^.KTAB[K] DIV 1000)) DO K:=K+1; IF ARY^.ATAB[K]=WORD THEN VOCAB:=ARY^.KTAB[K] MOD 1000; END; END; {VOCAB} PROCEDURE CARRY(OBJECT,WHERE:INTEGER); VAR TEMP : INTEGER; PROCEDURE LINKUP; BEGIN {LINKUP} TEMP:=VARY^.ATLOC[WHERE]; WHILE (VARY^.LINK[TEMP]<>OBJECT) DO TEMP:=VARY^.LINK[TEMP]; VARY^.LINK[TEMP]:=VARY^.LINK[OBJECT]; END; {LINKUP} BEGIN {CARRY} IF OBJECT<=100 THEN IF VARY^.PLACE[OBJECT]<>-1 THEN BEGIN VARY^.PLACE[OBJECT]:=-1; VBL^.HLDING:=VBL^.HLDING+1; IF VARY^.ATLOC[WHERE]=OBJECT THEN VARY^.ATLOC[WHERE]:=VARY^.LINK[OBJECT] ELSE LINKUP END ELSE ELSE IF VARY^.ATLOC[WHERE]=OBJECT THEN VARY^.ATLOC[WHERE]:=VARY^.LINK[OBJECT] ELSE LINKUP END; {CARRY} PROCEDURE DROP(OBJECT,WHERE:INTEGER); BEGIN {DROP} IF OBJECT>100 THEN VARY^.FIXED[OBJECT-100]:=WHERE ELSE BEGIN IF VARY^.PLACE[OBJECT]=-1 THEN VBL^.HLDING:=VBL^.HLDING-1; VARY^.PLACE[OBJECT]:=WHERE; END; IF WHERE>0 THEN BEGIN VARY^.LINK[OBJECT]:=VARY^.ATLOC[WHERE]; VARY^.ATLOC[WHERE]:=OBJECT; END; END; {DROP} PROCEDURE MOVE(OBJECT,WHERE:INTEGER); VAR FROM : INTEGER; BEGIN {MOVE} IF OBJECT>100 THEN FROM:=VARY^.FIXED[OBJECT-100] ELSE FROM:=VARY^.PLACE[OBJECT]; IF (FROM>0) AND (FROM <= 300) THEN CARRY(OBJECT,FROM); DROP(OBJECT,WHERE); END; {MOVE} PROCEDURE JUGGLE(OBJECT:INTEGER); BEGIN {JUGGLE} MOVE(OBJECT,VARY^.PLACE[OBJECT]); MOVE(OBJECT+100,VARY^.FIXED[OBJECT]); END; {JUGGLE} PROCEDURE DESTROY(OBJECT:INTEGER); BEGIN {DESTROY} MOVE(OBJECT,0); END; {DESTROY} FUNCTION PUT(OBJECT,WHERE,PVAL : INTEGER):INTEGER; BEGIN {PUT} MOVE(OBJECT,WHERE); PUT:=(-1)-PVAL; END; {PUT} PROCEDURE SPEAK(MSG:INTEGER); VAR I : INTEGER; MTEMP : STRING[6]; MTEMP2 : STRING; MTEXT : STRING[255]; PROCEDURE HOLDUP; BEGIN { HOLDUP } LINE:=LINE+1; IF LINE>=(TERMHIGHT-1) THEN BEGIN LINE:=1; WRITE(CHR(7),' PRESS TO CONTINUE'); READLN; END; END; { HOLDUP } BEGIN {SPEAK} MTEMP:=' '; MTEXT:=''; IF MSG>0 THEN BEGIN SEEK(MSGFILE,MSG); REPEAT GET(MSGFILE); FOR I:=1 TO 6 DO MTEMP[I]:=MSGFILE^[I]; IF ORD(MTEMP[1])>128 THEN MTEMP[1]:=CHR(ORD(MTEMP[1])-128); IF ORD(MTEMP[2])>128 THEN MTEMP[2]:=CHR(ORD(MTEMP[2])-128); MTEXT:=CONCAT(MTEXT,MTEMP); IF LENGTH(MTEXT)>TERMWIDTH THEN BEGIN I:=TERMWIDTH; WHILE MTEXT[I]<>' ' DO I:=I-1; MTEMP2:=COPY(MTEXT,1,I-1); DELETE(MTEXT,1,I); WRITELN(MTEMP2); HOLDUP; END; UNTIL ORD(MSGFILE^[1])>128; IF MTEXT<>' ' THEN {DONT PRINT DUMMY MSG} BEGIN WRITELN(MTEXT); HOLDUP; END; END; END; {SPEAK} PROCEDURE PSPEAK(MSG,SKIP:INTEGER); VAR I,M : INTEGER; BEGIN {PSPEAK} M:=ARY^.PTEXT[MSG]; SEEK(MSGFILE,M); FOR I:=0 TO SKIP DO BEGIN REPEAT GET(MSGFILE); M:=M+1; UNTIL ORD(MSGFILE^[1])>128; END; GET(MSGFILE); { INSURE GET BETWEEN SEEKS} SPEAK(M); END; {PSPEAK} FUNCTION YES(MSG,SPKYES,SPKNO:INTEGER):BOOLEAN; VAR INLINE : STRING; BEGIN {YES} YEA:=FALSE; SKIPIT:=FALSE; IF MSG<>0 THEN SPEAK(ARY^.RTEXT[MSG]); LINE:=1; REPEAT IF SKIPIT THEN WRITELN('PLEASE ANSWER THE QUESTION WITH YES OR NO'); SKIPIT:=TRUE; READLN(INLINE); UNTIL (INLINE='YES') OR (INLINE='Y') OR (INLINE='NO') OR (INLINE='N') OR (INLINE='yes') OR (INLINE='y') OR (INLINE='no') OR (INLINE='n'); YEA:=(INLINE='YES') OR (INLINE='Y') OR (INLINE='yes') OR (INLINE='y'); IF (INLINE='yes') OR (INLINE='y') OR (INLINE='no') OR (INLINE='n')THEN WRITELN(CHR(7),'YOU WONT GET VERY FAR IN LOWER CASE !'); IF YEA THEN SPKNO:=SPKYES; IF SPKNO<>0 THEN SPEAK(ARY^.RTEXT[SPKNO]); YES:=YEA; END; {YES} PROCEDURE ERRORHALT(I:INTEGER); BEGIN {ERRORHALT} WRITELN; WRITELN('FATAL ERROR # ',I,' ---- BYE!'); HALT; END; {ERRORHALT} PROCEDURE SET_NEW_LOC; FORWARD; PROCEDURE TESTCLOSE; VAR I : INTEGER; BEGIN { TESTCLOSE } IF (NEWLOC IN [1..8]) AND VBL^.CLOSING THEN BEGIN SPEAK(ARY^.RTEXT[130]); NEWLOC:=VBL^.LOC; IF NOT VBL^.PANIC THEN VBL^.CLOCK2:=15; VBL^.PANIC:=TRUE; END; IF (NEWLOC<>VBL^.LOC) AND NOT FORCED(VBL^.LOC) AND NOT BITSET(VBL^.LOC,3) THEN FOR I:=1 TO 5 DO IF (VARY^.ODLOC[I]=NEWLOC) AND VARY^.DSEEN[I] THEN BEGIN NEWLOC:=VBL^.LOC; SPEAK(ARY^.RTEXT[2]); I:=5; END; END; { TESTCLOSE } PROCEDURE DWARFSTUFF; VAR LASTLOC : INTEGER; TBITSET,TFORCED : BOOLEAN; PROCEDURE PIRATESTUFF; BEGIN { PIRATESTUFF} K:=0; STEAL:=FALSE; FOR J:=50 TO MAXTRS DO BEGIN IF (J=PYRAMID) AND ((VBL^.LOC=ARY^.PLAC[PYRAMID]) OR (VBL^.LOC=ARY^.PLAC[EMERALD])) THEN { NOTHING } ELSE BEGIN STEAL:=STEAL OR TOTING(J); IF VARY^.PLACE[J]=VBL^.LOC THEN K:=1; END; END; IF STEAL THEN BEGIN SPEAK(ARY^.RTEXT[128]); IF VARY^.PLACE[MESSAGE]=0 THEN MOVE(CHEST,VBL^.CHLOC); MOVE(MESSAGE,VBL^.CHLOC2); FOR J:=50 TO MAXTRS DO BEGIN IF (J=PYRAMID) AND ((VBL^.LOC=ARY^.PLAC[PYRAMID]) OR (VBL^.LOC=ARY^.PLAC[EMERALD])) THEN { NOTHING } ELSE BEGIN IF (VARY^.PLACE[J]=VBL^.LOC) AND (VARY^.FIXED[J]=0) THEN CARRY(J,VBL^.LOC); IF TOTING(J) THEN DROP(J,VBL^.CHLOC); END; END; VARY^.DLOC[6]:=VBL^.CHLOC; VARY^.ODLOC[6]:=VBL^.CHLOC; VARY^.DSEEN[6]:=FALSE; END ELSE BEGIN IF (VBL^.TALLY=(VBL^.TALLY2+1)) AND (K=0) AND (VARY^.PLACE[CHEST]=0) AND HERE(LAMP) AND (VARY^.PROP[LAMP]=1) THEN BEGIN SPEAK(ARY^.RTEXT[186]); MOVE(CHEST,VBL^.CHLOC); MOVE(MESSAGE,VBL^.CHLOC2); VARY^.DLOC[6]:=VBL^.CHLOC; VARY^.ODLOC[6]:=VBL^.CHLOC; VARY^.DSEEN[6]:=FALSE; END ELSE IF (VARY^.ODLOC[6]<>VARY^.DLOC[6]) AND PERCENT(20) THEN SPEAK(ARY^.RTEXT[127]); END; END; { PIRATESTUFF} BEGIN { DWARFSTUFF } IF VBL^.DFLAG=1 THEN IF (VBL^.LOC>=15) AND PERCENT(95) THEN BEGIN VBL^.DFLAG:=2; FOR I:=1 TO 2 DO IF PERCENT(50) THEN VARY^.DLOC[1+RAN(5)]:=0; FOR I:=1 TO 5 DO BEGIN IF VARY^.DLOC[I]=VBL^.LOC THEN VARY^.DLOC[I]:=DALTLC; VARY^.ODLOC[I]:=VARY^.DLOC[I]; END; SPEAK(ARY^.RTEXT[3]); DROP(AXE,VBL^.LOC); END ELSE ELSE BEGIN VBL^.DTOTAL:=0; ATTACK:=0; STICK:=0; FOR I:=1 TO 6 DO IF VARY^.DLOC[I]<>0 THEN BEGIN J:=1; KK:=ARY^.KEY[VARY^.DLOC[I]]; IF KK<>0 THEN REPEAT NEWLOC:=ARY^.TRAVEL2[KK]; IF (J>1) AND (J<=21) THEN LASTLOC:=VARY^.TK[J-1]; IF NEWLOC<=150 THEN BEGIN TBITSET:=BITSET(NEWLOC,3); TFORCED:=FORCED(NEWLOC); END ELSE BEGIN TBITSET:=FALSE; TFORCED:=FALSE; END; IF (NEWLOC>300) OR (NEWLOC<15) OR (NEWLOC=VARY^.ODLOC[I]) OR ((J>1) AND (NEWLOC=LASTLOC)) OR (J>=20) OR (NEWLOC=VARY^.DLOC[I]) OR TFORCED OR ((I=6) AND TBITSET) OR (ARY^.TRAVEL3[KK]=100) THEN ELSE BEGIN VARY^.TK[J]:=NEWLOC; J:=J+1; END; KK:=KK+1; UNTIL ARY^.TRAVEL[KK-1]<0; VARY^.TK[J]:=VARY^.ODLOC[I]; IF J>=2 THEN J:=J-1; J:=1+RAN(J); VARY^.ODLOC[I]:=VARY^.DLOC[I]; VARY^.DLOC[I]:=VARY^.TK[J]; VARY^.DSEEN[I]:=(VARY^.DSEEN[I] AND (VBL^.LOC>=15)) OR (VARY^.DLOC[I]=VBL^.LOC) OR (VARY^.ODLOC[I]=VBL^.LOC); IF VARY^.DSEEN[I] THEN BEGIN VARY^.DLOC[I]:=VBL^.LOC; IF I=6 THEN IF (VBL^.LOC<>VBL^.CHLOC) AND (VARY^.PROP[CHEST]<0) THEN PIRATESTUFF ELSE ELSE BEGIN VBL^.DTOTAL:=VBL^.DTOTAL+1; IF VARY^.ODLOC[I]=VARY^.DLOC[I] THEN BEGIN ATTACK:=ATTACK+1; IF VBL^.KNFLOC>=0 THEN VBL^.KNFLOC:=VBL^.LOC; IF RAN(1000)<(95*(VBL^.DFLAG-2)) THEN STICK:=STICK+1; END; END; END; END; END; IF VBL^.DTOTAL<>0 THEN BEGIN IF VBL^.DTOTAL=1 THEN SPEAK(ARY^.RTEXT[4]) ELSE BEGIN WRITE('THERE ARE ',VBL^.DTOTAL,' THREATENING '); WRITELN('LITTLE DWARVES IN THE ROOM WITH YOU'); END; IF ATTACK<>0 THEN BEGIN IF VBL^.DFLAG=2 THEN VBL^.DFLAG:=3; IF ATTACK=1 THEN BEGIN SPEAK(ARY^.RTEXT[5]); K:=52; END ELSE BEGIN K:=6; WRITE(ATTACK,' OF THEM THROW KNIVES AT YOU.'); END; IF STICK>1 THEN WRITELN(STICK,' OF THEM GET YOU!') ELSE SPEAK(ARY^.RTEXT[K+STICK]); IF STICK<>0 THEN BEGIN VBL^.OLDLC2:=VBL^.LOC; HE_DIED:=TRUE; END; END; END; END; { DWARFSTUFF } PROCEDURE DESCRIBE_CURRENT_LOCATION; BEGIN { DESCRIBE_CURRENT_LOCATION} IF VBL^.LOC=0 THEN BEGIN HE_DIED:=TRUE; EXIT(DESCRIBE_CURRENT_LOCATION); END; KK:=ARY^.STEXT[VBL^.LOC]; IF ((VARY^.ABB[VBL^.LOC] MOD VBL^.ABBNUM)=0) OR (KK=0) THEN KK:=ARY^.LTEXT[VBL^.LOC]; IF (NOT FORCED(VBL^.LOC)) AND DARK THEN BEGIN IF VBL^.WZDARK AND PERCENT(35) THEN BEGIN HE_DIED:=TRUE; PIT:=TRUE; EXIT(DESCRIBE_CURRENT_LOCATION); END; KK:=ARY^.RTEXT[16]; END; IF TOTING(BEAR) THEN SPEAK(ARY^.RTEXT[141]); SPEAK(KK); K:=1; IF FORCED(VBL^.LOC) THEN BEGIN SET_NEW_LOC; NEWLOCSET:=TRUE; EXIT(DESCRIBE_CURRENT_LOCATEION); END; IF (VBL^.LOC=33) AND PERCENT(25) AND NOT VBL^.CLOSING THEN SPEAK(ARY^.RTEXT[8]); IF NOT DARK THEN BEGIN VARY^.ABB[VBL^.LOC]:=VARY^.ABB[VBL^.LOC]+1; I:=VARY^.ATLOC[VBL^.LOC]; WHILE I<>0 DO BEGIN VBL^.OBJ:=I; IF VBL^.OBJ>100 THEN VBL^.OBJ:=VBL^.OBJ-100; IF (VBL^.OBJ=STEPS) AND TOTING(NUGGET) THEN ELSE BEGIN IF VARY^.PROP[VBL^.OBJ]<0 THEN BEGIN IF NOT VBL^.CLOSED THEN BEGIN VARY^.PROP[VBL^.OBJ]:=0; IF (VBL^.OBJ=RUG) OR (VBL^.OBJ=CHAIN) THEN VARY^.PROP[VBL^.OBJ]:=1; VBL^.TALLY:=VBL^.TALLY-1; IF (VBL^.TALLY=VBL^.TALLY2) AND (VBL^.TALLY<>0) THEN VBL^.LIMIT:=MIN(35,VBL^.LIMIT); END; END; IF NOT VBL^.CLOSED THEN BEGIN KK:=VARY^.PROP[VBL^.OBJ]; IF (VBL^.OBJ=STEPS) AND (VBL^.LOC=VARY^.FIXED[STEPS]) THEN KK:=1; PSPEAK(VBL^.OBJ,KK); END; END; I:=VARY^.LINK[I]; END; { WHILE I<>0 DO} END; END; { DESCRIBE_CURRENT_LOCATION } PROCEDURE CHECKHINTS; PROCEDURE GIVEHINT; BEGIN {GIVEHINT} VARY^.HINTLC[HINT]:=0; IF YES(ARY^.HINTS[HINT,3],0,54) THEN BEGIN WRITE('I AM PREPARED TO GIVE YOU A HINT, BUT '); WRITELN(' IT WILL COST YOU ',ARY^.HINTS[HINT,2],' POINTS'); VARY^.HINTED[HINT]:=YES(175,ARY^.HINTS[HINT,4],54); IF VARY^.HINTED[HINT] AND (VBL^.LIMIT>30) THEN VBL^.LIMIT:=VBL^.LIMIT+30*ARY^.HINTS[HINT,2]; END; END; {GIVEHINT} PROCEDURE CAVEHINT; BEGIN {CAVEHINT} IF (VARY^.PROP[GRATE]=0) AND NOT HERE(KEYS) THEN GIVEHINT ELSE VARY^.HINTLC[HINT]:=0; END; {CAVEHINT} PROCEDURE BIRDHINT; BEGIN {BIRDHINT} IF HERE(BIRD) AND TOTING(ROD) AND (VBL^.OBJ=BIRD) THEN GIVEHINT; END; {BIRDHINT} PROCEDURE SNAKEHINT; BEGIN {SNAKEHINT} IF HERE(SNAKE) AND NOT HERE(BIRD) THEN GIVEHINT ELSE VARY^.HINTLC[HINT]:=0; END; {SNAKEHINT} PROCEDURE MAZEHINT; BEGIN {MAZEHINT} IF (VARY^.ATLOC[VBL^.LOC]=0) AND (VARY^.ATLOC[VBL^.OLDLOC]=0) AND (VARY^.ATLOC[VBL^.OLDLC2]=0) AND (VBL^.HLDING>1) THEN GIVEHINT ELSE VARY^.HINTLC[HINT]:=0; END; {MAZEHINT} PROCEDURE DARKHINT; BEGIN {DARKHINT} IF (VARY^.PROP[EMERALD]<>-1) AND (VARY^.PROP[PYRAMID]=-1) THEN GIVEHINT ELSE VARY^.HINTLC[HINT]:=0; END; {DARKHINT} PROCEDURE WITTHINT; BEGIN {WITTHINT} GIVEHINT; END; {WITTHINT} BEGIN { CHECKHINTS} FOR HINT:=4 TO HNTSIZ DO BEGIN IF NOT VARY^.HINTED[HINT] THEN BEGIN IF BITSET(VBL^.LOC,HINT) THEN VARY^.HINTLC[HINT]:=VARY^.HINTLC[HINT]+1 ELSE VARY^.HINTLC[HINT]:=0; IF VARY^.HINTLC[HINT]>= ARY^.HINTS[HINT,1] THEN CASE HINT OF 4 : CAVEHINT; 5 : BIRDHINT; 6 : SNAKEHINT; 7 : MAZEHINT; 8 : DARKHINT; 9 : WITTHINT; END; {CASE OF HINT} END; END; END; { CHECKHINTS} PROCEDURE SET_NEW_LOC; VAR T1,T2,T3 : BOOLEAN; PROCEDURE PLOVERALCOVE; BEGIN { PLOVERALCOVE } NEWLOC:=199 - VBL^.LOC; IF (VBL^.HLDING=0) OR ((VBL^.HLDING=1) AND TOTING(EMERALD)) THEN ELSE BEGIN NEWLOC:=VBL^.LOC; SPEAK(ARY^.RTEXT[117]); END; EXIT(SET_NEW_LOC); END; { PLOVERALCOVE } PROCEDURE TROLLBRIDGE; BEGIN { TROLLBRIDGE } IF VARY^.PROP[TROLL]=1 THEN BEGIN PSPEAK(TROLL,1); VARY^.PROP[TROLL]:=0; MOVE(TROLL2,0); MOVE(TROLL2+100,0); MOVE(TROLL,ARY^.PLAC[TROLL]); MOVE(TROLL+100,ARY^.FIXD[TROLL]); JUGGLE(CHASM); NEWLOC:=VBL^.LOC; END ELSE BEGIN NEWLOC:=ARY^.PLAC[TROLL]+ARY^.FIXD[TROLL]-VBL^.LOC; IF VARY^.PROP[TROLL]=0 THEN VARY^.PROP[TROLL]:=1; IF TOTING(BEAR) THEN BEGIN SPEAK(ARY^.RTEXT[162]); VARY^.PROP[CHASM]:=1; VARY^.PROP[TROLL]:=2; DROP(BEAR,NEWLOC); VARY^.FIXED[BEAR]:=-1; VARY^.PROP[BEAR]:=3; IF VARY^.PROP[SPICES]<0 THEN VBL^.TALLY2:=VBL^.TALLY2+1; VBL^.OLDLC2:=NEWLOC; HE_DIED:=TRUE; END; END; EXIT(SET_NEW_LOC); END; { TROLLBRIDGE } BEGIN { SET_NEW_LOC } KK:=ARY^.KEY[VBL^.LOC]; IF KK=0 THEN ERRORHALT(26); NEWLOC:=VBL^.LOC; IF K=NULL THEN EXIT(SET_NEW_LOC); SKIPIT:=FALSE; IF K=BACK THEN BEGIN {BACK} SKIPIT:=TRUE; IF FORCED(K) THEN K:=VBL^.OLDLC2 ELSE K:=VBL^.OLDLOC; VBL^.OLDLC2:=VBL^.OLDLOC; VBL^.OLDLOC:=VBL^.LOC; K2:=0; IF K=VBL^.LOC THEN BEGIN SPEAK(ARY^.RTEXT[91]); EXIT(SET_NEW_LOC); END; OK:=FALSE; KK:=KK-1; REPEAT KK:=KK+1; IF K=ARY^.TRAVEL2[KK] THEN BEGIN K:=ABS(ARY^.TRAVEL[KK]); KK:=ARY^.KEY[VBL^.LOC]; OK:=TRUE; END ELSE BEGIN IF ARY^.TRAVEL2[KK]<=300 THEN BEGIN J:=ARY^.KEY[ARY^.TRAVEL2[KK]]; IF FORCED(ARY^.TRAVEL2[KK]) AND (ARY^.TRAVEL2[J]=K) THEN K2:=KK; END; IF ARY^.TRAVEL[KK]<0 THEN BEGIN KK:=K2; IF KK=0 THEN BEGIN SPEAK(ARY^.RTEXT[140]); EXIT(SET_NEW_LOC); END; K:=ABS(ARY^.TRAVEL[KK]); KK:=ARY^.KEY[VBL^.LOC]; OK:=TRUE; END; END; UNTIL OK OR (ARY^.TRAVEL2[KK]=K); END; {BACK} IF K=LOOK THEN BEGIN {LOOK} IF VBL^.DETAIL<3 THEN SPEAK(ARY^.RTEXT[15]); VBL^.DETAIL:=VBL^.DETAIL+1; VBL^.WZDARK:=FALSE; VARY^.ABB[VBL^.LOC]:=0; END {LOOK} ELSE {LOOK} IF K=CAVE THEN BEGIN {CAVE} IF VBL^.LOC<8 THEN SPEAK(ARY^.RTEXT[57]) ELSE SPEAK(ARY^.RTEXT[58]); END {CAVE} ELSE {CAVE} BEGIN {NOT SPECIAL} IF NOT SKIPIT THEN BEGIN VBL^.OLDLC2:=VBL^.OLDLOC; VBL^.OLDLOC:=VBL^.LOC; END; { TRAVEL = VERB } { TRAVEL2 = WHERE TO GO } { TRAVEL3 = CONDITION (IF ANY) } KK:=KK-1; REPEAT KK:=KK+1; OK:=(ABS(ARY^.TRAVEL[KK])=1) OR (ABS(ARY^.TRAVEL[KK])=K); UNTIL OK OR (ARY^.TRAVEL[KK]<0); IF NOT OK THEN BEGIN SPK:=12; CASE K OF 43,44,45,46,47,48,49,50,29,30 : SPK:=9; 7,36,37 : SPK:=10; 11,19 : SPK:=11; 62,65 : SPK:=42; 17 : SPK:=80; END; IF (VBL^.VERB=FIND) OR (VBL^.VERB=INVENTORY) THEN SPK:=59; SPEAK(ARY^.RTEXT[SPK]); EXIT(SET_NEW_LOC); END; REPEAT NEWLOC:=ARY^.TRAVEL2[KK]; TVCOND:=ARY^.TRAVEL3[KK]; K:=TVCOND MOD 100; IF K=0 THEN BEGIN T1:=FALSE; T2:=FALSE; T3:=FALSE; END ELSE BEGIN T1:=TOTING(K); T2:=AT(K); T3:=VARY^.PROP[K]<>(TVCOND DIV 100 -3) END; IF ((TVCOND<=100) AND ((TVCOND=0) OR PERCENT(TVCOND))) OR ((TVCOND>100) AND (TVCOND<=300) AND (T1 OR ((TVCOND>200) AND T2))) OR ((TVCOND>300) AND T3) THEN BEGIN IF NEWLOC<=300 THEN EXIT(SET_NEW_LOC); IF NEWLOC<=500 THEN BEGIN NEWLOC:=NEWLOC-300; IF NEWLOC=1 THEN PLOVERALCOVE ELSE IF NEWLOC=2 THEN DROP(EMERALD,VBL^.LOC) ELSE IF NEWLOC=3 THEN TROLLBRIDGE ELSE ERRORHALT(20); END ELSE BEGIN SPEAK(ARY^.RTEXT[NEWLOC-500]); NEWLOC:=VBL^.LOC; EXIT(SET_NEW_LOC); END; END; REPEAT IF ARY^.TRAVEL[KK]<0 THEN ERRORHALT(25); KK:=KK+1; UNTIL (TVCOND<>ARY^.TRAVEL3[KK]) AND (NEWLOC<>ARY^.TRAVEL2[KK]); UNTIL FALSE; { EXIT IS BY EXIT PROC} END; {NOT SPECIAL} END; { SET_NEW_LOC } ======================================================================================== DOCUMENT :usus Folder:VOL09:advverb.text ======================================================================================== PROCEDURE LEAVE; BEGIN {LEAVE} SKIPDWARF:=TRUE; SKIPDESCRIBE:=TRUE; IF SPK<>0 THEN SPEAK(ARY^.RTEXT[SPK]); EXIT(DOWHATHESAYS); END; {LEAVE} PROCEDURE MISCXIT; BEGIN {MISCXIT} IF (VBL^.OBJ=COINS) AND HERE(VEND_MACHINE) THEN BEGIN DESTROY(COINS); DROP(BATTERY,VBL^.LOC); PSPEAK(BATTERY,0); SPK:=0; LEAVE; END ELSE IF (VBL^.OBJ=BIRD) AND AT(DRAGON) AND (VARY^.PROP[DRAGON]=0) THEN BEGIN SPK:=154; DESTROY(BIRD); VARY^.PROP[BIRD]:=0; IF VARY^.PLACE[SNAKE]=ARY^.PLAC[SNAKE] THEN VBL^.TALLY2:=VBL^.TALLY2+1; LEAVE; END ELSE IF (VBL^.OBJ=BEAR) AND AT(TROLL) THEN BEGIN SPK:=163; MOVE(TROLL,0); MOVE(TROLL+100,0); MOVE(TROLL2,ARY^.PLAC[TROLL]); MOVE(TROLL2+100,ARY^.FIXD[TROLL]); JUGGLE(CHASM); VARY^.PROP[TROLL]:=2; END ELSE IF (VBL^.OBJ=VASE) AND (VBL^.LOC<>ARY^.PLAC[PILLOW]) THEN BEGIN SPK:=0; IF AT(PILLOW) THEN VARY^.PROP[VASE]:=0 ELSE BEGIN VARY^.PROP[VASE]:=2; VARY^.FIXED[VASE]:=-1; END; PSPEAK(VASE,VARY^.PROP[VASE]+1); END ELSE SPK:=54; END; {MISCXIT} PROCEDURE ASKWHATTODOITTO; BEGIN {ASKWHATTODOITTO} WRITELN(WD1,WD1X,' WHAT?'); VBL^.OBJ:=0; RESTART:=1; EXIT(DOWHATHESAYS); END; {ASKWHATTODOITTO} PROCEDURE FILL_IT; BEGIN {FILL_IT} IF VBL^.OBJ=VASE THEN BEGIN SPK:=29; IF LIQLOC(VBL^.LOC)=0 THEN SPK:=144; IF (LIQLOC(VBL^.LOC)=0) OR TOTING(VASE) THEN LEAVE; SPEAK(ARY^.RTEXT[145]); VARY^.PROP[VASE]:=2; VARY^.FIXED[VASE]:=-1; MISCXIT; LEAVE; END; IF (VBL^.OBJ<>0) AND (VBL^.OBJ<>BOTTLE) THEN LEAVE; IF (VBL^.OBJ=0) AND NOT HERE(BOTTLE) THEN ASKWHATTODOITTO; SPK:=107; IF LIQLOC(VBL^.LOC)=0 THEN SPK:=106; IF LIQ<>0 THEN SPK:=105; IF SPK<>107 THEN LEAVE; VARY^.PROP[BOTTLE]:=((VARY^.COND[VBL^.LOC] MOD 4) DIV 2) * 2; K:=LIQ; IF TOTING(BOTTLE) THEN VARY^.PLACE[K]:=-1; IF K=OIL THEN SPK:=108; LEAVE; END; {FILL_IT} PROCEDURE CARRY_IT; BEGIN {CARRY_IT} IF TOTING(VBL^.OBJ) THEN LEAVE; SPK:=25; IF (VBL^.OBJ=PLANT) AND (VARY^.PROP[PLANT]<=0) THEN SPK:=115; IF (VBL^.OBJ=BEAR) AND (VARY^.PROP[BEAR]=1) THEN SPK:=169; IF (VBL^.OBJ=CHAIN) AND (VARY^.PROP[BEAR]<>0) THEN SPK:=170; IF VARY^.FIXED[VBL^.OBJ]<>0 THEN LEAVE; IF (VBL^.OBJ=WATER) OR (VBL^.OBJ=OIL) THEN BEGIN IF HERE(BOTTLE) AND (LIQ=VBL^.OBJ) THEN VBL^.OBJ:=BOTTLE ELSE BEGIN VBL^.OBJ:=BOTTLE; IF VARY^.PROP[BOTTLE]<>1 THEN SPK:=105 ELSE IF TOTING(BOTTLE) THEN FILL_IT ELSE SPK:=104; LEAVE; END; END; IF VBL^.HLDING>MAXHLD THEN BEGIN SPK:=92; LEAVE; END; IF (VBL^.OBJ=BIRD) AND (VARY^.PROP[BIRD]=0) THEN BEGIN IF TOTING(ROD) THEN BEGIN SPK:=26; LEAVE; END; IF NOT TOTING(CAGE) THEN BEGIN SPK:=27; LEAVE; END; VARY^.PROP[BIRD]:=1; END; IF ((VBL^.OBJ=BIRD) OR (VBL^.OBJ=CAGE)) AND (VARY^.PROP[BIRD]<>0) THEN CARRY(BIRD+CAGE-VBL^.OBJ,VBL^.LOC); CARRY(VBL^.OBJ,VBL^.LOC); K:=LIQ; IF (VBL^.OBJ=BOTTLE) AND (K<>0) THEN VARY^.PLACE[K]:=-1; SPK:=54; LEAVE; END; {CARRY_IT} PROCEDURE DISTURBDWARVES; BEGIN {DISTURBDWARVES} SPEAK(ARY^.RTEXT[136]); ALLDONE:=TRUE; EXIT(DOWHATHESAYS); END; {DISTURBDWARVES} PROCEDURE DROP_IT; BEGIN {DROP IT} IF TOTING(ROD2) AND (VBL^.OBJ=ROD) AND NOT TOTING(ROD) THEN VBL^.OBJ:=ROD2; IF NOT TOTING(VBL^.OBJ) THEN LEAVE; IF (VBL^.OBJ=BIRD) AND HERE(SNAKE) THEN BEGIN SPK:=30; IF VBL^.CLOSED THEN DISTURBDWARVES; DESTROY(SNAKE); VARY^.PROP[SNAKE]:=1; END ELSE MISCXIT; K:=LIQ; IF K=VBL^.OBJ THEN VBL^.OBJ:=BOTTLE; IF (VBL^.OBJ=BOTTLE) AND (K<>0) THEN VARY^.PLACE[K]:=0; IF (VBL^.OBJ=CAGE) AND (VARY^.PROP[BIRD]<>0) THEN DROP(BIRD,VBL^.LOC); IF VBL^.OBJ=BIRD THEN VARY^.PROP[BIRD]:=0; DROP(VBL^.OBJ,VBL^.LOC); LEAVE; END; {DROP IT} PROCEDURE SAY_IT; VAR I : INTEGER; BEGIN {SAY_IT} IF WD2='' THEN BEGIN WD2:=WD1; WD2X:=WD1X; END; I:=VOCAB(WD2,-1); IF (I=62) OR (I=65) OR (I=71) OR (I=2025) THEN RESTART:=1 ELSE WRITELN('OKAY, "',WD2,WD2X,'"'); END; {SAY_IT} PROCEDURE L_U_IT; BEGIN {L_U_IT} IF (VBL^.OBJ=CLAM) OR (VBL^.OBJ=OYSTER) THEN BEGIN IF VBL^.OBJ=OYSTER THEN K:=1 ELSE K:=0; SPK:=124+K; IF TOTING(VBL^.OBJ) THEN SPK:=120+K; IF NOT TOTING(TRIDENT) THEN SPK:=122+K; IF VBL^.VERB=LOCK THEN SPK:=61; IF SPK=124 THEN BEGIN DESTROY(CLAM); DROP(OYSTER,VBL^.LOC); DROP(PEARL,105); END; LEAVE; END; IF VBL^.OBJ=DOOR THEN SPK:=111; IF (VBL^.OBJ=DOOR) AND (VARY^.PROP[DOOR]=1) THEN SPK:=54; IF VBL^.OBJ=CAGE THEN SPK:=32; IF VBL^.OBJ=KEYS THEN SPK:=55; IF (VBL^.OBJ=GRATE) OR (VBL^.OBJ=CHAIN) THEN SPK:=31; IF (SPK=31) AND HERE(KEYS) THEN BEGIN {KEYS HERE} IF VBL^.OBJ=CHAIN THEN BEGIN IF VBL^.VERB=LOCK THEN BEGIN IF VARY^.PROP[CHAIN]<>0 THEN SPK:=34 ELSE IF VBL^.LOC<>ARY^.PLAC[CHAIN] THEN SPK:=173 ELSE BEGIN SPK:=172; VARY^.PROP[CHAIN]:=2; IF TOTING(CHAIN) THEN DROP(CHAIN,VBL^.LOC); VARY^.FIXED[CHAIN]:=-1; END; END ELSE BEGIN IF VARY^.PROP[BEAR]=0 THEN SPK:=41 ELSE IF VARY^.PROP[CHAIN]=0 THEN SPK:=37 ELSE BEGIN SPK:=171; VARY^.PROP[CHAIN]:=0; VARY^.FIXED[CHAIN]:=0; IF VARY^.PROP[BEAR]<>3 THEN VARY^.PROP[BEAR]:=2; VARY^.FIXED[BEAR]:=2-VARY^.PROP[BEAR]; END; END END ELSE IF VBL^.CLOSING THEN BEGIN SPK:=130; IF NOT VBL^.PANIC THEN VBL^.CLOCK2:=15; VBL^.PANIC:=TRUE; END ELSE BEGIN SPK:=34+VARY^.PROP[GRATE]; IF VBL^.VERB=LOCK THEN VARY^.PROP[GRATE]:=0 ELSE BEGIN SPK:=SPK+2; VARY^.PROP[GRATE]:=1; END; END; END; LEAVE; END; {L_U_IT} PROCEDURE SAY_OK; BEGIN {SAY_OK} SPK:=54; LEAVE; END; {SAY_OK} PROCEDURE LAMP_ON; BEGIN {LAMP_ON} IF HERE(LAMP) THEN IF VBL^.LIMIT<0 THEN SPK:=184 ELSE BEGIN VARY^.PROP[LAMP]:=1; SPK:=0; SPEAK(ARY^.RTEXT[39]); SKIPDWARF:=TRUE; IF VBL^.WZDARK THEN EXIT(DOWHATHESAYS); END; LEAVE; END; {LAMP_ON} PROCEDURE LAMP_OFF; BEGIN {LAMP_OFF} IF HERE(LAMP) THEN BEGIN VARY^.PROP[LAMP]:=0; SPEAK(ARY^.RTEXT[40]); IF DARK THEN SPK:=16 ELSE SPK:=0; END; LEAVE; END; {LAMP_OFF} PROCEDURE WAVE_IT; BEGIN {WAVE_IT} IF (NOT TOTING(VBL^.OBJ)) AND ((VBL^.OBJ<>ROD) OR NOT TOTING(ROD2)) THEN SPK:=29; IF (VBL^.OBJ=ROD) AND AT(FISSURE) AND TOTING(VBL^.OBJ) AND NOT VBL^.CLOSING THEN BEGIN SPK:=0; VARY^.PROP[FISSURE]:=1-VARY^.PROP[FISSURE]; PSPEAK(FISSURE,2-VARY^.PROP[FISSURE]); END; LEAVE; END; {WAVE_IT} PROCEDURE KILL_IT; VAR I,J : INTEGER; BEGIN {KILL_IT} I:=0; FOR J:=1 TO 5 DO IF (VARY^.DLOC[J]=VBL^.LOC) AND (VBL^.DFLAG>=2) THEN BEGIN I:=J; J:=5; END; IF VBL^.OBJ=0 THEN BEGIN IF I<>0 THEN VBL^.OBJ:=DWARF; IF HERE(SNAKE) THEN VBL^.OBJ:=VBL^.OBJ*100 + SNAKE; IF AT(DRAGON) AND (VARY^.PROP[DRAGON]=0) THEN VBL^.OBJ:=VBL^.OBJ*100 + DRAGON; IF AT(TROLL) THEN VBL^.OBJ:=VBL^.OBJ*100 + TROLL; IF HERE(BEAR) AND (VARY^.PROP[BEAR]=0) THEN VBL^.OBJ:=VBL^.OBJ*100 + BEAR; IF VBL^.OBJ>100 THEN ASKWHATTODOITTO; IF VBL^.OBJ=0 THEN BEGIN IF HERE(BIRD) AND (VBL^.VERB<>THROW) THEN VBL^.OBJ:=BIRD; IF HERE(CLAM) OR HERE(OYSTER) THEN VBL^.OBJ:=VBL^.OBJ*100 + CLAM; IF VBL^.OBJ>100 THEN ASKWHATTODOITTO; END; END; IF VBL^.OBJ=BIRD THEN BEGIN SPK:=137; IF VBL^.CLOSED THEN LEAVE; DESTROY(BIRD); VARY^.PROP[BIRD]:=0; IF VARY^.PLACE[SNAKE]=ARY^.PLAC[SNAKE] THEN VBL^.TALLY2:=VBL^.TALLY2+1; SPK:=45; END; IF VBL^.OBJ=0 THEN SPK:=44; IF (VBL^.OBJ=CLAM) OR (VBL^.OBJ=OYSTER) THEN SPK:=150; IF VBL^.OBJ=SNAKE THEN SPK:=46; IF VBL^.OBJ=DWARF THEN SPK:=49; IF (VBL^.OBJ=DWARF) AND VBL^.CLOSED THEN DISTURBDWARVES; IF VBL^.OBJ=DRAGON THEN SPK:=167; IF VBL^.OBJ=TROLL THEN SPK:=157; IF VBL^.OBJ=BEAR THEN SPK:=165+(VARY^.PROP[BEAR]+1) DIV 2; IF (VBL^.OBJ<>DRAGON) OR (VARY^.PROP[DRAGON]<>0) THEN LEAVE; VBL^.VERB:=0; VBL^.OBJ:=0; IF NOT YES(49,0,0) THEN BEGIN RESTART:=2; SPK:=0; LEAVE; END; PSPEAK(DRAGON,1); VARY^.PROP[DRAGON]:=2; VARY^.PROP[RUG]:=0; K:=(ARY^.PLAC[DRAGON]+VARY^.FIXED[DRAGON]) DIV 2; MOVE(DRAGON+100,-1); MOVE(RUG+100,0); MOVE(DRAGON,K); MOVE(RUG,K); FOR I:=1 TO 100 DO IF (VARY^.PLACE[I]=ARY^.PLAC[DRAGON]) OR (VARY^.PLACE[I]=ARY^.FIXD[DRAGON]) THEN MOVE(I,K); VBL^.LOC:=K; K:=NULL; SET_NEW_LOC; EXIT(DOWHATHESAYS); END; {KILL_IT} PROCEDURE POUR_IT; BEGIN {POUR_IT} IF (VBL^.OBJ=BOTTLE) OR (VBL^.OBJ=0) THEN VBL^.OBJ:=LIQ; IF VBL^.OBJ=0 THEN ASKWHATTODOITTO; IF NOT TOTING(VBL^.OBJ) THEN LEAVE; SPK:=78; IF (VBL^.OBJ<>WATER) AND (VBL^.OBJ<>OIL) THEN LEAVE; VARY^.PROP[BOTTLE]:=1; VARY^.PLACE[VBL^.OBJ]:=0; SPK:=77; IF NOT (AT(PLANT) OR AT(DOOR)) THEN LEAVE; IF AT(DOOR) THEN BEGIN IF VBL^.OBJ=OIL THEN BEGIN SPK:=114; VARY^.PROP[DOOR]:=1; END ELSE BEGIN SPK:=113; VARY^.PROP[DOOR]:=0; END; LEAVE; END; SPK:=112; IF VBL^.OBJ<>WATER THEN LEAVE; PSPEAK(PLANT,VARY^.PROP[PLANT]+1); VARY^.PROP[PLANT]:=(VARY^.PROP[PLANT]+2) MOD 6; VARY^.PROP[PLANT2]:=VARY^.PROP[PLANT] DIV 2; K:=NULL; SET_NEW_LOC; EXIT(DOWHATHESAYS); END; {POUR_IT} PROCEDURE EAT_IT; BEGIN {EAT_IT} IF VBL^.OBJ=FOOD THEN BEGIN DESTROY(FOOD); SPK:=72; LEAVE; END; IF (VBL^.OBJ=BIRD) OR (VBL^.OBJ=SNAKE) OR (VBL^.OBJ=CLAM) OR (VBL^.OBJ=OYSTER) OR (VBL^.OBJ=DWARF) OR (VBL^.OBJ=DRAGON) OR (VBL^.OBJ=TROLL) OR (VBL^.OBJ=BEAR) THEN SPK:=71; LEAVE; END; {EAT_IT} PROCEDURE DRINK_IT; VAR I : INTEGER; BEGIN {DRINK_IT} IF (VBL^.OBJ=0) AND (LIQLOC(VBL^.LOC)<>WATER) AND ((LIQ<>WATER) OR NOT HERE(BOTTLE)) THEN ASKWHATTODOITTO; IF (VBL^.OBJ<>0) AND (VBL^.OBJ<>WATER) THEN SPK:=110; IF (SPK=110) OR (LIQ<>WATER) OR NOT HERE(BOTTLE) THEN LEAVE; VARY^.PROP[BOTTLE]:=1; VARY^.PLACE[WATER]:=0; SPK:=74; LEAVE; END; {DRINK_IT} PROCEDURE RUB_IT; BEGIN {RUB_IT} IF VBL^.OBJ<>LAMP THEN SPK:=76; LEAVE; END; {RUB_IT} PROCEDURE FEED_IT; BEGIN {FEED_IT} IF VBL^.OBJ=BIRD THEN BEGIN SPK:=100; LEAVE; END; IF (VBL^.OBJ=SNAKE) OR (VBL^.OBJ=DRAGON) OR (VBL^.OBJ=TROLL) THEN BEGIN IF (VBL^.OBJ=DRAGON) AND (VARY^.PROP[DRAGON]<>0) THEN SPK:=110; IF VBL^.OBJ=TROLL THEN SPK:=182; IF (VBL^.OBJ<>SNAKE) OR VBL^.CLOSED OR NOT HERE(BIRD) THEN LEAVE; SPK:=101; DESTROY(BIRD); VARY^.PROP[BIRD]:=0; VBL^.TALLY2:=VBL^.TALLY2+1; LEAVE; END; IF VBL^.OBJ=DWARF THEN BEGIN IF NOT HERE(FOOD) THEN LEAVE; SPK:=103; VBL^.DFLAG:=VBL^.DFLAG+1; LEAVE; END; IF VBL^.OBJ=BEAR THEN BEGIN IF VARY^.PROP[BEAR]=0 THEN SPK:=102; IF VARY^.PROP[BEAR]=3 THEN SPK:=110; IF NOT HERE(FOOD) THEN LEAVE; DESTROY(FOOD); VARY^.PROP[BEAR]:=1; VARY^.FIXED[AXE]:=0; VARY^.PROP[AXE]:=0; SPK:=168; LEAVE; END; SPK:=14; LEAVE; END; {FEED_IT} PROCEDURE TOSS_IT; VAR I : INTEGER; PROCEDURE TOSS_IT_AWAY; BEGIN {TOSS_IT_AWAY} SPEAK(ARY^.RTEXT[SPK]); DROP(AXE,VBL^.LOC); K:=NULL; SET_NEW_LOC; EXIT(DOWHATHESAYS); END; {TOSS_IT_AWAY} BEGIN {TOSS_IT} IF TOTING(ROD2) AND (VBL^.OBJ=ROD) AND NOT TOTING(ROD) THEN VBL^.OBJ:=ROD2; IF NOT TOTING(VBL^.OBJ) THEN LEAVE; IF (VBL^.OBJ>=50) AND (VBL^.OBJ<=MAXTRS) AND AT(TROLL) THEN BEGIN SPK:=159; DROP(VBL^.OBJ,0); MOVE(TROLL,0); MOVE(TROLL+100,0); DROP(TROLL2,ARY^.PLAC[TROLL]); DROP(TROLL2+100,ARY^.FIXD[TROLL]); JUGGLE(CHASM); LEAVE; END; IF (VBL^.OBJ=FOOD) AND HERE(BEAR) THEN BEGIN VBL^.OBJ:=BEAR; FEED_IT; END; IF VBL^.OBJ<>AXE THEN DROP_IT; FOR I:=1 TO 5 DO BEGIN IF VARY^.DLOC[I]=VBL^.LOC THEN BEGIN SPK:=48; IF RAN(3)<>0 THEN BEGIN VARY^.DSEEN[I]:=FALSE; VARY^.DLOC[I]:=0; SPK:=47; VBL^.DKILL:=VBL^.DKILL+1; IF VBL^.DKILL=1 THEN SPK:=149; END; TOSS_IT_AWAY; END; END; SPK:=152; IF AT(DRAGON) AND (VARY^.PROP[DRAGON]=0) THEN TOSS_IT_AWAY; SPK:=158; IF AT(TROLL) THEN TOSS_IT_AWAY; IF HERE(BEAR) AND (VARY^.PROP[BEAR]=0) THEN BEGIN SPK:=164; DROP(AXE,VBL^.LOC); VARY^.FIXED[AXE]:=-1; VARY^.PROP[AXE]:=1; JUGGLE(BEAR); LEAVE; END; VBL^.OBJ:=0; KILL_IT; END; {TOSS_IT} PROCEDURE FIND_IT; VAR I : INTEGER; BEGIN {FIND_IT} IF AT(VBL^.OBJ) OR ((LIQ=VBL^.OBJ) AND AT(BOTTLE)) OR (K=LIQLOC(VBL^.LOC)) THEN SPK:=94; IF VBL^.OBJ=DWARF THEN FOR I:=1 TO 6 DO IF (VARY^.DLOC[I]=VBL^.LOC) AND (VBL^.DFLAG>=2) THEN SPK:=94; IF VBL^.CLOSED THEN SPK:=138; IF TOTING(VBL^.OBJ) THEN SPK:=24; LEAVE; END; {FIND_IT} PROCEDURE BLAST_IT; BEGIN {BLAST_IT} IF (VARY^.PROP[ROD2]<0) OR NOT VBL^.CLOSED THEN LEAVE; BONUS:=133; IF VBL^.LOC=115 THEN BONUS:=134; IF HERE(ROD2) THEN BONUS:=135; SPEAK(ARY^.RTEXT[BONUS]); ALLDONE:=TRUE; EXIT(DOWHATHESAYS); END; {BLAST_IT} PROCEDURE READ_IT; BEGIN {READ_IT} IF DARK THEN BEGIN WRITELN('I SEE NO ',WD1,WD1X,' HERE.'); SPK:=0; LEAVE; END; IF VBL^.OBJ=MAGAZINE THEN SPK:=190; IF VBL^.OBJ=TABLET THEN SPK:=196; IF VBL^.OBJ=MESSAGE THEN SPK:=191; IF (VBL^.OBJ=OYSTER) AND VARY^.HINTED[2] AND TOTING(OYSTER) THEN SPK:=194; IF (VBL^.OBJ<>OYSTER) OR VARY^.HINTED[2] OR NOT TOTING(OYSTER) OR NOT VBL^.CLOSED THEN LEAVE; VARY^.HINTED[2]:=YES(192,193,54); SPK:=0; LEAVE; END; {READ_IT} PROCEDURE BREAK_IT; BEGIN {BREAK_IT} IF VBL^.OBJ=MIRROR THEN SPK:=148; IF (VBL^.OBJ=VASE) AND (VARY^.PROP[VASE]=0) THEN BEGIN SPK:=198; IF TOTING(VASE) THEN DROP(VASE,VBL^.LOC); VARY^.PROP[VASE]:=2; VARY^.FIXED[VASE]:=-1; LEAVE; END ELSE BEGIN IF (VBL^.OBJ<>MIRROR) OR NOT VBL^.CLOSED THEN LEAVE; SPEAK(ARY^.RTEXT[197]); DISTURBDWARVES; END; END; {BREAK_IT} PROCEDURE WAKE_IT; BEGIN {WAKE_IT} IF (VBL^.OBJ<>DWARF) OR NOT VBL^.CLOSED THEN LEAVE; SPEAK(ARY^.RTEXT[199]); DISTURBDWARVES; END; {WAKE_IT} PROCEDURE CARRY_SOMETHING; VAR I : INTEGER; BEGIN {CARRY_SOMETHING} IF (VARY^.ATLOC[VBL^.LOC]=0) THEN ASKWHATTODOITTO; IF VARY^.LINK[VARY^.ATLOC[VBL^.LOC]]<>0 THEN ASKWHATTODOITTO; FOR I:=1 TO 5 DO IF (VARY^.DLOC[I]=VBL^.LOC) AND (VBL^.DFLAG>=2) THEN ASKWHATTODOITTO; VBL^.OBJ:=VARY^.ATLOC[VBL^.LOC]; CARRY_IT; END; {CARRY_SOMETHING} PROCEDURE L_U_SOMETHING; BEGIN {L_U_SOMETHING} SPK:=28; IF HERE(CLAM) THEN VBL^.OBJ:=CLAM; IF HERE(OYSTER) THEN VBL^.OBJ:=OYSTER; IF AT(DOOR) THEN VBL^.OBJ:=DOOR; IF AT(GRATE) THEN VBL^.OBJ:=GRATE; IF (VBL^.OBJ<>0) AND HERE(CHAIN) THEN ASKWHATTODOITTO; IF HERE(CHAIN) THEN VBL^.OBJ:=CHAIN; IF VBL^.OBJ=0 THEN LEAVE; L_U_IT; END; {L_U_SOMETHING} PROCEDURE EAT_SOMETHING; BEGIN {EAT_SOMETHING} IF NOT HERE(FOOD) THEN ASKWHATTODOITTO; VBL^.OBJ:=FOOD; EAT_IT; END; {EAT_SOMETHING} PROCEDURE QUIT2; BEGIN {QUIT2} ALLDONE:=GAVEUP; IF GAVEUP THEN EXIT(DOWHATHESAYS); SPK:=0; LEAVE; END; {QUIT2} PROCEDURE QUIT; BEGIN {QUIT} GAVEUP:=YES(22,54,54); QUIT2; END; {QUIT} PROCEDURE REPORT; VAR I : INTEGER; BEGIN {REPORT - INVENTORY} SPK:=98; FOR I:=1 TO 100 DO IF (I<>BEAR) AND TOTING(I) THEN BEGIN IF SPK=98 THEN SPEAK(ARY^.RTEXT[99]); PSPEAK(I,-1); SPK:=0; END; IF TOTING(BEAR) THEN SPK:=141; LEAVE; END; {REPORT} PROCEDURE REPORT_SCORE; BEGIN {REPORT_SCORE} SCORE:=GETSCORE(TRUE); WRITELN('IF YOU WERE TO QUIT NOW, YOU WOULD SCORE'); WRITELN(SCORE,' OUT OF A POSSIBLE ',MAXSCORE); GAVEUP:=YES(143,54,54); QUIT2; END; {REPORT_SCORE} PROCEDURE WORD_FOO; BEGIN {WORD_FOO} K:=VOCAB(WD1,3); SPK:=42; IF VBL^.FOOBAR=1-K THEN BEGIN VBL^.FOOBAR:=K; IF K<>4 THEN BEGIN SPK:=54; LEAVE; END; IF (VARY^.PLACE[EGGS]=ARY^.PLAC[EGGS]) OR (TOTING(EGGS) AND (VBL^.LOC=ARY^.PLAC[EGGS])) THEN LEAVE; IF (VARY^.PLACE[EGGS]=0) AND (VARY^.PLACE[TROLL]=0) AND (VARY^.PROP[TROLL]=0) THEN VARY^.PROP[TROLL]:=1; K:=2; IF HERE(EGGS) THEN K:=1; IF VBL^.LOC=ARY^.PLAC[EGGS] THEN K:=0; MOVE(EGGS,ARY^.PLAC[EGGS]); PSPEAK(EGGS,K); SPK:=0; LEAVE; END; IF VBL^.FOOBAR<>0 THEN SPK:=151; LEAVE; END; {WORD_FOO} PROCEDURE SET_BRIEF; BEGIN {SET_BRIEF} SPK:=156; VBL^.ABBNUM:=10000; VBL^.DETAIL:=3; LEAVE; END; {SET_BRIEF} PROCEDURE READ_SOMETHING; BEGIN {READ_SOMETHING} IF HERE(MAGAZINE) THEN VBL^.OBJ:=MAGAZINE; IF HERE(TABLET) THEN VBL^.OBJ:=VBL^.OBJ*100 + TABLET; IF HERE(MESSAGE) THEN VBL^.OBJ:=VBL^.OBJ*100 + MESSAGE; IF VBL^.CLOSED AND TOTING(OYSTER) THEN VBL^.OBJ:=OYSTER; IF (VBL^.OBJ>100) OR (VBL^.OBJ=0) OR DARK THEN ASKWHATTODOITTO; READ_IT; END; {READ_SOMETHING} PROCEDURE SUSPEND; PROCEDURE SUSPEXIT; BEGIN { SUSPEXIT } WRITELN('ERROR SUSPENDING GAME'); CLOSE(INFILE); EXIT(SUSPEND); END; { SUSPEXIT } BEGIN { SUSPEND } NAMEANDPW; VBL^.PASSWORD:=TESTPW; VBL^.VERSION:=VERSION; REWRITE(INFILE,NAMEOFUSER); I:=(SIZEOF(VARYS)+511) DIV 512; IF I<>BLOCKWRITE(INFILE,VARY^.DBLK,I) THEN SUSPEXIT; I:=(SIZEOF(VBLS)+511) DIV 512; IF I<>BLOCKWRITE(INFILE,VBL^.DBLK,I) THEN SUSPEXIT; CLOSE(INFILE,LOCK); WRITELN; WRITE('ADVENTURE GAME SAVED AS ',NAMEOFUSER); EXIT(ADVENTURE); END; { SUSPEND } PROCEDURE ANALANITVERB; BEGIN {ANALANITVERB} CASE VBL^.VERB OF 1: CARRY_SOMETHING; { TAKE } 2: ASKWHATTODOITTO; { DROP } 3: ASKWHATTODOITTO; { SAY } 4: L_U_SOMETHING; { OPEN } 5: SAY_OK; { NOTHING } 6: L_U_SOMETHING; { LOCK } 7: LAMP_ON; { ON } 8: LAMP_OFF; { OFF } 9: ASKWHATTODOITTO; { WAVE } 10: ASKWHATTODOITTO; { CALM } 11: LEAVE; { WALK } 12: KILL_IT; { KILL } 13: POUR_IT; { POUR } 14: EAT_SOMETHING; { EAT } 15: DRINK_IT; { DRINK } 16: ASKWHATTODOITTO; { RUB } 17: ASKWHATTODOITTO; { TOSS } 18: QUIT; { QUIT } 19: ASKWHATTODOITTO; { FIND } 20: REPORT; { INVENTORY } 21: ASKWHATTODOITTO; { FEED } 22: FILL_IT; { FILL } 23: BLAST_IT; { BLAST } 24: REPORT_SCORE; { SCORE } 25: WORD_FOO; { FOO } 26: SET_BRIEF; { BRIEF } 27: READ_SOMETHING; { READ } 28: ASKWHATTODOITTO; { BREAK } 29: ASKWHATTODOITTO; { WAKE } 30: SUSPEND; { SUSPEND } END; {CASE} IF VBL^.VERB>29 THEN ERRORHALT(23); END; {ANALANITVERB} PROCEDURE ANALATVERB; BEGIN {ANALATVERB} CASE VBL^.VERB OF 1: CARRY_IT; { TAKE } 2: DROP_IT; { DROP } 3: SAY_IT; { SAY } 4: L_U_IT; { OPEN } 5: SAY_OK; { NOTHING } 6: L_U_IT; { LOCK } 7: LAMP_ON; { ON } 8: LAMP_OFF; { OFF } 9: WAVE_IT; { WAVE } 10: LEAVE; { CALM } 11: LEAVE; { WALK } 12: KILL_IT; { KILL } 13: POUR_IT; { POUR } 14: EAT_IT; { EAT } 15: DRINK_IT; { DRINK } 16: RUB_IT; { RUB } 17: TOSS_IT; { TOSS } 18: LEAVE; { QUIT } 19: FIND_IT; { FIND } 20: FIND_IT; { INVENTORY } 21: FEED_IT; { FEED } 22: FILL_IT; { FILL } 23: BLAST_IT; { BLAST } 24: LEAVE; { SCORE } 25: LEAVE; { FOO } 26: LEAVE; { BRIEF } 27: READ_IT; { READ } 28: BREAK_IT; { BREAK } 29: WAKE_IT; { WAKE } 30: SUSPEND; { SUSPEND } END; {CASE} IF VBL^.VERB>29 THEN ERRORHALT(24); END; {ANALATVERB} ======================================================================================== DOCUMENT :usus Folder:VOL09:castles.text ======================================================================================== PROGRAM CASTLES; {A WARGAME} CONST CLEARSCREEN = 89; CSPREFIX = 27; TYPE GAME = RECORD PLACE : ARRAY[1..7,1..7] OF CHAR; POP : ARRAY[1..7,1..7] OF INTEGER; OWN : ARRAY[1..7,1..7] OF INTEGER; TROOPS : ARRAY[1..7,1..7] OF INTEGER; NAME : ARRAY[1..4] OF STRING[12]; MONEY : ARRAY[1..4] OF REAL; ARMY : ARRAY[1..4] OF INTEGER; SEQ : ARRAY[1..4] OF INTEGER; TAX : ARRAY[1..4] OF REAL; TAXBASE : ARRAY[1..4] OF INTEGER; CAS : ARRAY[1..4] OF INTEGER; PAY : ARRAY[1..4] OF REAL; NUMP : INTEGER; TURN : INTEGER; ROUND : INTEGER; PTURN : INTEGER; ROUNDSINTURN : INTEGER; END; {RECORD - GAME} VAR SEED : REAL; DATA : GAME; GAMEDATA : FILE OF GAME; I,J,K,POSITION : INTEGER; RESTART : BOOLEAN; VALID : SET OF 11..77; ANS,S,PD : STRING; AN : CHAR; ATLEASTONEPLAYERIN,ALLBUTONEPLAYEROUT : BOOLEAN; FUNCTION RANDOM : REAL; BEGIN SEED := SEED * 27.182813 + 31.415917; SEED := SEED - TRUNC(SEED); RANDOM := SEED; END; {RANDOM} FUNCTION RND(LOW, HIGH : INTEGER):INTEGER; VAR RANGE : INTEGER; BEGIN RANGE := HIGH - LOW + 1; RND := TRUNC(RANDOM * RANGE + LOW); END; {RND} PROCEDURE SEQIT; VAR I, J, SWAP : INTEGER; BEGIN WITH DATA DO BEGIN FOR I := 1 TO NUMP-1 DO BEGIN J := RND(I,NUMP); SWAP := SEQ[I]; SEQ[I] := SEQ[J]; SEQ[J] := SWAP; END; END; END; {SEQIT} PROCEDURE SPLIT(VAR ST : STRING); BEGIN {SPLIT} IF POSITION < LENGTH(ANS) THEN IF NOT(ANS[POSITION] IN ['0'..'9']) THEN REPEAT POSITION := POSITION + 1; UNTIL (POSITION = LENGTH(ANS)) OR (ANS[POSITION] IN ['0'..'9']); IF POSITION < LENGTH(ANS) THEN IF ANS[POSITION] IN ['0'..'9'] THEN REPEAT ST := CONCAT(ST,COPY(ANS,POSITION,1)); POSITION := POSITION+1; UNTIL (NOT(ANS[POSITION] IN ['0'..'9'])) OR (POSITION = LENGTH(ANS)); IF POSITION <= LENGTH(ANS) THEN BEGIN IF ANS[POSITION] IN ['0'..'9'] THEN ST := CONCAT(ST,COPY(ANS,POSITION,1)); POSITION := POSITION + 1; END; END; {SPLIT} PROCEDURE CONVERT(VAR STR : STRING; VAR INT : INTEGER); VAR I,L,M : INTEGER; BEGIN {CONVERT} L := 2; {MAXIMUM NUMBER OF DIGITS TO CONVERT - FROM LEFT} L := LENGTH(STR) - L + 1; IF L < 1 THEN L := 1; M := 1; INT := 0; FOR I := LENGTH(STR) DOWNTO L DO BEGIN INT := INT + (ORD(STR[I])-48) * M; M := M * 10; END; END;{CONVERT} PROCEDURE CLEARTHESCREEN; BEGIN GOTOXY(0,0); WRITELN(CHR(CSPREFIX),CHR(CLEARSCREEN)); END; {CLEARTHESCREEN} PROCEDURE OUTMSG; BEGIN WITH DATA DO BEGIN CLEARTHESCREEN; WRITELN('THE GAME IS OVER ...........'); FOR I := 1 TO NUMP DO BEGIN IF ARMY[I] > 0 THEN BEGIN WRITELN; WRITELN; WRITELN('WARLORD ',NAME[I],','); WRITELN; WRITELN('THE WAR IS OVER, BUT THE GAME HAS JUST BEGUN........'); FOR J := 1 TO 10000 DO BEGIN END; WRITELN; WRITELN; WRITELN('YOU HAVE CONQUERED THE WHOLE OF THE LAND ... '); WRITELN; FOR J := 1 TO 10000 DO BEGIN END; WRITE('WARLORD'); IF NUMP > 2 THEN WRITE('S'); FOR J := 1 TO NUMP DO BEGIN IF J<>I THEN BEGIN WRITE(' '); IF (NUMP>2) AND ((J=NUMP) OR ((J=NUMP-1) AND (I=NUMP))) THEN WRITE('AND '); WRITE(NAME[J]); IF NUMP>3 THEN WRITE(','); END; END; IF NUMP > 2 THEN WRITE(' HAVE') ELSE WRITE(' HAS'); WRITELN(' BEEN'); WRITELN('SUBJIGATED TO YOUR WILL AND COMMAND .............'); FOR J := 1 TO 10000 DO BEGIN END; WRITELN; WRITELN; WRITELN('IT IS UP TO YOU NOW TO THINK OF A JUST AND LASTING'); WRITE('REWARD FOR THE PERSON'); IF NUMP>2 THEN WRITE('S'); WRITE(' WHO '); IF NUMP>2 THEN WRITE('HAVE ') ELSE WRITE('HAS '); WRITELN('CAUSED YOU SO MMUCH GRIEF ......'); FOR J := 1 TO 10000 DO BEGIN END; WRITELN; WRITELN; WRITELN; WRITELN('I HOPE YOU HAVE FUN.................................'); WRITELN; EXIT(CASTLES); END; END; END; END; PROCEDURE WAIT; BEGIN GOTOXY(39,15); WRITE('PRESS RETURN TO CONTINUE'); GOTOXY(55,13); READ(ANS); RESET(INPUT); END;{WAIT} PROCEDURE NEWGAME; VAR A,I,J,K,R : INTEGER; X : REAL; ANS : STRING[20]; PROCEDURE CASTLE(IL, IH, JL, JH, P : INTEGER); BEGIN WITH DATA DO BEGIN I := RND(IL,IH); J := RND(JL,JH); P := SEQ[P]; CAS[P] := I*10+J; PLACE[I,J] := 'C'; TROOPS[I,J] := ARMY[P]; OWN[I,J] := P; POP[I,J] := TRUNC(RANDOM * 3.6 + 6); END; {WITH DATA} END; {CASTLE PROCEDURE} PROCEDURE RAND; BEGIN I := RND(1,7); J := RND(1,7); END; {RAND} BEGIN {NEWGAME} WITH DATA DO BEGIN CLEARTHESCREEN; GOTOXY(20,5); WRITE('Do you want to restart an old game? '); READ(AN); RESET(INPUT); IF (AN = 'Y') OR (AN = 'y') THEN BEGIN RESET(GAMEDATA,'CASTLES.DATA'); GET(GAMEDATA); DATA := GAMEDATA^; CLOSE(GAMEDATA,LOCK); RESTART := TRUE; END ELSE BEGIN REPEAT GOTOXY(20,7); WRITE('How many players? '); READ(AN); IF EOF THEN RESET(INPUT); A := ORD(AN) - 48; IF NOT (A IN [2..4]) THEN BEGIN GOTOXY(0,15); WRITE('2, 3, or 4 players only please.'); WAIT; CLEARTHESCREEN; END; UNTIL A IN [2..4]; NUMP := A; GOTOXY(20,9); WRITE('Enter any character. '); READ(AN); RESET(INPUT); FOR A := 0 TO ORD(AN) DO X := RANDOM; FOR I := 1 TO NUMP DO BEGIN REPEAT GOTOXY(20,9+I*2); WRITE('What is player ',PD[I],'''s name? '); RESET(INPUT); READLN(ANS); IF EOF THEN RESET(INPUT); UNTIL ANS <> ''; NAME[I] := ANS; FOR A := 0 TO LENGTH(ANS) DO X := RANDOM; ARMY[I] := RND(7,11); MONEY[I] := 0; END; FOR I := 1 TO 7 DO FOR J:= 1 TO 7 DO BEGIN POP[I,J] := 0; TROOPS[I,J] := 0; PLACE[I,J] := '*'; OWN[I,J] := 0; END; SEQIT; CASTLE(1,2,3,5,1); CASTLE(6,7,3,5,2); IF NUMP > 2 THEN CASTLE(3,5,1,2,3); IF NUMP > 3 THEN CASTLE(3,5,6,7,4); POP[4,4] := 9; PLACE[4,4] := 'X'; K := 1; REPEAT RAND; IF PLACE[I,J] <> '*' THEN K :=1 ELSE BEGIN K := K+1; PLACE[I,J] := 'T'; POP[I,J] := TRUNC(RANDOM *3.5 + 4); END; {ELSE} UNTIL K > NUMP; FOR K := 1 TO 9 DO BEGIN IF K < 5 THEN BEGIN REPEAT RAND UNTIL PLACE[I,J] = '*'; PLACE[I,J] := 'L'; REPEAT RAND UNTIL PLACE[I,J] = '*'; PLACE[I,J] := 'S'; END; {WHILE K < 5} REPEAT RAND UNTIL PLACE[I,J] = '*'; PLACE[I,J] := 'F'; END; FOR I := 1 TO 7 DO FOR J := 1 TO 7 DO IF PLACE[I,J] = '*' THEN POP[I,J] := RND(1,3); TURN := 1; RESTART := FALSE; END; END; {WITH DATA} END; {NEWGAME} PROCEDURE BOARD; VAR ROW, COL, I, J : INTEGER; PLAYER : ARRAY[1..4] OF 'A'..'D'; BEGIN WITH DATA DO BEGIN CLEARTHESCREEN; FOR J := 1 TO 7 DO BEGIN GOTOXY(J*7,0); WRITE(J); END; FOR I := 1 TO 7 DO BEGIN GOTOXY(0,I*2); WRITE(I); END; FOR I := 1 TO 7 DO FOR J := 1 TO 7 DO BEGIN GOTOXY(J*7-2,I*2); WRITE(PLACE[I,J]); IF OWN[I,J] <> 0 THEN WRITE(POP[I,J],PD[OWN[I,J]],TROOPS[I,J]) ELSE WRITE(' '); END; END;{WITH DATA} END; {BOARD} PROCEDURE PLAY; VAR STILLPLAYING,MOVEOK : BOOLEAN; FROM,TX,NUMBER,PL,FI,FJ,TI,TJ,R,PT,DL,AL : INTEGER; DF : REAL; PROCEDURE INTEST; VAR F,T,N :STRING; BEGIN {INTEST} REPEAT GOTOXY(55,14); READLN(ANS); IF EOF THEN RESET(INPUT); UNTIL ANS <> ''; POSITION := 1; F := ''; T := ''; N := ''; SPLIT(F); SPLIT(T); SPLIT(N); CONVERT(F,FROM); CONVERT(T,TX); CONVERT(N,NUMBER); END;{INTEST} PROCEDURE MERROR(ERROR : INTEGER); VAR E : STRING[40]; BEGIN MOVEOK := FALSE; E := 'Unidentified error. '; CASE ERROR OF 1: E := 'INVALID FROM POSITION '; 2: E := 'INVALID TO POSITION '; 3: E := 'You have no army there. '; 4: E := 'One move at a time please. '; 5: E := 'You can''t march into a lake! '; 6: E := 'You don''t have that many troops there!'; 7: E := 'You don''t have enough money.? '; 8: E := 'Invalid position. '; 9: E := 'You don''t own that place. '; 10: E := 'You can''t place troops in the capital.'; 11: E := 'For no move enter a ''0'' from position. '; 12: E := 'NOW you MUST take at least one. ' END; GOTOXY(0,15); WRITE(E); WAIT; END; {MERROR} PROCEDURE COMBAT; PROCEDURE RESULTS; BEGIN WITH DATA DO BEGIN CLEARTHESCREEN; WRITE('COMBAT RESULTS BETWEEN WARLORDS '); WRITELN(NAME[PL],' AND ',NAME[OWN[TI,TJ]]); WRITELN(); WRITE('ATTACKING WARLORD ',NAME[PL]); WRITELN(' LOST ',AL,' ARMIES'); WRITELN(); WRITE('DEFENDING WARLORD '); WRITE(NAME[OWN[TI,TJ]],' LOST '); WRITELN(DL,' ARMIES '); END;{WITH DATA} END;{RESULTS} BEGIN {COMBAT} WITH DATA DO BEGIN CASE PLACE[TI,TJ] OF '*': DF := 1; 'C': DF := 4; 'X': DF := 3; 'F': DF := 1.75; 'S': DF := 2; 'T': DF := 1.5 END; DL := TRUNC((NUMBER * (RANDOM * 0.5 + 0.5))/DF); AL := TRUNC(TROOPS[TI,TJ] * (RANDOM * 0.5 + 0.5) * DF); IF AL > NUMBER THEN AL := NUMBER; IF DL > TROOPS[TI,TJ] THEN DL := TROOPS[TI,TJ]; RESULTS; TROOPS[TI,TJ] := TROOPS[TI,TJ] - DL; ARMY[OWN[TI,TJ]] := ARMY[OWN[TI,TJ]] - DL; NUMBER := NUMBER - AL; ARMY[PL] := ARMY[PL] - AL; WRITE('ATTACK WAS '); IF TROOPS[TI,TJ] > 0 THEN BEGIN {UNSUCCESSFUL} WRITELN('UNSUCCESSFUL'); TROOPS[FI,FJ] := TROOPS[FI,FJ] + NUMBER; IF TROOPS[FI,FJ] > 0 THEN OWN[FI,FJ] := PL; END {UNSUCCESSFUL} ELSE BEGIN {SUCCESSFUL} WRITELN('SUCCESSFUL'); IF PLACE[TI,TJ] = 'C' THEN BEGIN {TAKE CAS} CAS[OWN[TI,TJ]] := 0; MONEY[PL] := MONEY[PL] + MONEY[OWN[TI,TJ]]; IF CAS[PL] = 0 THEN CAS[PL] := TI * 10 + TJ; END; {TAKE CAS} TROOPS[TI,TJ] := NUMBER; OWN[TI,TJ] := PL; END; {SUCCESSFUL} WAIT; END;{WITH DATA} END;{COMBAT} PROCEDURE MOVE; BEGIN WITH DATA DO BEGIN IF (PLACE[TI,TJ] = 'C') AND (OWN[TI,TJ] = 0) THEN CAS[PL] := TX; IF ((PLACE[TI,TJ] = 'F') OR (PLACE[TI,TJ] = 'S')) AND (RANDOM <= 0.7) THEN BEGIN AL := TRUNC(RANDOM * NUMBER +1); NUMBER := NUMBER -AL; ARMY[PL] := ARMY[PL] - AL; IF PLACE[TI,TJ] = 'F' THEN WRITE(AL,' TROOPS LOST IN FOREST ') ELSE WRITE(AL,' TROOPS DROWNED IN SWAMP '); WAIT; END; TROOPS[TI,TJ] := TROOPS[TI,TJ] + NUMBER; IF NUMBER > 0 THEN OWN[TI,TJ] := PL; END;{WITH DATA} END;{MOVE} PROCEDURE ECONOMIC; CONST TAXRATE = 675.0; PAYRATE = 325.0; VAR N : STRING; A, LINE : INTEGER; PROCEDURE INEW; BEGIN WRITELN(); WRITE('How many? '); READ(ANS); RESET(INPUT); POSITION := 1; N := ''; SPLIT(N); CONVERT(N,A); MOVEOK := TRUE; END; PROCEDURE FIELDTROOPS; BEGIN WITH DATA DO BEGIN {FT1} REPEAT GOTOXY(0,7); WRITELN(); GOTOXY(0,7); WRITE('Do you wish to rase field troops? '); READ(AN); RESET(INPUT); UNTIL (AN = 'Y') OR (AN = 'N') OR (AN = 'y') OR (AN = 'n'); WRITELN(); IF (AN = 'Y') OR (AN = 'y') THEN BEGIN {FT2} REPEAT INEW; MOVEOK := TRUE; IF (A * 2000.0) > MONEY[I] THEN MERROR(7); IF A = 0 THEN MERROR(12); UNTIL MOVEOK = TRUE; MONEY[I] := MONEY[I] - A * 2000.0; ARMY[I] := ARMY[I] + A; PL := I; REPEAT MOVEOK := TRUE; BOARD; GOTOXY(0,15); WRITE('Where do you want them? '); INTEST; IF NOT(FROM IN VALID) THEN MERROR(8) ELSE BEGIN J := FROM DIV 10; K := FROM MOD 10; IF OWN[J,K] <> I THEN MERROR(9); IF PLACE[J,K] = 'X' THEN MERROR(10); IF MOVEOK THEN TROOPS[J,K] := TROOPS[J,K] + A; END; UNTIL MOVEOK = TRUE; BOARD; WAIT; CLEARTHESCREEN; END; {FT2} END; {WITH DATA} END; {FT1} PROCEDURE CASTLETROOPS; BEGIN WITH DATA DO BEGIN {CASTLESTROOPS} REPEAT GOTOXY(0,11); WRITELN(); GOTOXY(0,11); WRITE('Do you wish to raise castle troops? '); READ(AN); RESET(INPUT); UNTIL (AN = 'Y') OR (AN = 'y') OR (AN = 'N') OR (AN = 'n'); IF (AN = 'Y') OR (AN = 'y') THEN BEGIN REPEAT INEW; MOVEOK := TRUE; IF (A * 2000.0) > MONEY[I] THEN MERROR(7); IF A = 0 THEN MERROR(12); UNTIL MOVEOK = TRUE; J := CAS[I] DIV 10; K := CAS[I] MOD 10; TROOPS[J,K] := TROOPS[J,K] + A; MONEY[I] := MONEY[I] - A * 2000.0; ARMY[I] := ARMY[I] + A; WRITELN('TROOPS IN CASTLE NOW = ',TROOPS[J,K]); END; WAIT; END; {WITH DATA} END; {CASTLETROOPS} BEGIN WITH DATA DO BEGIN {ECONOMICS} ATLEASTONEPLAYERIN := FALSE; ALLBUTONEPLAYEROUT := TRUE ; FOR I := 1 TO NUMP DO BEGIN TAX[I] := 0; TAXBASE[I] := 0; ARMY[I] := 0; END; FOR I:= 1 TO 7 DO FOR J := 1 TO 7 DO BEGIN PL := OWN[I,J]; IF PL <> 0 THEN BEGIN TAXBASE[PL] := TAXBASE[PL] + POP[I,J]; IF PLACE[I,J] = 'T' THEN TAXBASE[PL] := TAXBASE[PL] + 1; ARMY[PL] := ARMY[PL] + TROOPS[I,J]; END; END; FOR I := 1 TO NUMP DO BEGIN TAX[I] := TAXBASE[I] * (TAXRATE + RANDOM * TAXRATE/4); PAY[I] := ARMY[I] * (PAYRATE + RANDOM * PAYRATE/4); IF CAS[I] <> 0 THEN BEGIN MONEY[I] := MONEY[I] - PAY[I]; IF MONEY[I] < 0 THEN BEGIN TAX[I] := TAX[I] + MONEY[I]; MONEY[I] := 0; END; CLEARTHESCREEN; WRITELN('WARLORD ',PD[I],' ',NAME[I]); WRITELN('TREASURY BALANCE: ',MONEY[I] : 6 : 2); WRITELN('ARMIES: ',ARMY[I]); WRITELN('TAXES COLLECTED: ',TAX[I]:6:2); WRITELN('POPULATION: ',TAXBASE[I]); IF ARMY[I] > 0 THEN BEGIN IF ATLEASTONEPLAYERIN THEN ALLBUTONEPLAYEROUT := FALSE; ATLEASTONEPLAYERIN := TRUE; END; IF MONEY[I] >= 2000 THEN FIELDTROOPS; MONEY[I] := MONEY[I] + TAX[I]; GOTOXY(0,9); WRITE('TREASURY NOW EQUALS ',MONEY[I] : 6 : 2); IF MONEY[I] >= 2000 THEN CASTLETROOPS ELSE WAIT; END; END; END;{WITH DATA} END;{ECONOMIC} PROCEDURE SAVEGAME; BEGIN CLEARTHESCREEN; GOTOXY(20,8); WRITE('Do you want to stop now? '); READ(AN); RESET(INPUT); IF (AN = 'Y') OR (AN = 'y') THEN STILLPLAYING :=FALSE; GOTOXY(20,10); WRITE('Do you want to save this game? '); READ(AN); RESET(INPUT); IF (AN = 'Y') OR (AN = 'y') THEN BEGIN REWRITE(GAMEDATA,'CASTLES.DATA'); GAMEDATA^ := DATA; PUT(GAMEDATA); CLOSE(GAMEDATA,LOCK); WRITElN('Game saved.'); END; END;{SAVEGAME} BEGIN {PLAY} WITH DATA DO BEGIN STILLPLAYING := TRUE; WHILE STILLPLAYING DO BEGIN {TURN} IF RESTART = FALSE THEN BEGIN {CAMPAIGN} ROUNDSINTURN := RND(1,4); IF (TURN < 6) AND (ROUNDSINTURN > 2) THEN ROUNDSINTURN := ROUNDSINTURN - 1; FOR R := 1 TO ROUNDSINTURN DO BEGIN {ROUND} ROUND := R; SEQIT; FOR PT := 1 TO NUMP DO BEGIN {PTURN} PTURN := PT; PL := SEQ[PTURN]; IF ARMY[PL] > 0 THEN BEGIN {PLAYER} REPEAT {UNTIL MOVOK} BOARD; GOTOXY(54,4); WRITE('CAMPAGIN ',TURN); GOTOXY(55,5); WRITE('ROUND ',ROUND); GOTOXY(55,6); WRITE('WARLORD ',PD[PL]); GOTOXY(55,7); WRITE(NAME[PL]); GOTOXY(0,15); WRITE(' MOVE? (FROM TO NUMBER)'); INTEST; MOVEOK := TRUE; IF NOT(FROM = 0) THEN BEGIN {CHECK MOVE1} IF NOT (FROM IN VALID) THEN MERROR(1); IF NOT (TX IN VALID) THEN MERROR(2); IF MOVEOK THEN BEGIN {CHECK MOVE2} FI := FROM DIV 10; FJ := FROM MOD 10; TI := TX DIV 10 ; TJ:= TX MOD 10; IF OWN[FI,FJ] <> PL THEN MERROR(3); IF (ABS(TI-FI) > 1) OR (ABS(TJ-FJ) > 1) THEN MERROR(4); IF PLACE[TI,TJ] = 'L' THEN MERROR(5); IF (NUMBER > TROOPS[FI,FJ]) AND (OWN[FI,FJ] = PL) THEN MERROR(6); IF NUMBER = 0 THEN MERROR(11); END;{CHECK MOVE2} END;{CHECK MOVE1} UNTIL MOVEOK; IF NOT(FROM = 0) THEN BEGIN {DO MOVE} TROOPS[FI,FJ] := TROOPS[FI,FJ] - NUMBER; IF TROOPS[FI,FJ] = 0 THEN OWN[FI,FJ] := 0; IF (OWN[TI,TJ] <> PL) AND (OWN[TI,TJ] <> 0) THEN COMBAT ELSE MOVE; END; {DO MOVE} END; {PLAYER} END; {PTURN} END; {ROUND} END; {CAMPAIGN} BOARD; GOTOXY(0,15); WRITE('END OF CAMPAIGN '); WAIT; RESTART := FALSE; SAVEGAME; IF STILLPLAYING THEN BEGIN ECONOMIC; IF ALLBUTONEPLAYEROUT THEN OUTMSG; TURN := TURN + 1; END; END; {TURN} END; {DATA} END; {PLAY} BEGIN {DUMMY MAIN PROGRAM} WITH DATA DO BEGIN SEED := 1.23456789; VALID := [11..17,21..27,31..37,41..47,51..57,61..67,71..77]; RESTART := FALSE; PD := 'ABCD'; FOR I := 1 TO 4 DO SEQ[I] := I; NEWGAME; PLAY; END;{WITH DATA} END. ======================================================================================== DOCUMENT :usus Folder:VOL09:catalog.9.text ======================================================================================== CATALOG OF VOLUME 9 -**- USUS LIBRARY GAMES: Adventure, Castles, Spacewar, and Startrek name size description ADV.TEXT 34 Source for ADVENTURE. ADV.DOC.TEXT 20 Read this documentation on setting up the program. ADV.MISCINFO 4 Tells ADV your screen dimensions. ADVINIT.TEXT 22 Run this program to set up ADV's data files. ADVS1.TEXT 42 These are the text files used by ADVINIT. ADVS2.TEXT 8 ADVS3.TEXT 22 ADVS4.TEXT 10 ADVS5.TEXT 14 ADVS6.TEXT 38 ADVS7.TEXT 6 ADVS8.TEXT 4 ADVS9.TEXT 4 ADVS10.TEXT 4 ADVS11.TEXT 4 ADVSUBS.TEXT 42 ADVVERB.TEXT 42 CASTLES.TEXT 36 A board game for two or more players, in which you CASTLES.DOC 6 and your opponents are warlords plundering each other, raising armies, etc. SPACEWAR.TEXT 20 Fast action for two players shooting it out in their space ships...it'll require work to get it running on your machine. STARTREK.TEXT 6 A Pascal version of the classic game. STAR.PART1.TEXT 24 STAR.PART2.TEXT 22 STAR.PART3.TEXT 22 VOLUME.9.TEXT 10 Documentation for this disk. NOTE: USUS Library material may be used only in accordance with policy outlined elsewhere. In particular, these programs may not be given to nonmembers of USUS, nor may commercial use be made of them, without the written permission of the authors. All programs will be the same for various formats, since no processor- dependent features are involved. ======================================================================================== DOCUMENT :usus Folder:VOL09:spacewar.text ======================================================================================== PROGRAM Spacewar; TYPE status = PACKED ARRAY[0..7] OF BOOLEAN; VAR serialtrix : RECORD CASE BOOLEAN OF TRUE : (fdevaddr : INTEGER); FALSE: (serialstatus : ^status); END; hitset : ARRAY[0..7] OF SET OF 0..15; ch : CHAR; dx,dy : ARRAY[0..7] OF INTEGER; shot, wait, otx,oty, orp,ox,oy, myscore, yourscore, dt, tx,ty,txv,tyv, mx,my,mxv,myv, rp,xv,yv,x,y : INTEGER; clship,ship : ARRAY[0..7] OF STRING[8]; targ,cltarg,tstring : STRING[8]; PROCEDURE Initships; PROCEDURE Inittstring; VAR temp : INTEGER; BEGIN tstring := ' '; FOR temp := 1 TO 8 DO tstring[temp] := CHR(0); END; PROCEDURE Makeclstring; VAR temp : INTEGER; BEGIN FOR temp := 1 TO 8 DO IF ORD(tstring[temp])>12 THEN tstring[temp] := ' '; END; BEGIN hitset[0] := [1,2,5,6,9,10,13,14]; hitset[1] := [2,3,5,6,7,8,9,10,12,13]; hitset[2] := [4,5,6,7,8,9,10,11]; hitset[3] := [0,1,4,5,6,9,10,11,14,15]; hitset[4] := hitset[0]; hitset[5] := hitset[1]; hitset[6] := hitset[2]; hitset[7] := hitset[3]; targ := '[] []'; targ[3] := CHR(8); targ[4] := CHR(8); targ[5] := CHR(11); cltarg := ' '; cltarg[3] := CHR(8); cltarg[4] := CHR(8); cltarg[5] := CHR(11); Inittstring; tstring[1] := ' '; tstring[2] := '|'; tstring[3] := CHR(8); tstring[4] := CHR(11); tstring[5] := '|'; tstring[6] := CHR(8); tstring[7] := CHR(11); tstring[8] := '^'; ship[0] := tstring; Makeclstring; clship[0] := tstring; Inittstring; tstring[1] := '/'; tstring[2] := CHR(11); tstring[3] := '/'; tstring[4] := CHR(11); tstring[5] := '+'; ship[1] := tstring; Makeclstring; clship[1] := tstring; Inittstring; tstring[1] := CHR(11); tstring[2] := '-'; tstring[3] := '-'; tstring[4] := '>'; ship[2] := tstring; Makeclstring; clship[2] := tstring; Inittstring; tstring[1] := CHR(11); tstring[2] := CHR(11); tstring[3] := '\'; tstring[4] := CHR(10); tstring[5] := '\'; tstring[6] := CHR(10); tstring[7] := '+'; ship[3] := tstring; Makeclstring; clship[3] := tstring; tstring := ship[0]; tstring[2] := 'v'; tstring[8] := '|'; ship[4] := tstring; clship[4] := clship[0]; tstring := ship[1]; tstring[1] := '+'; tstring[5] := '/'; ship[5] := tstring; clship[5] := clship[1]; tstring := ship[2]; tstring[2] := '<'; tstring[4] := '-'; ship[6] := tstring; clship[6] := clship[2]; tstring := ship[3]; tstring[3] := '+'; tstring[7] := '\'; ship[7] := tstring; clship[7] := clship[3]; END; PROCEDURE Explosion(x,y : INTEGER); VAR temp1,temp2 : INTEGER; BEGIN WRITE(CHR(7)); FOR temp1 := 1 TO 9 DO BEGIN FOR temp2 := 0 TO 2 DO BEGIN GOTOXY(x, y + temp2); WRITE('***'); END; END; FOR temp2 := 0 TO 2 DO BEGIN GOTOXY(x,y + temp2); WRITE(' '); END; END; PROCEDURE Chkscore; BEGIN dt := 0; tx := 70; ty := 20; txv := 1; tyv := 1; orp := 0;rp := 0; xv := 0; yv := 0; x := 40; y := 11; WRITE(CHR(27),'*'); GOTOXY(0,1); WRITELN('M'); WRITELN('E'); WRITELN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN('Y'); WRITELN('O'); WRITELN('U'); GOTOXY(0,4); WRITE(myscore); GOTOXY(0,13); WRITE(yourscore); WRITELN; FOR wait := 1 TO 5000 DO BEGIN END; IF myscore = 10 THEN WRITELN('I win'); IF yourscore=10 THEN WRITELN('You win'); IF 10 IN [myscore,yourscore] THEN EXIT(Spacewar); END; PROCEDURE Chkcollisions; BEGIN IF (dt<>0) AND (mx IN [tx,tx+1]) AND (my IN [ty,ty-1]) THEN BEGIN Explosion(mx,my); yourscore := yourscore + 1; Chkscore; END; IF (ty - y > -3) AND (ty - y < 2) AND (tx - x > -2) AND (tx - x < 3) THEN IF (ty-y+2)*4+tx-x+1 IN hitset[rp] THEN BEGIN Explosion(x,y); myscore := myscore + 1; Chkscore; END; END; PROCEDURE Oposition; VAR temp : INTEGER; BEGIN IF (dt<>0) AND (dt < 32) THEN { move missle } BEGIN dt := dt + 1; GOTOXY(mx,my); WRITE(' '); IF (mx + mxv > 78) OR (mx + mxv < 1) THEN mxv := -mxv; IF (my + myv > 22) OR (my + myv < 1) THEN myv := -myv; mx := mx + mxv; my := my + myv; IF dt = 32 THEN {get rid of missle and randomize target} BEGIN shot := 0; IF txv < 2 THEN txv := txv + 1 ELSE txv := txv - 1; IF tyv < 2 THEN tyv := tyv + 1 ELSE tyv := tyv - 1; GOTOXY(mx, my); WRITE(' '); dt := 0; END ELSE BEGIN GOTOXY(mx,my); WRITE('*'); END; END; {move target} IF (tx + txv > 77) OR (tx + txv < 1) THEN txv := -txv; IF (ty + tyv > 22) OR (ty + tyv < 1) THEN tyv := -tyv; tx := tx + txv; ty := ty + tyv; IF (x + xv > 76) OR (x + xv < 1) THEN xv := -xv; IF (y + yv > 21) OR (y + yv < 2) THEN yv := -yv; x := x + xv; y := y + yv; GOTOXY(ox,oy); WRITE(clship[orp]); GOTOXY(x,y); WRITE(ship[rp]); GOTOXY(otx,oty); WRITE(cltarg); GOTOXY(tx,ty); WRITE(targ); ox := x; oy := y; orp := rp; otx := tx; oty := ty; Chkcollisions; END; PROCEDURE Updvel; BEGIN CASE ORD(ch) OF 12 : rp := (rp + 1) MOD 8; 8 : rp := (rp - 1) MOD 8; 10 : CASE rp OF 0 : IF yv > -4 THEN yv := yv - 1; 1 : BEGIN IF xv < 4 THEN xv := xv + 1; IF yv >-4 THEN yv := yv - 1; END; 2 : IF xv < 4 THEN xv := xv + 1; 3 : BEGIN IF xv < 4 THEN xv := xv + 1; IF yv < 4 THEN yv := yv + 1; END; 4 : IF yv < 4 THEN yv := yv + 1; 5 : BEGIN IF yv < 4 THEN yv := yv + 1; IF xv >-4 THEN xv := xv - 1; END; 6 : IF xv > -4 THEN xv := xv - 1; 7 : BEGIN IF xv >-4 THEN xv := xv - 1; IF yv >-4 THEN yv := yv - 1; END; END; 11 : BEGIN GOTOXY(mx,my); WRITE(' '); dt := 1; shot := shot + 1; mx := x + dx[rp] ; my := y + dy[rp]; mxv := xv; myv := yv; IF shot MOD 4 = 0 THEN BEGIN IF txv < 2 THEN txv := txv + 1 ELSE txv := txv - 1; IF tyv < 2 THEN tyv := tyv + 1 ELSE tyv := tyv - 1; END; CASE rp OF 0 : IF myv > -4 THEN myv := myv - 2; 1 : BEGIN IF mxv < 4 THEN mxv := mxv + 2; IF myv >-4 THEN myv := myv - 2; END; 2 : IF mxv < 4 THEN mxv := mxv + 2; 3 : BEGIN IF mxv < 4 THEN mxv := mxv + 2; IF myv < 4 THEN myv := myv + 2; END; 4 : IF myv < 4 THEN myv := myv + 2; 5 : BEGIN IF myv < 4 THEN myv := myv + 2; IF mxv >-4 THEN mxv := mxv - 2; END; 6 : IF mxv > -4 THEN mxv := mxv - 2; 7 : BEGIN IF mxv >-4 THEN mxv := mxv - 2; IF myv >-4 THEN myv := myv - 2; END; END; END; END; IF rp < 0 THEN rp := rp + 8; END; BEGIN serialtrix.fdevaddr := -1007; {FC11} dt := 0; rp := 0; xv := 0; yv := 0; x := 40; y := 11; ox := 0; oy := 0; otx := 0; oty := 0; orp := 0; myscore := 0; yourscore := 0; { eventually these will start as random numbers } tx := 70; ty := 20; txv := 1; tyv := 1; dx[0] := 1; dy[0] := -2; dx[1] := 2; dy[1] := -2; dx[2] := 2; dy[2] := -1; dx[3] := 2; dy[3] := 0; dx[4] := 1; dy[4] := 0; dx[5] := 0; dy[5] := 0; dx[6] := 0; dy[6] := -1; dx[7] := 0; dy[7] := -2; Initships; WRITE(CHR(27),'*'); GOTOXY(x,y); WRITE(ship[rp]); FOR wait := 1 TO 5000 DO BEGIN END; shot := 0; REPEAT WHILE NOT serialtrix.serialstatus^[1] DO BEGIN Oposition; END; READ(keyboard,ch); IF ORD(ch) IN [12,8,10,11] THEN Updvel; UNTIL ch IN ['Q','q']; WRITELN('quit'); END. ======================================================================================== DOCUMENT :usus Folder:VOL09:star.part1.text ======================================================================================== {beginning of STAR.PART1.TEXT} TYPE digits = 0..max_digit; quad_range = 0..galaxy_size; sect_range = 0..quad_size; quad_rec = RECORD is_history : BOOLEAN; {seen in long range scanner} kling_base_num, {number of klingon bases} kling_num, {number of klingons} fed_base_num, {number of federation bases} star_num : digits; {number of stars} END {of quad_rec}; objects = (s_nothing, s_star, s_enterprise, s_nova, s_klingon, s_fed_base, s_kling_base); cond_types = (c_green, c_red, c_yellow, c_black, c_docked); sect_x_y = RECORD x, y : sect_range; END {of sect_x_y}; quad_x_y = RECORD x, y : quad_range; END {of quad_x_y}; klingon_rec = RECORD position : sect_x_y; energy_left : INTEGER; END {of klingon_rec}; device_rec = RECORD name : STRING[20]; down_time : INTEGER; END {of device_rec}; VAR seed : REAL; bell : CHAR; cur_year, start_year, end_year, cur_energy, cur_torps, start_klingons, total_k_bases, total_klingons, bad_points : INTEGER; cur_sect : sect_x_y; cur_quad : quad_x_y; device : ARRAY [min_device..max_device] OF device_rec; quadrant : ARRAY [sect_range, sect_range] OF objects; galaxy : ARRAY [quad_range, quad_range] OF quad_rec; klingons : ARRAY [0..max_klingons] OF klingon_rec; symbols : PACKED ARRAY [objects] OF CHAR; cond_names : ARRAY [cond_types] OF STRING[10]; condition : cond_types; FUNCTION random (low, hi : INTEGER) : INTEGER; {Return a random number between two bounds} BEGIN seed := ((seed * 11.0) + 7.0); seed := seed - TRUNC (seed / 1999.0) * 1999.0; random := TRUNC (seed / 1999.0 * (hi - low + 1)) + low; END {of random}; FUNCTION distance (pos_1_x, pos_1_y : sect_range; pos_2 : sect_x_y) : INTEGER; BEGIN distance := ROUND (SQRT (SQR (pos_1_x - pos_2.x) + SQR (pos_1_y - pos_2.y))); END {of distance}; FUNCTION radians (degrees : INTEGER) : REAL; BEGIN radians := degrees * 0.0174533; END {of radians}; FUNCTION interval (number, min_value, max_value : INTEGER) : INTEGER; BEGIN IF number < min_value THEN interval := min_value ELSE IF number > max_value THEN interval := max_value ELSE interval := number; END {of interval}; PROCEDURE re_initialize; VAR ch : CHAR; BEGIN cur_energy := ent_energy; cur_torps := start_torps; FOR ch := min_device TO max_device DO device[ch].down_time := 0; END {of re_initialize}; PROCEDURE initialize; VAR r_num, total_fed_base, i, j : INTEGER; BEGIN device['0'].name := 'Warp Engines'; device['1'].name := 'Short Range Sensors'; device['2'].name := 'Long Range Sensors'; device['3'].name := 'Phaser Control'; device['4'].name := 'Photon Tubes'; device['5'].name := 'Damage Control'; device['6'].name := 'History Computers'; device['7'].name := 'Self Destruct'; symbols[s_nothing] := no_sym; symbols[s_star] := star_sym; symbols[s_enterprise] := ent_sym; symbols[s_nova] := nova_sym; symbols[s_klingon] := kling_sym; symbols[s_fed_base] := f_base_sym; symbols[s_kling_base] := k_base_sym; cond_names[c_red] := 'Red'; cond_names[c_green] := 'Green'; cond_names[c_yellow] := 'Yellow'; cond_names[c_black] := 'Black'; cond_names[c_docked] := 'Docked'; cur_sect.x := random (0, quad_size); cur_sect.y := random (0, quad_size); cur_quad.x := random (0, galaxy_size); cur_quad.y := random (0, galaxy_size); total_klingons := 0; total_k_bases := 0; FOR i := 0 TO galaxy_size DO FOR j := 0 TO galaxy_size DO WITH galaxy[i, j] DO BEGIN is_history := FALSE; r_num := random (0, SQR (galaxy_size)); IF random (0, SQR (galaxy_size)) <= 6 THEN kling_base_num := 1 ELSE kling_base_num := 0; total_k_bases := total_k_bases + kling_base_num; kling_num := TRUNC (EXP (-random (0, galaxy_size)) * max_digit) DIV 2; total_klingons := total_klingons + kling_num; IF random (0, SQR (galaxy_size)) < 3 THEN fed_base_num := 1 ELSE fed_base_num := 0; total_fed_base := total_fed_base + fed_base_num; star_num := random (0, quad_size); END {of WITH}; start_klingons := total_klingons; IF total_fed_base = 0 THEN galaxy[random (0, galaxy_size), random (0, galaxy_size)].fed_base_num := 1; IF total_k_bases = 0 THEN BEGIN galaxy[random (0, galaxy_size), random (0, galaxy_size)].kling_base_num := 1; total_k_bases := 1; END {of IF}; cur_year := random (3000, 4000); start_year := cur_year; end_year := start_year + random (10, 40); bad_points := 0; bell := CHR (alarm); re_initialize; END {of initialize}; PROCEDURE set_condition; VAR i, j : INTEGER; BEGIN IF galaxy[cur_quad.x, cur_quad.y].kling_base_num <> 0 THEN condition := c_black ELSE IF galaxy[cur_quad.x, cur_quad.y].kling_num <> 0 THEN condition := c_red ELSE IF cur_energy < ent_energy DIV 10 THEN condition := c_yellow ELSE condition := c_green; FOR i := cur_sect.x - 1 TO cur_sect.x + 1 DO FOR j := cur_sect.y - 1 TO cur_sect.y + 1 DO IF quadrant[interval (i, 0, quad_size), interval (j, 0, quad_size)] = s_fed_base THEN condition := c_docked; END {of set_condition}; PROCEDURE klingon_attack; VAR hit, i : INTEGER; ship_type : STRING; BEGIN WITH galaxy[cur_quad.x, cur_quad.y] DO IF (kling_base_num <> 0) OR (kling_num <> 0) THEN BEGIN IF condition = c_docked THEN WRITELN ('Starbase shields protect the Enterprise') ELSE FOR i := 0 TO max_klingons DO WITH klingons[i] DO IF energy_left > 0 THEN BEGIN hit := TRUNC (energy_left / distance (position.x, position.y, cur_sect) * (10 + random (0, 10)) / 10); cur_energy := cur_energy - hit; IF energy_left = ent_energy THEN ship_type := 'Starbase ' ELSE ship_type := ''; WRITELN (hit, ' unit hit on Enterprise from Klingon ', ship_type, 'at sector ', position.x, '-', position.y, ' (', cur_energy, ' left)'); END {of IF energy_left}; END {of IF (}; END {of klingon_attack}; PROCEDURE print_digit (number : INTEGER; VAR must_print : BOOLEAN); BEGIN must_print := must_print OR (number <> 0); IF must_print THEN WRITE (number) ELSE WRITE (' '); END {of print_digit}; PROCEDURE setup_quad (quad : quad_x_y; VAR ent_sect : sect_x_y); VAR i, j, nova_count, kling_index : INTEGER; PROCEDURE setup_stuff (object : objects; count : INTEGER); VAR x, y : INTEGER; BEGIN WHILE count <> 0 DO BEGIN REPEAT x := random (0, quad_size); y := random (0, quad_size); UNTIL quadrant[x, y] = s_nothing; quadrant[x, y] := object; count := count - 1; END {of WHILE}; END {of setup_stuff}; BEGIN FOR i := 0 TO quad_size DO FOR j := 0 TO quad_size DO quadrant[i, j] := s_nothing; ent_sect.x := random (0, quad_size); ent_sect.y := random (0, quad_size); quadrant[ent_sect.x, ent_sect.y] := s_enterprise; WITH galaxy[quad.x, quad.y] DO BEGIN nova_count := random (0, star_num DIV 2); setup_stuff (s_star, star_num - nova_count); setup_stuff (s_nova, nova_count); setup_stuff (s_klingon, kling_num); setup_stuff (s_fed_base, fed_base_num); setup_stuff (s_kling_base, kling_base_num); END {of WITH}; kling_index := 0; FOR i := 0 TO quad_size DO FOR j := 0 TO quad_size DO IF quadrant[i, j] IN [s_klingon, s_kling_base] THEN WITH klingons[kling_index] DO BEGIN position.x := i; position.y := j; IF quadrant[i, j] = s_kling_base THEN energy_left := ent_energy ELSE energy_left := kling_energy; kling_index := kling_index + 1; END {of WITH}; FOR kling_index := kling_index TO max_klingons DO klingons[kling_index].energy_left := 0; END {of setup_quad}; PROCEDURE print_quadrant; VAR i, j : quad_range; BEGIN set_condition; IF device['1'].down_time <> 0 THEN WRITELN ('*** Short Range Sensors Inoperable ***') ELSE BEGIN WRITELN ('----------------------'); FOR i := 0 TO quad_size DO BEGIN FOR j := 0 TO quad_size DO WRITE (symbols[quadrant[i, j]], ' '); WRITE (' '); CASE i OF 0 : WRITELN ('Stardate ', cur_year); 1 : WRITELN ('Condition ', cond_names[condition]); 2 : WRITELN ('Quadrant ', cur_quad.x, '-', cur_quad.y); 3 : WRITELN ('Sector ', cur_sect.x, '-', cur_sect.y); 4 : WRITELN ('Energy ', cur_energy); 5 : WRITELN ('Photon torpedoes ', cur_torps); 6 : WRITELN ('Klingons left ', total_klingons); 7 : WRITELN; END {of CASE}; END {of FOR i}; WRITELN ('----------------------'); END {of ELSE}; END {of print_quadrant}; PROCEDURE print_galaxy (top_x, left_y : INTEGER; size : INTEGER; mark_history : BOOLEAN); VAR i, j : INTEGER; must_print : BOOLEAN; PROCEDURE print_separator (entries : INTEGER); VAR count : INTEGER; BEGIN FOR count := 0 TO entries DO WRITE ('|-----'); WRITELN ('|'); END {of print_separator}; BEGIN IF mark_history THEN WRITELN ('Long Range Sensor Scan For Quadrant ', cur_quad.x, '-', cur_quad.y) ELSE BEGIN WRITELN ('History Computer Report; Stardate ', cur_year); IF condition <> c_docked THEN cur_energy := cur_energy - 100; END {of ELSE}; print_separator (size); FOR i := top_x TO top_x + size DO BEGIN FOR j := left_y TO left_y + size DO IF (i IN [0..quad_size]) AND (j IN [0..quad_size]) THEN WITH galaxy[i, j] DO IF mark_history OR is_history THEN BEGIN is_history := is_history OR (device['6'].down_time = 0); must_print := FALSE; WRITE ('|'); print_digit (kling_base_num, must_print); print_digit (kling_num, must_print); print_digit (fed_base_num, must_print); must_print := TRUE; print_digit (star_num, must_print); WRITE (' '); END {of WITH} ELSE WRITE ('|+++++') ELSE WRITE ('|xxxxx'); WRITELN ('|'); print_separator (size); END {of FOR i}; END {of print_galaxy}; PROCEDURE print_damage; VAR ch : CHAR; BEGIN WRITELN ('Device name: Repair Time:'); FOR ch := min_device TO max_device DO WRITELN (device[ch].name:20, device[ch].down_time:5); END {of print_damage}; {ending of STAR.PART1.TEXT} ======================================================================================== DOCUMENT :usus Folder:VOL09:star.part2.text ======================================================================================== {beginning of STAR.PART2.TEXT} PROCEDURE move_enterprise; VAR course : INTEGER; x_inc, y_inc, x_pos, y_pos, warp : REAL; PROCEDURE handle_damage; VAR ch, start_ch : CHAR; BEGIN FOR ch := min_device TO max_device DO IF device[ch].down_time <> 0 THEN device[ch].down_time := device[ch].down_time - 1; IF random (0, 100) < 6 THEN BEGIN ch := CHR (random (ORD (min_device), ORD (max_device))); WRITELN ('*** Space storm, ', device[ch].name, ' damaged ***'); device[ch].down_time := random (device[ch].down_time, 5); END {of IF} ELSE IF random (0, 100) < 12 THEN BEGIN ch := CHR (random (ORD (min_device), ORD (max_device))); start_ch := ch; REPEAT IF ch = max_device THEN ch := min_device ELSE ch := SUCC (ch); UNTIL (ch = start_ch) OR (device[ch].down_time <> 0); IF device[ch].down_time <> 0 THEN BEGIN WRITELN ('*** Truce, ', device[ch].name, ' state of repair improved ***'); device[ch].down_time := random (0, device[ch].down_time - 1); END {of IF device}; END {of IF random}; END {of handle_damage}; PROCEDURE move_intra (VAR x_pos, y_pos, x_inc, y_inc : REAL; course : INTEGER; warp : REAL); BEGIN x_inc := -COS (radians (course)); y_inc := SIN (radians (course)); x_pos := cur_sect.x; y_pos := cur_sect.y; WHILE (ROUND (x_pos) IN [0..quad_size]) AND (ROUND (y_pos) IN [0..quad_size]) AND (warp >= 0.125) DO IF quadrant[ROUND (x_pos), ROUND (y_pos)] = s_nothing THEN BEGIN x_pos := x_pos + x_inc; y_pos := y_pos + y_inc; warp := warp - 0.125; END {of IF} ELSE warp := 0.0; END {of move_intra}; BEGIN {of move_enterprise} WRITE ('Course: '); READLN (course); WRITE ('Warp factor (0-12): '); READLN (warp); IF (warp < 0.0) OR (warp > 12.0) OR ((warp > 0.2) AND (device[min_device].down_time <> 0)) THEN WRITELN ('Can''t move that fast !!') ELSE BEGIN cur_year := cur_year + 1; cur_energy := TRUNC (cur_energy - 8 * warp); handle_damage; quadrant[cur_sect.x, cur_sect.y] := s_nothing; move_intra (x_pos, y_pos, x_inc, y_inc, course, warp); IF (ROUND (x_pos) IN [0..quad_size]) AND (ROUND (y_pos) IN [0..quad_size]) THEN IF quadrant[ROUND (x_pos), ROUND (y_pos)] = s_fed_base THEN BEGIN WRITELN ('Collision with starbase''s elastic shields at sector ', ROUND (x_pos), '-', ROUND (y_pos)); move_intra (x_pos, y_pos, x_inc, y_inc, (course + 180) MOD 360, warp); END {of IF}; IF (ROUND (x_pos) IN [0..quad_size]) AND (ROUND (y_pos) IN [0..quad_size]) THEN BEGIN IF quadrant[ROUND (x_pos), ROUND (y_pos)] IN [s_star, s_nova, s_klingon, s_kling_base] THEN BEGIN WRITELN ('Enterprise blocked by object at sector ', ROUND (x_pos), '-', ROUND (y_pos)); x_pos := x_pos - x_inc; y_pos := y_pos - y_inc; END {of IF quadrant}; cur_sect.x := interval (ROUND (x_pos), 0, quad_size); cur_sect.y := interval (ROUND (y_pos), 0, quad_size); quadrant[cur_sect.x, cur_sect.y] := s_enterprise; END {of IF ROUND} ELSE BEGIN {Inter-Quadrant moving} cur_quad.x := interval (TRUNC (cur_quad.x + warp * x_inc + cur_sect.x * 0.125), 0, galaxy_size); cur_quad.y := interval (TRUNC (cur_quad.y + warp * y_inc + cur_sect.y * 0.125), 0, galaxy_size); setup_quad (cur_quad, cur_sect); END {of IF}; END {of ELSE}; set_condition; IF condition = c_docked THEN re_initialize; END {of move_enterprise}; PROCEDURE fire_phasers; VAR i, fire_amount, hit : INTEGER; BEGIN WRITELN ('Phasers locked on target. Energy available = ', cur_energy); WRITE ('Number of units to fire: '); READLN (fire_amount); IF fire_amount > cur_energy THEN WRITELN ('Unable to fire.') ELSE IF fire_amount > 0 THEN BEGIN IF condition <> c_docked THEN cur_energy := cur_energy - fire_amount; FOR i := 0 TO max_klingons DO WITH klingons[i] DO IF energy_left > 0 THEN BEGIN hit := TRUNC (fire_amount / distance (position.x, position.y, cur_sect) * (10 + random (0, 10))) DIV 10; energy_left := energy_left - hit; WRITE (hit, ' unit hit on Klingon at sector ', position.x, '-', position.y); IF energy_left > 0 THEN WRITELN (' (', energy_left, ' left)') ELSE BEGIN WRITELN ('. Klingon DESTROYED', bell); total_klingons := total_klingons - 1; galaxy[cur_quad.x, cur_quad.y].kling_num := galaxy[cur_quad.x, cur_quad.y].kling_num - 1; quadrant[position.x, position.y] := s_nothing; END {of ELSE}; END {of IF energy_left} END {of IF >}; END {of fire_phasers}; PROCEDURE fire_torpedoes; VAR i, course : INTEGER; hit_something : BOOLEAN; x_inc, y_inc, x_pos, y_pos : REAL; PROCEDURE hit_nova (nova_x, nova_y : sect_range; VAR kling_num : INTEGER); VAR hit, i : INTEGER; BEGIN WRITELN ('Torpedo causes unstable star to nova'); IF condition <> c_docked THEN BEGIN hit := 600 * random (0, 10) DIV distance (nova_x, nova_y, cur_sect); IF hit > 0 THEN WRITELN ('Enterprise loses ', hit, ' units of energy'); cur_energy := cur_energy - hit; END {of IF}; FOR i := 0 TO max_klingons DO WITH klingons[i] DO IF energy_left > 0 THEN BEGIN energy_left := energy_left - 120 * random (0, 10) DIV distance (nova_x, nova_y, position); IF energy_left <= 0 THEN BEGIN quadrant[position.x, position.y] := s_nothing; total_klingons := total_klingons - 1; kling_num := kling_num - 1; END {of IF <=}; END {of IF >}; END {of hit_nova}; PROCEDURE hit_kling_base (VAR kling_base_num : INTEGER); VAR i, k_docked : INTEGER; quad_x, quad_y : quad_range; BEGIN WRITELN ('*** Klingon Starbase DESTROYED ***', bell); kling_base_num := kling_base_num - 1; k_docked := 0; FOR i := 1 TO random (0, SQR (galaxy_size)) DO BEGIN REPEAT quad_x := random (0, galaxy_size); quad_y := random (0, galaxy_size); UNTIL (quad_x <> cur_quad.x) OR (quad_y <> cur_quad.y); k_docked := k_docked + galaxy[quad_x, quad_y].kling_num; galaxy[quad_x, quad_y].kling_num := 0; END {of FOR}; WRITELN (k_docked, ' Klingons were killed while docked'); total_klingons := total_klingons - k_docked; END {of hit_kling_base}; BEGIN {of fire_torpedoes} IF cur_torps = 0 THEN WRITELN ('All photon torpedoes expended.') ELSE BEGIN WRITE ('Torpedo course: '); READLN (course); IF condition <> c_docked THEN cur_torps := cur_torps - 1; x_inc := -COS (radians (course)); y_inc := SIN (radians (course)); x_pos := cur_sect.x; y_pos := cur_sect.y; hit_something := FALSE; WRITELN ('Torpedo track:'); WITH galaxy[cur_quad.x, cur_quad.y] DO WHILE NOT hit_something AND (ROUND (x_pos) IN [0..quad_size]) AND (ROUND (y_pos) IN [0..quad_size]) DO CASE quadrant[ROUND (x_pos), ROUND (y_pos)] OF s_enterprise, s_nothing : BEGIN WRITELN (ROUND (x_pos), '-', ROUND (y_pos)); x_pos := x_pos + x_inc; y_pos := y_pos + y_inc; END {of s_nothing}; s_star : BEGIN hit_something := TRUE; WRITELN ('Star destroyed, you got the planets, ', 'too! Nice shot!'); bad_points := bad_points + random (0, 500); star_num := star_num - 1; END {of s_star}; s_nova : BEGIN hit_something := TRUE; star_num := star_num - 1; hit_nova (ROUND (x_pos), ROUND (y_pos), kling_num); END {of s_nova}; s_klingon : BEGIN hit_something := TRUE; WRITE ('*** Klingon DESTROYED ***', bell); IF random (0, 100) < 30 THEN WRITE (' (The only good Klingon is a dead', ' Klingon)'); WRITELN; kling_num := kling_num - 1; total_klingons := total_klingons - 1; FOR i := 0 TO max_klingons DO WITH klingons[i] DO IF (energy_left > 0) AND (ROUND (x_pos) = position.x) AND (ROUND (y_pos) = position.y) THEN energy_left := 0; END {of s_klingon}; s_fed_base : BEGIN hit_something := TRUE; WRITELN ('*** Starbase destroyed ... ', 'Congratulations ... Dummy ***'); bad_points := bad_points + random (0, 500); fed_base_num := fed_base_num - 1; END {of s_fed_base}; s_kling_base : BEGIN hit_something := TRUE; hit_kling_base (kling_base_num); total_k_bases := total_k_bases - 1; END {of s_kling_base}; END {of CASE}; IF hit_something THEN quadrant[ROUND (x_pos), ROUND (y_pos)] := s_nothing ELSE WRITELN ('Torpedo missed.'); END {of ELSE}; END {of fire_torpedoes}; PROCEDURE self_destruct; VAR ch : CHAR; BEGIN REPEAT WRITE ('Are you SURE ? '); READ (ch); WRITELN; UNTIL ch IN ['y', 'Y', 'n', 'N']; IF ch IN ['y', 'Y'] THEN EXIT (star_trek); END {of self_destruct}; PROCEDURE command; VAR ch : CHAR; valid_command : BOOLEAN; BEGIN REPEAT WRITE ('Command: '); READLN (ch); WRITELN; valid_command := ch IN [min_device..max_device]; IF valid_command THEN BEGIN IF (device[ch].down_time <> 0) AND (ch > SUCC (min_device)) THEN WRITELN ('*** ', device[ch].name, ' INOPERABLE ***') ELSE CASE ch OF '0' : move_enterprise; '1' : print_quadrant; '2' : print_galaxy (cur_quad.x - 1, cur_quad.y - 1, 2, TRUE); '3' : fire_phasers; '4' : fire_torpedoes; '5' : print_damage; '6' : print_galaxy (0, 0, galaxy_size, FALSE); '7' : self_destruct; END {of CASE}; END {of IF} ELSE BEGIN WRITELN ('0 = Set course'); WRITELN ('1 = Short range sensor scan'); WRITELN ('2 = Long range sensor scan'); WRITELN ('3 = Fire phasors'); WRITELN ('4 = Fire photon torpedoes'); WRITELN ('5 = Damage control report'); WRITELN ('6 = History computer report'); WRITELN ('7 = Self destruct'); END {of ELSE}; UNTIL valid_command; IF ch IN ['0', '3', '4'] THEN BEGIN klingon_attack; print_quadrant; END {of IF}; END {of command}; {ending of STAR.PART2.TEXT} ======================================================================================== DOCUMENT :usus Folder:VOL09:star.part3.text ======================================================================================== {begining of STAR.PART3.TEXT} PROCEDURE instructions; VAR ch : CHAR; PROCEDURE space_wait; BEGIN WRITELN; WRITE ('Type to continue'); READ (ch); WRITELN; END {of space_wait}; PROCEDURE page_1; BEGIN WRITELN ('The galaxy is divided into 64 quadrants with the'); WRITELN ('following coordinates:'); WRITELN; WRITELN (' 0 1 2 3 4 5 6 7'); WRITELN ('---------------------------------'); WRITELN ('| | | | | | | | | 0'); WRITELN ('---------------------------------'); WRITELN ('| | | | | | | | | 1'); WRITELN ('---------------------------------'); WRITELN ('| | | | | | | | | 2'); WRITELN ('---------------------------------'); WRITELN ('| | | | | | | | | 3'); WRITELN ('---------------------------------'); WRITELN ('| | | | | | | | | 4'); WRITELN ('---------------------------------'); WRITELN ('| | | | | | | | | 5'); WRITELN ('---------------------------------'); WRITELN ('| | | | | | | | | 6'); WRITELN ('---------------------------------'); WRITELN ('| | | | | | | | | 7'); WRITELN; WRITELN ('Each quadrant is similarly divided into 64 sectors.'); space_wait; END {of page_1}; PROCEDURE page_2; BEGIN WRITELN; WRITELN ('::: DEVICES :::'); WRITELN; WRITELN (' :: Warp Engines ::'); WRITELN; WRITELN (' Course = a number in degrees.'); WRITELN (' Numbers indicate direction starting at the top and'); WRITELN (' going counter clockwise.'); WRITELN; WRITELN (' 0'); WRITELN (' 315 | 45'); WRITELN (' \|/'); WRITELN (' 270 --*-- 90'); WRITELN (' /|\'); WRITELN (' 225 | 135'); WRITELN (' 180'); WRITELN; WRITELN (' Warp Factor = a REAL number from 0 to 12.'); WRITELN (' Distance traveled = quadrants.'); WRITELN (' Warp .2 = The Enterprise travels 1 sector.'); WRITELN (' .5 = 4 sectors.'); WRITELN (' 1 = 1 quadrant.'); WRITELN (' 2 = 2 quadrants.'); space_wait; END {of page_2}; PROCEDURE page_3; BEGIN WRITELN; WRITELN (' For example, if you travel from quadrant 1-1 in the'); WRITELN (' direction of 90 degrees at warp 2, you would stop at'); WRITELN (' quadrant 1-3 in the next stardate. NOTE: every use of'); WRITELN (' the warp engines takes one stardate. If the Enterprise'); WRITELN (' is blocked by something during an intra-quadrant travel,'); WRITELN (' it will stop in front of it (and waste a stardate).'); WRITELN; WRITELN (' :: Short Range Sensors ::'); WRITELN; WRITELN (' The short range sensors display a detailed view of the '); WRITELN (' quadrant currently occupied by the Enterprise. The '); WRITELN (' The following symbols have meanings as follows:'); WRITELN; WRITELN (' Symbol Meaning'); WRITELN (' ', no_sym, ' empty space'); WRITELN (' ', star_sym, ' a stable star'); WRITELN (' ', nova_sym, ' an unstable star'); WRITELN (' ', ent_sym, ' the Enterprise'); WRITELN (' ', f_base_sym, ' a Federation base'); WRITELN (' ', kling_sym, ' a Klingon ship'); WRITELN (' ', k_base_sym, ' a Klingon base'); space_wait; END {of page_3}; PROCEDURE page_4; BEGIN WRITELN; WRITELN (' :: Long Range Sensors ::'); WRITELN; WRITELN (' The long range sensors display the objects in the nine'); WRITELN (' closest quadrants. Each digit in each box means '); WRITELN (' means something:'); WRITELN; WRITELN (' The ONES digit represents the number of STARS.'); WRITELN (' TENS FEDERATION BASES.'); WRITELN (' HUNDREDS KLINGON SHIPS'); WRITELN (' THOUSANDS KLINGON BASES'); WRITELN; WRITELN (' For example:'); WRITELN (' 319 means 3 Klingons, 1 Federation base, and 9 stars.'); WRITELN (' 206 means 2 Klingons, 0 Federation bases, and 6 stars.'); WRITELN (' 1007 means 1 Klingon base and 7 stars.'); WRITELN; WRITELN (' :: Phasers ::'); WRITELN; WRITELN (' Any portion of the energy available can be fired. The'); WRITELN (' battle computer divides this amount among the Klingon'); WRITELN (' ships in the quadrant and determines the various directions'); space_wait; END {of page_4}; PROCEDURE page_5; BEGIN WRITELN; WRITELN (' of fire. The effectiveness of a hit depends mostly on the'); WRITELN (' distance to the target. A Klingon battle cruiser starts with'); WRITELN (kling_energy:5, ' units of energy. It can fire an amount equal to'); WRITELN (' whatever energy is left. Note that phasers are ineffective '); WRITELN (' against stars, Klingon bases, and Federation bases.'); WRITELN; WRITELN (' :: Photon Torpedoes ::'); WRITELN; WRITELN (' Initially the Enterprise has ', start_torp, ' photon torpedoes.'); WRITELN (' One torpedo destroys whatever it hits. The range of the'); WRITELN (' photon torpedoes (like phasers) is limited to the current'); WRITELN (' quadrant. The course of a photon torpedo is set the same'); WRITELN (' way as that of the Enterprise. Torpedoes and phasers are'); WRITELN (' restocked when the Enterprise docks at a Federation base.'); WRITELN; WRITELN (' :: Damage Control Report ::'); WRITELN; WRITELN (' The damage control report lists the state of repair of each'); WRITELN (' device. A non-zero state indicates the number of stardates'); WRITELN (' required to repair the device. Devices can be damaged by'); WRITELN (' space storms, and are repaired by time and truces.'); space_wait; END {of page_5}; PROCEDURE page_6; BEGIN WRITELN; WRITELN (' :: History Computers ::'); WRITELN; WRITELN (' The history computers keep a record of all the quadrants'); WRITELN (' scanned with the long range scanners. The history report'); WRITELN (' uses the same display format as the long range scanners,'); WRITELN (' except that the entire galaxy is displayed. A quadrant'); WRITELN (' that has not been scanned is printed as "+++++".'); WRITELN; WRITELN (' :: Suicide Device ::'); WRITELN; WRITELN (' It is possible to implement a self-destruct sequence merely'); WRITELN (' by invoking this command. The game is terminated.'); WRITELN; WRITELN ('To get a list of all commands, type "9" when asked for a'); WRITELN ('command. All commands are terminated by the [RETURN] key.'); WRITELN ('You have at least on supporting starbase. Your energy and'); WRITELN ('photon torpedoes are replenished when you are docked at a'); WRITELN ('Federation starbase. G O O D L U C K !'); WRITELN; space_wait; END {of page_6}; BEGIN WRITELN ('Orders: Stardate ', cur_year); WRITELN; WRITELN ('As commander of the United Starship Enterprise,'); WRITELN ('your mission is to rid the galaxy of the deadly'); WRITELN ('Klingon menace. To do this, you must destroy the '); WRITELN ('Klingon invasion force of ', total_klingons, ' battle cruisers.'); WRITELN ('You have ', end_year - cur_year + 1, ' solar years to complete'); WRITELN ('your mission (i.e. until stardate ', end_year, '). The '); WRITELN ('Enterprise is currently in quadrant ', cur_quad.x, '-', cur_quad.y, ', sector ', cur_sect.x, '-', cur_sect.y, '.'); WRITELN; WRITE ('Do you need further instructions (y/n) ? '); READ (ch); WRITELN; WRITELN; IF ch IN ['Y', 'y'] THEN BEGIN page_1; page_2; page_3; page_4; page_5; page_6; WRITELN; WRITELN; END {of IF}; END {of instructions}; PROCEDURE finish_game; VAR rating : INTEGER; BEGIN IF (cur_energy <= 0) OR (cur_year >= end_year) THEN BEGIN WRITELN ('It is stardate ', cur_year, '. The Enterprise has been'); WRITELN ('destroyed. The Federation will be conquered. There'); WRITELN ('are still ', total_klingons, ' Klingon battle cruisers.'); WRITELN ('You are dead.'); END {of IF} ELSE BEGIN rating := start_klingons DIV (cur_year - start_year) * 100; WRITELN ('It is stardate ', cur_year, '. The last Klingon battle'); WRITELN ('cruiser in the galaxy has been destroyed. The Federation'); WRITE ('has been saved. '); IF bad_points > rating THEN BEGIN WRITELN ('However, because of your wanton '); WRITELN ('destruction of Federation bases and planet systems,'); WRITELN ('you have been thrown in the brig never to see the'); WRITELN ('light of day again.'); END {of IF bad_points} ELSE BEGIN WRITELN ('You are a hero and a new admiral.'); WRITELN (start_klingons, ' Klingons in ', cur_year - start_year, ' years gives a rating of ', rating); END {of ELSE bad_points}; END {of ELSE}; END {of finish_game}; {ending of STAR.PART3.TEXT} ======================================================================================== DOCUMENT :usus Folder:VOL09:startrek.text ======================================================================================== PROGRAM star_trek; CONST ent_energy = 5000; {units of energy to start enterprise} start_torps = 10; {photon torpedos to start} kling_energy = 300; {units of energy to start klingon ships} galaxy_size = 7; {square size of galaxy - 1} quad_size = 7; {square size of quadrant - 1} max_digit = 9; {maximum value of single digit} min_device = '0'; {lowest device number} max_device = '7'; {highest device number} max_klingons = 11; {maximum number of klingon entities in 1 quad} no_sym = '.'; {symbol for nothingness} star_sym = '*'; {symbol for star} nova_sym = '+'; {symbol for nova} ent_sym = 'E'; {symbol for enterprise} f_base_sym = 'B'; {symbol for federation base} kling_sym = 'K'; {symbol for klingon ship} k_base_sym = '@'; {symbol for klingon base} alarm = 7; {terminal alarm} {$I star.part1.text} {$I star.part2.text} {$I star.part3.text} BEGIN {of star_trek} seed := 3.14159; initialize; setup_quad (cur_quad, cur_sect); set_condition; instructions; klingon_attack; print_quadrant; WHILE (cur_energy > 0) AND (total_klingons > 0) AND (total_k_bases > 0) AND (cur_year <> end_year) DO command; finish_game; END {of star_trek}. ======================================================================================== DOCUMENT :usus Folder:VOL09:volume.9.text ======================================================================================== DOCUMENTATION FOR USUS LIBRARY VOLUME 9 Games The programs on this disk represent games in various stages of develop- ment, from ADVENTURE, which is superb and complete, to SPACEWAR, which will work fine now if you and a friend have your Microengines hooked together, but needs work for other configurations. ADVENTURE.....There are a number of files on this disk that comprise the game Adventure, all of which boil down to four (a code file and three data files) when the game is actually run. This is the FULL, ORIGINAL FORTRAN Adventure, translated into UCSD Pascal via a PL/I version. Several of us have played it, and we have all found it the fastest disk-based ADVENTURE going. Splendid job, Mike Turner! To get started, READ THE DOCUMENTATION, which tells you how to set up the data files with ADVINIT, and don't forget ADV.MISCINFO, which tells the system how big your screen is. Total setup time with a fresh disk is about 10 minutes, required once only. STARTREK......Barry Demchak wrote a good if relatively routine Pascal version of the BASIC classic; it has the added feature of Klingon starbases to make life interesting. Startrek always seems to inspire game programmers to further heights, and if this is your passion, Barry's given you a good start...maybe add real time? If so, several caveats: use a counter to time moves, rather than the system clock, which few of us have (and scale the counter with a startup query of slow, medium, or fast processor). Put all your screen control in one place so we can find it, perhaps in your own screen control unit (a USUS standard screen control unit is being drafted). CASTLES.......This is Pat Horton's implementation of a strategic board game. Board and move codes are described in CASTLES.DOC, which you should probably have printed out and sitting beside you when you play. SPACEWAR......Pat Horton has done an excellent job of putting together the start of the classic battling space ships. It is designed to be used with two computers hooked together by their remote ports (or is it two terminals and one computer?). To get an idea of how the game functions with only one terminal, delete the 8th line from the end ("WHILE NOT...") and play with one ship inoperative. Playing is easy, since there are only five commands. Control H, J, K, and L are used to control the ship: ^H and ^L turn it 45 degrees to the right and to the left; ^J causes the ship to accelerate in its current direction; and ^K causes the ship to fire. Typing a "q" or "Q" quits the game. This version lacks a sun, although there seems to be a gravitational field pulling you toward the center. If you move to the edge of the screen, you'll bounce back like a tennis ball, rather than appearing on the other side of the screen as is usually done. "Bullets" fired have little momentum, and mostly follow your ship; I saw only one at a time. Action happens only if you or your opponent press a key, though it keeps up with "repeat" keys nicely and moves fast. Pat has done a nice job of indicating the orientation of your ship (it requires all printing ASCII characters, however, and may not work on a standard Apple). There are several instances of writing an ESC-"*" sequence to the screen, which I believe is meant to clear it. Good playing!! Jim Gagne, USUS Library Chairman Datamed Research, Inc., 1433 Roscomare Road, Los Angeles, CA 90024 ======================================================================================== DOCUMENT :usus Folder:VOL10:benchmark.text ======================================================================================== program BENCHMARK; type REC2_TYPE=record next:^REC2_TYPE end; var NUM_LOOPS:integer; I,J,K,L,TEST:integer; R,S,T:real; A:array [1..100] of integer; B:array [1..100] of real; STR1,STR2,STR3:string[80]; CH:char; REC1:record FIRSTI,SECONDI:integer; FIRSTR,SECONDR:real; end; ROOT,PTR:^REC2_TYPE; CSET:set of char; procedure prompt; procedure prompt1; begin writeln('21. CASE statements. 22. PROCEDURE calls.'); writeln('23. PROC. calls w/INTEGER param. 24. PROC. calls w/REAL param.'); writeln('25. PROC. calls w/local var. 26. SET unions.'); writeln('27. SET differences. 28. SET IN''s.'); writeln('29. pointer transfers. 30. STRING transfers.'); writeln('31. STRING comparison.'); writeln; writeln('STRING functions 32. LENGTH 33. COPY 34. POS 35. CONCAT'); writeln(' 36. DELETE 37. INSERT'); writeln('number crunching 38. SIN 39. COS 40. EXP 41. ATAN'); writeln(' 42. LN 43. LOG 44. PWROFTEN 45. TRUNC'); writeln(' 46. ROUND'); end; begin gotoxy(0,0); write(chr(26)); writeln(' 1. null FOR loops (TO). 2. null FOR loops (DOWNTO).'); writeln(' 3. INTEGER increments (FOR loop). 4. null WHILE loops.'); writeln(' 5. null REPEAT loops. 6. INTEGER adds.'); writeln(' 7. INTEGER multiplies. 8. INTEGER divides.'); writeln(' 9. REAL increments. 10. REAL adds'); writeln('11. REAL multiplies. 12. REAL divides.'); writeln('13. INTEGER transfers. 14. INTEGER ARRAY transfers.'); writeln('15. REAL transfers. 16. REAL ARRAY transfers.'); writeln('17. INTEGER RECORD transfers. 18. REAL RECORD transfers.'); writeln('19. INTEGER IF comparisons. 20. REAL IF comparisons.'); prompt1; end; {PROMPT} procedure SPACEBAR; begin repeat read(keyboard,CH) until CH=' ' end; {SPACEBAR} procedure DUMMY1; begin end; {DUMMY1} procedure DUMMY2(I:integer); begin end; {DUMMY2} procedure DUMMY3(I:real); begin end; {DUMMY3} procedure DUMMY4; var I:integer; begin end; {DUMMY4} procedure TEST1; begin write('1--> hit SPACEBAR to start ',NUM_LOOPS,' null FOR loops (TO) timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin end; writeln; write(chr(7),' end null FOR loops (TO) timing...'); writeln; writeln end; {TEST1} procedure TEST2; begin write('2--> hit SPACEBAR to start ',NUM_LOOPS,' null FOR loops (DOWNTO) timing...'); SPACEBAR; write(chr(7)); for I:=NUM_LOOPS downto 1 do begin end; writeln; write(chr(7),' end null FOR loops (DOWNTO) timing...'); writeln; writeln end; {TEST2} procedure TEST3; begin write('3--> hit SPACEBAR to start ',NUM_LOOPS,' integer increments (FOR loop) timing...'); SPACEBAR; J:=0; write(chr(7)); for I:=1 to NUM_LOOPS do begin J:=J+1 end; writeln; write(chr(7),' end integer increments (FOR loop) timing...'); writeln; writeln end; {TEST3} procedure TEST4; begin write('4--> hit SPACEBAR to start ',NUM_LOOPS,' null WHILE loops timing...'); SPACEBAR; J:=0; write(chr(7)); while (J hit SPACEBAR to start ',NUM_LOOPS,' null REPEAT loops timing...'); SPACEBAR; J:=0; write(chr(7)); repeat J:=J+1 until (J=NUM_LOOPS); writeln; write(chr(7),' end null REPEAT loops timing...'); writeln; writeln end; {TEST5} procedure TEST6; begin write('6--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER adds timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin J:=J+K end; writeln; write(chr(7),' end INTEGER adds timing...'); writeln; writeln end; {TEST6} procedure TEST7; begin write('7--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER mulitplies timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin J:=K*1 end; writeln; write(chr(7),' end INTEGER mulitplies timing...'); writeln; writeln end; {TEST7} procedure TEST8; begin write('8--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER divides timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin J:=K div 1 end; writeln; write(chr(7),' end INTEGER divides timing...'); writeln; writeln end; {TEST8} procedure TEST9; begin write('9--> hit SPACEBAR to start ',NUM_LOOPS,' REAL increments timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=R+1.0 end; writeln; write(chr(7),' end REAL increments timing...'); writeln; writeln end; {TEST9} procedure TEST10; begin write('10--> hit SPACEBAR to start ',NUM_LOOPS,' REAL adds timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=R+S end; writeln; write(chr(7),' end REAL adds timing...'); writeln; writeln end; {TEST10} procedure TEST11; begin write('11--> hit SPACEBAR to start ',NUM_LOOPS,' REAL multiplies timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=S*T end; writeln; write(chr(7),' end REAL multiplies timing...'); writeln; writeln end; {TEST11} procedure TEST12; begin write('12--> hit SPACEBAR to start ',NUM_LOOPS,' REAL divides timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=S/T end; writeln; write(chr(7),' end REAL divides timing...'); writeln; writeln end; {TEST12} procedure TEST13; begin write('13--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER transfers timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin J:=K end; writeln; write(chr(7),' end INTEGER transfers timing...'); writeln; writeln end; {TEST13} procedure TEST14; begin J:=5; K:=12; write('14--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER ARRAY transfers timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin A[J]:=A[K] end; writeln; write(chr(7),' end INTEGER ARRAY transfers timing...'); writeln; writeln end; {TEST14} procedure TEST15; begin write('15--> hit SPACEBAR to start ',NUM_LOOPS,' REAL transfers timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=S end; writeln; write(chr(7),' end REAL transfers timing...'); writeln; writeln end; {TEST15} procedure TEST16; begin J:=5; K:=12; write('16--> hit SPACEBAR to start ',NUM_LOOPS,' REAL ARRAY transfers timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin B[J]:=B[K] end; writeln; write(chr(7),' end REAL ARRAY transfers timing...'); writeln; writeln end; {TEST16} procedure TEST17; begin write('17--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER RECORD transfers timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin REC1.FIRSTI:=REC1.SECONDI end; writeln; write(chr(7),' end INTEGER RECORD transfers timing...'); writeln; writeln end; {TEST17} procedure TEST18; begin write('18--> hit SPACEBAR to start ',NUM_LOOPS,' REAL RECORD transfers timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin REC1.FIRSTR:=REC1.SECONDR end; writeln; write(chr(7),' end REAL RECORD transfers timing...'); writeln; writeln end; {TEST18} procedure TEST19; begin J:=5; K:=12; write('19--> hit SPACEBAR to start ',NUM_LOOPS,' INTEGER IF comparisions timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do if (J hit SPACEBAR to start ',NUM_LOOPS,' REAL IF comparisons timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do if (R hit SPACEBAR to start ',NUM_LOOPS,' CASE statements timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do case J of 1:begin end; 2:begin end; 3:begin end; 4:begin end; end; writeln; write(chr(7),' end CASE statements timing...'); writeln; writeln end; {TEST21} procedure TEST22; begin write('22--> hit SPACEBAR to start ',NUM_LOOPS,' PROCEDURE calls timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do DUMMY1; writeln; write(chr(7),' end PROCEDURE calls timing...'); writeln; writeln end; {TEST22} procedure TEST23; begin write('23--> hit SPACEBAR to start ',NUM_LOOPS,' PROCEDURE calls (INTEGER param) timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do DUMMY2(I); writeln; write(chr(7),' end PROCEDURE calls (INTEGER param) timing...'); writeln; writeln end; {TEST23} procedure TEST24; begin write('24--> hit SPACEBAR to start ',NUM_LOOPS,' PROCEDURE calls (REAL param) timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do DUMMY3(R); writeln; write(chr(7),' end PROCEDURE calls (REAL param) timing...'); writeln; writeln end; {TEST24} procedure TEST25; begin write('25--> hit SPACEBAR to start ',NUM_LOOPS,' PROCEDURE calls (local var) timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do DUMMY4; writeln; write(chr(7),' end PROCEDURE calls (local var) timing...'); writeln; writeln end; {TEST25} procedure TEST26; begin write('26--> hit SPACEBAR to start ',NUM_LOOPS,' SET unions timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin CSET:=CSET+['a','b'] end; writeln; write(chr(7),' end SET unions timing...'); writeln; writeln end; {TEST26} procedure TEST27; begin write('27--> hit SPACEBAR to start ',NUM_LOOPS,' SET differences timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin CSET:=CSET-['a','b'] end; writeln; write(chr(7),' end SET differences timing...'); writeln; writeln end; {TEST27} procedure TEST28; begin write('28--> hit SPACEBAR to start ',NUM_LOOPS,' SET IN''s timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do if (CH in CSET) then begin end; writeln; write(chr(7),' end SET IN''s timing...'); writeln; writeln end; {TEST28} (*$I BENCHMARK1.TEXT*) begin {MAIN PROGRAM} write(chr(26),chr(30)); J:=100; K:=200; L:=300; R:=400; S:=500; T:=600; write('Enter number of loops per test: '); readln(NUM_LOOPS); repeat PROMPT; writeln; write('Enter test (enter "0" for all, negative number to quit): '); readln(TEST); write(chr(26),chr(30)); if (TEST>=0) then case TEST of 0:begin TEST1; TEST2; TEST3; TEST4; TEST5; TEST6; TEST7; TEST8; TEST9; TEST10; TEST11; TEST12; TEST13; TEST14; TEST15; TEST16; TEST17; TEST18; TEST19; TEST20; TEST21; TEST22; TEST23; TEST24; TEST25; TEST26; TEST27; TEST28; TEST29; TEST30; TEST31; TEST32; TEST33; TEST34; TEST35; TEST36; TEST37; TEST38; TEST39; TEST40; TEST41; TEST42; TEST43; TEST44; TEST45; TEST46; end; 1:TEST1; 2:TEST2; 3:TEST3; 4:TEST4; 5:TEST5; 6:TEST6; 7:TEST7; 8:TEST8; 9:TEST9; 10:TEST10; 11:TEST11; 12:TEST12; 13:TEST13; 14:TEST14; 15:TEST15; 16:TEST16; 17:TEST17; 18:TEST18; 19:TEST19; 20:TEST20; 21:TEST21; 22:TEST22; 23:TEST23; 24:TEST24; 25:TEST25; 26:TEST26; 27:TEST27; 28:TEST28; 29:TEST29; 30:TEST30; 31:TEST31; 32:TEST32; 33:TEST33; 34:TEST34; 35:TEST35; 36:TEST36; 37:TEST37; 38:TEST38; 39:TEST39; 40:TEST40; 41:TEST41; 42:TEST42; 43:TEST43; 44:TEST44; 45:TEST45; 46:TEST46; end; until (TEST<0); end. ======================================================================================== DOCUMENT :usus Folder:VOL10:benchmark1.text ======================================================================================== procedure TEST29; begin new(ROOT); new(ROOT^.NEXT); ROOT^.NEXT^.NEXT:=ROOT; PTR:=ROOT; write('29--> hit SPACEBAR to start ',NUM_LOOPS, ' pointer transfers timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin PTR:=PTR^.NEXT end; writeln; write(chr(7),' end pointer transfers timing...'); writeln; writeln end; {TEST29} procedure TEST30; begin STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...'; write('30--> hit SPACEBAR to start ',NUM_LOOPS,' STRING transfers timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin STR2:=STR1 end; writeln; write(chr(7),' end STRING transfers timing...'); writeln; writeln end; {TEST30} procedure TEST31; begin STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...'; STR2:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing.. '; write('31--> hit SPACEBAR to start ',NUM_LOOPS,' STRING comparison timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do if (STR2=STR1) then begin end; writeln; write(chr(7),' end STRING comparison timing...'); writeln; writeln end; {TEST31} procedure TEST32; begin STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...'; write('32--> hit SPACEBAR to start ',NUM_LOOPS,' LENGTH operations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin J:=length(STR1) end; writeln; write(chr(7),' end LENGTH operations timing...'); writeln; writeln end; {TEST32} procedure TEST33; begin STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...'; write('33--> hit SPACEBAR to start ',NUM_LOOPS,' COPY operations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin STR2:=copy(STR1,1,65) end; writeln; write(chr(7),' end COPY operations timing...'); writeln; writeln end; {TEST33} procedure TEST34; begin STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...'; write('34--> hit SPACEBAR to start ',NUM_LOOPS,' POS operations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin J:=pos('...',STR1) end; writeln; write(chr(7),' end POS operations timing...'); writeln; writeln end; {TEST34} procedure TEST35; begin STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...'; STR2:='This is it!! '; write('35--> hit SPACEBAR to start ',NUM_LOOPS,' CONCAT operations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin STR3:=concat(STR1,STR2) end; writeln; write(chr(7),' end CONCAT operations timing...'); writeln; writeln end; {TEST35} procedure TEST36; begin STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...'; write('36--> hit SPACEBAR to start ',NUM_LOOPS,' DELETE operations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin delete(STR1,6,11) end; writeln; write(chr(7),' end DELETE operations timing...'); writeln; writeln end; {TEST36} procedure TEST37; begin STR1:='27--> hit SPACEBAR to start NUM_LOOPS STRING operations timing...'; write('37--> ht SPACEBAR to start ',NUM_LOOPS,' INSERT operations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin insert('STR1 = ',STR1,1) end; writeln; write(chr(7),' end INSERT operations timing...'); writeln; writeln end; {TEST37} procedure TEST38; begin write('38--> hit SPACEBAR to start ',NUM_LOOPS,' SIN evaluations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=sin(I) end; writeln; write(chr(7),' end SIN evaluations timing...'); writeln; writeln end; {TEST38} procedure TEST39; begin write('39--> hit SPACEBAR to start ',NUM_LOOPS,' COS evaluations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=cos(I) end; writeln; write(chr(7),' end COS evaluations timing...'); writeln; writeln end; {TEST39} procedure TEST40; begin write('40--> hit SPACEBAR to start ',NUM_LOOPS,' EXP evaluations timing...'); R:=-1.34583E-1; SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin S:=exp(R) end; writeln; write(chr(7),' end EXP evaluations timing...'); writeln; writeln end; {TEST40} procedure TEST41; begin write('41--> hit SPACEBAR to start ',NUM_LOOPS,' ATAN evaluations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=atan(I) end; writeln; write(chr(7),' end ATAN evaluations timing...'); writeln; writeln end; {TEST41} procedure TEST42; begin write('42--> hit SPACEBAR to start ',NUM_LOOPS,' LN evaluations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=ln(I) end; writeln; write(chr(7),' end LN evaluations timing...'); writeln; writeln end; {TEST42} procedure TEST43; begin write('43--> hit SPACEBAR to start ',NUM_LOOPS,' LOG evaluations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=log(I) end; writeln; write(chr(7),' end LOG evaluations timing...'); writeln; writeln end; {TEST43} procedure TEST44; begin J:=32; write('44--> hit SPACEBAR to start ',NUM_LOOPS,' PWROFTEN operations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin R:=PWROFTEN(J) end; writeln; write(chr(7),' end PWROFTEN operations timing...'); writeln; writeln end; {TEST44} procedure TEST45; begin R:=2.79234E4; write('45--> hit SPACEBAR to start ',NUM_LOOPS,' TRUNC operations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin J:=trunc(R) end; writeln; write(chr(7),' end TRUNC operations timing...'); writeln; writeln end; {TEST45} procedure TEST46; begin R:=2.79234E4; write('46--> hit SPACEBAR to start ',NUM_LOOPS,' ROUND operations timing...'); SPACEBAR; write(chr(7)); for I:=1 to NUM_LOOPS do begin J:=ROUND(R) end; writeln; write(chr(7),' end ROUND operations timing...'); writeln; writeln end; {TEST46} begin {MAIN PROGRAM} write(chr(26),chr(30)); J:=100; K:=200; L:=300; R:=400; S:=500; T:=600; write('Enter number of loops per test: '); readln(NUM_LOOPS); repeat PROMPT; writeln; write('Enter test (enter "0" for all, negative number to quit): '); readln(TEST); write(chr(26),chr(30)); if (TEST>=0) then case TEST of 0:begin TEST1; TEST2; TEST3; TEST4; TEST5; TEST6; TEST7; TEST8; TEST9; TEST10; TEST11; TEST12; TEST13; TEST14; TEST15; TEST16; TEST17; TEST18; TEST19; TEST20; TEST21; TEST22; TEST23; TEST24; TEST25; TEST26; TEST27; TEST28; TEST29; TEST30; TEST31; TEST32; TEST33; TEST34; TEST35; TEST36; TEST37; TEST38; TEST39; TEST40; TEST41; TEST42; TEST43; TEST44; TEST45; TEST46; end; 1:TEST1; 2:TEST2; 3:TEST3; 4:TEST4; 5:TEST5; 6:TEST6; 7:TEST7; 8:TEST8; 9:TEST9; 10:TEST10; 11:TEST11; 12:TEST12; 13:TEST13; 14:TEST14; 15:TEST15; 16:TEST16; 17:TEST17; 18:TEST18; 19:TEST19; 20:TEST20; 21:TEST21; 22:TEST22; 23:TEST23; 24:TEST24; 25:TEST25; 26:TEST26; 27:TEST27; 28:TEST28; 29:TEST29; 30:TEST30; 31:TEST31; 32:TEST32; 33:TEST33; 34:TEST34; 35:TEST35; 36:TEST36; 37:TEST37; 38:TEST38; 39:TEST39; 40:TEST40; 41:TEST41; 42:TEST42; 43:TEST43; 44:TEST44; 45:TEST45; 46:TEST46; end; until (TEST<0); end. ======================================================================================== DOCUMENT :usus Folder:VOL10:btre.file.text ======================================================================================== {************************************************************************ * * * filed as BTRE.FILE.TEXT * * * ************************************************************************} {$S+} {$G+} program BTREE_ADDRESS_FILES; { program title: B-TREE ADDRESS written by: R. M. Wilson HI-COUNTRY DATA SYSTEMS P.O. Box 4095 Woodland Park, CO. 80863 date written: 12 August 1981 latest revision: 26-May-82 program function: ---------------- This program is designed to: Test a pascal implementation of B-trees using files. The program is based on a standard B-TREE algorithm implemented with pointers found in ALGORITHMS + DATA STRUCTURES = PROGRAMS by Niklaus Wirth on pages 253-257. program development notes: ------------------------- 26-May-82 Several very important bugs concerning the value of PERSON_AVAIL after the deletion of the last data element in the root node were corrected. remarks: ------- This program was written while developing a program for a small business where retrival of customer information was an operation which had to be fast. Further, ease of updating and modifing the various records was also a prime consideration. This particular program was designed to serve as the test bed for the final program and as a ready reference of a file structure implementation of a B- tree. It can easily be modified for many different business applications requiring fast data retrival. This program uses strings as the key rather than integers as does Wirth's program. It should be of note that significant changes have been made in the main program to increase the program's usefulness, to reduce the number of "data entry" crashes, and to increase the "bells & whistles" that the user sees. Since the program is primarily designed as a demonstration of the B- tree implemented with files, the program output is directed towards that end. The program prints out the unique keys in the B-tree and then, upon request, will print a list of all the keys (unique or duplicate) in either alphabetical or reverse alphabetical order. (Duplicate keys will be printed out in the order in which they were entered.) In order to convert the program into a real utility, some rather minor changes would have to be made. (Hints on how to do this are contained in the documen-tation.) The biggest problem in converting the original program from pointers to files was keeping track of which node/record number should be in the window after the completion of a call to a procedure in which the window was shifted by a "seek" command. The second biggest problem (26-May-82) was trying to find where the persistant little bug was that kept cropping up from time to time where data previously entered was lost. The cause, hopefully, was rather sloppy control of the value of PERSON_AVAIL when the root node only contained one record, and that record was deleted either through an intentional deletion or by default when the record was modified in such a way that the key was changed. The program has been extensively documented to help the user understand how the program functions. Although quite a bit of time was spent documenting the program, a recursively implemented b-tree using a file structure can be a mess to trace. With that in mind, there is every possibility that the documen-tation may be incorrect in one or two spots in regards to exactly what each step is designed to accomplish. Although the documentation may be a bit tedious for those who are already familiar with using files in UCSD PASCAL, the repetative steps are documented in order to help the user who is not as proficient. Further, even though there is so much documentation as to make the page appear rather grey and hard to read instead of the crispness often associated with a PASCAL program, it was felt that it was better to over document rather than under document with the confusion that might result. In addition to the B-tree implementation, I have attempted to incorporate some features to enhance the usability of the program such as hopefully "bomb proof" data entry, all keys coverted to uppercase, facilities to change the location of a record if the key is changed due to a correction made to the person's first or last name, etc. Most importantly, provisions for duplicate keys have been made, and "garbage collection" is performed to reuse emptied nodes. Procedures for inorder and post order traversal of the b-tree have been included as well. The method of handling collisions of duplicate keys is by the use of a linked list structure. When an initial collision occurs, an empty node is fetched and the duplicate key stored in this node. The duplicate node is linked to the original key via an integer pointer. If the duplicate node reaches capacity an additional empty node is fetched and linked into the chain, etc. The use of a full node to store one duplicate key is very uneconomical in terms of disk space, but is far faster and easier to implement than a separate file of collision nodes with the same key, and avoids the problem of file management when a file grows to the point that it "collides" with another file on the disk. A more efficient use of the disk space could be obtained if through analysis or previous experience you can estimate how many collisions are likely to occur for a given data base and a file of PERSON (inaddition to the file of PERSON_NODE) is put on the disk when the program is initialized. Using this techique would require extensive rewriting of the present program and, depending on the number of estimated collisions per unique key, could significantly and adversly affect the retrival time for a given duplicate key. The nodes of the B-tree are limited to a maximum size of four records per node. This was done to make tracing and learning the B=tree easier. The constant MAX_NODE_SIZE can be increased as you desire. (For example if MAX_NODE_SIZE=8 then there are a maximum of five disk accesses to find any one of 2000 records.) Obiviously the greater MAX_NODE_SIZE is the fewer disk accesses required for a given number of data. It should be of note that the program as presented is not optimized for either memory usage or efficient operation. The program developed for the business application implemented six separate B- trees. In order to reduce the memory requirments case statements were used extensively along with a type declaration which kept track of the particular record structure. The various procedures nested within SEARCH and DELETE were broken out and the parameter list for each was increased as required to ensure proper functioning. Each of the major program functions was also set up as a segment procedure to optimize memory usage. The initialization routine puts 20 empty nodes on the disk. This number is controlled by MAX_PERS_NODES, and can be set to any size your disk drives will handle. (Using a fixed size data file has the advantage that the file will not be blocked by other files on the disk as the amount of data in the file grows.) You should be note that the program is rather limited in its capacity. A maximum of only 80 people can be stored when MAX_NODE_SIZE=4 and MAX_PERS_NODES=20. Due to the nature of the B- tree structure, even though 20 nodes can in theory store 80 records this maximum is obtained only where there are not a lot of operations where the new record entered is put into an already full node. When ever this happens, two new nodes are required. By simple reasoning, you can see if every node in the tree is full and you try to insert a new node then one new node is required for each level of the tree up to the root node where two new nodes are required if it is full. In this tree of order 4 if the root node is full then it must have five children. If each of those children are full and do not have any successor nodes then if you insert a new record, the tree is adjusted with a new root node and the old root node is broken into two sub nodes with two records each whose children have records as follows: sub node "1" children 4,4,4 sub node "2" children 4,2,2 As you can see (especially if you run the program!) the tree is now a 3 level tree with only one more record but two more nodes. If we continued to add new records into the nodes which are already full, we will quickly reach our maximum of 20 nodes and would not be any where close to 80 total records. So it should be apparent that the maximum empty nodes required to safely start an insertion operation is equal to the depth of the tree plus one. It should be further be ovibious that the maximum depth of the tree is equal to N where N is the largest integer possible where exp(N*ln(MAX_NODE_SIZE))<=MAX_PERS_NODES, and then the minimum number of empty or unused nodes required to ensure a successful insertion is N+1. In order to enable the user to appreciate all of the disk accesses that must take place during insertions and deletions, a period is printed out for each "seek" that is executed. IMPLEMENTATION NOTES -------------------- This program was written on a Western Digital MICROENGINE with a TeleVideo 920C terminal. As such some minor changes may have to be made to convert to other computers. Specifically, page(output) doesn't clear the CRT for me, so I am forced to use the CLEARSCREEN routine. Further, my printer is hooked to the serial port which is addressed as "#8" or "REMOTE:", and you will have to change all of the REMOTE:'s to whatever suits your installation. Changed by gws to be compatable with H-19. REMOTE: also changed to printer: COPYRIGHT --------- This program is furnished to the USUS group for unrestricted personal or non-profit use. Use of this program for commercial purposes is authorized with the following restrictions: 1--> Prior notification to and acknowledgement by the author 2--> A message similar to the one below appears on the screen upon execution and remains there until a key is hit. ************************************************************************* * * * * * * * * * * * Program derived from BTREE.ADDRESS * * written by * * R.M. Wilson * * Hi-Country Data Systems * * P.O. Box 4258 * * Woodland Park, CO 80863 * * * * * * * * * * * * * * * * * * * ************************************************************************* } {l #5:btree.list.text} {$I BTREE.DCLR.TEXT} {$I BTREE.STD.TEXT} {$I BTREE.INIT.TEXT} {$I BTREE.GET.TEXT} {$I BTRE.FIND1.TEXT} {$I BTRE.FIND2.TEXT} {$I BTREE.DEL1.TEXT} {$I BTREE.DEL2.TEXT} {$I BTREE.PRNT.TEXT} {$I BTREE.DOIT.TEXT} begin {MAIN PROGRAM} CLEARSCREEN; TITLE; INIT; CLEARSCREEN; reset(CONTROLFILE,CONTROL); {open control file and leave it open for ready access} get(CONTROLFILE); {get the control file data} FILE_LEN:=CONTROLFILE^; {get the control file data} write('Output to printer? (y/n) '); {chose output device} if YES then reset(OUTFILE,'printer:') {output device is printer} else reset(OUTFILE,'CONSOLE:'); {output device is CRT} repeat writeln; write('Enter or Delete a node? (E/D) {Hit to quit} '); read(keyboard,CH); writeln; if CH in ['e','E'] then if FILE_LEN.PERSON_UNUSEDsuccessor node} end {if not DUPLICATE} else begin {node is full of duplicate keys so must start filling a new node and link the full node to it} NEW_HEIGHT:=false; {prevent action in procedure SEARCH} DUPLICATE:=false; {reset flag/control variable} P0:=NEXT_NODE; {link to latest node in linked list} NEW_NODE.DATA[1]:=U; {fill first slot of empty node} NEW_NODE.P0:=-1; {no additional duplicate key nodes (yet!)} NEW_NODE.NODESIZE:=1 {set correct node size} end {else begin} end; {else begin} end; {with PERSONS^} {************************************************************************ * * * Although it seems sensible that a simple "put(PERSONS)" would work * * correctly all by itself, unless all four lines below are used, only * * the very first item added to the original root node is saved. * * A "get" statement advances the file pointer to the next record * * location. * * * *************************************************************************} Z:=PERSONS^; {assign node to temp while seeking} seek(PERSONS,A); {set window on node/record number A} write('.'); {show user something is happending} PERSONS^:=Z; {"dispose" of temp} put(PERSONS); {write PERSON_NODE to disk} if SPLIT then begin {find place to put NEW_NODE} seek(PERSONS,NEXT_NODE); {set window to "empty" node location} write('.'); {show user something is happending} get(PERSONS); {fill file buffer} FILE_LEN.PERSON_AVAIL:=PERSONS^.P0; {remove node from linked list of available nodes and reset pointer to new head of the list} FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED-1; {correct number of empty or unused nodes} seek(PERSONS,NEXT_NODE); {reset window to "empty" node location} write('.'); {show user something is happending} PERSONS^:=NEW_NODE; {assign NEW_NODE to "disk variable"} put(PERSONS); {write NEW_NODE to disk} end; {if SPLIT} end; {INSERT} function PERSON_FOUND(U:PERSON;K:integer):boolean; {************************************************************************ * * * Check to see if the correct person found. * * * ************************************************************************} var TEMP_KEY:FNAME; {hold key if data is changed} begin if FOUND then begin PERSON_FOUND:=false; exit(PERSON_FOUND) end; {if FOUND} PRINT_PERSON(U); {display record in question} writeln; writeln; write('IS THIS THE CORRECT PERSON? (y/n) '); if YES then begin FOUND:=true; {global found the correct person} PERSON_FOUND:=true; NEW_HEIGHT:=false; {B-tree not growing} DUPLICATE:=false; {reset flag/control variable} LEAVE:=true; {we've found it so set exit flag} WRONG:=false; {the inputed and inverted key wasn't wrong} V:=U; {pass record back to original call of SEARCH} writeln; writeln; write('Is the customer data correct?'); {verify data} if not YES then begin {data incorrect} TEMP_KEY:=V.KEY; {save for comparing} PERSON_CHANGE(V); {change it} if TEMP_KEY<>V.KEY then begin {key has changed so node must be moved to correct location} CLEARSCREEN; {clear CRT} PRINTAT(0,8,'You changed the key so...'); PERSONPTR:=U; {save old node for deletion comparison} CHANGED:=true; {set flag for deletion} WRONG:=true {set flag for reinsertion} end {if TEMP_KEY<>V.KEY} else if U<>V then begin PERSONS^.DATA[K]:=V; {put corrected data into node} Z:=PERSONS^; {hold node while seeking} seek(PERSONS,A); {reset file window to location of node A} write('.'); {show user something is happending} PERSONS^:=Z; {put corrected node into file buffer} put(PERSONS) {write correct node onto disk} end {else if U<>V} end {if not YES} end {if YES} else PERSON_FOUND:=false {did not find person} end; {PERSON_FOUND} ======================================================================================== DOCUMENT :usus Folder:VOL10:btre.find2.text ======================================================================================== {************************************************************************ * * * filed as BTRE.FIND2.TEXT revised 31-May-82 * * * ************************************************************************} procedure START_NEW_PERSON; label 1; begin GET_NEW_PERSON(V); {get the data} 1:if V.KEY<>INPUTKEY then begin {************************************************************************ * * * This "if..then" statement allows user to catch errors in the data * * inputed in regards to the key which will be used to fetch the data. * * User can put in a special key which could not easily be discovered. * * (i.e. if normal key = BJONES and user inputed FSMITH) * * * ************************************************************************} CLEARSCREEN; gotoxy(0,11); writeln('The computed key does not match the input key.'); writeln; writeln; writeln; writeln('Do you want to verify the data you inputed? (y/n) '); if YES then begin PRINT_PERSON(V); writeln; writeln; writeln('Is the above correct? (y/n) '); if not YES then PERSON_CHANGE(V); goto 1 end; {if YES} writeln('Do you want the input key or the computed key? (I/C) '); writeln; writeln; writeln('INPUTKEY = ':25,FAKE_KEY); {user inputed key} TEMP_KEY:=V.KEY; {protect V.KEY} INVERT_KEY(TEMP_KEY,2); {convert to "user format"} writeln; write('COMPUTED KEY = ':25,TEMP_KEY); {display results} CH:=READKEY(['C','I','c','i']); {"bomb proofing"} if CH in ['C','c'] then begin {location for the insertion was based on INPUTKEY so get back to where the process can be started all over again using the computed key} CLEARSCREEN; PRINTAT(0,8,'You changed the key so...'); LEAVE:=true; {set exit flag} WRONG:=true; {user inputed key was wrong} NEW_HEIGHT:=false; {prevent strange things from happening} FOUND:=true {we found a place to insert the incorrect key} end {if CH in} else V.KEY:=INPUTKEY; {use the user key} end {if V.KEY<>INPUTKEY} end; {START_NEW_PERSON} begin {SEARCH} {We search key INPUTKEY in the record number "A"...NEW_HEIGHT=false} if A=-1 then begin {item with key INPUTKEY not in b-tree} NEW_HEIGHT:=true; {at this point NEW_HEIGHT only means something is to be added or inserted into the b-tree} if FOUND then exit(SEARCH); {found new location for changed node} CLEARSCREEN; {clear CRT} gotoxy(0,8); {position cursor} writeln('Person <',FAKE_KEY,'> address file not found.'); writeln; write('Is the key correct? (y/n) '); if YES then begin WRONG:=false; {the key was correct} writeln; writeln; write('Start a new address file? (y/n) '); if YES then START_NEW_PERSON else begin {don't start a new address file} LEAVE:=true; {set flag to return to calling procedure ASAP} NEW_HEIGHT:=false; {B-tree is not growing} FOUND:=true {we found a place to put the correct key} end {else begin} end {if YES} else begin {user inputed key incorrectly} WRONG:=true; {key is incorrect} NEW_HEIGHT:=false; {prevent strange things from happening} FOUND:=false; {flag to get new key} LEAVE:=true {set flag to return to calling procedure ASAP} end {else begin} end {if A=-1} else begin {we have not reached a "null" or terminal node yet} seek(PERSONS,A); {set the file window to the record to search} write('.'); {show user something is happending} get(PERSONS); {load the file buffer} with PERSONS^ do begin if DUPLICATE then begin {check duplicate nodes} for J:=1 to NODESIZE do if PERSON_FOUND(DATA[J],J) then exit(SEARCH); {we found it!} SEARCH(INPUTKEY,P0,V,FOUND,WRONG); {not found...continue search} if LEAVE then exit(SEARCH); {if LEAVE=true then either the key is incorrect or user decided not to make an entry} if NEW_HEIGHT then begin {************************************************************************ * * * In the original program each recursive call of "SEARCH" was coded * * so that the "person record" passed was "U" and not "V". When the * * code to handle changed nodes was added, it was necessary to pass * * that changed node back down to the original calling procedure and * * back up to the search and insert routines. * * * * The simplist method of achieving this was to modify all of the * * recursive calls of "SEARCH" to pass "V" rather than "U". However, * * the "INSERT" procedure uses "U" to insert the new record. Rather * * than rewriting "INSERT" and suffering through all of the "joys" of * * debugging that would surely result, I elected to simply add the * * "U:=V" which is found below and prior to every other call of * * "INSERT". * * * ************************************************************************} U:=V; INSERT {insert new duplicate key} end {if NEW_HEIGHT} end {if DUPLICATE} else begin {continue search for key} L:=1; {set left limit} R:=NODESIZE; {set right limit} repeat {binary search for INPUTKEY} K:=(L+R) div 2; if INPUTKEY<=DATA[K].KEY then R:=K-1; {reset right limit} if INPUTKEY>=DATA[K].KEY then L:=K+1; {reset left limit} until R1 then begin {We found a key that matches} if PERSON_FOUND(DATA[K],K) then exit(SEARCH) {We found it!!} else begin {we didn't find it} DUPLICATE:=true; {set flag to check for possible duplicates} SEARCH(INPUTKEY,DATA[K].DUPE,V,FOUND,WRONG); {initiate search for duplicate keys} if NEW_HEIGHT then begin {must enter first duplicate key} seek(PERSONS,FILE_LEN.PERSON_AVAIL); {set file window to head of linked list of available nodes} write('.'); {show user something is happending} get(PERSONS); {load file buffer} I:=P0; {save link information} NODESIZE:=0; {initialize node} P0:=-1; {initialize node} R:=MAX_NODE_SIZE+1; {prevent unwanted action in INSERT} A1:=A; {save primary key location} A:=FILE_LEN.PERSON_AVAIL; {initialize for INSERT} U:=V; {for INSERT to function properly} INSERT; {insert it (finally!)} A:=A1; {restore primary key location} seek(PERSONS,A); {reset file window to primary key node} write('.'); {show user something is happending} get(PERSONS); {load file buffer} DATA[K].DUPE:=FILE_LEN.PERSON_AVAIL; {store location of duplicate key} Z:=PERSONS^; {hold buffer data while seeking} seek(PERSONS,A); {reset file window to primary key node} write('.'); {show user something is happending} PERSONS^:=Z; {load file buffer} put(PERSONS); {write file buffer to disk} FILE_LEN.PERSON_AVAIL:=I; {reset link list pointer to head node} FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED-1 {correct number of empty or unused nodes} end {if NEW_HEIGHT} end {else begin} end {if L-R>1} else begin {item is not in this b-tree node} if R=0 then Q:=P0 {if R=0 then INPUTKEYDATA[R].KEY} SEARCH(INPUTKEY,Q,V,FOUND,WRONG); {search the appropriate successor node} if LEAVE then exit(SEARCH); {if LEAVE=true then either the key is incorrect or user decided not to make an entry} {************************************************************************ * * * The conditional statement and the included "seek" and "get" are the * * elusive keys which make the SEARCH and INSERT procecures work * * correctly. It is essential that the window be reset to the value * * after the recursive call, before INSERT is called. * * * ************************************************************************} {if SPLIT then record/node number A is not in file buffer, and both INSERT and KEY_INSERT reference that record/node} if SPLIT then begin {if SPLIT then file window was moved} seek(PERSONS,A); {reset file window} write('.'); {show user something is happending} get(PERSONS); {load file buffer} end; {if SPLIT} if NEW_HEIGHT then begin U:=V; {for INSERT to function properly} INSERT {insert new unique key} end {if NEW_HEIGHT} end {else begin} end {with PERSONS^} end {else begin} end {else begin} end; {SEARCH} ======================================================================================== DOCUMENT :usus Folder:VOL10:btree.data ======================================================================================== < binary file -- not listed > ÿÿÿÿ ======================================================================================== DOCUMENT :usus Folder:VOL10:btree.dclr.text ======================================================================================== {************************************************************************ * * * filed as BTREE.DCLR.TEXT revised 27 November 1981 * * * ************************************************************************} {label 1;} const MAX_NODE_SIZE=4; {order of the B-TREE} MIN_NODE_SIZE=2; {MAX_NODE_SIZE div 2} MAX_PERS_NODES=20; {number of nodes in data file} {************************************************************************ * * * For a more useful program, change the above as follows... * * * * MAX_NODE_SIZE=8; * * MIN_NODE_SIZE=4; * * MAX_PERS_NODE=400; * * * * That will allow up to 3200 names and addresses to be stored. * * * ************************************************************************} CONTROL='BTREE.DATA'; {name of file management data} PERSON_FILE='PERSON.DATA'; {name of data file} type LNAME=string[20]; {last name} FNAME=string[10]; {first name} ADRS=string[30]; {line of address} ZIP=string[10]; {zip code} FONE=string[13]; {area code and phone number} ST=string[3]; {state} SETOFCHAR=set of char; {for function READKEY} SIZENODE=0..MAX_NODE_SIZE; PERSON=packed record {person informaton} SUCC_NODE:integer; {pointer to "child" node} DUPE:integer; {pointer to node with duplicate key(s)} KEY:FNAME; {search key} FIRST:FNAME; {first name} LAST:LNAME; {last name} STREET:ADRS; {street/apartment address} CITY:ADRS; ZIPCODE:ZIP; STATE:ST; PHONE:FONE end; PERSON_NODE=packed record {b-tree node of "many" persons} NODESIZE:SIZENODE; P0:integer; {pointer to successor node} DATA:packed array[1..MAX_NODE_SIZE] of PERSON; {array of person records} end; CONTROLDATA=packed record {file management data} PERSON_AVAIL:integer; {pointer to empty node} PERSON_ROOT:integer; {pointer to root PERSON_NODE} PERSON_UNUSED:integer; {how many nodes are unused} PERSON_MIN:integer; {minimum required for insertion} end; PERSFILE=file of PERSON_NODE; {person b-tree} CONTFILE=file of CONTROLDATA; {file management data} var I,J,K,N:integer; {loop variables} OUTFILE:interactive; {to change output device from CRT to printer} FAKE_KEY:FNAME; {what user thinks the key is} REAL_KEY:FNAME; {the actual key} LEAVE:boolean; {to control program exit from segments} DUPLICATE:boolean; {indicates there is a duplicate key} CHANGED:boolean; {indicates retrieved record modified} NEW_HEIGHT:boolean; {indicates that tree must grow or shrink} SPLIT:boolean; {indicates if node is split} CH,AN:char; {used for primarily for option selection} FILE_LEN:CONTROLDATA; {file management data} CONTROLFILE:CONTFILE; {file management data} PERSONPTR:PERSON; {dynamic pointer to a single person record} PERSONS:PERSFILE; {person b-tree} ======================================================================================== DOCUMENT :usus Folder:VOL10:btree.del1.text ======================================================================================== {************************************************************************ * * * filed as BTREE.DEL1.TEXT revised 31-May-82 * * * ************************************************************************} procedure DELETE(INPUTKEY:FNAME; A:integer; var FOUND,WRONG:boolean); {************************************************************************ * * * Search and delete INPUTKEY in the b-tree node/record number A. If * * the deletion cause an underflow (i.e. NODESIZE0 then begin {move K items from ADJACENT_NODE to TOO_SMALL} for I:=1 to K-1 do TOO_SMALL.DATA[I+MIN_NODE_SIZE]:=ADJACENT_NODE.DATA[I]; PARENT.DATA[S]:=ADJACENT_NODE.DATA[K]; {add "new" person to parent to replace deleted person} PARENT.DATA[S].SUCC_NODE:=B; {set "new" person successor node to correct record number} ADJACENT_NODE.P0:=ADJACENT_NODE.DATA[K].SUCC_NODE; {set correct lessor successor node to correct record number} ADJ_SIZE:=ADJ_SIZE-K; {adjust for persons transferred to TOO_SMALL} for I:=1 to ADJ_SIZE do {"close-up" gap left by transfer} ADJACENT_NODE.DATA[I]:=ADJACENT_NODE.DATA[I+K]; ADJACENT_NODE.NODESIZE:=ADJ_SIZE; {adjust for persons transferred to TOO_SMALL} TOO_SMALL.NODESIZE:=MIN_NODE_SIZE-1+K; {adjust for persons transferred to TOO_SMALL} NEW_HEIGHT:=false; {b-tree is not shrinking vertically} seek(PERSONS,B); {set file window to ADJACENT_NODE} write('.'); {show user something is happening} PERSONS^:=ADJACENT_NODE; {assign to "disk variable"} put(PERSONS) {write revised node to disk} end {if K>0} else begin {merge nodes TOO_SMALL and ADJACENT_NODE} for I:=1 to MIN_NODE_SIZE do {transfer to TOO_SMALL until it is the maximum size} TOO_SMALL.DATA[I+MIN_NODE_SIZE]:=ADJACENT_NODE.DATA[I]; for I:=S to PARENT_SIZE-1 do PARENT.DATA[I]:=PARENT.DATA[I+1]; {"Krunch" PARENT_NODE} TOO_SMALL.NODESIZE:=MAX_NODE_SIZE; {adjust for transfer from ADJACENT_NODE} PARENT.NODESIZE:=PARENT_SIZE-1; {dispose(ADJACENT_NODE)} seek(PERSONS,B); {set file window to node being deleted} write('.'); {show user something is happening} ADJACENT.P0:=FILE_LEN.PERSON_AVAIL; {link node to available list} PERSONS^:=ADJACENT; {load file buffer} put(PERSONS); {write buffer to disk} FILE_LEN.PERSON_AVAIL:=B; {reset pointer to head of linked list} FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1; {correct number of empty or unused nodes} NEW_HEIGHT:=PARENT.NODESIZE0 then begin {move K items from node ADJACENT_NODE to TOO_SMALL} for I:=MIN_NODE_SIZE-1 downto 1 do {"Krunch" TOO_SMALL} TOO_SMALL.DATA[I+K]:=TOO_SMALL.DATA[I]; TOO_SMALL.DATA[K]:=PARENT.DATA[S]; {add "new" person to replace deleted person} TOO_SMALL.DATA[K].SUCC_NODE:=TOO_SMALL.P0; {set correct successor node to correct record number} ADJ_SIZE:=ADJ_SIZE-K; {adjust for persons transferred to TOO_SMALL} for I:=K-1 downto 1 do {transfer to K persons TOO_SMALL} TOO_SMALL.DATA[I]:=ADJACENT_NODE.DATA[I+ADJ_SIZE]; TOO_SMALL.P0:=ADJACENT_NODE.DATA[ADJ_SIZE].SUCC_NODE; {set correct lessor successor node to correct record number} PARENT.DATA[S]:=ADJACENT_NODE.DATA[ADJ_SIZE]; {transfer replacement person to PARENT} PARENT.DATA[S].SUCC_NODE:=A; {set correct successor node to correct record number} ADJACENT_NODE.NODESIZE:=ADJ_SIZE-1; {adjust for persons transferred to TOO_SMALL} TOO_SMALL.NODESIZE:=MIN_NODE_SIZE-1+K; {adjust for persons transferred to TOO_SMALL} NEW_HEIGHT:=false; {b-tree is not shrinking vertically} seek(PERSONS,A); {set file window to underflow node} write('.'); {show user something is happening} PERSONS^:=TOO_SMALL; {assign to a "disk variable"} put(PERSONS) {write revised underflow node to disk} end {if K>0} else begin {merge nodes TOO_SMALL and ADJACENT_NODE} ADJACENT_NODE.DATA[ADJ_SIZE]:=PARENT.DATA[S]; {transfer replacement person to adjacent node} ADJACENT_NODE.DATA[ADJ_SIZE].SUCC_NODE:=TOO_SMALL.P0; {set correct successor node to correct record number} for I:=1 to MIN_NODE_SIZE-1 do {transfer persons to ADJACENT_NODE} ADJACENT_NODE.DATA[I+ADJ_SIZE]:=TOO_SMALL.DATA[I]; ADJACENT_NODE.NODESIZE:=MAX_NODE_SIZE; {adjust for persons transferred from TOO_SMALL} PARENT.NODESIZE:=PARENT_SIZE-1; {dispose(TOO_SMALL)} seek(PERSONS,A); {set file window to node begin deleted} write('.'); {show user something is happening} TOO_SMALL.P0:=FILE_LEN.PERSON_AVAIL; {link to list of available nodes} PERSONS^:=TOO_SMALL; {load file buffer} put(PERSONS); {write buffer to disk} FILE_LEN.PERSON_AVAIL:=A; {reset pointer to new head of linked list} FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1; {correct number of empty or unused nodes} NEW_HEIGHT:=PARENT.NODESIZE-1 then begin {P is not a terminal node} DEL(Q); {continue looking for terminal node} seek(PERSONS,P); {reset the file window to P node} write('.'); {show user something is happening} get(PERSONS); {load file buffer} if NEW_HEIGHT then begin UNDERFLOW(P,Q,PERSONS^.NODESIZE); {correct the underflow} seek(PERSONS,P); {reset the file window to P node} write('.'); {show user something is happening} get(PERSONS) {load the file buffer} end {if NEW_HEIGHT} end {if Q<>-1} else begin Z:=PERSONS^; {hold while seeking} seek(PERSONS,A); {set the file window to A node} write('.'); {show user something is happening} get(PERSONS); {load the file buffer} W:=PERSONS^; {hold while seeking} Z.DATA[Z.NODESIZE].SUCC_NODE:=W.DATA[K].SUCC_NODE; {set correct successor node to correct record number} W.DATA[K]:=Z.DATA[Z.NODESIZE]; {transfer person} Z.NODESIZE:=Z.NODESIZE-1; {adjust for deletion} if DUPLICATE then NEW_HEIGHT:=Z.NODESIZE<1 {not required?} {if Z.NODESIZE<1 then b-tree is shrinking horizontally} else NEW_HEIGHT:=Z.NODESIZE0 then begin {we must krunch node} for I:=J to NODESIZE do DATA[I]:=DATA[I+1]; {krunch node} if P0>-1 then begin {there are additional duplicate nodes} W:=PERSONS^; {hold while seeking} seek(PERSONS,P0); {set file window to next duplicate node} write('.'); {show user something is happening} get(PERSONS); {load file buffer} M:=1; {initialize to slot to transfer from} I:=W.NODESIZE+1; {initialize to slot to transfer into} repeat W.DATA[I]:=DATA[M]; {transfer} I:=I+1; {increment} M:=M+1; {increment} until (I>MAX_NODE_SIZE) or (M>NODESIZE); {I should >MAX_NODE_SIZE at the same time as M>NODESIZE. This allows for successful krunching of two records which some how require the transfer of more than one data slot} W.NODESIZE:=I-1; {set to correct value} Y:=PERSONS^; {hold while seeking} seek(PERSONS,B); {reset file window to location of "W" node} write('.'); {show user something is happening} I:=W.P0; {save location of "Y" node} if Y.NODESIZE=1 then begin {"Y" node must be deleted} W.P0:=-1; {set flag to indicate no more duplicate nodes} DUPLICATE:=false {reset flag/control variable} end; {if Y.NODESIZE} PERSONS^:=W; {load file buffer} put(PERSONS); {write buffer to disk} PERSONS^:=Y; {load file buffer} KRUNCH(I,M-1); {continue KRUNCH process} NEW_HEIGHT:=false {prevent action upon return to DELETE} end {if P0>-1} else begin {there are no additional duplicate nodes} W:=PERSONS^; {hold whild seeking} seek(PERSONS,B); {reset file window to "W" node} write('.'); {show user something is happening} PERSONS^:=W; {load file buffer} put(PERSONS); {write buffer to disk} end {else begin} end {if NODESIZE>0} else begin {delete node number B} LEAVE:=true; NEW_HEIGHT:=true; {set flag for action in DELETE} Y:=PERSONS^; {save buffer while seeking} Y.P0:=FILE_LEN.PERSON_AVAIL; {link node number B into available node list} FILE_LEN.PERSON_AVAIL:=B; {reset pointer to new head node} FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1; {correct total of empty or unused nodes} seek(PERSONS,B); {reset file window to node number B} write('.'); {show user something is happening} PERSONS^:=Y; {load file buffer} put(PERSONS); {write file buffer to disk} end {else begin} end {with PERSONS^} end; {KRUNCH} begin {DELETE} {We search for key INPUTKEY in the record number "A"...NEW_HEIGHT=false} if A=-1 then begin {person is not in b-tree} NEW_HEIGHT:=false; {nothing to delete so b-tree can not shrink} CLEARSCREEN; gotoxy(0,8); writeln(OUTFILE,'Person <',FAKE_KEY,'> not found.'); writeln; write('Is the key correct? (y/n) '); if not YES then WRONG:=true; {set flag to get new key} LEAVE:=true {set flag to exit delete} end {if A=-1} else begin seek(PERSONS,A); {set the file window to the record to search} write('.'); {show user something is happening} get(PERSONS); {load the file buffer} with PERSONS^ do begin if DUPLICATE then begin {search duplicate node for match} for J:=1 to NODESIZE do if PERSON_FOUND(DATA[J],J) then begin KRUNCH(A,J); {delete person} if LEAVE then exit(DELETE); {exit to prevent last four lines of DELETE from executing} end; {if PERSON_FOUND}; DELETE(INPUTKEY,P0,FOUND,WRONG); {continue searching duplicate nodes} if LEAVE then exit(DELETE) {prevent the last four lines from executing} end {if DUPLICATE} else begin L:=1; {set left pointer for binary search} R:=NODESIZE; {set right pointer for binary search} repeat {binary array search} K:=(L+R) div 2; {compute mid point} if INPUTKEY<=DATA[K].KEY then R:=K-1; {set right limit} if INPUTKEY>=DATA[K].KEY then L:=K+1; {set left limit} until L>R; {next 2 lines determine which node to search next to find either INPUTKEY or the successor terminal node to the node where INPUTKEY was found} if R=0 then Q:=P0 else Q:=DATA[R].SUCC_NODE; if L-R>1 then begin {we found a candidate for deletion} if PERSON_FOUND(DATA[K],K) then begin {delete it!!} if DATA[K].DUPE=-1 then begin {there are no duplicate keys} if Q=-1 then begin {A is a terminal node} NODESIZE:=NODESIZE-1; {correct nodesize} NEW_HEIGHT:=NODESIZE1 then Z.DATA[K].DUPE:=M {more duplicates exist so set pointer to correct value} else Z.DATA[K].DUPE:=-1; {no other duplicates exist so set pointer to nul or nil} KRUNCH(M,1); {KRUNCH the duplicate node} seek(PERSONS,A); {reset file window to node number "A"} write('.'); {show user something is happening} PERSONS^:=Z; {load file buffer} put(PERSONS); {write file buffer to disk} if LEAVE then exit(DELETE); {prevent last four lines from executing} end {else begin} end {if PERSON_FOUND} else begin {not found} if DATA[K].DUPE>-1 then begin {duplicate keys exist} DUPLICATE:=true; {set flag to initiate search for duplicate keys} DELETE(INPUTKEY,DATA[K].DUPE,FOUND,WRONG); {search for duplicate keys} if NEW_HEIGHT then begin {set node "A" duplicate link to nil} seek(PERSONS,A); {reset file window to node "A"} write('.'); {show user something is happening} get(PERSONS); {load file buffer} DATA[K].DUPE:=-1; {set duplicate link to nul or nil} Z:=PERSONS^; {hold while seeking} seek(PERSONS,A); {reset file window to node "A"} write('.'); {show user something is happening} put(PERSONS); {write file buffer to disk} NEW_HEIGHT:=false {reset flag} end; {if NEW_HEIGHT} if LEAVE then exit(DELETE) {************************************************************************ * * * If LEAVE=true then either the deletion was successful and the exit * * is to prevent the last four lines of this procedure from executing, * * or the user decided not to delete the record, or the key the user * * inputed was incorrect. * * * ************************************************************************} end {if DATA[K].DUPE>-1} end {else begin} end {if L-R>1} else begin {haven't found INPUTKEY so must keep searching} DELETE(INPUTKEY,Q,FOUND,WRONG); if LEAVE then exit(DELETE); seek(PERSONS,A); {reset the file window to the A node} write('.'); {show user something is happening} get(PERSONS); {load the file buffer} if NEW_HEIGHT then begin {underflow condition exists} UNDERFLOW(A,Q,R); {correct it} seek(PERSONS,A); {reset the file window to the A node} write('.'); {show user something is happening} get(PERSONS) {load the file buffer} end {if NEW_HEIGHT} end {else begin} end {else begin} end; {with PERSONS^ do} TEMP:=PERSONS^; {hold while seeking} seek(PERSONS,A); {reset the file window to the A node} write('.'); {show user something is happening} PERSONS^:=TEMP; {assign to a "disk variable"} put(PERSONS) {write revised A node to the disk} end {else begin} end; {DELETE} ======================================================================================== DOCUMENT :usus Folder:VOL10:btree.doit.text ======================================================================================== {************************************************************************ * * * filed as BTREE.DOIT.TEXT revised 31-May-82 * * * ************************************************************************} procedure KEY_INSERT; {************************************************************************ * * * This procedure controls the retrival or correction of existing * * records and/or the addition of new records. * * * ************************************************************************} label 1; var INPUTKEY:string; {search key} FOUND,WRONG:boolean; {insertion control variables} U:PERSON; {for adding new root} I,J,Q:integer; {loop control variables} OLDPERS,NEWPERS:PERSON_NODE; {OLDPERS for deleteing old root due to changed key} {NEWPERS for adding new root due to insertion} begin REAL_KEY:=' '; {initialize} reset(PERSONS,PERSON_FILE); {open data file} 1:SPLIT:=false; {initialize} (*writeln(OUTFILE,'ROOT = ',FILE_LEN.PERSON_ROOT); writeln(OUTFILE,'AVAIL = ',FILE_LEN.PERSON_AVAIL);*) CHANGED:=false; {initialize} DUPLICATE:=false; {initialize} WRONG:=false; {initialize} FOUND:=false; {initialize} LEAVE:=false; {initialize} repeat write('Enter KEY to find/insert: '); readln(INPUTKEY); {get search key} until GOOD_STRING(INPUTKEY); {prevent meaningless keys} J:=length(INPUTKEY); if J>10 then J:=10; REAL_KEY:=copy(INPUTKEY,1,J); UPPERCASE(REAL_KEY); {convert to uppercase} FAKE_KEY:=REAL_KEY; {save INPUTKEY for display purposes} INVERT_KEY(REAL_KEY,1); {convert to correct format} (*writeln(OUTFILE,'SEARCH KEY ',INPUTKEY); {display user key} writeln(OUTFILE,'REAL SEARCH KEY ',REAL_KEY); {display real key}*) write('Searching for <',FAKE_KEY,'>'); SEARCH(REAL_KEY,FILE_LEN.PERSON_ROOT,U,FOUND,WRONG); {find/insert search key} if WRONG then begin {inputed key incorrect or key changed in SEARCH} if FOUND then begin {key changed in SEARCH} SPLIT:=false; {re-initialize} DUPLICATE:=false; {re-initialize} LEAVE:=false; {re-initialize} WRONG:=false; {re-initialize} U.SUCC_NODE:=-1; {initialize} U.DUPE:=-1; {initialize} (*writeln('Person "U" equals...'); writeln; writeln; PRINT_PERSON(U); writeln; writeln; writeln('U.KEY = "',U.KEY,'"'); writeln(OUTFILE,'ROOT = ',FILE_LEN.PERSON_ROOT); write(OUTFILE,'AVAIL = ',FILE_LEN.PERSON_AVAIL); readln; *) writeln; writeln; write('Inserting record into new location'); SEARCH(U.KEY,FILE_LEN.PERSON_ROOT,U,FOUND,WRONG); if NEW_HEIGHT then begin {insert new base node} Q:=FILE_LEN.PERSON_ROOT; {pointer to old root node} with NEWPERS do begin {initialize new root node} NODESIZE:=1; {any new root node only has one person} P0:=Q; {initialize lessor successor pointer} DATA[1]:=U; {add person to new root node} end; {with NEWPERS} seek(PERSONS,FILE_LEN.PERSON_AVAIL); {set file window to next "empty" node locaton} write('.'); {show user something is happening} get(PERSONS); {load file buffer} J:=PERSONS^.P0; {save location of next node in linked list} seek(PERSONS,FILE_LEN.PERSON_AVAIL); {set file window to first available empty node} write('.'); {show user something is happening} PERSONS^:=NEWPERS; {assign to a "disk variable"} put(PERSONS); {write new root node to disk} FILE_LEN.PERSON_ROOT:=FILE_LEN.PERSON_AVAIL; {update root node pointer} FILE_LEN.PERSON_AVAIL:=J; {reset pointer to new head node of linked list} FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED-1; {correct number of empty or unused nodes} end; {if NEW_HEIGHT} if CHANGED then begin SPLIT:=false; {re-initialize} DUPLICATE:=false; {re-initialize} LEAVE:=false; {re-initialize} WRONG:=false; {re-initialize} writeln; writeln; write('Deleting record from previous location'); FOUND:=true; DELETE(PERSONPTR.KEY,FILE_LEN.PERSON_ROOT,FOUND,WRONG); if NEW_HEIGHT then begin {root node size was reduced} seek(PERSONS,FILE_LEN.PERSON_ROOT); {set file window to root node} write('.'); {show user something is happening} get(PERSONS); {load file buffer} J:=FILE_LEN.PERSON_ROOT; {save location of root node} if PERSONS^.NODESIZE=0 then begin {must reset root pointer} FILE_LEN.PERSON_ROOT:=PERSONS^.P0; {if PERSONS^.NODESIZE=0 then the root node is empty so reset the root to the old root lessor successor} PERSONS^.P0:=FILE_LEN.PERSON_AVAIL; {link old root node to the linked list of available nodes} FILE_LEN.PERSON_AVAIL:=J; {reset pointer to linked list of available nodes} FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1; {correct number of empty or unused nodes} end; {if PERSONS^.NODESIZE=0} OLDPERS:=PERSONS^; {hold while seeking} seek(PERSONS,J); {set file window to old root node} write('.'); {show user something is happening} PERSONS^:=OLDPERS; {load file buffer} NEW_HEIGHT:=false; {prevent unwanted action} put(PERSONS) {write file buffer to disk} end {if NEW_HEIGHT} end {if CHANGED} end {if FOUND} else begin writeln; writeln; goto 1 end {else begin} end; {if WRONG} if NEW_HEIGHT then begin {insert new base node} Q:=FILE_LEN.PERSON_ROOT; {pointer to old root node} with NEWPERS do begin {initialize new root node} NODESIZE:=1; {any new root node only has one person} P0:=Q; {initialize lessor successor pointer} DATA[1]:=U; {add person to new root node} end; {with NEWPERS} seek(PERSONS,FILE_LEN.PERSON_AVAIL); {set file window to next "empty" node locaton} write('.'); {show user something is happening} get(PERSONS); {load file buffer} J:=PERSONS^.P0; {save location of next node in linked list} seek(PERSONS,FILE_LEN.PERSON_AVAIL); {set file window to first available empty node} write('.'); {show user something is happening} PERSONS^:=NEWPERS; {assign to a "disk variable"} put(PERSONS); {write new root node to disk} FILE_LEN.PERSON_ROOT:=FILE_LEN.PERSON_AVAIL; {update root node pointer} FILE_LEN.PERSON_AVAIL:=J; {reset pointer to new head node of linked list} FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED-1; {correct number of empty or unused nodes} end; {if NEW_HEIGHT} {************************************************************************ * * * The five lines which follow save the revised control data to the * * disk. This is done after each operation where an insertion or * * deletion might have taken place. The reason is is done here rather * * than upon program exit is to limit the damage which might be done * * if there is a power or other failure prior to exiting the program. * * * ************************************************************************} close(PERSONS,lock); {ensure entire file is in directory} seek(CONTROLFILE,0); {reset file window to node 0} write('.'); {show user something is happening} CONTROLFILE^:=FILE_LEN; {load CONTROLFILE buffer} put(CONTROLFILE); {write CONTROLFILE buffer to disk} writeln; writeln; write('Print out or traverse B-tree? (y/n) '); if YES then PRINT_IT end; {KEY_INSERT} procedure KEY_DELETE; {************************************************************************ * * * This procedure controls the deletion of existing records. * * * ************************************************************************} label 1; var INPUTKEY:string; {search key} U:PERSON; {not required?} FOUND,WRONG:boolean; {insertion control variables} OLDPERS:PERSON_NODE; I,J,Q:integer; {loop control variables} begin REAL_KEY:=' '; {initialize} reset(PERSONS,PERSON_FILE); {open data file} 1:SPLIT:=false; {initialize} (*writeln(OUTFILE,'ROOT = ',FILE_LEN.PERSON_ROOT); writeln(OUTFILE,'AVAIL = ',FILE_LEN.PERSON_AVAIL);*) CHANGED:=false; {initialize} DUPLICATE:=false; {initialize} WRONG:=false; {initialize} FOUND:=false; {initialize} LEAVE:=false; {initialize} repeat write('Enter KEY to delete: '); readln(INPUTKEY); {get search key} until GOOD_STRING(INPUTKEY); {prevent meaningless keys} J:=length(INPUTKEY); if J>10 then J:=10; REAL_KEY:=copy(INPUTKEY,1,J); UPPERCASE(INPUTKEY); {convert to uppercase} FAKE_KEY:=INPUTKEY; {save INPUTKEY for display purposes} REAL_KEY:=INPUTKEY; {initialize} INVERT_KEY(REAL_KEY,1); {convert key to correct format} (*writeln(OUTFILE,'DELETE KEY ',INPUTKEY); {display user key} writeln(OUTFILE,'REAL DELETE KEY ',REAL_KEY); {display real key}*) write('Deleteing record <',FAKE_KEY,'>'); DELETE(REAL_KEY,FILE_LEN.PERSON_ROOT,FOUND,WRONG); {delete search key} if WRONG then goto 1; if NEW_HEIGHT then begin {root node size was reduced} seek(PERSONS,FILE_LEN.PERSON_ROOT); {set file window to root node} write('.'); {show user something is happening} get(PERSONS); {load file buffer} J:=FILE_LEN.PERSON_ROOT; {save location of root node} if PERSONS^.NODESIZE=0 then begin {must reset root pointer} FILE_LEN.PERSON_ROOT:=PERSONS^.P0; {if PERSONS^.NODESIZE=0 then the root node is empty so reset the root to the old root lessor successor} PERSONS^.P0:=FILE_LEN.PERSON_AVAIL; {link old root node to the linked list of available nodes} FILE_LEN.PERSON_AVAIL:=J; {reset pointer to linked list of available nodes} FILE_LEN.PERSON_UNUSED:=FILE_LEN.PERSON_UNUSED+1; {correct number of empty or unused nodes} end; {if PERSONS^.NODESIZE=0} OLDPERS:=PERSONS^; {hold while seeking} seek(PERSONS,J); {set file window to old root node} write('.'); {show user something is happening} PERSONS^:=OLDPERS; {load file buffer} put(PERSONS) {write file buffer to disk} end; {if NEW_HEIGHT} close(PERSONS,lock); {make sure entire file is in directory} {************************************************************************ * * * The five lines which follow save the revised control data to the * * disk. This is done after each operation where an insertion or * * deletion might have taken place. The reason is is done here rather * * than upon program exit is to limit the damage which might be done * * if there is a power or other failure prior to exiting the program. * * * ************************************************************************} close(PERSONS,lock); {ensure entire file is in directory} seek(CONTROLFILE,0); {reset file window to node 0} write('.'); {show user something is happening} CONTROLFILE^:=FILE_LEN; {load CONTROLFILE buffer} put(CONTROLFILE); {write CONTROLFILE buffer to disk} writeln; writeln; write('Print out or traverse B-tree? (y/n) '); if YES then PRINT_IT end; {KEY_DELETE} procedure DATA_FULL; begin CLEARSCREEN; gotoxy(0,11); writeln('There is no more space to insert data!!!!!'); gotoxy(16,23); write('hit SPACEBAR to continue <--'); CH:=READKEY([' ']) end; {DATA_FULL} procedure TITLE; var S:string; I,J:integer; begin S:='ADDRESS BOOK'; PRINTAT(37-length(S) div 2,2,S); S:='written by'; PRINTAT(37-length(S) div 2,3,S); S:='R. M. Wilson'; PRINTAT(37-length(S) div 2,4,S); S:='Copyright by'; PRINTAT(37-length(S) div 2,13,S); S:='HI-COUNTRY DATA SYSTEMS'; PRINTAT(37-length(S) div 2,15,S); S:='P.O. Box 4258'; PRINTAT(37-length(S) div 2,16,S); S:='Woodland Park, CO 80863-4258'; PRINTAT(37-length(S) div 2,17,S); S:='November 27, 1981'; PRINTAT(37-length(S) div 2,18,S); S:='Hit "SPACEBAR" to continue <--'; PRINTAT(37-length(S) div 2,23,S); CH:=READKEY([' ']); CLEARSCREEN end; {TITLE} ======================================================================================== DOCUMENT :usus Folder:VOL10:btree.get.text ======================================================================================== {************************************************************************ * * * filed as BTREE.GET.TEXT revised 27 November 1981 * * * ************************************************************************} {L *GET.TEXT} procedure UPPERCASE(var KEY:FNAME); {maps key to all uppercase} {************************************************************************ * * * This procedure makes sure regardless of what the user types in the * * search for the key will be done for upper case "keys" only. * * * ************************************************************************} begin for I:=1 to length(KEY) do if (ord(KEY[I])>=97) and (ord(KEY[I])<=122) then {chr(97)=a & chr(122)=z} KEY[I]:=chr(ord(KEY[I])-32) end; {UPPERCASE} procedure PRINT_PERSON(U:PERSON); {************************************************************************ * * * This procedure displays the record being entered or retrieved and * * asks if the data is correct. If it is then nothing out of the * * ordinary happens, however if a correction is made then the revised * * record is written to the disk. * * * ************************************************************************} begin CLEARSCREEN; with U do begin (*writeln('KEY -->',KEY,'<--'); {KEY is the actual key}*) writeln; writeln('1--> First name: ',FIRST); writeln('2--> Last name: ',LAST); {************************************************************************ * * * In order to make this a usable program for names and addresses, * * must remove the (**) from around the lines below. * * * ************************************************************************} (*writeln('3--> Street address: ',STREET); writeln('4--> City: ',CITY); writeln('5--> State: ',STATE); writeln('6--> ZIP code: ',ZIPCODE); writeln('7--> Telephone number: ',PHONE); *) writeln; end {with CUSTMERS^.DATA[K]} end; {PRINTRECORD} function GOOD_STRING(S:string):boolean; begin if S<>'' then begin {S is not null string} if (S[1]<'!') or (S[1]>'~') then begin {S[1] not human readable} writeln; writeln('error in entry...please re-enter '); writeln; GOOD_STRING:=false end {if S[1]=' '} else GOOD_STRING:=true end {if S<>''} else begin {S is null string} writeln; writeln('error in entry...please re-enter '); writeln; GOOD_STRING:=false end {else begin} end; {GOOD_STRING} procedure INVERT_KEY(var V:FNAME;K:integer); {************************************************************************ * * * This procedure takes the user inputed key and converts it to the * * actual key. This conversion is made to simplify displaying * * "sounds like" records if the desired record is not found. * * * ************************************************************************} var TEMP_KEY:FNAME; {temporary key used while converting} begin TEMP_KEY:=' '; J:=length(V); if J>10 then J:=10; case K of 1:begin {convert original user input} TEMP_KEY[J]:=V[1]; for I:=1 to J-1 do TEMP_KEY[I]:=V[I+1]; end; 2:begin {convert computed key to compare with user input} J:=1; while (J<=9) and (V[J]=' ') do begin V[1]:=V[J+1]; J:=J+1; end; {while} for I:=2 to 11-J do V[I]:=V[I+J-1]; J:=1; while (J<=9) and (V[J]<>' ') do J:=J+1; if J=9 then if V[10]<>' ' then J:=10; for I:=2 to J do TEMP_KEY[I]:=V[I-1]; TEMP_KEY[1]:=V[J] end end; {case K} V:=TEMP_KEY; end; {INVERT_KEY} procedure COMPUTE_KEY(var V:PERSON); {************************************************************************ * * * This procedure computes the actual key from the FIRST and LAST * * names which the user inputs. It also computes a "FAKE_KEY" * * which it displays to the user. * * * * NOTE: * * ---- * * * * The real key/fake key concept was developed because it is * * more natural for a user to type in the first initial and * * last name rather than the last name and first initial, but * * it is easier to write code to find "sounds like" or * * similar spellings if the key is last name and first initial. * * * * first name = BOB last name = WILSON * * * * user/fake key = BWILSON actual key = WILSONB * * * ************************************************************************} var FAKE_KEY:FNAME; {for user edification only} begin with V do begin KEY:=' '; {initialize} FAKE_KEY:=' '; {initialize} J:=length(LAST); if J>=10 then J:=9; {Since KEY:string[10] and one letter of the key must be the first initial, the maximum number of characters that can be mapped is 9.} for I:=1 to J do begin KEY[I]:=LAST[I]; {real key has last name before FIRST[1]} FAKE_KEY[I+1]:=LAST[I] {fake key has last name after FIRST[1]} end; {for I} FAKE_KEY[1]:=FIRST[1]; KEY[J+1]:=FIRST[1]; UPPERCASE(FAKE_KEY); {make all keys upper case because abc<>ABC} UPPERCASE(KEY); {make all keys upper case because abc<>ABC} (*writeln('REAL KEY -->',KEY,'<--'); {display results} writeln('USER KEY -->',FAKE_KEY,'<--'); {display results} *) end {with V} end; {COMPUTE_KEY} procedure GET_FIRST(var FIRST:FNAME); var INPUTKEY:string; J:integer; begin repeat write('Enter first name: '); readln(INPUTKEY); until GOOD_STRING(INPUTKEY); {prevent meaningless keys} J:=length(INPUTKEY); if J>10 then J:=10; FIRST:=copy(INPUTKEY,1,J); end; {GET_FIRST} procedure GET_LAST(var LAST:LNAME); var INPUTKEY:string; J:integer; begin repeat write('Enter last name: '); readln(INPUTKEY) until GOOD_STRING(INPUTKEY); {prevent meaningless keys} J:=length(INPUTKEY); if J>20 then J:=20; LAST:=copy(INPUTKEY,1,J); end; {GET_LAST} procedure PERSON_CHANGE(var U:PERSON); {************************************************************************ * * * This procedure allows user to change new data records before they * * are written to the disk, and change old data records as required. * * * ************************************************************************} var FIELD_NUM:integer; {which field to change} begin with U do begin repeat {until the data is correct} repeat {until (FIELD_NUM>0) and (FIELD_NUM<=7)} writeln; writeln; write('Enter field number in error: '); readln(FIELD_NUM) {************************************************************************ * * * A simple "read(FIELD_NUM)" causes strange and not so wonderful * * things to happen. For some reason the system uses a "read" here * * correctly, but the next read statement executed by the program * * executes without any user input and uses the same data entered here * * where "read(keyboard,CH)" is used. * * * ************************************************************************} until (FIELD_NUM>0) and (FIELD_NUM<=7); {this is "bomb proofing"...must be changed if the number of fields are changed} writeln; case FIELD_NUM of 1:begin GET_FIRST(FIRST); COMPUTE_KEY(U) {we might have changed the key} end; 2:begin GET_LAST(LAST); COMPUTE_KEY(U) {we might have changed the key} end; {************************************************************************ * * * In order to make this a usable program for names and addresses, * * must remove the (**) from around the lines below. * * * ************************************************************************} (*3:begin repeat write('Enter street address: '); readln(STREET) until GOOD_STRING(STREET); {prevent meaningless data} end; 4:begin repeat write('Enter city: '); readln(CITY) until GOOD_STRING(CITY); {prevent meaningless data} end; 5:begin repeat write('Enter state: '); readln(STATE) until GOOD_STRING(STATE); {prevent meaningless data} end; 6:begin repeat write('Enter zip: '); readln(ZIPCODE) until GOOD_STRING(ZIPCODE); {prevent meaningless data} end; 7:begin repeat write('Enter telephone number: '); readln(PHONE) until GOOD_STRING(PHONE); {prevent meaningless data} end;*) end; {case FIELD_NUM} PRINT_PERSON(U); {print modified/corrected record} writeln; writeln; write('Is the customer data correct?'); until YES end {with U} end; {PERSON_CHANGE} procedure GET_NEW_PERSON(var V:PERSON); {************************************************************************ * * * This procedure initializes and gets a new record. It then calls * * other procedures to display and verify the data. * * * ************************************************************************} var INPUTKEY:string; begin CLEARSCREEN; {clear CRT} with V do begin SUCCNODE:=-1; {there are no successor nodes (yet!)} DUPE:=-1; {there are no duplicate keys (yet!)} KEY:=' '; {initialize} writeln; GET_FIRST(FIRST); GET_LAST(LAST); COMPUTE_KEY(V); {compute real key based on FIRST and LAST} {************************************************************************ * * * In order to make this a usable program for names and addresses, * * must remove the (**) from around the lines below. * * * ************************************************************************} (*repeat write('Enter street address: '); readln(STREET); until GOOD_STRING(STREET); {prevent meaningless data} repeat write('Enter city: '); readln(CITY); until GOOD_STRING(CITY); {prevent meaningless data} repeat write('Enter state: '); readln(STATE); until GOOD_STRING(STATE); {prevent meaningless data} repeat write('Enter ZIP code: '); readln(ZIPCODE); until GOOD_STRING(ZIPCODE); {prevent meaningless data} repeat write('Enter telephone number: '); readln(PHONE); until GOOD_STRING(PHONE); {prevent meaningless data} *) end; {with V} PRINT_PERSON(V); {display data entered} writeln; writeln; write('Is the above correct? '); {verify data} if not YES then PERSON_CHANGE(V) {change it if not correct} end; {GET_NEW_PERSON} {L-} ======================================================================================== DOCUMENT :usus Folder:VOL10:btree.init.text ======================================================================================== {************************************************************************ * * * filed as BTREE.INIT.TEXT revised 27 November 1981 * * * ************************************************************************} procedure INIT; {************************************************************************ * * * This procedure checks the disk in the "prefix" drive and reads the * * data files if they exist. If they don't it initializes and creates * * new data files. * * * ************************************************************************} var GOOD_FILE:boolean; begin CLEARSCREEN; {clear screen} gotoxy(0,11); {position cursor} write('Initializing data files'); {$I-} { prohibit I/O runtime error if file is not on disk } reset(CONTROLFILE,CONTROL); {open old control data file} if ioresult=0 then GOOD_FILE:=true {file exists} else GOOD_FILE:=false; {no file on disk} write('.'); {let user know somthing is happening} close(CONTROLFILE); write('.'); {let user know somthing is happening} {$I+} { enable I/O runtime errors } if not GOOD_FILE then begin N:=0; {initialize} repeat N:=N+1 until exp(N*ln(MAX_NODE_SIZE))>MAX_PERS_NODES; rewrite(CONTROLFILE,CONTROL); {open new control data file} write('.'); {let user know somthing is happening} with CONTROLFILE^ do begin {initialize control data file} PERSON_AVAIL:=0; {no person nodes in newly created files} PERSON_ROOT:=-1; {indicates no record in PERSONS} PERSON_UNUSED:=MAX_PERS_NODES; {how many nodes are unused} PERSON_MIN:=N {minimum empty nodes for insertion} end; {with CONTROLFILE^} put(CONTROLFILE); {write initialized control data file to disk} write('.'); {let user know somthing is happening} close(CONTROLFILE,lock); {write control data file name in directory} write('.'); {let user know somthing is happening} end; {if not GOOD_FILE begin} {$I-} { prohibit I/O runtime error if file is not on disk } reset(PERSONS,PERSON_FILE); {open old person data file} if ioresult=0 then GOOD_FILE:=true {file exists} else GOOD_FILE:=false; {no file on disk} write('.'); {let user know somthing is happening} close(PERSONS); write('.'); {let user know somthing is happening} {$I+} { enable I/O runtime errors } if not GOOD_FILE then begin rewrite(PERSONS,PERSON_FILE); {open new person data file} write('.'); {let user know somthing is happening} with PERSONS^ do begin {initialize first PERSON_NODE} NODESIZE:=0; {no person entered yet} P0:=-1; {indicates there is no "lessor" successor node} for I:=1 to MAXNODESIZE do begin {initialize each node slot} with DATA[I] do begin {initialize each node slot} SUCCNODE:=-1; {indicates there is no "lessor" successor node} DUPE:=-1; {indicates there is no duplicate key} KEY:=''; {not really required...done for "double protection"} FIRST:=''; {not really required...done for "double protection"} LAST:=''; {not really required...done for "double protection"} STREET:=''; {not really required...done for "double protection"} CITY:=''; {not really required...done for "double protection"} ZIPCODE:=''; {not really required...done for "double protection"} STATE:=''; {not really required...done for "double protection"} PHONE:=''; {not really required...done for "double protection"} end; {with DATA[I]} end; {for I} for J:=1 to MAX_PERS_NODES-1 do begin P0:=J; {points to next available empty node} put(PERSONS); write('.'); {let user know somthing is happening} end; {for J} P0:=-1; {flag to indicate no more nodes available} end; {with PERSONS^} put(PERSONS); {write final initialized PERSON_NODE to disk} write('.') {let user know somthing is happening} end; {if not GOOD_FILE begin} close(PERSONS,lock); {write PERSFILE name in directory} CLEARSCREEN {clear screen} end; {INIT} {l-} ======================================================================================== DOCUMENT :usus Folder:VOL10:btree.prnt.text ======================================================================================== {************************************************************************ * * * filed as BTREE.PRNT.TEXT revised 31-May-82 * * * ************************************************************************} {************************************************************************ * * * The three procedures which follow print the B-tree as a B-tree and * * traverse the tree both inorder and postorder. For a useful program, * * these procedures must be deleted and new data output procedures * * written. Since personal taste and intended use play such signif- * * cant role in determining what is a suitable format, no attempt has * * been made to suggest alternatives. * * * ************************************************************************} procedure PRINTTREE(N,BTREE_LEVEL:integer); var I:integer; {loop control variable} PERSONS:PERSFILE; begin if not(N<0) then begin {if N<0 then node is "null" node} write(OUTFILE,N:4); reset(PERSONS,PERSON_FILE); {open the data file for display} seek(PERSONS,N); {set file window to node N} get(PERSONS); {load file buffer} for I:=1 to BTREE_LEVEL do write(OUTFILE,' '); {provides horizontal indication of different levels} for I:=1 to PERSONS^.NODESIZE do write(OUTFILE,PERSONS^.DATA[I].KEY:12); {print out persons in node} writeln(OUTFILE); PRINTTREE(PERSONS^.P0,BTREE_LEVEL+1); {print out lessor successor node} for I:=1 to PERSONS^.NODESIZE do {print out other successor nodes} PRINTTREE(PERSONS^.DATA[I].SUCC_NODE,BTREE_LEVEL+1); end; {if not(N<0)} close(PERSONS) {close the file} end; {PRINTTREE} procedure INORDER(NODENUM:integer); {************************************************************************ * * * This procedure traverses a btree in order and prints out the data * * in the correct order. For this program, it will print out the data * * in alphabetical order of the keys. Duplicate keys will be printed * * in whatever order they are in linked list. It should be noted that * * for ASCII characters alphebetical order implies that "0" comes * * before "9" which comes before "a" which, in turn, comes before "A". * * * ************************************************************************} var SLOT:integer; {which data element being visited} begin if NODENUM>0 then exit(INORDER); {no such record exists... prevents useless search when FILE_LEN.PERSON_ROOT=-1} SLOT:=0; {initialize slot} seek(PERSONS,NODENUM); {set file window to node NODENUM} get(PERSONS); {load file buffer} {if PERSONS^.NODESIZE<1 then exit(INORDER);} {node is empty} if DUPLICATE then begin {print out duplicate nodes} for SLOT:=1 to PERSONS^.NODESIZE do begin write(OUTFILE,NODENUM:4,' '); writeln(OUTFILE,PERSONS^.DATA[SLOT].KEY,' ',PERSONS^.DATA[SLOT].FIRST) end; {for SLOT} if PERSONS^.P0>=0 then INORDER(PERSONS^.P0); {more duplicate keys exists so print them out} DUPLICATE:=false; {reset flag/control variable} end {if DUPLICATE} else begin if PERSONS^.P0>=0 then begin {if P0>=0 then there is a key with a value less than DATA[1].KEY} INORDER(PERSONS^.P0); {see if there are more "lessor" keys} seek(PERSONS,NODENUM); {reset the file windown to node NODENUM} get(PERSONS) {load file buffer} end; {if PERSONS^.P0>=0} {************************************************************************ * * * The for..do loop which follows prints DATA[SLOT] of node number * * NODENUM, and checks to see if there are some data greater than the * * datum DATA[SLOT] in a successor node. If there are, the successor * * node is checked. Finally the file window is reset in order to * * repeat the entire process for each datum in the node NODENUM. * * * ************************************************************************} for SLOT:=1 to PERSONS^.NODESIZE do begin write(OUTFILE,NODENUM:4,' '); writeln(OUTFILE,PERSONS^.DATA[SLOT].KEY,' ',PERSONS^.DATA[SLOT].FIRST); {print data} if PERSONS^.DATA[SLOT].DUPE>=0 then begin {a duplicate key exists} DUPLICATE:=true; {set flag to print out duplicate keys} INORDER(PERSONS^.DATA[SLOT].DUPE); {print them out} seek(PERSONS,NODENUM); {reset file window to node "NODENUM"} get(PERSONS) {load file buffer} end; {if PERSONS^.DATA[SLOT].DUPE>=0} if PERSONS^.DATA[SLOT].SUCC_NODE>=0 then begin {keys with a value > DATA[SLOT].KEY exist in a successor node} INORDER(PERSONS^.DATA[SLOT].SUCC_NODE); {check successor node} seek(PERSONS,NODENUM); {reset file window to node NODENUM} get(PERSONS) {load file buffer} end {if PERSONS^.DATA[SLOT].SUCC_NODE>=0} end; {for SLOT} end {else begin} end; {INORDER} procedure POSTORDER(NODENUM:integer); {************************************************************************ * * * This procedure traverses a btree in postorder and prints out the * * data in inverse order. For this program, it will print out the data * * in reverse alphabetical order of the keys. Duplicate keys will be * * printed out in whatever order they are in in the linked list. It * * should be noted that for ASCII characters alphabetical order implies * * that "0" comes before "9" which comes before "a" which, in turn, * * comes before "A". * * * ************************************************************************} var SLOT:integer; {loop control variable} begin if NODENUM>0 then exit(POSTORDER); {no such record exists... prevents useless search when FILE_LEN.PERSON_ROOT=-1} SLOT:=0; {initialize SLOT} seek(PERSONS,NODENUM); {set file window to node NODENUM} get(PERSONS); {load file buffer} {if PERSONS^.NODESIZE<1 then exit(POSTORDER);} {node is empty} if DUPLICATE then begin {print out duplicate nodes} for SLOT:=1 to PERSONS^.NODESIZE do begin write(OUTFILE,NODENUM:4,' '); writeln(OUTFILE,PERSONS^.DATA[SLOT].KEY,' ',PERSONS^.DATA[SLOT].FIRST) end; {for SLOT} if PERSONS^.P0>=0 then INORDER(PERSONS^.P0); {more duplicate keys exists so print them out} DUPLICATE:=false; {reset flag/control variable} end {if DUPLICATE} else begin if PERSONS^.DATA[PERSONS^.NODESIZE].SUCC_NODE>=0 then begin {there are data greater than PERSONS^.DATA[PERSONS^.NODESIZE].KEY} POSTORDER(PERSONS^.DATA[PERSONS^.NODESIZE].SUCC_NODE); {check them} seek(PERSONS,NODENUM); {reset file window to node NODENUM} get(PERSONS) {load file buffer} end; {if PERSONS^.DATA[PERSONS^.NODESIZE].SUCC_NODE>=0} {************************************************************************ * * * The for..do loop which follows prints DATA[SLOT] of node number * * NODENUM, and checks to see if there are some data lessor than the * * datum DATA[SLOT] in a successor node. If there are, the successor * * node is checked. Finally the file window is reset in order to * * repeat the entire process for each datum in the node NODENUM. * * * ************************************************************************} for SLOT:=PERSONS^.NODESIZE downto 1 do begin write(OUTFILE,NODENUM:4,' '); writeln(OUTFILE,PERSONS^.DATA[SLOT].KEY,' ',PERSONS^.DATA[SLOT].FIRST); {print datum} if PERSONS^.DATA[SLOT].DUPE>=0 then begin {a duplicate key exists} DUPLICATE:=true; {set flag to print out duplicate keys} INORDER(PERSONS^.DATA[SLOT].DUPE); {print them out} seek(PERSONS,NODENUM); {reset file window to node "NODENUM"} get(PERSONS) {load file buffer} end; {if PERSONS^.DATA[SLOT].DUPE>=0} if SLOT>1 then begin {if SLOT=1 then runtime error results because DATA[SLOT-1] would be DATA[0] which doesn't exist} if PERSONS^.DATA[SLOT-1].SUCC_NODE>=0 then begin {there is lessor data} POSTORDER(PERSONS^.DATA[SLOT-1].SUCC_NODE); {check it} seek(PERSONS,NODENUM); {reset file window to node NODENUM} get(PERSONS) {load file buffer} end {if PERSONS^.DATA[SLOT-1].SUCC_NODE>=0} end {if SLOT>1} {************************************************************************ * * * The next line checks to see if there is any lessor data than * * the datum in DATA[1] in a successor node, and if so it checks that * * successor node. * * * ************************************************************************} else if PERSONS^.P0>=0 then POSTORDER(PERSONS^.P0); end {for SLOT} end {else begin} end; {POSTORDER} procedure PRINT_IT; {************************************************************************ * * * Print out the btree and inorder and postorder traversals. * * * ************************************************************************} begin CLEARSCREEN; gotoxy(0,4); write('Print out B-tree? (y/n) '); if YES then begin writeln(OUTFILE); writeln(OUTFILE); writeln(OUTFILE,'--> PERSON B-TREE'); writeln(OUTFILE); writeln(OUTFILE); writeln(OUTFILE,' Node'); writeln(OUTFILE); PRINTTREE(FILE_LEN.PERSON_ROOT,1); {print the b-tree} writeln(OUTFILE); writeln(OUTFILE); end; {if YES} writeln; writeln; write('Traverse b-tree inorder? (y/n) '); if YES then begin {do it} reset(PERSONS,PERSON_FILE); {open data file} writeln(OUTFILE); writeln(OUTFILE); writeln(OUTFILE,'--> INORDER TRAVERSAL'); writeln(OUTFILE); writeln(OUTFILE); writeln(OUTFILE,' Node'); writeln(OUTFILE); INORDER(FILE_LEN.PERSON_ROOT); {traverse tree} close(PERSONS,lock); {close the data file} end; {if CH in} writeln; writeln; write('Traverse b-tree in postorder? (y/n) '); if YES then begin {do it} reset(PERSONS,PERSON_FILE); {open data file} writeln(OUTFILE); writeln(OUTFILE); writeln(OUTFILE,'--> POSTORDER TRAVERSAL'); writeln(OUTFILE); writeln(OUTFILE); writeln(OUTFILE,' Node'); writeln(OUTFILE); POSTORDER(FILE_LEN.PERSON_ROOT); {traverse tree} close(PERSONS,lock); {close the data file} writeln(OUTFILE); writeln(OUTFILE); end {if CH in} end; {PRINT_IT} ======================================================================================== DOCUMENT :usus Folder:VOL10:btree.std.text ======================================================================================== {************************************************************************ * * * filed as BTREE.STD.TEXT revised 19 November 1981 * * * ************************************************************************} function READKEY(OKSET:SETOFCHAR):char; {************************************************************************ * * * This procedure looks at each keypress and determines if the key * * pressed is valid, i.e. the "set of char which are valid may be * * varied with each call of this procedure. If the key pressed is * * not in the valid or 'OKSET', then the bell sounds. If the key * * pressed is valid the computer accepts the input and the program * * continues to run. * * * ************************************************************************} var CH:char; GOOD:boolean; begin repeat read(keyboard,CH); if eoln(KEYBOARD) then CH:=chr(13); GOOD:=CH in OKSET; if not GOOD then write(chr(7)) until GOOD; READKEY:=CH end; {READKEY} function YES:boolean; begin YES:=READKEY(['Y','N','y','n']) in ['y','Y'] end; {YES} procedure PRINTAT(X,Y:integer;S:string); {************************************************************************ * * * This procedure writes a string at a designated location on the CRT * * * ************************************************************************} begin gotoxy(X,Y); write(S) end; {PRINTAT} procedure CLEARSCREEN; {************************************************************************ * * * This procedure is for the TeleVideo only. The TeleVideo and/or the * * MICROENGINE will not clear the screen with the standard * * "page(output)". * * Note: changed by gws to be compatable with H-19 * ************************************************************************} begin gotoxy ( 0, 0 ); write(chr(27),chr(69)); {H-19 specific} end; {CLEARSCREEN} ======================================================================================== DOCUMENT :usus Folder:VOL10:catalog.1.text ======================================================================================== (* included from catalog *) procedure SORT; {sorts the directory file in alphebetical order} var I:RECNUM; BUF:CATALOG_RECORD; {holds record during exchange} FLAG:boolean; {FALSE if an exchange made during pass} begin writeln('sorting ',DREC,' records '); repeat FLAG:=true; for I:=DREC downto 2 do if (DCAT[I].FILE_NAME0 then begin writeln('Unit not on line '); LEAVE:=true; exit(UPDATE); end;{if IORESULT<>0} VOL:=DIRX[0].DIR_VOL_NAME; SPS:=copy(BLANKS,1,7-length(VOL)); {put VOL in consistent format} VOL:=concat(VOL,SPS); for I:=1 to DIRX[0].NUM_OF_FILES do begin with DIRX[I] do begin if length(DIR_FILE_NAME)>0 then begin DREC:=DREC+1; with DCAT[DREC] do begin VOL_NAME:=VOL; FILE_NAME:=DIR_FILE_NAME; SPS:=copy(BLANKS,1,15-length(FILE_NAME)); FILE_NAME:=concat(FILE_NAME,SPS); FILE_KIND:=DIR_FILE_KIND; FILE_DATE:=DIR_FILE_DATE; FILE_SIZE:=LAST_BLOCK-FIRST_BLOCK; BLOCKS_USED:=BLOCKS_USED+FILE_SIZE; end {with DCAT[DREC]} end {IF length} end {with DIRX[I]} end;{for I} {next we create entry with name FREE.SPACE containing the unused space on the volume} DREC:=DREC+1; with DCAT[DREC] do begin VOL_NAME:=VOL; FILE_NAME:='FREE.SPACE'; SPS:=copy(BLANKS,1,15-length(FILE_NAME)); FILE_NAME:=concat(FILE_NAME,SPS); FILE_KIND:=INFO; FILE_DATE:=DIRX[0].LAST_BOOT; FILE_SIZE:=DIRX[0].TOTAL_BLOCKS-BLOCKS_USED; end {with DCAT[DREC]} end;{GETDIR} procedure SETDEX; {if first occurance of file name with DEX as first letter then put record number in DEXRAY and increment DEX} begin if (NCAT[NREC].FILE_NAME[1]>=DEX) {have we reached or exceeded the next index?} then begin if (NCAT[NREC].FILE_NAME[1]>DEX) then {fill DEXRAY to the next valid index} repeat DEXRAY[DEX]:=0; if DEX='Z' then exit(SETDEX); DEX:=succ(DEX); until (NCAT[NREC].FILE_NAME[1]=DEX); DEXRAY[DEX]:=NTOTREC+NREC; if DEX='Z' then exit(SETDEX); DEX:=succ(DEX); end {if NCAT[NREC].FILE_NAME>=DEX} end;{SETDEX} procedure MERGE; {merges DCAT with OCAT to form NCAT} var X,Y,Z:1..33; CONTINUE:boolean; OO,O,D:RECNUM; begin DEX:='A'; {set first match char for index at 'A'} O:=OREC; OREC:=1; D:=1; {REMOV is true if folume is to be deleted} if (NOT REMOV) then VOL:=DCAT[1].VOL_NAME; {DREC+1 is 1 more than the number of files in DCAT} while (DO)) then Z:=11; case Z of 11,12,13,21:begin {add record to NCAT from DCAT} NREC:=NREC+1; NCAT[NREC]:=DCAT[D]; D:=D+1; {increment D} write('add ',NCAT[NREC].FILE_NAME:18); writeln(NCAT[NREC].VOL_NAME:10) end; 22 :begin {add record to NCAT from DCAT} NREC:=NREC+1; NCAT[NREC]:=DCAT[D]; OREC:=OREC+1; {increment OREC} D:=D+1; {increment D} end; 23,31,33 :begin {add record to NCAT from OCAT} NREC:=NREC+1; NCAT[NREC]:=OCAT[OREC]; OREC:=OREC+1; {increment OREC} end; 32 :begin {DO NOT add record to NCAT} write('DELETE ',OCAT[OREC].FILE_NAME:18); writeln(OCAT[OREC].VOL_NAME:10); OREC:=OREC+1; {increment OREC} end; end;{case Z} SETDEX; {check pointer index} end;{with ?} if NREC=NLREC then WRITECAT; {NLREC is the max array size} if ((OREC>OLREC) and (not OFILEEND)) then begin {if you are out of OCAT then get some more} READ_OLD_CAT; O:=OREC; OREC:=1; end;{if ((OREC>OLREC) and (not OFILEEND))} end;{while} {DCAT is empty} repeat {gets whats left of OCAT} CONTINUE:=false; if OREC<=O then for OO:=OREC to O do if OCAT[OO].VOL_NAME<>VOL then begin NREC:=NREC+1; NCAT[NREC]:=OCAT[OO]; if NREC=NLREC then WRITECAT; SETDEX; end {if OCAT[OO].VOL_NAME<>VOL} else begin write('DELETE ',OCAT[OO].FILE_NAME:18); writeln(OCAT[OO].VOL_NAME:10) end;{else begin} if not OFILEEND then begin {if you are out of OCAT get some more} READ_OLD_CAT; O:=OREC; OREC:=1; CONTINUE:=true; end;{if not OFILEEND} until not CONTINUE; {writeln('DEX=',DEX); writeln('CH=',CH);} if DEX<'Z' then for CH:=DEX to 'Z' do begin {writeln('DEX=',DEX); writeln('CH=',CH);} DEXRAY[CH]:=DEXRAY[PRED(DEX)]; end;{for CH} DONE:=true; WRITECAT; WRITEDEX; end;{MERGE} begin {update} rewrite(P,'CONSOLE:'); CLEARSCREEN; write('Searching for old CATALOG...'); if LOOKUP(OFILENAME) then begin writeln; reset(OCATFILE,OFILENAME); close(OCATFILE,purge); end;{if} RENAME; if not REMOV then begin GETDIR; SORT; CLEARSCREEN; for RN:=1 to DREC do begin PRINT_RECORD(DCAT[RN]); if (RN mod 20=0) then begin CLEARSCREEN end {if} end {for RN} end;{if} writeln; write('Searching for old CATALOG...'); if LOOKUP(OFILENAME) then begin writeln; reset(OCATFILE,OFILENAME); READ_OLD_CAT; end {if} else OREC:=0; rewrite(NCATFILE,NFILENAME); NREC:=0; MERGE; close(OCATFILE); close(P); writeln; writeln; writeln('BACKCAT contains ',OTOTREC,' records'); writeln('MASTCAT contains ',NTOTREC,' records'); writeln; writeln; close(NCATFILE,lock); SPACEBAR; end;{UPDATE} procedure SEARCH; var HARDCOPY,STOP,FOUND:boolean; TAR1,TAR2:char; I,START:integer; WILDCARD:0..16; CAT:CATALOG_RECORD; TARGET,SPS:string; procedure LONGSEARCH; {used when alphebetical pointers can't be used} var N:RECNUM; begin delete(TARGET,1,1); writeln(TARGET); repeat READ_NEW_CAT; for N:=1 to NREC do if pos(TARGET,NCAT[N].FILE_NAME)<>0 then PRINT_RECORD(NCAT[N]); until NFILEEND; close(NCATFILE); SPACEBAR; close(P); exit(SEARCH) end;{LONGSEARCH} procedure SEARCH_FOR_VOLUME; var BLKS,SPS:string[7]; N:RECNUM; begin BLKS:=' '; delete(TARGET,pos(':',TARGET),1); SPS:=copy(BLKS,1,7-length(TARGET)); TARGET:=concat(TARGET,SPS); writeln(TARGET); repeat READ_NEW_CAT; for N:=1 to NREC do if (NCAT[N].VOL_NAME=TARGET) then PRINT_RECORD(NCAT[N]); until NFILEEND; close(NCATFILE); SPACEBAR; close(P); exit(SEARCH) end;{SEARCH_FOR_VOLUME} begin {SEARCH} HARDCOPY:=false; STOP:=false; FOUND:=false; repeat write('Enter name of file to be found: '); readln(TARGET); if (length(TARGET)>16) then writeln('NAME TOO LONG...'); until (length(TARGET)<=16); make_upper ( target ); gotoxy(0,12); write(chr(8),chr(27),chr(108)); write('Select desired option...',chr(27),chr(109)); writeln; writeln; writeln('1--> output to CRT'); writeln; write('2--> output to PRINTER '); CH:=READKEY(['1','2']); CLEARSCREEN; if CH='1' then rewrite(P,'CONSOLE:') else begin rewrite(P,'printer:'); CLEARSCREEN; PRINTAT(0,12,'Sending search results to PRINTER... '); for I:=1 to 5 do writeln(P); HARDCOPY:=true; end;{else} reset(NCATFILE,NFILENAME); if pos(':',TARGET)<>0 then SEARCH_FOR_VOLUME; WILDCARD:=pos('=',TARGET); if WILDCARD=1 then LONGSEARCH; if WILDCARD>1 then TARGET:=copy(TARGET,1,WILDCARD-1); TAR1:=TARGET[1]; {TAR1 used to get pointer from DEXRAY} {TAR2 used to end search} if (length(TARGET)>1) and (WILDCARD <> 2) then TAR2:=TARGET[2] else TAR2:='z'; if TAR2<'A' then START:=0 else if TAR1>'Z' then START:=DEXRAY['Z'] else START:=DEXRAY[TAR1]; seek(NCATFILE,START); get(NCATFILE); repeat CAT:=NCATFILE^; if ((WILDCARD=0) and (pos(TARGET,CAT.FILE_NAME)=1)) then begin PRINT_RECORD(CAT); FOUND:=true; end;{if} if ((WILDCARD>1) and (pos(TARGET,CAT.FILE_NAME)>=1)) then begin PRINT_RECORD(CAT); FOUND:=true; end;{if} if ((CAT.FILE_NAME[1]>TAR1) or (CAT.FILE_NAME[2]>TAR2)) then STOP:=true; get(NCATFILE); until (STOP or eof(NCATFILE)); if not FOUND then writeln('File ',TARGET,' not found... '); close(NCATFILE); close(P); if not HARDCOPY then SPACEBAR; end;{SEARCH} procedure CLEARSCREEN; {for Heath H19} begin gotoxy ( 0, 0 ); write(chr(27),chr(69)); end; function READKEY; var CH:CHAR; GOOD:BOOLEAN; begin repeat read(KEYBOARD,CH); if eoln(KEYBOARD) then CH:=chr(13); GOOD:=CH in OKSET; if not GOOD then write(chr(7)) else if CH in [' '..'}'] then write(CH); until GOOD; READKEY:=CH; end;{READKEY} procedure PRINTAT; begin gotoxy(X,Y); write(S); end;{PRINTAT} function YES; begin YES:=READKEY(['Y','y','N','n']) in ['Y','y']; end;{YES} procedure SPACEBAR; { a technique to hold data/display on CRT } var CH:CHAR; begin gotoxy(22,23); write('Hit "SPACE-BAR" to continue <---'); CH:=READKEY([' ']); end;{SPACEBAR} procedure QUIT; {exit program} begin CLEARSCREEN; exit(program); end;{QUIT} function LOOKUP; {returns TRUE if filename present -- FALSE if not} var IOR:0..15; begin {$I-} reset(CATFILE,FN); IOR:=IORESULT; CLOSE(CATFILE); {$I+} if IOR=0 then LOOKUP:=true else begin LOOKUP:=false; if IOR<>10 then writeln('IORESULT for ',FN,' is ',IOR) end {else begin} end;{LOOKUP} procedure MEM; begin writeln('MEMORY AVAILABLE AT PROCEDURE ',PN,' = ',MEMAVAIL); end;{MEM} procedure READDEX; {*********************************************************************** * * * This procedure reads the file of pointers to the first occurrence * * of each letter in the alphabet. * * * ************************************************************************} var DEXFILE:file of INDEXARRAY; begin reset(DEXFILE,PFILENAME); DEXRAY:=DEXFILE^; get(DEXFILE); close(DEXFILE) end;{READDEX} procedure ENTER_VOL_NAME; var SPS:VOL_ID; begin VOL:=' '; repeat CLEARSCREEN; PRINTAT(0,12,'Enter name of volume to be removed --> '); readln(VOL); until (length(VOL)<=8); make_upper ( vol ); if (pos(':',VOL)<>0) then delete(VOL,pos(':',VOL),1); SPS:=copy(BLANKS,1,7-length(VOL)); VOL:=concat(VOL,SPS); writeln(VOL,':'); DREC:=0 end;{ENTER_VOL_NAME} ======================================================================================== DOCUMENT :usus Folder:VOL10:catalog.2.text ======================================================================================== (* included from catalog *) procedure PRINT_DATE; {prints date to console or printer} begin with REC do begin write(P,DAY:3,'-'); case MONTH of 1:write(P,'Jan'); 2:write(P,'Feb'); 3:write(P,'Mar'); 4:write(P,'Apr'); 5:write(P,'May'); 6:write(P,'Jun'); 7:write(P,'Jul'); 8:write(P,'Aug'); 9:write(P,'Sep'); 10:write(P,'Oct'); 11:write(P,'Nov'); 12:write(P,'Dec'); end;{case MONTH} write(P,'-',YEAR:2,' ':3); end {with} end;{PRINT_DATE} procedure PRINT_KIND;{prints file to console or printer} begin case FILE_KIND of XDISK:write(P,'Bad block'); CODE:write(P,'Code file'); TEXT:write(P,'Text file'); INFO:write(P,'Info file'); DATA:write(P,'Data file'); GRAF:write(P,'Graf file'); FOTO:write(P,'Foto file'); end {case FILE_KIND} end;{PRINT_KIND} procedure PRINT_RECORD; {prints record to console or printer} begin with CAT1 do begin write(P,FILE_NAME,' ':18-length(FILE_NAME)); write(P,VOL_NAME,' ',8-length(VOL_NAME)); write(P,FILE_SIZE:4); PRINT_DATE(FILE_DATE); PRINT_KIND(FILE_KIND); writeln(P) end {with CAT1} end;{PRINT_RECORD} procedure READ_NEW_CAT; {reads NREC or to "eof" from NCATFILE} var I:RECNUM; begin I:=1; NREC:=0; get(NCATFILE); while (not eof(NCATFILE)) do begin NCAT[I]:=NCATFILE^; if ((NCAT[I].VOL_NAME=' ')) then begin NREC:=I-1; NTOTREC:=NTOTREC+NREC; NFILEEND:=true; exit(READ_NEW_CAT); end;{if NCAT[I].VOL_NAME=} if I=NLREC then begin NREC:=I; NTOTREC:=NTOTREC+I; exit(READ_NEW_CAT); end;{if I=NLREC} I:=I+1; get(NCATFILE); end;{while (not eof(NCATFILE))} NREC:=I-1; NTOTREC:=NTOTREC+NREC; NFILEEND:=true end;{READ_NEW_CAT} procedure READ_OLD_CAT; {reads OREC record or to eof from OCATFILE} var I:RECNUM; begin I:=1; OREC:=0; get(OCATFILE); while (not eof (OCATFILE)) do begin OCAT[I]:=OCATFILE^; if ((OCAT[I].VOL_NAME=' ')) then begin OREC:=I-1; OTOTREC:=OTOTREC+OREC; OFILEEND:=true; exit(READ_OLD_CAT); end;{if OCAT[I].VOL_NAME=} if I=OLREC then begin OREC:=I; OTOTREC:=OTOTREC+I; exit(READ_OLD_CAT); end;{if I=OLREC} I:=I+1; get(OCATFILE); end;{while (not eof(OCATFILE))} OREC:=I-1; OTOTREC:=OTOTREC+OREC; OFILEEND:=true end;{READ_OLD_CAT} procedure WRITECAT; {writes NREC records to NCATFILE} var I:RECNUM; begin if NTOTREC=0 then with NCAT[0] do begin VOL_NAME:=' '; FILE_NAME:=' '; FILE_KIND:=UNTYPED; FILE_DATE.MONTH:=0; FILE_DATE.DAY:=0; FILE_DATE.YEAR:=0; FILE_SIZE:=0; NCATFILE^:=NCAT[0]; PUT(NCATFILE); end;{if NTOTREC=0} writeln; write('Writing CATALOG to disk'); for I:=1 to NREC do begin NCATFILE^:=NCAT[I]; PUT(NCATFILE); write('.'); end;{for I} writeln; NTOTREC:=NTOTREC+NREC; NREC:=0; if DONE then close(NCATFILE,LOCK) end;{WRITECAT} procedure TITLE; var S:string; I,J:integer; begin S:='UCSD PASCAL CATALOG'; PRINTAT(37-length(S) div 2,0,S); S:='written by'; PRINTAT(37-length(S) div 2,1,S); S:='E. J. Heyman'; PRINTAT(37-length(S) div 2,2,S); S:='Centerville, DL'; PRINTAT(37-length(S) div 2,3,S); S:='first published in'; PRINTAT(37-length(S) div 2,9,S); S:='BYTE Magazine May 1981'; PRINTAT(37-length(S) div 2,10,S); S:='and extensively modified by'; PRINTAT(37-length(S) div 2,11,S); S:='R. M. Wilson'; PRINTAT(37-length(S) div 2,12,S); S:='HI-COUNTRY DATA SYSTEMS'; PRINTAT(37-length(S) div 2,13,S); S:='P.O. Box 4258'; PRINTAT(37-length(S) div 2,14,S); S:='Woodland Park, CO 80863-4258'; PRINTAT(37-length(S) div 2,15,S); S:='May 7, 1981'; PRINTAT(37-length(S) div 2,16,S); end; {TITLE} ======================================================================================== DOCUMENT :usus Folder:VOL10:catalog.text ======================================================================================== (*$L-#6:*) {************************************************************************ * * * This program is filed as CATALOG.TEXT * * * ************************************************************************} { program title: CATALOG written by: R. M. Wilson date written: 7 May 1981 written for: HI-COUNTRY DATA SYSTEMS and WESTERN SOFTWARE DEVELOPMENT program function: To provide a central catalog for the many files on the various disks. remarks: This is an extensively modified version of the program by Edward Heyman, 300 Center Hill Rd., Centerville, DL. 19807, published in the May 1981 issue of "BYTE" magazine. There were MANY serious bugs in the original program. These have been corrected and the program works very well!!!!! Well, almost very well. Some more things have been fixed, such as allowing lower case input and some kludges to get it to work under IV.0 on my LSI-11. I also changed a value in the main record to allow disks with more that 988 blocks. - gws This program is furnished to the USUS group for unrestricted personal use. Use of this program for commercial purposes is strictly prohibited. Obligitory message from BYTE (message added by gws) From CATALOG by Edward Heyman appearing in the May 1981 issue of Byte magazine. Copyright 1981 Byte Publications, Inc. Used with the permission of Byte Publications, Inc. Note that if you had used CATALOG as it appeared in BYTE, your database is still valid at, at least mine worked. gws} program CATALOG; procedure dummy; {this kludge is necessary under IV.0 to allow the system to allocate the global data. It will not affect the operation under II.0. gws} const BLANKS=' '; MAXREC=300 {400}; {may have to reduce for different computer} MAXREC_1=301 {401}; {may have to reduce for different computer} {I had to reduce these because of a STACK OVERFLOW! - gws} NFILENAME='#5:MASTCAT.DATA'; OFILENAME='#5:BACKCAT.DATA'; PFILENAME='#5:CAT.POINT.DATA'; type DATE_RECORD=packed record MONTH:0..12; DAY:0..31; YEAR:0..100 end; SETOFCHAR=set of char; {for function READKEY} ACTIVITY=string[26]; DIR_SIZE=0..77; VOL_ID=string[7]; FILE_ID=string[15]; FILE_TYPE=(UNTYPED,XDISK,CODE,TEXT,INFO,DATA,GRAF,FOTO,SECUREDIR); DIR_RECORD=record FIRST_BLOCK:integer; LAST_BLOCK:integer; case DIR_FILE_KIND:FILE_TYPE of SECUREDIR,UNTYPED:(DIR_VOL_NAME:VOL_ID; ZERO_BLOCK, NUM_OF_FILES, TOTAL_BLOCKS:integer; LAST_BOOT:DATE_RECORD); XDISK,CODE,TEXT,INFO,DATA,GRAF,FOTO: (DIR_FILE_NAME:FILE_ID; LASTBYTE:1..512; DIR_FILE_DATE:DATE_RECORD) end; CATALOG_RECORD=packed record VOL_NAME:VOL_ID; FILE_NAME:FILE_ID; FILE_KIND:FILE_TYPE; FILE_DATE:DATE_RECORD; FILE_SIZE:0..{988}maxint; {allow for big disk - gws} end; DIRECTORY=array[DIR_SIZE] of DIR_RECORD; CATARRAY=array[0..MAXREC] of CATALOG_RECORD; FILEN=string[20]; RECNUM=0..MAXREC_1; INDEX='A'..'Z'; INDEX_ARRAY=array[INDEX] of integer; var NREC,NLREC,OREC,OLREC,DREC,DLREC:RECNUM; NTOTREC,OTOTREC:0..2047; LEAVE,REMOV,NFILEEND,OFILEEND,DONE:boolean; CH:char; DEX:INDEX; DEXRAY:INDEXARRAY; P:file of char; {used to swithch from console to printer} VOL:VOL_ID; BOOT_VOL,TEST:string; CATFILE,OCATFILE,NCATFILE:file of CATALOG_RECORD; NCAT,OCAT:CATARRAY; procedure CLEARSCREEN;forward; procedure make_upper ( var strg : string ); forward; function READKEY(OKSET:SETOFCHAR):CHAR;forward; procedure PRINTAT(X,Y:INTEGER;S:STRING);forward; function YES:BOOLEAN;forward; procedure SPACEBAR;forward; procedure MEM(PN:string);forward; procedure QUIT;forward; procedure WRITECAT;forward; procedure READ_OLD_CAT;forward; procedure READ_NEW_CAT;forward; procedure PRINT_RECORD(CAT1:CATALOG_RECORD);forward; procedure PRINT_KIND(FILE_KIND:FILE_TYPE);forward; procedure PRINT_DATE(REC:DATE_RECORD);forward; procedure ENTER_VOL_NAME;forward; procedure READDEX;forward; function LOOKUP(FN:FILEN):boolean;forward; procedure INITIALIZE; var I:RECNUM; DEXFILE:file of INDEXARRAY; begin MEM('INITIALIZE'); if (not LOOKUP(NFILENAME)) then begin writeln(chr(7),'There is no file named ',NFILENAME,' on this disk'); write('Do you want to create a ',NFILENAME,'? '); if not YES then begin LEAVE:=true; exit(INITIALIZE) end;{if not YES} writeln; writeln('Filling array[0]'); with NCAT[0] do begin VOL_NAME:=' '; FILE_NAME:=' '; FILE_KIND:=UNTYPED; FILE_DATE.MONTH:=0; FILE_DATE.DAY:=0; FILE_DATE.YEAR:=0; FILE_SIZE:=0; end;{with NCAT[0]} for I:=1 to MAXREC do NCAT[I]:=NCAT[0]; writeln('Array is filled '); rewrite(CATFILE,NFILENAME); for I:=0 to MAXREC do begin CATFILE^:=NCAT[I]; PUT(CATFILE) end;{for I} CLOSE(CATFILE,LOCK) end {if (not LOOKUP(NFILENAME))} else writeln('The file ',NFILENAME,' already exists on this volume '); writeln; if not LOOKUP(PFILENAME) then begin writeln(chr(7),'There is no file named ',PFILENAME,' on this disk '); writeln('Do you want to create a ',PFILENAME,'? '); if not YES then begin LEAVE:=true; exit(INITIALIZE) end;{if not YES} for DEX:='A' to 'Z' do DEXRAY[DEX]:=0; rewrite(DEXFILE,PFILENAME); DEXFILE^:=DEXRAY; PUT(DEXFILE); CLOSE(DEXFILE,LOCK); writeln(PFILENAME,' written to disk') end {if not LOOKUP(PFILENAME)} else writeln('File ',PFILENAME,' exists '); SPACEBAR; end;{INITIALIZE} procedure make_upper (*var strg : string*); {upper case conversion - gws} var qq : integer; begin if length ( strg ) > 0 then for qq := 1 to length ( strg ) do if strg [ qq ] in [ 'a' .. 'z' ] then strg [ qq ] := chr ( ord ( strg [ qq ] ) - 32 ); end; procedure DISPLAY; {writes the entire MASTCAT.DAT file to the console} var I:RECNUM; HARDCOPY:boolean; begin HARDCOPY:=false; CLEARSCREEN; write('Searching for CATALOG...'); if (LOOKUP(NFILENAME)) then begin writeln; gotoxy(0,12); write(chr(8),chr(27),chr(108)); write('Select desired option...',chr(27),chr(109)); writeln; writeln; writeln('1--> output to CRT'); writeln; write('2--> output to PRINTER '); CH:=READKEY(['1','2']); CLEARSCREEN; if CH='1' then rewrite(P,'CONSOLE:') else begin rewrite(P,'printer:'); PRINTAT(0,12,'Sending entire CATALOG to PRINTER... '); for I:=1 to 5 do writeln(P); HARDCOPY:=true end;{else} NREC:=0; reset(NCATFILE,NFILENAME); repeat READ_NEW_CAT; for I:=1 to NREC do begin PRINT_RECORD(NCAT[I]); if (I mod 20=0) and not HARDCOPY then begin SPACEBAR; CLEARSCREEN end {if} end;{for I} until NFILEEND; close(NCATFILE); end {if (LOOKUP(NFILENAME))} else writeln(NFILENAME,' not present'); writeln; if HARDCOPY then writeln(P,'MASTCAT contains ',NTOTREC,' records') else writeln('MASTCAT contains ',NTOTREC,' records'); close(P); if not HARDCOPY then SPACEBAR; end;{DISPLAY} procedure BACKUP; {compares file names & reports files without backups} var HARDCOPY,PASS,UNBACK:boolean; CH:char; I,C,N:RECNUM; begin PASS:=false; UNBACK:=false; HARDCOPY:=false; CLEARSCREEN; write('Searching for CATALOG...'); if (LOOKUP(NFILENAME)) then begin gotoxy(0,12); write(chr(8),chr(27),chr(108)); write('Select desired option...',chr(27),chr(109)); writeln; writeln; writeln('1--> output to CRT'); writeln; write('2--> output to PRINTER '); CH:=READKEY(['1','2']); CLEARSCREEN; if CH='1' then rewrite(P,'CONSOLE:') else begin rewrite(P,'printer:'); PRINTAT(0,12,'Sending backup data to PRINTER... '); for I:=1 to 5 do writeln(P); writeln(P,'The following files are not backed up...'); writeln(P); HARDCOPY:=true end;{else} C:=0; if not HARDCOPY then writeln('The following files are not backed up...'); reset(NCATFILE,NFILENAME); repeat READ_NEW_CAT; if (PASS and UNBACK) then if (NCAT[0].FILE_NAME<>NCAT[1].FILE_NAME) then begin PRINT_RECORD(NCAT[0]); C:=C+1; if (C mod 20=0) and not HARDCOPY then begin SPACEBAR; CLEARSCREEN end {if} end;{if (NCAT[0].FILE_NAME<>NCAT[1].FILE_NAME)} for N:=1 to NREC-1 do if ((NCAT[N].FILE_NAME<>NCAT[N-1].FILE_NAME) and (NCAT[N].FILE_NAME<>NCAT[N+1].FILE_NAME)) then begin PRINT_RECORD(NCAT[N]); C:=C+1; if (C mod 20=0) and not HARDCOPY then begin SPACEBAR; CLEARSCREEN end {if} end;{if((NCAT[N]>FILE} PASS:=true; if not NFILEEND and (NCAT[NREC].FILE_NAME<>NCAT[NREC-1].FILE_NAME) then UNBACK:=true else UNBACK:=false; NCAT[0]:=NCAT[NREC]; if NFILEEND then begin if NCAT[NREC].FILE_NAME<>NCAT[NREC-1].FILE_NAME then begin PRINT_RECORD(NCAT[NREC]); C:=C+1; if (C mod 20=0) and not HARDCOPY then begin SPACEBAR; CLEARSCREEN end {if} end {if} end;{if NFILEEND} until NFILEEND; close(NCATFILE); end {if (LOOKUP(NFILENAME))} else writeln('CATALOG not present '); close(P); if not HARDCOPY then SPACEBAR; end;{BACKUP} procedure UPDATE; var DCAT:array[DIR_SIZE] of CATALOG_RECORD; RN:RECNUM; procedure RENAME; {changes name of MASTCAT.DATA to BACKCAT.DATA} var I:integer; SPS:string[16]; VOL,AVOL:VOL_ID; DIR:DIRECTORY; begin unitread(5,DIR[0],2048,2); VOL:=DIR[0].DIR_VOL_NAME; SPS:=COPY(BLANKS,1,7-length(VOL)); AVOL:=concat(VOL,SPS); for I:=1 to DIR[0].NUM_OF_FILES do with DIR[I] do begin if (DIR_FILE_NAME='MASTCAT.DATA') then DIR_FILE_NAME:='BACKCAT.DATA'; end;{with DIR[I]} unitwrite(5,DIR[0],2048,2); end;{RENAME} procedure WRITEDEX; {writes a file of pointers to the first occurrence of each letter in the alphabet} var DEXFILE:file of INDEXARRAY; begin rewrite(DEXFILE,PFILENAME); DEXFILE^:=DEXRAY; put(DEXFILE); close(DEXFILE,LOCK); end;{WRITEDEX} (*$I catalog.1.text*) (*$I catalog.2.text*) begin {dummy} {MAIN PROGRAM} CLEARSCREEN; TITLE; SPACEBAR; CLEARSCREEN; MEM('MAIN'); LEAVE:=false; if ((not LOOKUP(NFILENAME)) or (not LOOKUP(PFILENAME))) then begin PRINTAT(0,11,'Insert disk with CATALOG files on it into drive #5: '); SPACEBAR; CLEARSCREEN; if ((not LOOKUP(NFILENAME)) or (not LOOKUP(PFILENAME))) then INITIALIZE; end;{if} if LEAVE then exit(program); writeln; CLEARSCREEN; DLREC:=MAXREC; OLREC:=MAXREC; NLREC:=MAXREC; READDEX; {load the pointer array} repeat REMOV:=false; NFILEEND:=false; OFILEEND:=false; DONE:=false; NREC:=0; OREC:=0; DREC:=0; NTOTREC:=0; OTOTREC:=0; VOL:=' '; CLEARSCREEN; {MEM('MAIN');} write('Catalog: S)earch D)isplay B)ackup U)pdate R)emove Q)uit '); CH:=READKEY(['S','D','B','U','R','Q','s','d','b','u','r','q']); CLEARSCREEN; case CH of 'U','u':UPDATE; 'S','s':SEARCH; 'D','d':DISPLAY; 'R','r':begin REMOV:=true; ENTER_VOL_NAME; UPDATE end; 'B','b':BACKUP; 'Q','q':begin CLEARSCREEN; PRINTAT(0,12, 'Ensure that the "boot disk" is in the correct drive.'); PRINTAT(0,14,'If it is not, the system will CRASH!!!'); SPACEBAR; QUIT end; end;{case CH} if LEAVE then exit(program); until false end; begin dummy end. ======================================================================================== DOCUMENT :usus Folder:VOL10:kruskal.1.text ======================================================================================== (* included from kruskal.text*) procedure UNION(I,J:integer); (************************************************************************ * * * * * This procedure takes two disjointed sets and joins them. procedure * * FIND must be used to find the parent nodes for the disjoined sets. * * Each parent or root node "parent value" has a negative number which * * represents the number of elements in that set. * * * * For example if we have an element J calling FIND(J) will return * * the value of the root node (i.e. which node in the array is the root * * node for the set in J is contained). The array "PARENT" is used to * * indicate which elements are in which sets. If I,J,K,L,M are all * * elements in "X" such that X={I,J,K,L,M,...} then PARENT(I), * * PARENT(J), PARENT(K), etc will all have the same value X. PARENT(X) * * will have a negative number which indicates the number of set * * elements. * * * * In "procedure KRUSKAL" the array "PARENT" is initialized so that * * each slot = -1. (That way each node is in its own set of size 1.) * * The first line in "UNION" determines what the size of the new set * * will be. * * * * Next the smaller set is determined so that the union may be pre- * * formed more efficiently (shade of a greedy algorithm!!). * * * * Then the smaller set is joined to the larger set by setting the * * value of the root node of the smaller set to the location of the * * root node of the larger set. * * * * Last the value of the larger root node is set to the negative value * * equal to the number of elements in the new set. * * * * It should be noted that another way of doing this which would allow * * for more efficient determinations of the inclusion of an element in * * a given set would be to set the value of "PARENT" of each set member * * to the location of the root node. * * * * * ************************************************************************) var X:integer; begin X:=PARENT[I] + PARENT[J]; if TRACEOPTION then begin if HARDCOPY or BOTH then begin writeln(PRINTER); writeln(PRINTER,'UNION(',I,',',J,')'); writeln(PRINTER,'PARENT[',I,']=',PARENT[I]); writeln(PRINTER,'PARENT[',J,']=',PARENT[J]); writeln(PRINTER,'X=',X); end;{if HARDCOPY or BOTH} if CRT or BOTH then begin writeln; writeln('UNION(',I,',',J,')'); writeln('PARENT[',I,']=',PARENT[I]); writeln('PARENT[',J,']=',PARENT[J]); writeln('X=',X); end;{if CRT or BOTH} end;{if TRACEOPTION} if PARENT[I]>PARENT[J] then begin PARENT[I]:=J; PARENT[J]:=X end else begin PARENT[J]:=I; PARENT[I]:=X; end; if TRACEOPTION then begin if HARDCOPY or BOTH then begin writeln(PRINTER,'PARENT[',I,']=',PARENT[I]); writeln(PRINTER,'PARENT[',J,']=',PARENT[J]); writeln(PRINTER,'X=',X); end;{if HARDCOPY or BOTH} if CRT or BOTH then begin writeln('PARENT[',I,']=',PARENT[I]); writeln('PARENT[',J,']=',PARENT[J]); writeln('X=',X); SPACEBAR; writeln; end;{if CRT or BOTH} end;{if TRACEOPTION} end;{UNION} procedure FIND(I:integer;var L:integer); {************************************************************************ * * * This procedure uses the technique of "collasping" the tree to the * * root node. In plain english since the value of all roots nodes is * * <0, it examines the value of each parent until it finds a negative * * value and thus the root node of the element in question has been * * found. * * * * The most important part of the procedure is the first while loop. * * A quick examination will reveal the loop repeats until PARENT(J)<0 * * at which time the loop is terminated an "J" is the value of the * * location of the root node of the set/element. * * * * The second while loop sets the value of PARENT() to the * * location of the set root for all elements in the set above element * * "J" to the location of the root node. (see comments for "UNION") * * * ************************************************************************} var J,K,TEMP:integer; begin if TRACEOPTION and (HARDCOPY or BOTH) then write(PRINTER,'FIND(',I,')='); if TRACEOPTION and (CRT or BOTH) then write('FIND(',I,')='); J:=I; while PARENT[J]>0 do J:=PARENT[J]; K:=I; while K<>J do begin TEMP:=PARENT[K]; PARENT[K]:=J; K:=TEMP; end;{while} L:=J; if TRACEOPTION then begin if HARDCOPY or BOTH then writeln(PRINTER,L); if CRT or BOTH then writeln(L); end;{if TRACEOPTION} end;{FIND} procedure ADJUST(I,ARRAYSIZE:integer); {************************************************************************ * * * This along with HEAPIFY produces a low to high HEAP * * * ************************************************************************} label 1; var J:integer; ITEM:PRICE; begin J:=2*I; if TRACEOPTION then begin if HARDCOPY or BOTH then begin writeln(PRINTER,'ADJUST(',I,',',ARRAYSIZE,')'); writeln(PRINTER,'J=',J,' ARRAYSIZE=',ARRAYSIZE); end;{if HARDCOPY or BOTH} if CRT or BOTH then begin writeln('ADJUST(',I,',',ARRAYSIZE,')'); writeln('J=',J,' ARRAYSIZE=',ARRAYSIZE); {SPACEBAR;} writeln; end;{if CRT or BOTH} end;{if TRACEOPTION} ITEM:=COST[I]; while (J<=ARRAYSIZE) do begin if (JCOST[J+1].HOWMUCH) then J:=J+1; if ITEM.HOWMUCH >=COST[J].HOWMUCH then begin COST[J div 2]:=COST[J]; J:=J*2; end {if} else goto 1 end;{while} 1:COST[J div 2]:=ITEM; end;{ADJUST} procedure HEAPIFY(ARRAYSIZE:integer); var I:integer; begin if HARDCOPY or BOTH then begin writeln(PRINTER); writeln(PRINTER,'HEAPIFY(',ARRAYSIZE,')'); writeln(PRINTER); end; if CRT or BOTH then begin writeln; writeln('HEAPIFY(',ARRAYSIZE,')'); SPACEBAR; writeln; end; for I:=((ARRAYSIZE*ARRAYSIZE) div 2) downto 1 do ADJUST(I,ARRAYSIZE*ARRAYSIZE); end;{HEAPIFY} procedure PRINTHEAP; var I:integer; begin I:=1; while COST[I].EDGE[1]<>0 do begin if HARDCOPY or BOTH then begin writeln(PRINTER,'COST[',I,'].HOWMUCH=',COST[I].HOWMUCH); end;{if HARDCOPY or BOTH} if CRT or BOTH then begin writeln('COST[',I,'].HOWMUCH=',COST[I].HOWMUCH); end;{if CRT or BOTH} I:=I+1; end;{while} if CRT or BOTH then begin SPACEBAR; writeln; end;{if CRT or BOTH} if HARDCOPY or BOTH then begin writeln(PRINTER); end;{if HARDCOPY or BOTH} end;{PRINTHEAP} procedure KRUSKAL(var COST:A1;ARRAYSIZE:integer;var T:A2;var MINCOST:integer); var I,J,K,L,R,U,V:integer; NODE:PRICE;{this is used rather than COST[I] to ensure it is not inadvertently changed} begin if TRACEOPTION then PRINTHEAP; HEAPIFY(ARRAYSIZE); if TRACEOPTION then PRINTHEAP; CLEARSCREEN; if DETAIL then EXAMINE; for I:=1 to ARRAYSIZE do PARENT[I]:=-1; I:=0; MINCOST:=0; L:=ARRAYSIZE*ARRAYSIZE; for R:=L downto 2 do begin while (I0) do begin {************************************************************************ * * * The next three lines remove the edge with the smallest cost, replace * * it with one of infinite value (i.e. one which does not exist), and * * then forms a new "low-high" heap with the lowest cost on top. * * * ************************************************************************} NODE:=COST[1]; COST[1]:=COST[L]; if TRACEOPTION then begin CLEARSCREEN; with NODE do begin if HARDCOPY or BOTH then begin writeln(PRINTER); writeln(PRINTER,'...NODE...'); writeln(PRINTER,'EDGE[1] = ',EDGE[1]); writeln(PRINTER,'EDGE[2] = ',EDGE[2]); writeln(PRINTER,'HOWMUCH = ',HOWMUCH); end;{if HARDCOPY or BOTH} if CRT or BOTH then begin writeln; writeln('...NODE...'); writeln('EDGE[1] = ',EDGE[1]); writeln('EDGE[2] = ',EDGE[2]); writeln('HOWMUCH = ',HOWMUCH); SPACEBAR; writeln; end;{if CRT or BOTH} end;{with NODE} PRINTHEAP; end;{if TRACEOPTION} ADJUST(1,L); if DETAIL then EXAMINE; if TRACEOPTION then PRINTHEAP; with NODE do begin {we determine the node ends of the edge} U:=EDGE[1]; V:=EDGE[2]; {we find the root nodes for each end node} FIND(U,J); FIND(V,K); if J<>K then begin {if J=K then edge is already included in the solution set} I:=I+1; {increments the solution set to the next array slot} {we assign the edge to the solution set} T[I,1]:=U; T[I,2]:=V; {we compute the cost for the solution to this point} MINCOST:=MINCOST+HOWMUCH; if TRACEOPTION then begin if HARDCOPY or BOTH then begin writeln(PRINTER,'J=',J,' K=',K,' I=',I); writeln(PRINTER,'T[',I,',1]=',T[I,1]); writeln(PRINTER,'T[',I,',2]=',T[I,2]); writeln(PRINTER,'MINCOST=',MINCOST); end;{if HARDCOPY or BOTH} if CRT or BOTH then begin writeln('J=',J,' K=',K,' I=',I); writeln('T[',I,',1]=',T[I,1]); writeln('T[',I,',2]=',T[I,2]); writeln('MINCOST=',MINCOST); end;{if CRT or BOTH} end;{if TRACEOPTION} {we join the nodes into a set} UNION(J,K); end;{if J<>K} end;{with NODE} end;{while} end;{for R} if I<>ARRAYSIZE-1 then begin CLEARSCREEN; PRINTAT(0,12,'NO SPANNING TREE'); SPACEBAR; QUIT; end;{if I<>n-1} end;{KRUSKAL} procedure INITIALIZE; var I:integer; begin for I:=1 to 2500 do begin COST[I].PATH:=false; COST[I].EDGE[1]:=0; end; end;{INITIALIZE} procedure TRACE; var CH:char; begin CRT:=false; HARDCOPY:=false; BOTH:=false; CLEARSCREEN; PRINTAT(0,12,'Do you want to trace the program? '); if YES then begin TRACEOPTION:=true; PRINTAT(0,14,'Trace program on Printer, CRT or Both? (P/C/B) '); CH:=READKEY(['C','B','P','c','b','p']); case CH of 'c','C':CRT:=true; 'b','B':BOTH:=true; 'p','P':HARDCOPY:=true; end;{case} PRINTAT(0,16,'Trace program in detail? (Y/N)' ); if YES then DETAIL:=true else DETAIL:=false; end {if YES} else TRACEOPTION:=false; end;{TRACE} procedure TITLE; var S:string; I,J:integer; begin S:='MINIMUM SPAN KRUSKAL'; PRINTAT(37-length(S) div 2,2,S); S:='written by'; PRINTAT(37-length(S) div 2,3,S); S:='R. M. Wilson'; PRINTAT(37-length(S) div 2,4,S); S:='Copyright by'; PRINTAT(37-length(S) div 2,13,S); S:='HI-COUNTRY DATA SYSTEMS'; PRINTAT(37-length(S) div 2,15,S); S:='P.O. Box 4258'; PRINTAT(37-length(S) div 2,16,S); S:='Woodland Park, CO 80863-4258'; PRINTAT(37-length(S) div 2,17,S); S:='March 1981'; PRINTAT(37-length(S) div 2,18,S); end; {TITLE} ======================================================================================== DOCUMENT :usus Folder:VOL10:kruskal.text ======================================================================================== {************************************************************************ * * * This program is filed as KRUSKAL.TEXT * * * ************************************************************************} { program title: Minimum Span Kruskal written by: R. M. Wilson HI-COUNTRY DATA SYSTEMS date written: March 1981 latest revision: March 1981 written for: CS440 -- Design and Analysis of Algorithms University of Colorado at Colorado Springs Spring semester 1981 program function: ---------------- This program is designed to determine the minimum spanning tree by the Kruskal algorithm. remarks: ------- This program is furnished to the USUS group for unrestricted personal or non-profit use. Use of this program for commercial purposes is authorized with the following restrictions: 1--> Prior notification to and acknowledgement by the author 2--> A message similar to the one below appears on the screen upon execution and remains there until a key is hit. ************************************************************************* * * * * * * * * * * * Program derived from KRUSKAL * * written by * * R.M. Wilson * * Hi-Country Data Systems * * P.O. Box 4258 * * Woodland Park, CO 80863 * * * * * * * * * * * * * * * * * * * ************************************************************************* } {$G+} program MIN_SPAN_TREE_KRUSKAL; label 1; const MAXNODE=50; type PRICE=record EDGE:packed array[1..2] of integer; HOWMUCH:integer; PATH:boolean; end; {************************************************************************ * * * I elected to use a record structure because I felt it would be * * easier to keep track of the various variables relating to each node * * * ************************************************************************} A1=packed array[1..2500] of PRICE; {array[1..(MAXNODE*MAXNODE)} A2=packed array[1..49,1..2] of integer; A3=packed array[1..MAXNODE] of integer; SETOFCHAR=set of char; var COST:A1; T:A2; ARRAYSIZE,MINCOST,I,J,K:integer; PARENT:A3; TRACEOPTION:boolean; HARDCOPY:boolean; BOTH:boolean; CRT:boolean; PRINTER:interactive; DETAIL:boolean; CH:char; procedure CLEARSCREEN; {for Heath H-19} begin gotoxy ( 0, 0 ); write(chr(27),chr(69)); end; function READKEY(OKSET:SETOFCHAR):CHAR; {************************************************************************ * * * This procedure look at each keypress and determines if the key * * pressed is valid, i.e. the "set" of char which are valid may be * * varied with each call of this procedure. If the key pressed is * * not in the valid or 'OKSET', then the bell sounds. If the key * * pressed is valid the computer accepts the input and the program * * continues to run. * * * ************************************************************************} var CH:CHAR; GOOD:boolean; begin repeat read(KEYBOARD,CH); if eoln(KEYBOARD) then CH:=chr(13); GOOD:=CH in OKSET; if not GOOD then write(chr(7)) until GOOD; READKEY:=CH; end;{READKEY} procedure PRINTAT(X,Y:integer;S:string); {************************************************************************ * * * This procedure writes a string at a designated location on the CRT * * * ************************************************************************} begin gotoxy(X,Y); write(S); end;{PRINTAT} function YES:boolean; begin YES:=READKEY(['Y','y','N','n']) in ['Y','y']; end;{YES} procedure SPACEBAR; { a technique to hold data/display on CRT } var CH:CHAR; begin gotoxy(22,23); write('Hit "SPACE-BAR" to continue <---'); CH:=READKEY([' ']); end;{SPACEBAR} procedure QUIT; {exit program} begin CLEARSCREEN; exit(program); end;{QUIT} procedure EXAMINE; begin CLEARSCREEN; I:=1; while COST[I].EDGE[1]<>0 do begin if HARDCOPY or BOTH then begin writeln(PRINTER); writeln(PRINTER,'COST[',I,'].EDGE[1] = ',COST[I].EDGE[1]); writeln(PRINTER,'COST[',I,'].EDGE[2] = ',COST[I].EDGE[2]); writeln(PRINTER,'COST[',I,'].HOWMUCH = ',COST[I].HOWMUCH); end;{if HARDCOPY or BOTH} if CRT or BOTH then begin writeln; writeln('COST[',I,'].EDGE[1] = ',COST[I].EDGE[1]); writeln('COST[',I,'].EDGE[2] = ',COST[I].EDGE[2]); writeln('COST[',I,'].HOWMUCH = ',COST[I].HOWMUCH); SPACEBAR; writeln; end;{if CRT or BOTH} I:=I+1; if HARDCOPY or BOTH then begin writeln(PRINTER); end;{if HARDCOPY or BOTH} if CRT or BOTH then writeln; end;{while} end;{EXAMINE} procedure INPUTCOST; var ROW,COL:integer; begin CLEARSCREEN; PRINTAT(0,10,'Enter number of vertices in graph: '); readln(ARRAYSIZE); if (ARRAYSIZE<=0) or (ARRAYSIZE>MAXNODE) then QUIT; {prevents program blowup with out of range data entry...does not prevent blowup if non numeric entry attempted} I:=1; for ROW:=1 to ARRAYSIZE do begin for COL:=ROW to ARRAYSIZE do begin if ROW<>COL then begin with COST[I] do begin EDGE[1]:=ROW; EDGE[2]:=COL; CLEARSCREEN; gotoxy(0,10); write('Is there a path from ',ROW,' to ',COL,' ? '); if YES then begin PRINTAT(0,12,'(if "y" hit accidently, enter 32767)'); gotoxy(0,14); write('Enter cost of path from ',ROW,' to ',COL,'---> '); readln(HOWMUCH); PATH:=true; end {if YES} else HOWMUCH:=32767; end;{with} {************************************************************************ * * * The technique of echoing the duplicate edge in a non directed graph * * immediately rather than waiting was used in the following 'with' * * statement because it works better with the record structure. * * * ************************************************************************} with COST[I+1] do begin EDGE[1]:=COL; EDGE[2]:=ROW; HOWMUCH:=COST[I].HOWMUCH; PATH:=true; end;{with} I:=I +2; end;{if ROW<>COL} end;{for COL} end;{for ROW} for ROW:=1 to ARRAYSIZE do begin with COST[I] do begin EDGE[1]:=ROW; EDGE[2]:=ROW; HOWMUCH:=32767; I:=I+1; end;{with} end;{for ROW} if DETAIL then EXAMINE; end;{INPUTCOST} (*$I kruskal.1.text*) begin {MAIN PROGRAM} CLEARSCREEN; TITLE; SPACEBAR; CLEARSCREEN; rewrite(PRINTER,'printer:'); 1:INITIALIZE; TRACE; INPUTCOST; writeln; KRUSKAL(COST,ARRAYSIZE,T,MINCOST); writeln; writeln('The minimum cost for a spanning tree is ',MINCOST); writeln; writeln('The spanning tree is'); writeln('--------------------'); K:=1; for I:=1 to ARRAYSIZE-1 do begin write('[',T[I,K],',',T[I,K+1],']'); writeln; end;{for I} SPACEBAR; CLEARSCREEN; PRINTAT(0,12,'Compute another minimum spanning tree? '); if YES then begin CLEARSCREEN; goto 1 end {if YES} else QUIT end.{MIN_SPAN_TREE_KRUSKAL} ======================================================================================== DOCUMENT :usus Folder:VOL10:new.bfs.text ======================================================================================== {************************************************************************ * * * This program is filed as NEW.BFS.TEXT * * * ************************************************************************} { program title: New Breadth First Search written by: R. M. Wilson HI-COUNTRY DATA SYSTEMS date written: April 2, 1981 latest revision: April 7, 1981 written for: CS440 -- Algorithm Analysis and Design University of Colorado at Colorado Springs Spring semester 1981 program function: ---------------- This program is designed to test an improved breadth first search algorithm. remarks: ------- This is based on a program by Dr. Richard S. Wiener from an algorithm by Horowitz & Sahni in their book "Fundementals of Computer Algorithms." This program is furnished to the USUS group for unrestricted personal or non-profit use. Use of this program for commercial purposes is authorized with the following restrictions: 1--> Prior notification to and acknowledgement by the author 2--> A message similar to the one below appears on the screen upon execution and remains there until a key is hit. ************************************************************************* * * * * * * * * * * * Program derived from BREADTHFS6 * * written by * * R.M. Wilson * * Hi-Country Data Systems * * P.O. Box 4258 * * Woodland Park, CO 80863 * * * * * * * * * * * * * * * * * * * ************************************************************************* } {$g+} program NEW_BREADTH_FIRST_SEARCH; label 1; const MAX=512; type RARRAY=array[1..MAX] of integer; SETOFINTEGER=set of 1..MAX; SETOFCHAR=set of char; {for function READKEY} ACTIVITY=string[26]; var G:packed array[1..MAX,1..MAX] of boolean; VISITED:packed array[1..MAX] of boolean; {VISITED keeps track of the nodes visited} QUEUE:RARRAY; {QUEUE keeps track of the queue of "unexpolored nodes"} FIRST,NEXT,N:integer; ALLNODES,CONNECTED:SETOFINTEGER; procedure CLEARSCREEN; {for TeleVideo 920C} begin write(chr(26),chr(30)); end; function READKEY(OKSET:SETOFCHAR):CHAR; {************************************************************************ * * * This procedure look at each keypress and determines if the key * * pressed is valid, i.e. the "set" of char which are valid may be * * varied with each call of this procedure. If the key pressed is * * not in the valid or 'OKSET', then the bell sounds. If the key * * pressed is valid the computer accepts the input and the program * * continues to run. * * * ************************************************************************} var CH:CHAR; GOOD:boolean; begin repeat read(KEYBOARD,CH); if eoln(KEYBOARD) then CH:=chr(13); GOOD:=CH in OKSET; if not GOOD then write(chr(7)) until GOOD; READKEY:=CH; end;{READKEY} procedure PRINTAT(X,Y:integer;S:string); {************************************************************************ * * * This procedure writes a string at a designated location on the CRT * * * ************************************************************************} begin gotoxy(X,Y); write(S); end;{PRINTAT} function YES:boolean; begin YES:=READKEY(['Y','y','N','n']) in ['Y','y']; end;{YES} procedure SPACEBAR; { a technique to hold data/display on CRT } var CH:CHAR; begin gotoxy(22,23); write('Hit "SPACE-BAR" to continue <---'); CH:=READKEY([' ']); end;{SPACEBAR} procedure QUIT; {exit program} begin CLEARSCREEN; exit(program); end;{QUIT} procedure INITIALIZE; var I:integer; begin FIRST:=0;{points to the first element in the queue} NEXT:=1;{points to the next element in the queue} for I:= 1 to MAX do begin VISITED[I]:=false; QUEUE[I]:=0; end; end;{INITIALIZE} (*procedure GRAPHINPUT; {************************************************************************ * * * Test the worst case * * * ************************************************************************} var ROW,COL:integer; AN:char; begin CLEAR; PRINTAT(0,12,'How many nodes in the graph? '); readln(N); writeln; CLEAR; for ROW:=1 to N do for COL:=1 to N do G[ROW,COL]:=false; {the three lines that follow make up the worst case} for COL:=1 to N-1 do G[1,COL]:=true; for ROW:=2 to N-1 do G[ROW,N]:=true; G[N,1]:=true; end;{INPUTGRAPH}*) procedure GRAPHINPUT; var ROW,COL:integer; AN:char; begin PRINTAT(0,12,'How many nodes in the graph? '); readln(N); writeln; CLEARSCREEN; for ROW:=1 to N do for COL:=1 to N do if ROW<>COL then begin gotoxy(0,12); write('Is there a path from node ',ROW,' to ',COL,'? (Y,N)'); if YES then begin writeln; G[ROW,COL]:=true; end {if YES} else G[ROW,COL]:=false; writeln; CLEARSCREEN; end;{if ROW<>COL} for ROW:=1 to N do G[ROW,ROW]:=false; end;{INPUTGRAPH} procedure ADD_TO_QUEUE(I:integer;var QUEUE:RARRAY); begin if FIRST=0 then first:=1; QUEUE[NEXT]:=I; NEXT:=NEXT+1; end;{ADDTOQUEUE} procedure DELETE_FROM_QUEUE(var I:integer;var QUEUE:RARRAY); begin if FIRST=0 then begin FIRST:=1; exit(DELETE_FROM_QUEUE); end;{if FIRST} I:=QUEUE[FIRST]; FIRST:=FIRST+1; end;{DELETE_FROM_QUEUE} procedure TEST(J:integer;var BAD:boolean); var I:integer; begin I:=0; repeat I:=I+1; if VISITED[I]=false then BAD:=true; until (BAD) or (I=N); if BAD then begin CLEARSCREEN; gotoxy(0,12); write('Graph is NOT connected from node ',J); SPACEBAR; QUIT end {if BAD} else CONNECTED:=CONNECTED+[J] end;{TEST} procedure BFS; label 1,2; var I,J,T:integer; BAD:boolean; ROUTE:SETOFINTEGER; begin BAD:=false;{graph is connected} for J:=1 to N do begin if ALLNODES=CONNECTED then goto 2 else if not (J in CONNECTED) then begin INITIALIZE; ROUTE:=[]; T:=J; VISITED[T]:=TRUE; repeat ROUTE:=ROUTE+[T]; for I:=1 to N do begin if (I<>T) and (G[T,I]<>false) and (VISITED[I]=false) then begin ADD_TO_QUEUE(I,QUEUE); VISITED[I]:=TRUE; if I in CONNECTED then begin CONNECTED:=CONNECTED+ROUTE; ROUTE:=[]; goto 1; end;{if I in} end;{if} end;{for I} if NEXT-FIRST=0 then TEST(J,BAD); DELETE_FROM_QUEUE(T,QUEUE); until BAD or (NEXT-FIRST=-1); end;{if not (J in CONNECTED)} 1:end;{for J} 2:writeln; writeln(chr(7),'End BFS...'); writeln; if not BAD then write('Graph is connected'); end;{BFS} procedure TITLE; var S:string; I,J:integer; begin S:='BREADTH FIRST SEARCH'; PRINTAT(37-length(S) div 2,2,S); S:='written by'; PRINTAT(37-length(S) div 2,3,S); S:='R. M. Wilson'; PRINTAT(37-length(S) div 2,4,S); S:='Copyright by'; PRINTAT(37-length(S) div 2,13,S); S:='HI-COUNTRY DATA SYSTEMS'; PRINTAT(37-length(S) div 2,15,S); S:='P.O. Box 4258'; PRINTAT(37-length(S) div 2,16,S); S:='Woodland Park, CO 80863-4258'; PRINTAT(37-length(S) div 2,17,S); S:='April 7, 1981'; PRINTAT(37-length(S) div 2,18,S); end; {TITLE} begin {MAIN PROGRAM} CLEARSCREEN; TITLE; SPACEBAR; 1:CLEARSCREEN; CONNECTED:=[]; GRAPHINPUT; CLEARSCREEN; SPACEBAR; gotoxy(0,10); write('Beginning BFS...',chr(7)); BFS; SPACEBAR; CLEARSCREEN; PRINTAT(0,12,'Test another graph? '); if YES then goto 1; QUIT; end. ======================================================================================== DOCUMENT :usus Folder:VOL10:person.data ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL10:vol10.doc.text ======================================================================================== USUS Volume 10 This disk contains the submissions of Bob Wilson BTRE.FILE.TEXT 30 This file contains the main program and the documentation for the B-tree program. BTREE.STD.TEXT 8 an include file BTREE.DCLR.TEXT 10 BTREE.INIT.TEXT 12 BTREE.GET.TEXT 28 BTRE.FIND1.TEXT 22 BTRE.FIND2.TEXT 22 BTREE.DEL1.TEXT 22 BTREE.DEL2.TEXT 32 BTREE.PRNT.TEXT 26 BTREE.DOIT.TEXT 30 the last include file BENCHMARK.TEXT 28 Jon Bondy's benchmark with some added goodies BENCHMARK1.TEXT 18 an include file NEW.BFS.TEXT 22 This is interesting, but I don't know what it is! KRUSKAL.TEXT 22 ditto KRUSKAL.1.TEXT 28 an include file CATALOG.TEXT 26 This is an improved version of the disk archiver which was published in the May '81 Byte CATALOG.2.TEXT 10 an include file CATALOG.1.TEXT 24 ditto VOL10.DOC.TEXT 10 You're reading it 20/20 files, 436 blocks used, 58 unused, 58 in largest __________________________________________________________________________ Please transfer the text below to a disk label if you copy this volume. USUS Volume 10 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Notes on the programs on this disk BTREE The Btree program on this disk in an example of a btree implementation. It is also a demo address list database although the demo is trivial. There was a program called ADDRESS on the first release of this disk, but it has been omitted when I discovered that it was just an early version of BTREE. BENCHMARK This is Jon Bondy's benchmark with some added functions. This benchmark is particularly interesting because it shows you quite graphically which p- system constructs take the most time. One that isn't here is long integer operations which can run VERY slowly. A 36 digit long integer divide can run as slow as 4 per second on an LSI-11. Also some of the results of string operations are highly dependant on the data being processed, so beware. POS runs particularly slowly when there are several occurances of part of the first operand in the second operand such as: pos ( 'ab', 'aaaaaaaaaaaaaaaaaaaaab' ); KRUSKAL and NEW.BFS I'll be damned if I know what these are, they solve some algorithm which is way over my head. CATALOG This is a handy disk archiver program which first appeared in the May '81 issue of Byte. It is published here with the permission of both the author and Byte Publications. Bob Wilson reworked it as the original was reputed to have several serious bugs. I have worked over Bob's version as I couldn't get it to work on my hard disk and it had some other additional problems. If you have used the original, your database will still work, but a database which you generate with this version may generate value range errors if used with the original version. ======================================================================================== DOCUMENT :usus Folder:VOL11:bjack.1.text ======================================================================================== WRITE('HOUSE LIMIT IS $200.. BET PLEASE ? '); READLN(BET); UNTIL (0'H') OR (REPLY='D'); IF BUST THEN BEGIN CLEAR_LINE(XOVER,YOVER); IF SPLIT THEN BEGIN YOVER:=YOVER+1; END; WRITE('YOU BUSTED WITH ',HANDVAL[I]:3); END {IF BUST} ELSE BUST:=FALSE; IF REPLY='D' THEN BEGIN IF SPLIT THEN BEGIN IF SPLITHAND THEN DBLDOWN3:=TRUE; IF NOT SPLITHAND THEN DBLDOWN:=TRUE; END ELSE DBLDOWN:=TRUE; END; IF (REPLY='S') THEN SPLIT:=TRUE; END; {DEALPLAYER} PROCEDURE DEALHOUSE; BEGIN PERSON:=DEALER; SHOHOLE; WHILE (HANDVAL[2]<17) OR ((HANDVAL[2]=17) AND (NUMACES[2]>0)) DO BEGIN DEAL; SHOWHAND; {TENCOUNT;} SCORE; END; {WHILE} HSCORE; END; {DEALHOUSE} PROCEDURE EVALUATE; VAR HV:INTEGER; BEGIN IF SPLITHAND THEN I:=3 ELSE I:=1; IF BUST THEN BEGIN IF SPLITHAND AND BUSTSECOND THEN WIN:=FALSE; IF SPLIT AND ((NOT SPLITHAND) AND BUSTFIRST) THEN WIN:=FALSE ELSE WIN:=TRUE; CLEAR_LINE(XOVER,YOVER); WRITE('THE HOUSE BUSTED WITH ',HANDVAL[2]:3); END ELSE IF HANDVAL[I]=HANDVAL[2] THEN PUSH:=TRUE ELSE IF HANDVAL[I]>HANDVAL[2] THEN BEGIN IF SPLIT THEN BEGIN IF NOT SPLITHAND AND NOT BUSTFIRST THEN WIN:=TRUE; IF SPLITHAND AND NOT BUSTSECOND THEN WIN:=TRUE; END ELSE WIN:=TRUE; END; IF PUSH THEN BEGIN CLEAR_LINE(XOVER,YOVER); WRITE(' - PUSH -'); END; HV:=HANDVAL[2]; IF (NOT PUSH) AND (NOT BUST) THEN BEGIN CLEAR_LINE(XOVER,YOVER); IF HV=21 THEN WRITE('DEALER HAS 21!!') ELSE WRITE('PAY ',HV+1); END; {NOT PUSH} END; {EVALUATE} PROCEDURE DEALSPLIT; BEGIN RANSUIT(CARD); SCORE; NAMECARD; SHOWHAND; DEAL; SCORE; SHOWHAND; {TENCOUNT;} DEALPLAYER; IF BUST THEN BEGIN IF SPLITHAND THEN BUSTSECOND:=TRUE ELSE BUSTFIRST:=TRUE; BUST:=FALSE; END; PSCORE; END; PROCEDURE SPLITPR; BEGIN HANDVAL[1]:=0; HANDVAL[3]:=0; NUMACES[1]:=0; NUMACES[3]:=0; XPLYR:=0; YPLYR:=YHAND0; CARD:=FIRSTCARD; DEALSPLIT; XPLYR:=XSPLIT; YPLYR:=YSPLIT; CARD:=THIRDCARD; SPLITHAND:=TRUE; DEALSPLIT; IF BUSTFIRST AND BUSTSECOND THEN DBLBUST:=TRUE; END; PROCEDURE INSURANCE; BEGIN IF ACEUP THEN BEGIN CLEAR_LINE(XOVER,YOVER); SQUAWK; WRITE('Do want insurance (y/n)? '); READ(REPLY); IF REPLY IN ['Y', 'y' ] THEN BEGIN CLEAR_LINE(XOVER,YOVER); WRITE('The maximum insurance bet is $',BET DIV 2); GOTOXY(XOVER,YOVER+1); WRITE('Your insurance bet?'); (*$I-*) REPEAT READLN(INSBET); IF (IORESULT<>0) OR (INSBET<=0) OR (INSBET>BET DIV 2) THEN BEGIN SQUAWK; CLEAR_LINE(XOVER+19,YOVER+1); END; UNTIL (INSBET>0) AND (INSBET<=BET DIV 2); (*$I+*) CLEAR_LINE(XOVER,YOVER+1); END ELSE EXIT(INSURANCE); IF HANDVAL[2]=21 THEN BEGIN DOLLARS:=DOLLARS+INSBET+INSBET; WRITE('You win double the insurance bet!'); END ELSE BEGIN DOLLARS:=DOLLARS-INSBET; WRITE('No Blackjack, you lose the insurance bet'); END; CLEAR_LINE(XWIN+32,YWIN); WRITE(DOLLARS); END; END; BEGIN {MAIN PROGRAM} CHOICE:=['H','G','D','S','Q']; TIME(HI,LO); FOR HI:=1 TO 100 DO HI:=HI; TIME(HI,LO_AGAIN); IF LO=LO_AGAIN THEN BEGIN {$I-} REPEAT BEGIN WRITE(' PLEASE ENTER A RANDOM NUMBER - '); READLN(SEED); END; UNTIL IORESULT=0; {$I+} END ELSE SEED:=LO_AGAIN; IF SEED<0 THEN SEED:=SEED*(-1); CLEAR_SCREEN ( 0, 0 ); WRITELN(' Welcome to Blackjack (aka "21").'); WRITELN; WRITELN(' ',VERSION); WRITELN; WRITELN(' to start the game'); WRITELN; WRITELN(' Be sure to hold on to your wallet!'); READ(REPLY); CLEAR_SCREEN ( 0, 0 ); FRESHDECK; FOR I:=1 TO 52 DO BEGIN CARD_NOT_IN_DECK[I]:=FALSE; CARD_ON_TABLE[I]:=FALSE; END; BET:=200; NUMTENS:=16; NOTTEN:=36; CHANGED_BET:=FALSE; SHUFFLE; SETUP; INSTRUCTIONS; PLAYERIN; DOLLARS:=0; REPEAT IF BET>0 THEN BEGIN DEAL2; INSURANCE; TEST21; IF NOT BJACK THEN BEGIN DEALPLAYER; IF SPLIT THEN SPLITPR ELSE PSCORE; IF DBLBUST THEN BEGIN BUST:=FALSE; END; {NOTSEEN;} IF NOT (BUST OR (SPLIT AND DBLBUST)) THEN BEGIN DEALHOUSE; IF SPLIT THEN BEGIN EVALUATE; WINNINGS; SPLITHAND:=FALSE; WIN:=FALSE; PUSH:=FALSE; EVALUATE; END ELSE EVALUATE; END; {IF NOT BUST} END; {NOT BJACK} END; {BET>0} INSTRUCTIONS; WINNINGS; PLAYERIN; SETUP; CLEAR_SCREEN ( 0, YOVER ); UNTIL BET<0 END. {MAIN PROGRAM} ======================================================================================== DOCUMENT :usus Folder:VOL11:blackjack.text ======================================================================================== (*$L-#6:*) (*$S+*) PROGRAM BLACKJK; {GAME OF BLACKJACK WRITTEN IN PASCAL BY T.R. STOKES} {MODIFICATIONS TO PERMIT S(piltpair AND Q(uit ADDED BY G. W. SCHREYER 8-NOV-80} {Further modifications to permit doubling down on a split and to allow insurance and a better random number generator added by G.W. Schreyer 15-Dec-80} {Even further modified to burn a card. GWS 16-DEC-80} {Tens ratio stuff added 19-Dec-80 and revised 23-Dec-80 gws} {and revised again 24-Dec-80 gws} {and commented out 7-Apr-81 because it never did work just right} {An original bug in procedure score fixed 26-Dec-80 gws} CONST VERSION = 'blackjack version 3.0 26 Dec 82'; XINST = 10; {VARIOUS X-Y COORDS FOR SCREEN MESSAGES} YINST = 3; XWIN = 11; YWIN = 2; XBET = 8; YBET = 1; YHAND0= 6; {LEVEL-1 OF CARDS PLAYED} TYPE VEGAS = (PLAYER,DEALER); VAR NOTTEN,NUMTENS :INTEGER; TENS_RATIO :REAL; DECK :ARRAY[1..52] OF INTEGER; CARD,HI,LO,LO_AGAIN :INTEGER; RANK,SUIT :INTEGER; DBLDOWN3 :BOOLEAN; CHANGED_BET :BOOLEAN; NAMRANK,NAMSUIT :STRING; CARDSLEFT :INTEGER; SEED :INTEGER; PERSON :VEGAS; HANDVAL :ARRAY[1..3] OF INTEGER; HANDSIZE :ARRAY[1..3] OF INTEGER; TBET,BET,DOLLARS :INTEGER; BUST,BJACK,PUSH,WIN :BOOLEAN; XPLYR,YPLYR :INTEGER; XDELR,YDELR :INTEGER; XSPLIT,YSPLIT :INTEGER; I,J,Q :INTEGER; {GENERAL PURPOSE INDICES} NUMACES :ARRAY[1..3] OF INTEGER; WAIT :INTEGER; SHUFFLED_SINCE_HOLCARD:BOOLEAN; JUST_SHUFFLED :BOOLEAN; CARDVAL :INTEGER; REPLY :CHAR; HOLVAL,XRANK :INTEGER; HOLCARD :BOOLEAN; CHOICE :SET OF CHAR; XHOLE,YHOLE :INTEGER; HOLSUIT,HOLRANK :STRING; DBLDOWN,PAIR,SPLIT :BOOLEAN; SPLITHAND,DBLBUST :BOOLEAN; FSTCARD :INTEGER; THIRDCARD,FIRSTCARD :INTEGER; BUSTFIRST,BUSTSECOND :BOOLEAN; XOVER,YOVER :INTEGER; ACEUP :BOOLEAN; INSBET :INTEGER; CARD_ON_TABLE :ARRAY[1..52] OF BOOLEAN; CARD_NOT_IN_DECK :ARRAY[1..52] OF BOOLEAN; CARDS_NOT_SEEN :INTEGER; PROCEDURE SQUAWK; BEGIN WRITE(CHR(7)); END; procedure clear_line ( x, y : integer ); begin gotoxy ( x, y ); write ( chr ( 27 ) , 'K' ); {H-19} end; procedure clear_screen ( x, y : integer ); begin gotoxy ( x, y ); write ( chr ( 27 ) , 'J' ); {H-19} end; PROCEDURE TENCOUNT; BEGIN IF HOLCARD THEN XRANK:=HOLVAL ELSE XRANK:=RANK; IF (XRANK>9) AND (XRANK<14) THEN NUMTENS:=NUMTENS-1 ELSE NOTTEN:=NOTTEN-1; IF NUMTENS=0 THEN TENS_RATIO:=99.999 ELSE TENS_RATIO:=NOTTEN/NUMTENS; CLEAR_LINE(60,9); WRITE('Tens ratio'); CLEAR_LINE ( 62, 11 ); WRITE(NOTTEN:2,'/',NUMTENS:2); CLEAR_LINE(61,12); WRITE(TENS_RATIO:5:3); CLEAR_LINE(60,15); WRITE('Cards left'); CLEAR_LINE(65,17); WRITE(CARDSLEFT); END; PROCEDURE RANSUIT(VAR CARD:INTEGER); FORWARD; PROCEDURE COUNTERFIX; BEGIN RANSUIT(CARD); {TENCOUNT;} END; PROCEDURE CLEARTOP; BEGIN CLEAR_LINE(0,0); END; PROCEDURE SHUFMES; BEGIN CLEARTOP; GOTOXY(5,0); WRITE('SHUFFLING- HAVE A DRINK ON THE HOUSE.'); FOR WAIT:=1 TO 2000 DO WAIT:=WAIT; END; {SHUFMES} FUNCTION RND:REAL; BEGIN RND:=SEED/32767; SEED:=(103*SEED+1999) MOD 32767; IF SEED<0 THEN SEED:=SEED*(-1); END; {RND} PROCEDURE FRESHDECK; BEGIN FOR I:=1 TO 52 DO BEGIN DECK[I]:=I; END; {FOR} END; {FRESHDECK} PROCEDURE NAMECARD; BEGIN NAMRANK:=' '; {MAKE IT ONE BYTE LONG} NAMRANK[1]:=CHR(RANK+48); {SO THIS WILL WORK} IF RANK=1 THEN NAMRANK:='ACE ' ELSE IF RANK>9 THEN BEGIN CASE RANK OF 10:NAMRANK:='10 '; 11:NAMRANK:='JACK '; 12:NAMRANK:='QUEEN'; 13:NAMRANK:='KING '; END {RANKCASE} END; BEGIN CASE SUIT OF 1:NAMSUIT:='CLUBS '; 2:NAMSUIT:='DIAMONDS'; 3:NAMSUIT:='HEARTS '; 4:NAMSUIT:='SPADES '; END {SUITCASE} END; END; {NAMECARD} PROCEDURE RANSUIT; BEGIN RANK:=CARD MOD 13; IF RANK=0 THEN RANK:=13; SUIT:=(CARD-1) DIV 13 + 1; END; {RANSUIT} PROCEDURE BURN; VAR T:INTEGER; BEGIN REPEAT CARD:=DECK[CARDSLEFT]; IF CARD_NOT_IN_DECK[CARD] THEN COUNTERFIX; CARDSLEFT:=CARDSLEFT-1; UNTIL CARD_NOT_IN_DECK[CARD]=FALSE; RANSUIT(CARD); NAMECARD; GOTOXY(5,0); WRITE('Burning a'); IF (RANK=8) OR (RANK=1) THEN WRITE('n'); WRITE(' ',NAMRANK:6,' of ',NAMSUIT); FOR T:= 1 TO 5000 DO T:=T; CLEARTOP; HOLCARD:=FALSE; {TENCOUNT;} END; PROCEDURE SHUFFLE; VAR TEMP,RI:INTEGER; BEGIN SHUFMES; FOR I:=1 TO 52 DO CARD_NOT_IN_DECK[I]:=CARD_ON_TABLE[I]; CARDSLEFT:=52; FOR I:=1 TO 52 DO BEGIN TEMP:=DECK[I]; RI:=TRUNC(52*RND+1); DECK[I]:=DECK[RI]; DECK[RI]:=TEMP; END; {FOR} CLEARTOP; NOTTEN:=36; NUMTENS:=16; BURN; CARDS_NOT_SEEN:=0; JUST_SHUFFLED:=TRUE; END; {SHUFFLE} PROCEDURE NOTSEEN; BEGIN IF NOT SHUFFLED_SINCE_HOLCARD AND (BUST OR (SPLIT AND DBLBUST)) THEN BEGIN CARDS_NOT_SEEN:=CARDS_NOT_SEEN+1; END; CLEAR_LINE(58,20); WRITE('Cards not seen'); CLEAR_LINE(65,22); WRITE(CARDS_NOT_SEEN); END; PROCEDURE SETUP; BEGIN BUST:=FALSE; DBLDOWN3:=FALSE; TENS_RATIO:=0; BJACK:=FALSE; SHUFFLED_SINCE_HOLCARD:=FALSE; JUST_SHUFFLED:=FALSE; ACEUP:=FALSE; FOR I:=1 TO 52 DO CARD_ON_TABLE[I]:=FALSE; INSBET:=0; DBLBUST:=FALSE; SPLITHAND:=FALSE; BUSTFIRST:=FALSE; BUSTSECOND:=FALSE; Q:=0; PUSH:=FALSE; WIN:=FALSE; DBLDOWN:=FALSE; FSTCARD:=0; PAIR:=FALSE; SPLIT:=FALSE; XOVER:=5; YOVER:=4; XPLYR:=0; YPLYR:=YHAND0; XDELR:=26; YDELR:=YHAND0; XSPLIT:=0; YSPLIT:=YHAND0+9; FOR I:=1 TO 3 DO BEGIN HANDVAL[I]:=0; NUMACES[I]:=0; HANDSIZE[I]:=0; END; {FOR} END; {SETUP} PROCEDURE SHOWHAND; VAR X,Y,CN :INTEGER; BEGIN CASE PERSON OF PLAYER: BEGIN YPLYR:=YPLYR+1; Y:=YPLYR; X:=XPLYR; END; DEALER: BEGIN YDELR:=YDELR+1; Y:=YDELR; X:=XDELR; IF SPLIT THEN YSPLIT:=YHAND0; END; END; {CASE} NAMECARD; GOTOXY(X,Y); CN:=Y-YHAND0; IF SPLITHAND THEN CN:=Y-YSPLIT; WRITE(CN:3,')',NAMRANK:6,' OF ',NAMSUIT); HOLCARD:=FALSE; END; {SHOWHAND} PROCEDURE SCORE; VAR CARDVAL:INTEGER; BEGIN CASE PERSON OF PLAYER:IF SPLITHAND THEN I:=3 ELSE I:=1; DEALER:I:=2; END; {CASE} CARDVAL:=RANK; IF RANK>10 THEN CARDVAL:=10; IF RANK=1 THEN BEGIN CARDVAL:=11; NUMACES[I]:=NUMACES[I]+1; END; HANDVAL[I]:=HANDVAL[I]+CARDVAL; WHILE (HANDVAL[I]>21) AND (NUMACES[I]>0) DO BEGIN HANDVAL[I]:=HANDVAL[I]-10; NUMACES[I]:=NUMACES[I]-1; END; IF HANDVAL[I]>21 THEN BUST:=TRUE; END; {SCORE} PROCEDURE PSCORE; BEGIN IF SPLITHAND THEN I:=3 ELSE I:=1; GOTOXY(XPLYR+6,YPLYR+1); WRITE('TOTAL = ',HANDVAL[I]:3); END; {PSCORE} PROCEDURE HSCORE; BEGIN GOTOXY(XDELR+6,YDELR+1); WRITE('TOTAL = ',HANDVAL[2]:3); END; {HSCORE} PROCEDURE WINNINGS; BEGIN IF NOT PUSH THEN BEGIN TBET:=BET; IF DBLBUST THEN DOLLARS:=DOLLARS-BET; IF DBLDOWN AND (NOT SPLITHAND) THEN TBET:=BET+BET; IF DBLDOWN3 THEN TBET:=BET+BET; IF WIN THEN DOLLARS:=DOLLARS+TBET ELSE DOLLARS:=DOLLARS-TBET END; CLEAR_LINE(XWIN,YWIN); WRITE('In U.S. of A. Dollars you have $',DOLLARS); END; {WINNINGS} PROCEDURE DOWHAT; BEGIN CLEAR_LINE(XOVER,YOVER); REPEAT GOTOXY(XOVER,YOVER); WRITE('YOUR MONEY ? '); READ(REPLY); IF REPLY IN [ 'a'..'z' ] THEN REPLY := CHR ( ORD ( REPLY ) - 32 ); CLEAR_LINE(XOVER,YOVER+1); UNTIL REPLY IN CHOICE; IF (REPLY='D') AND (HANDSIZE[1]>2) AND (NOT SPLIT) THEN BEGIN CLEAR_LINE(XOVER,YOVER+1); WRITE('NO-NO, NOT AFTER 3 OR MORE!!'); SQUAWK; DOWHAT; END; IF (REPLY='S') AND (NOT PAIR) THEN BEGIN CLEAR_LINE (XOVER,YOVER+1); WRITE ('YOU DON''T HAVE A PAIR TO SPLIT!'); SQUAWK; DOWHAT; END; IF SPLIT AND (REPLY='S') THEN BEGIN CLEAR_LINE(XOVER,YOVER+1); WRITE('YOU CAN''T SPLIT A SPLIT PAIR!'); SQUAWK; DOWHAT; END; END; {DOWHAT} PROCEDURE NOSHOW; VAR CN:INTEGER; BEGIN YDELR:=YDELR+1; GOTOXY(XDELR,YDELR); CN:=YDELR-YHAND0; WRITE(CN:3,') ?????????'); XHOLE:=XDELR; YHOLE:=YDELR; HOLSUIT:=NAMSUIT; HOLRANK:=NAMRANK; HOLVAL:=RANK; END; {NOSHOW} PROCEDURE INSTRUCTIONS; BEGIN GOTOXY(XINST,YINST); WRITE('H)it, G)ood, D)oubledown, S)plitpair, Q(uit'); END; {INSTRUCTIONS} PROCEDURE PLAYERIN; VAR C,B:CHAR; BEGIN (*$I-*) CLEAR_LINE(XBET,YBET); IF (NOT CHANGED_BET) AND (BET<>0) THEN BEGIN WRITE('HOUSE LIMIT IS $200.. BET LIMIT ? (Y/N) '); READ(B); IF B<>'N' THEN BET:=200 ELSE BET:=0; END ELSE BEGIN CHANGED_BET:=TRUE; REPEAT CLEAR_LINE(XBET,YBET); IF BET=0 THEN BEGIN REPEAT CLEAR_LINE(XBET,YBET); (*$I BJACK.1.TEXT*) ======================================================================================== DOCUMENT :usus Folder:VOL11:chase.text ======================================================================================== (*$S+*) PROGRAM CHASE; CONST MAN = 'O'; {SYMBOL FOR THE MAN} EDGE = 'I'; {SYMBOL FOR THE FENCE} OBST = '*'; {SYMBOL FOR AN OBSTRUCTION} ROBOT = 'R'; {SYMBOL FOR A ROBOT} BLANK = ' '; {AN ASCII BLANK} DROB = 3; {STARTING NO OF ROBOTS} ROBMAX = 20; {MAX NO OF ROBOTS ALLOWED} XMAX = 39; {MAX HORIZONTAL FIELD DIMENSION} YMAX = 14; {MAX VERTICAL FIELD DIMENSION} TOP = 2; {SPACE ABOVE FIELD} SIDE = 5; {SPACE TO LEFT OF FIELD} CLRSCRN = 26; {CLEAR SCREEN CODE} VAR FIELD : PACKED ARRAY[0..XMAX,0..YMAX] OF CHAR; AGAIN,PLAY : BOOLEAN; WIN : BOOLEAN; MI,MJ : INTEGER; {COORDINATES OF THE MAN} R : INTEGER; {NUMBER OF ROBOTS LEFT} RI,RJ : ARRAY[1..ROBMAX] OF INTEGER; {ROBOT COORDINATES} SEED : INTEGER; DIFF : INTEGER; {DIFFICULTY} IDIFF : 0..10; {INITIAL DIFFICULTY} GAMENU : INTEGER; {GAME NUMBER} M : CHAR; NROB : INTEGER; {NUMBER OF ROBOTS} WINS : INTEGER; {NUMBER OF GAMES WON} GOODCHAR : SET OF CHAR; {GOOD CHARACTERS} MOVES : INTEGER; {COUNT OF MOVES} CRASH : INTEGER; {NO OF ROBOTS "CRASHED"} FUNCTION RND(LO,HI:INTEGER):INTEGER; {RANDOM NUMBER GENERATOR} VAR Q :REAL; I :INTEGER; BEGIN Q:=SEED/32767; SEED:=(103*SEED+1999) MOD 32767; IF SEED<0 THEN SEED:=-1*SEED; RND:=TRUNC((HI-LO)*Q)+LO; END; PROCEDURE DOMOVE(COL,ROW:INTEGER;SYMBOL:CHAR); {DISPLAY SYMBOL AT I,J ON FIELD} BEGIN GOTOXY(COL,ROW); {POSITION CURSOR} WRITE(SYMBOL) END; {END OF DOMOVE PROCEDURE} PROCEDURE CLEARSCREEN; BEGIN WRITE(CHR(27),CHR(69)) {h-19 specific} END; PROCEDURE CURSOR_OFF; BEGIN WRITE(CHR(27),'x5'); {H-19} END; PROCEDURE CURSOR_ON; BEGIN WRITE(CHR(27),'y5'); {H-19} END; PROCEDURE INSTRUCTIONS; {DISPLAY INSTRUCTIONS} VAR M:CHAR; BEGIN CLEARSCREEN; WRITELN('WELCOME TO THE WONDERFUL EXCITING GAME OF CHASE':60); GOTOXY(0,3); WRITE('WOULD YOU LIKE INSTRUCTIONS ? (Y OR N) ':55); READ(M); IF M in ['Y', 'y' ] THEN BEGIN WRITELN;WRITELN; WRITELN(' HERE ARE SOME INSTRUCTIONS'); WRITELN('YOU,"O",ARE IN A HIGH VOLTAGE MAZE.'); WRITELN('THE ROBOTS,"R",ARE TRYING TO DESTROY YOU.'); WRITELN('TO WIN, YOU MUST DESTROY THE ROBOTS.'); WRITELN('THIS IS DONE BY RUNNING THEM INTO FENCE POSTS,"*",'); WRITELN('OR BY RUNNING THEM INTO EACH OTHER.'); WRITELN('THE DIAGRAM BELOW THE MAZE SHOWS HOW YOU CAN MOVE'); WRITELN('THE ROBOTS WILL TRY TO FOLLOW YOU.'); WRITELN('THERE ARE 3 ROBOTS TO START FOR A BEGINNER.'); WRITELN('THE NUMBER WILL INCREASE AS YOU WIN GAMES !'); WRITELN; WRITELN(' GOOD LUCK!!!!!') END; END; {END OF INSTRUCTIONS} PROCEDURE STARTGAME; VAR SK: CHAR; BEGIN WRITELN;WRITELN;WRITELN; WRITE('ENTER A NUMBER FOLLOWED BY RETURN ':51);READLN(SEED); REPEAT CLEARSCREEN; WRITELN(' HOW GOOD A PLAYER ARE YOU ?'); WRITELN; WRITELN(' BEGINNER - B'); WRITELN(' INTERMEDIATE - I'); WRITELN(' EXPERT - E'); WRITELN(' OLD PRO - P'); WRITELN; WRITE(' TYPE IN YOUR SKILL '); READ (SK); WRITELN; IF SK IN ['a'..'z'] then sk := chr ( ord ( sk ) - 32 ); IF NOT (SK IN ['B','I','E','P']) THEN BEGIN GOTOXY(10,10); WRITE(' WHAT WAS THAT AGAIN PLEASE ? ',CHR(7)); READ (SK); IF SK IN ['a'..'z'] then sk := chr ( ord ( sk ) - 32 ); WRITELN END; UNTIL (SK IN ['B','I','E','P']); CLEARSCREEN; CASE SK OF 'B': IDIFF:=0; 'I': IDIFF:=1; 'E': IDIFF:=3; 'P': IDIFF:=5; END; END; PROCEDURE INITIALIZE; {SET UP BLANK FIELD SURROUNDED BY FENCE} VAR I,J:INTEGER; BEGIN FOR I:=0 TO XMAX DO BEGIN FOR J:=0 TO YMAX DO IF((I=0) OR (I=XMAX) OR (J=0) OR (J=YMAX)) THEN FIELD[I,J]:=EDGE ELSE FIELD[I,J]:=BLANK END; END; {END OF INITIALIZE} PROCEDURE INNERFIELD; {SET UP MAN, ROBOTS AND OBSTRUCTIONS} VAR I,J,L,POSTS:INTEGER; BEGIN CURSOR_OFF; MI:=RND(1,XMAX-1); MJ:=RND(1,YMAX-1); {LOCATE MAN AT ANY RANDOM POSITION} FIELD[MI,MJ]:=MAN; R:=NROB; FOR L:=1 TO R DO {NOW DO R ROBOTS} BEGIN REPEAT I:=RND(0,XMAX);J:=RND(0,YMAX); UNTIL FIELD[I,J]=BLANK; FIELD[I,J]:=ROBOT; RI[L]:=I; RJ[L]:=J END; POSTS:=RND(25,35); {NOW SET UP 25 TO 35 POSTS} FOR L:=1 TO POSTS DO BEGIN REPEAT IF DIFF>3 THEN BEGIN I:=RND(0,XMAX); J:=RND(0,YMAX) END ELSE BEGIN I:=RND(1,XMAX-1); J:=RND(1,YMAX-1) END; UNTIL FIELD[I,J]=BLANK; FIELD[I,J]:=OBST END; CURSOR_ON; END; {END OF INNERFIELD} PROCEDURE MAP; {DISPLAY PLAYING FIELD} VAR I,J:INTEGER; BEGIN CURSOR_OFF; CLEARSCREEN; WRITELN('GAME DIFF ROBOTS WINS MOVE':79); WRITE(' ':44,GAMENU:3,DIFF:5,R:8,WINS:10,MOVES:8); GOTOXY(0,0); FOR J:=0 TO YMAX DO BEGIN FOR I:=0 TO XMAX DO WRITE(FIELD[I,J]); WRITELN END; WRITELN; WRITELN('7 8 9 Q = QUIT'); WRITELN('4 X 6 5 = NO MOVE'); WRITE('1 2 3 MOVE => '); CURSOR_ON; END; {END OF MAP} PROCEDURE MOVE; {ENTER YOUR MOVE FROM KEYBOARD} VAR M : INTEGER; C : CHAR; BAD : BOOLEAN; BEGIN BAD:=FALSE; REPEAT WRITE(' ',CHR(8)); READ (C); IF C IN ['a'..'z'] then c := chr ( ord ( c ) - 32 ); IF NOT (C IN GOODCHAR) THEN BEGIN GOTOXY(4,21); BAD:=TRUE; WRITE('BAD MOVE, PLEASE TRY AGAIN ':33,CHR(7)) END; UNTIL (C IN GOODCHAR); IF BAD THEN BEGIN GOTOXY(4,21); WRITE(' ':40); GOTOXY(10,22); END; IF C='Q' THEN BEGIN PLAY:=FALSE; WIN:=FALSE END; CURSOR_OFF; M:=ORD(C)-48; FIELD[MI,MJ]:=BLANK; DOMOVE(MI,MJ,BLANK); CASE M OF 7: BEGIN MI:=MI-1; MJ:=MJ-1 END; 8: MJ:=MJ-1; 9: BEGIN MI:=MI+1; MJ:=MJ-1 END; 4: MI:=MI-1; 5: ; 6: MI:=MI+1; 1: BEGIN MI:=MI-1; MJ:=MJ+1 END; 2: MJ:=MJ+1; 3: BEGIN MI:=MI+1; MJ:=MJ+1 END END; MOVES:=MOVES+1; IF FIELD[MI,MJ] = BLANK THEN BEGIN DOMOVE(MI,MJ,MAN); FIELD[MI,MJ]:=MAN END ELSE BEGIN IF FIELD[MI,MJ] = EDGE THEN BEGIN WIN:=FALSE; PLAY:=FALSE; WRITELN('OUCH, YOU GOT ELECTROCUTED!') END ELSE BEGIN IF FIELD[MI,MJ] = ROBOT THEN WRITELN('THWACK! YOU RAN INTO A ROBOT (TURKEY!)') ELSE WRITELN('ZZAP! YOU RAN INTO AN ELECTIFIED POST'); WIN:=FALSE; PLAY:=FALSE END; END; CURSOR_ON; END; {END OF MOVE PROCEDURE} PROCEDURE ROBOTMOVE; {COMPUTE MOVE FOR R OR FEWER ROBOTS} VAR M,L,I,J:INTEGER; BEGIN FOR L:=1 TO NROB DO BEGIN IF((RI[L]<>0) AND (WIN)) THEN BEGIN FIELD[RI[L],RJ[L]]:=BLANK; DOMOVE(RI[L],RJ[L],BLANK); IF MI>RI[L] THEN RI[L]:=RI[L]+1; IF MIRJ[L] THEN RJ[L]:=RJ[L]+1; IF MJ2 THEN DIFF:=IDIFF+1; IF WINS>5 THEN DIFF:=IDIFF+2; IF WINS>8 THEN DIFF:=IDIFF+3; IF WINS>11 THEN DIFF:=IDIFF+4; IF WINS>15 THEN DIFF:=IDIFF+6; IF WINS>20 THEN DIFF:=IDIFF+8; IF WINS>30 THEN DIFF:=IDIFF+12; NROB:=DROB+2*DIFF; IF NROB > 18 THEN NROB:=19; END; END; END; WRITE(CHR(27),'t'); {sets keypad shifted mode} END. ======================================================================================== DOCUMENT :usus Folder:VOL11:contents.text ======================================================================================== USUS(UK) SOFTWARE LIBRARY VOLUME 1 23RD MARCH 1982 Contents of this volume Austin Tate, ERCC 22-Feb-82 ------------------------------------------------------------------------- This volume holds a mailing address data base, mailing label and forms letter production utility called MAIL along with associated text files and utilities. See the file MAIL.READ.TEXT for details of the files included. ======================================================================================== DOCUMENT :usus Folder:VOL11:mail.doc.text ======================================================================================== -------------------------------------------------------------------------- MAIL 19th February, 1982 -------------------------------------------------------------------------- Preface: Some users are going to wish to use only the word processing capabilities of this program. Others are going to want to use all the facilities that are offered. A word to the wise is in order. Take your time and understand what the manual has to say BEFORE you run the program. It is always a good idea when using software to do so, but in this case it is essential. Thank you and good luck. The program and manual were begun by Patrick Horton at Associated Computer Industries. They were subsequently updated and modified by Austin Tate at the Edinburgh Regional Computing Centre. The program and manual are copyright (c) 1982 by Austin Tate, ERCC. TABLE OF CONTENTS ------------------------------------------------ Welcome Files in the System Flags (part 1) getting started prompt line preliminary functions: O)ptions D)escriptions basic functions A)dd C)hange D)elete R)estore F)ind 1)st ' ')step Z)ero S)ort O)ptions Input and Output files Flags (part 2) Mailing Labels Format Letter Format Page Layout Quit option M)labels L)etter final commands Q)uit K)runch I)nit word processing special characters ^ page throws = carriage return suppressed ~ literal line direction (~ is default) [: :] margin and spacing specification {% %} flagged paragraphs (* *) tokens for fields of selected records \\ include mailing label in letter flagged paragraphs field designators greeting tokens spacing and margins general rules summary Notes Implementation notes mailing labels file format overview of operation of MAIL Restriction on file sizes ERCC Notes Initialisation of MAIL data files Conversion of MAILER names and addresses into MAIL Increasing the size of a MAIL data file Data Manipulation on records of your own description Producing files for SORT/MERGE operations Welcome to the Mail program users manual. The main purpose of a manual like this, and perhaps the hardest to achieve, is to provide the user with an intuitive understanding of the program. It is the task of the writer to convey the feeling of being in complete control of the program to the user. This feeling of confidence probably defines the difference between a useful program and one which is never used. Hopefully this manual will convey to you the fact that the program is actually quite simple to use although it has some relativly complicated features. The program is designed to maintain a mailing list and allow for the production of two types of output: mailing labels and form letters. The form letter producer is essentially a text processor designed to work best towards a certain goal - that of producing form letters. The program is also designed to be very compatible with the UCSD p-System, utilizing the same single stroke commands and descriptive prompt lines. In other words it was made to look like part of the system. Files in the system ------------------- There are several files associated with the program that you as a user will be involved with. The first is the code file for the program itself: MAIL.CODE. This is the file that you will instruct the system to execute. The second file is called MAIL.INFO.DATA and contains the working parameters of the system. These parameters are variables that determine how the functions of the program will act. They are kept in a file so that you don't have to set up the operating environment everytime you run the program. Some examples of the parameters kept in this file are: left and right margins for letters, number of labels wide to a page, and output file (printer port or filename). A complete description of everything in this file will be given later. The third file you will run into is the mailing system data file. The default name for this is MAIL.DATA, although, as you will see, you can specify any name you wish for this file. The data in the file is stored as records. Records contain data stored in two different formats. The first is fields, which are essentially strings of character data such as first name, or address. The second format or type of data stored in a record is called a flag. There are 48 flags stored with each record. Each flag is essentially an on-off switch, or a yes-no bit of information, that you set when you add the record to the file. The description or meaning of each flag is arbitrarily set by you and is stored in the file MAIL.INFO.DATA. Also stored in MAIL.INFO.DATA are 48 flags which are used as a mask by which records can be selected for output for labels or letters. For now, all you need to know is that there are 48 flags stored with each record in MAIL.DATA, and 48 flags and 48 descriptions stored in the file MAIL.INFO.DATA. The fourth file associated with the system is the input file for the L)etters command of the program. This file may have any name ending in '.TEXT', and contains text along with special word-processing symbols and tokens. The exact format of the file will be described later. The file name for this file is stored in the file MAIL.INFO.DATA as the I)nput file. Several sample input files are available: MAIL.E.G.TEXT gives a brief explanation of the MAIL system itself. It is suitable for use with MAIL as it is normally distributed (i.e., before changes are made to the O)ptions set by default). The MAIL system will assume that it should use this example text file for processing by the L)etters command if the MAIL O)ptions are not altered. MAIL.LETT.TEXT is a short form letter and may be used as a guide for constructing your own letters for use with MAIL. MAIL.FORM.TEXT is a text which when processed by the L)etter command in MAIL will produce a form containing all the data stored about an individual in the MAIL data file. The fifth and last file associated with the program has been previously mentioned. It is the file to which output will be directed. It may not even be a file, but may be a port-device such as 'REMOTE:', or 'PRINTER:'. When wishing to output things to the screen, '#2:' should be used rather than 'CONSOLE:' as the program recognizes it and will compensate for the fact that the prompt lines and the output are both going to the same place. The name for this file is also stored in the file MAIL.INFO.DATA. First Things First ------------------ It is important that you have a good overview of the internal workings of the program before you actually start to use it. Otherwise, you might not realize that there was actually a more efficient way to do something than the one you had chosen. Back to the Flags ----------------- Summing up what you have already learned about flags, you know that there are 48 flags and descriptions stored in the format file, and 48 flags stored with each record in the data file. It was also previously mentioned that you will arbitrarily set up the meanings associated with each flag. This should be done before you add records so that you may set the flags on the records as you add them, rather than going back over them later when you decide what the flags mean. The flags will be used for three purposes. They will be used for the selection of records for output, for the inclusion of paragraphs or sentences into letters and for the construction of a 'greeting' in form letters. You can determine which records will be output to labels or letters by setting the flags in MAIL.INFO.DATA (henceforth called system flags). These flags are used as a mask against which the individual record flags are compared. There are two options for selecting a record: either all flags must match or any single flag must match. This and other options are set up in the O)ptions part of the program. You can mark out part of the text in a letter file into what is called a flagged paragraph using special characters which will be described later. Then the paragraph (or sentence, or word) will only be included in a certain letter if the corresponding flag is set. You can also determine the form of greeting used in form letters where no overriding specification is given for a particular record. This is done by setting some of a special set of five flags associated with the greeting (flags 44-48) - see later. It should be pointed out that it is not nessecary to use the flags, only sometimes beneficial. Most people will never use all 48 flags. Usually about 10 will be sufficient to categorize the different records in the file. Getting Started --------------- Although you should wait until you have a good understanding of the program to add data to it, now is a good time to set up the files associated with the program. When the UCSD p-System is running and at the main command level, you should execute (by typing 'X') the MAIL program from whichever disk it resides on. After a few seconds the program will say: 'Give volume for file MAIL.INFO.DATA (...):' You should respond with something like '#4:', or '4', or 'MAIL1:', or the name of a presently active diskette. The default would be '#5:'. The program will then inform you that it is making the file. After this, the program will say that it couldn't find the file MAIL.DATA, and ask you to enter another filename. If you wish to call your file MAIL.DATA then enter a blank carriage return, otherwise enter another filename. Later on, after you have already used the program, entering this filename would be all you have to do; however since you are creating it you have to specify some other things now. The program will ask you on which volume you wish to place the file. Respond with the number or name of a volume which has at least 5 blocks or enough room to handle a file of the size you desire (The default for this would be '#5:'). The program will then ask you the size in blocks for the file that you wish to create. Five blocks is the minimum, and if you enter a return it will maximize the size of the file to the number of remaining blocks on the specified diskette. The file may be of any size, but you should know now that the program's sort utility can only handle 250 blocks. If you know you have a large data base of information to enter type 250 here. After all of this is done the program will return with the Mail prompt line. If these files already exist (as in the second time through) then the program will go directly to the prompt line. Any time you run the program it will look for MAIL.DATA. If not found you will be able to create it or specify another file. If the other file you specify does not already exist you will be allowed to create it. The files MAIL.DATA and MAIL.INFO.DATA will be found, if existent, on either the #4 or #5 disk drives. The program will work with single drive systems as well. Prompt line ----------- So now you have the files and you should see the prompt line: >Mail: A)dd, C)hange, D)elete, F)ind, 1)st, ' ')step, O)ptions, Q)uit ? You can view the extended prompt line: >Mail: L)etter, M)labels, S)ort, I)nit, K)runch, R)estore, Z)ero ? by entering a '?'. Options ------- The first command you should explore and work with is the O)ptions command. This allows you to set up the parameters in the file MAIL.INFO.DATA. So type 'O' for O)ptions and in a few seconds you should get a screen full of data, along with the prompt line: O)ptions: D)scrps, F)lags, M)labels, L)etter, I)nput, O)utput, Q)uit: Quickly read over the different fields presented on the screen. The environment should be set up to input a file called *MAIL.E.G.TEXT and output it to the screen. Type 'D' for D)escriptions, and we will begin to actually set up the descriptions for our flags. Descriptions ------------ You should set one descriptor for every type of record you are going to use in the file. To do this type the number of the descriptor followed by a return, followed by the description you wish to tag to that number and another return. Some descriptors that have already been mentioned as potentially useful are: Employee, Friend, Vendor, and OEM. The important thing is that you set as many or more than you need right now, before you add records to the file, so use your imagination. Do you need a breakdown on the number of employees? Would it be useful if you knew if the person was married or had kids? There are many that you can probably think of. Be sure that you have set as many as plausible before proceeding. You may have noticed that flags 44-48 already have descriptions. They are prefix, fname, minit, lname, and suffix. There exists a way to combine the different fields of the label along with the letter text file. These flags allow you to pre-determine what will fall into a super-field called the greeting. Since in the data file the name is broken up into the prefix, first name, middle initial, and so on, there must exist a way of putting them together. Although you could include the tokens for each of the individual fields (the method for this will be described later) it would be easier if there was one field which would be a common greeting. These five flags represent what parts of the file data will go into the greeting- name. So given the name 'Mr. Bob R. Smith, PhD.', and the setting of the flags for Prefix and Lname, the greeting field would come out to 'Mr. Smith'. It is important that this is understood before the data is added to the file. Once you have set the descriptions you may type a 'Q' for Q)uit. You should now see the Options prompt line again. You may type 'Q' for quit again followed by 'U' for update and the information will be written out to the file. Now you are ready to begin adding information to the file. Basic Functions --------------- The basic functions to establishing a mailing list with the program MAIL are: A)dd, C)hange, D)elete, R)estore, F)ind, 1)st, ' ')step, S)ort, and Z)ero. In addition to these basic functions there are the following output functions: M)labels (print mailing labels), L)etter, and O)ptions (which allows you to modify the output parameters, etc). There is also a class of functions termed final functions because of their file closing capabilities. They are Q)uit (which has the sub-options U)pdate and E)xit without updating), K)runch, and I)nitialize. This repertoire of functions allows for a diversified approach to the management of the data. Adding Records -------------- Once you have all the necessary files, and have set up the descriptions associated with the flags, you may begin adding records. Enter the command A)dd and then enter the necessary information. The miscellaneous field may be used for any purpose you wish. It may be broken down into as many as ten sub-fields by the use of backslashes. These subfields or the whole field may be included in the text of the form letter (as can any other field in the file) by including a token which will be described later. After setting the flags that are associated with the particular record the program will then display the record and ask 'O.K.? '. Upon answering 'Y' or 'y' for yes, you will then be allowed to add more records or to process the record using any of the other commands. Changing Information -------------------- To change the data in the file merely position the window at the record you wish to change using the commands S)tep or F)ind, and then enter the command C)hange. You may then change any field in the record or you may Q)uit. Whenever you change a record, a backup copy of the original record is made and is available for your use should you want to make a change for some temporary purpose or should you find the changes you made unsatisfactory. To access the back-up on an individual record basis you may type R)estore and the record will be retrieved and put back into its original place. If you wish to restore all the records then you will have to enter either I)nit OR Q)uit and E)xit without updating. However, the commands I)nit and Q)uit E)xit without updating have the unpleasant side effect of also removing any records you might have added to the work file, so be careful with their usage. Deleting Records ---------------- To delete a record, position the window at the record and type 'D' for D)elete. A D)elete is not made permanent until a K)runch or U)pdate is executed. This is the same as with C)hange. Also the same is the fact that I)nit and Q)uit E)xit without updating will undo a D)elete. In other words an I)nit or Q)uit E)xit without updating will restore any D)eletes, but as with change, you will lose any A)dds you might have done..... so use the commands I)nit and Q)uit E)xit without updating cautiously. Restore ------- The command R)estore allows one to retrieve the information that was in a record before it was C)hanged. To use the command merely position the window on the record you wish to restore and type 'R' for R)estore and the record will be returned to its original form. In this way you can change the data in a record for some temporary purpose without losing the original information. Finding a Record ---------------- The command F)ind allows you to look for a record. You may search by R)ecnumber, any field in the file, or any previously entered searchkey. To find a certain record number enter the F)ind command followed by a R)ec# command and then the record number you wish to be at. The program will then position itself as close as possible to that record number. If you wish to find by a certain field after entering the F)ind command, enter the proper field designator (ie. 'F' for F)irstname) then enter the identifier you wish to find filled with question marks where you don't care. (ie. The wildcard '92???' for zip code would find all zip codes starting with 92. The wildcard '92?' would find all three digit zip codes starting with 92. ) Find commands using field specifications begin their search at the current record and search in the set direction until the start or end of the file is reached. The symbol '$' may be used as the last character of a wildcard to mean "and any further characters remaining". Thus partial matches may be specified. If you already have used the command you may continue processing from the record you are at searching for the wildcard field you previously entered by entering a '^' instead of a field designator. 1st - First record ------------------ Since it is often necessary to return to the first record of the data base, '1' for 1)st is provided as a shorthand for F)ind R)ecordnumber 1 at the command level of MAIL to perform this function. Step ---- By typing a space (or blank) you may move the window one record in the direction specified by the arrow at the beginning of the prompt line. The commands '>', '+' and '.' will set the arrow in a positive direction wheras the commands '<', '-' and ',' will set the arrow in the negative direction. Sort ---- The command S)ort allows you to sort the file by any field within the file. When a S)ort is executed a K)runch is also done. This is to insure the integrity of the file. To sort the file enter a S)ort command followed by the field designator for the field that you wish the file to be sorted by. Approximately one point two seconds maximum per record are required for the sort on a Pascal Microengine. The sort takes approximately two point four seconds maximum per record for a Z-80 based microcomputer. Zero ---- The command Z)ero allows you to zero out the mailing labels file. However, when it asks 'Caution: Type 'YES' if you want to zero out the file:', you must type out the word 'YES'. A 'Y' response is not sufficient. This is a safeguard to stop one from accidently destroying the file. This change is NOT reversable by the I)nit or Q)uit Exit without updating commands, IT IS PERMANENT. Options ------- The Options command allows you to set the input and output file, output formatting parameters, and the record selection criteria. The sub-commands under O)ptions are: D)escriptions, F)lags, M)ailing labels, L)etter, I)nput, and O)utput. The next few paragraphs define the action of the commands under the O)ptions command. Input and Output ---------------- The command O)utput allows one to change the device to which the output will be directed. The terminal is designated as '#2:', the printer port is '#6:' or 'PRINTER:', and the remote port is '#8:' or 'REMOUT:'. You may also specify a filename such as '#5:MAILING.TEXT' as your purpose dictates. The I)nput command refers to the input file used in producing L)etters. The command will only allow the entry of a legitimate file that is available on a disk presently active in the system. This file contains text along with optional formatting information. The exact format of the formatting information will be included in the section 'Word Processing'. Flags ----- S)et and R)emove may be used to alter the flags used for record selection in the L)etter and M)labels MAIL commands. There are two different O)ptions for the use of the flags. The first - A)ll - specifies that for each match flag set, the corresponding record flag must also be set. Hence all flags must match before any record will be output. The second option - S)ingle - specifies that if any single record flag is in the set of selection critera then the record will be included for output. You may set the D)escriptions associated with each flag arbitrarily. The only descriptions that the program reserves for its own use are: Prefx, Suffx, Lname, Fname, and Minit. If these reserved flags are S)et, they will be used as standard flags for creating the greeting token when processing letters. If none of these are set, a default form of greeting is used. You may dump the current flags set and descriptions by entering a D)ump command under the sub-command: F)lags. Mailing Labels Format --------------------- The variable parameters for mailing labels are: type - may be rolodex or envelope (rolodex includes phone number) number of mailing labels wide to a page. vertical tab between rows of labels left margin after EACH label Letter Format ------------- For outputting Letters, the parameters that are contained under the O)ptions command are as follows: the directive character used in letters (the default is '~') number of characters per line of text number of lines per page of text top margin left margin right margin paragraph margin (indentation) paragraph widow (do not start a new paragraph if within this number of lines from the bottom of the page) starting page number pagination (on-off) justification (on-off) stop between pages (on-off) form feed between pages (on-off) flagged paragraph matching option (A)ll or S)ingle) (Recall that there was an option as to whether a single flag was sufficient or if all flags were to match before a record would be output. As it was for the selection of records so it is for the inclusion of paragraphs. There is an option by which you can determine whether to include a paragraph if a single flag matches or if it is necessary that all flags must match.) The method of changing any of these parameters is straightforward and should be self-explanitory upon the running of the program. Page Layout ----------- Each line of text is made up as follows: <...left margin...><...text...><...right margin...> <...............characters per line...............> At the start of each paragraph, the text is indented the set number of characters for the paragraph margin as well as the left margin (ie the paragraph margin is the number of characters to be indented from the left margin edge). When paging is NOT selected, a number of blank lines equal to the set top margin are output for each letter and then the whole document follows on a line by line basis (subject to the formatting options embedded in the letter itself). When paging is selected, the pages are processed as follows:- 1. top margin blank lines 2. text lines at the required line spacing 3. a 5 line footer which on letters over one page long will have a page number on the 3rd line 4. an optional form feed (for sheet feeders, etc) 5. an optional pause to allow the user to manually insert or align paper in the printer. 1, 2 and 3 together comprise the set number of lines per page. Quit option ----------- Once you have entered the O)ptions command you may make changes to any of the parameters listed above until such a time as you decide to Q)uit. Upon Q)uitting you have three options. R)eturning allows you to continue changing parameters. U)pdating makes permanent any changes you have made during O)ptions. Lastly, E)xit without updating allows you to return the output parameters to the state they were in when you first entered O)ptions. M)labels -------- When an M)labels command is issued there are four choices for output. The first: S)ingle, allows a record to be added to the mailing label output queue, regardless of the flags set. The second: A)ll will loop through all records and use the flag selection criteria for adding labels for records to the output queue. The flag selection criteria must have been previously set in the O)ptions MAIL command. The command W)ildcard has a similar function to the F)ind function except that labels for EVERY record matching the wildcard are output, not just the first one. And lastly there is the R)epeat function which allows you to generate as many copies of the current record in the window as you please. Its use is straightforward and need not be discussed here. You will notice that above it was mentioned that the labels for records will be added to the 'output queue'. What this means is that if you have set the parameter for the number of labels wide to a page to three, then NO labels will be printed until three records have been added to the queue. This only applies to S)ingle print commands, as the commands A)ll, W)ildcard, and R)epeat will dump any remaining records in the queue upon completion of their loop, regardless of how many there are. Letter ------ The command L)etter has a similar function to M)labels, but there is no queue to worry about. The sub-commands: A)ll, S)ingle, and W)ildcard are available. The L)etter command, A)ll and W)ildcard options process records from the currently selected record onwards. This allows for a simple recovery mechanism in case of print failure on long form letter runs. Note that the ribbon and paper out detection lights on the printer are not monitored by the program. Therefore, the user should ensure that enough paper is available and that the ribbon will not run out before starting any long letter runs. Final Commands -------------- The commands that are included under final commands are: Q)uit, I)nit, and K)runch. Quit ---- The command Q)uit has three sub-commands. R)eturn allows you to continue the session. U)pdate performs a K)runch, (see below) then leaves the program. E)xit without updating resets the records to their original status and leaves the program. Init ---- I)nit resets the program (apart from Z)ero or any changes in O)ptions) to its beginning state. Krunch ------ K)runch makes any A)dds, D)eletes, and C)hanges permanent. Word Processing --------------- The command L)etter invokes the word processor to act upon the input file listed in the O)ptions section. The command L)etter allows for either S)ingle, A)ll (with flag criteria), or W)ildcard selection of records for combination with text. The input file is processed sequentially from start to finish for each record selected to be output. Special Characters ------------------ There are special characters, that when encountered in the input file by the program, have special functional meanings. Some of the characters are actually two character combinations that are treated as single characters. The special characters are: ^ - when the option 'pagination' is set to 'yes' throws a page when encountered as the first character of the line (ASCII 94, carat, andsymbol ...) = - when the first character in the line causes the following carriage return to be suppressed if the line evaluates to a blank line (ASCII 61, equals ...) ~ - causes the line which contains it to be output literally (not formatted into paragraphs) (ASCII 126, tilde, squiggle ...) The '~' is the default directive character. It may be altered in the O)ption section of MAIL. This could be of value on terminals which cannot generate '~'. The two character combinations are: [: , :] - (left square bracket, colon) (colon,right square bracket) (ASCII 91, ASCII 58) (ASCII 58, ASCII 93) - mark special margin and spacing values {% , %} - (left curly bracket, percent) (percent, right curly bracket) (ASCII 123, ASCII 37) (ASCII 37, ASCII 125) - mark what is termed a flagged paragraph (* , *) - (left parenthesis, asterisk) (asterisk, right parenthesis) (ASCII 40, ASCI 42) (ASCII 42, ASCII 41) - mark what is termed a 'Token' \\ - (backslash, backslash) (ASCII 92, ASCII 92) - in the interest of simplifying the usage of the text processor it is possible to insert a formatted mailing label anywhere in the text by merely including a double backslash (\\) at the beginning of a line. *** all ascii values given in decimal Flagged Paragraphs ------------------ When the character {% is encountered it is assumed to start what is called a flagged paragraph. Everything between {% and %} is considered in the paragraph, whether it be part of a line or a page, whether it contains tokens, or any other special characters. A flagged paragraph is only included if the flags on the record that is currently be output are set correctly. There are two options for the selection of a paragraph. They are S)ingle and A)ll. S)ingle means that if any single flag in the record matches one of the flags specified in the paragraph then the paragraph is output. A)ll means that all flags must match. The method for setting flagged paragraphs is that the opening '{%' is followed by a flag number (1-48) and a slash (/). As many flags as you desire may be included at the beginning of any paragraph. ie. given the flagged paragraph: {%1/2/ Hello there %} the words 'Hello there' would be included in the letter if: a) flagged paragraph option is set to A)ll and record flags 1 AND 2 are set, or: b) flagged paragraph option is set to S)ingle and record flag 1 OR 2 is set. You may also indicate that text is to be include if a flag is NOT set by listing that flag as a negative number. ie. given that the option is set to A)ll and the flagged paragraph: '{%1/-2/ Hello there %}', then the words 'Hello there' will only be included if flag 1 is set and flag 2 is NOT set. Flagged paragraphs may be nested to any level. Fields in a record ------------------ There exists a method of combining the data from the file with the letter text. The information from the file is made up of groups of letters called 'fields'. For our purposes some method of designating the fields is necessary. The designations for the fields in the record are as follows: (they may be upper or lower case) PR - prefix to the name FN - first name MN - middle initial LN - last name SU - suffix to the name TI - title CN - company name AD - address CI - city ST - state CO - country ZI - zip or post code PN - phone number MI - miscellaneous M0 to M9 parts of miscellaneous field In addition to these fields there is another field called the 'greeting' which is designated 'GR'. Greeting -------- It would be wise to discuss the concept of 'standard flags' here. Recall, if you will, that there were five flags which were reserved for system use. These flags, if set on a particular record, decide which name fields will be combined into the 'greeting'. If a particular record does not have any of the five flags set or the setting does not lead to the production of a greeting, the setting of the default standard flags are used to try to produce a greeting for the record. If no standard flags are set then the greeting field will be the prefix and the last name. If the prefix is blank then the greeting will the first name. If none of these provide reasonable results the greeting will be 'Sir'. Tokens ------ Anything on a single line falling between (* and *) is considered a token. The main use of tokens is to include some data from the record, in a formatted way, with the letter. The token '(*FN*)' evaluates to the first name from the record. So, given the phrase 'Hello there (*FN*)', and a record for 'Harry S. Smith', the letter would end up with 'Hello there Harry'. A field size designator may be included, and justification within this field is indicated by the presence of blanks within the token. ie. (* FN:60 *) - first name centered in 60 spaces. (* LN:60*) - last name right justified in 60 spaces. (*GR:60 *) - greeting left justified in 60 spaces. Sometimes it is nice to be able to have the presence or absence of a group of characters contingent on a field being blank or not. This is done by following that field with the desired characters in between equals signs. For instance when putting the personal title on a line with company name you will want a comma and a space if the title is not blank, but if the title is blank you don't want the extra comma. The way to specify this is: (*TI*)=, =(*CN*) (everything between the equals signs is included only if the title is not blank) The last aspect of tokens to be discussed is nested tokens. Tokens may be nested ONLY two deep. Any deeper tokens will cause the program to botch at that point. ie. (* (*FN*) (*MN*)= =(*LN*):60 *) will cause the first name middle initial (and blank if there is a middle initial), and last name to be combined into one field, and that larger field to be centered in 60 spaces. (* This is the name (*FN*):60 *) will cause the words: 'This is the name' to combined with the first name from the record into one large field and for this larger field to be centered in sixty spaces. (* Center This:60 *) will cause the words 'Center This' to be centered in 60 spaces. Spacing and Margins ------------------- Anything between '[:' and ':]' is considered for parsing as a spacing designator or a margin designator. [:L30:] says set the left margin to 30, [:R30:] does the same thing for the right margin. [:S2:] means switch to double spacing, [:S1:] means switch to single spacing. These parameters are reset to their default settings upon the start of a new paragraph. General Rules ------------- The program will take sentences from the file and combine them into paragraphs. Any blank line is assumed to start (or end) a paragraph. Hence the necessity of the '~' special character. If you have a line in a letter that consists only of (* FN:60 *) and another line that consists of only (* LN:60 *) then upon output these two lines will be combined into one line of a paragraph and the spacing information in the letter will be ignored to allow for right justification. If the spacing layout is to be preserved, a direction character ('~' by default) should be included anywhere in a line. When a direction character is encountered, the line will be output without justification or other layout changes (the '~' will be removed). The only other character that needs further explaining is the '=' at the beginning of a line. This means that if the line evaluates to a blank line then DO NOT count the carriage return at the end of the line. One use for this is: given two lines: ~(* (*FN*) (*LN*) *) =~(* (*TI*)=, =(*CN*) *) there would be no blank line if there were no company or title. This is usually used on letterheads containing a mailing label. Summary ------- This concludes the user manual for the program Mail. There is a file of examples called 'MAIL.E.G.TEXT' which you should dump and then run through the letter processor so you can see exactly how it works in practice. Please direct any questions or comments to the: ERCC Microcomputer Support Unit in the first instance. Notes ----- I Implementation Notes -------------------- Format of MAIL data file ------------------------ For anyone wishing to access the mailing labels data the file format is defined as follows: TYPE labelrec = RECORD code :STRING[6]; lname :STRING[15]; fname :STRING[10]; minit :STRING[2]; prefx :STRING[5]; suffx :STRING[6]; title :STRING[15]; coname :STRING[30]; phone :STRING[15]; address:STRING[30]; city :STRING[15]; state :STRING[2]; country:STRING[15]; zip :STRING[8]; misc :STRING[90]; flags :ARRAY[1..48] OF BOOLEAN; END; Overview of the operation of the MAIL program --------------------------------------------- Mail System Data File: The mail system maintains a direct access file of mail records. Record 0 is special and holds the current maximum record in the zip field (as a string). The system can claim space for new records so long as there is unused space on the disk following the current mail records file. So, it is straightforward to move files to allow for expansion of a mail data file up to a complete disk if needed. There are no limits built into the program in this respect. However, if a S)ort is to be done, it is recommended that there be a maximum of 350 record entries (as heap space is used during the sort). Code entry on records: A 'code' entry is kept with each record. This holds 'Perm' for normal entries. Record 0 also has 'Perm' in its code. During the execution of the system, various values are placed in here ('Add', 'Change', etc.). Deleted records have a blank code entry. Such blank entries are used, where possible, before new space is allocated for A)dded records. Backup linked list of records: As records are changed, the old versions are kept on a linked list of backup records. The new versions are then put in the main data file. R)estore operations on a record or a Q)uit from the program and E)xit without updating can then use this list to restore the old values. II Restrictions on file sizes -------------------------- The mailing label file may be of any size, however the S)ort routine is only capable of safely handling 350 records or approximately 250 blocks of data. This should be taken into consideration when building files and using the system. ERCC Notes ---------- I Initialisation of MAIL data files --------------------------------- The utility MAIL.INIT may be used to convert a text file containing name, addresses and information fields into MAIL data records. The input format expected is: name and its maximum width is 30 company name 30 address 30 city, zip or post code 15 for city, 8 for zip or post code miscellaneous information 90 This can be repeated for further individuals. Note that a comma is used to separate a city from any zip or post code present. An example of an input file for the MAIL.INIT utility is available on the release disk as file MAILINITEG.TEXT. II Conversion of MAILER names and addresses into MAIL -------------------------------------------------- The ERCC initially supported a simple mailing label manager named MAILER. The MAIL system is intended to replace this package and to increase the facilities available to users. In order to protect the investment already made in data capture of mailing information by MAILER users, the utility MAIL.INIT may be used to read text files produced as output by MAILER (i.e., the format defined for input to MAIL.INIT is that produced as output from the earlier MAILER system). The MAIL.INIT program should be self explanatory. Besides importing name, address and miscellaneous information to MAIL records, it allows a single MAIL Flag to be set on each record imported. This is useful if you wish to mark all the imported records as belonging to some grouping (e.g., all members of a single committee). Further uses of the MAIL data file for other purposes can then add to the records by using other Flags to differentiate the groupings. MAIL.INIT creates a new MAIL data base and populates it with the names and addresses in the given input file. Note that there may not be an exact correspondence between your original address fields (which could have unrestricted use) and those assigned in MAIL. However, it should enable simple interactive changes to the new MAIL data file to be made in MAIL itself. The actual mapping of the information fields is: MAILER ---> MAIL name Prefix,Fname,Minit,Lname, Suffix or title address 1 company name address 2 address address 3 city, zip or post code information miscellaneous III Increasing the size of a MAIL data file --------------------------------------- A MAIL data file will grow to occupy the free (unused) space on a disk following the existing data file. If the data file becomes full and deletions cannot be made, you should copy the existing data file to a larger unused area to ensure that free (unused) space is available following it. The UCSD Filer can be used to achieve this by K(runching disks, C(hanging file names and T(ransferring files. After the operation, the MAIL data file should retain its original name. IV Data Manipulation on records of your own description ---------------------------------------------------- If you require functions similar to those provided in MAIL but on records of your own description, you could investigate the FORMULEX package provided on various UCSD systems (including SuperBrain and Apple II). This system lets you define your own screen form with various fields and gives facilities to build up a file of such records. Record searching and file manipulation is provided for. The system is one of a selection of systems which provide 'electronic form' interfaces to data. The form letter production facility of MAIL is not directly available in FORMULEX. V Producing files for SORT/MERGE operations ----------------------------------------- SORT/MERGE is a package which enables files of records to be sorted according to some key fields. One version of the package is available to sort text files consisting of fixed single line records according to up to 6 keys. The L)etter facility of the MAIL program may be used to output files in a form suitable for SORT/MERGE operations. A L)etter I)nput file is prepared which consists of a single line defining the record format. It should be preceeded by the tilde ('~') character to prevent justification. Fixed width fields can be forced by (*:*) (e.g., (*LN:30*) will put out the Last Name in a field of width 30 characters). An example might be: ~(*FN:30*)(*LN:30*)(*CN:30*) This should be placed as the I)nput filename in the O)ptions section of MAIL or given explicitly as the input file name for L)etter. The O)utput filename should be specified as some disk file. This will become the input to a subsequent SORT/MERGE operation. It is also necessary to set up the L)etter O)ptions such that non-paginated, non-stop-between-pages, output with no top, left or right margins is produced. The characters on a line should be set wider than the record width to be written to the O)utput file. All these options may be set in the MAIL O)ptions command. You may then do a L)etter operation and use a selection criteria which will produce an output record for each MAIL record selected. This O)utput file will become the input to SORT/MERGE operations. Note that any additional blank lines inserted by MAIL between records will be ignored by SORT/MERGE. ======================================================================================== DOCUMENT :usus Folder:VOL11:mail.e.g.text ======================================================================================== This is a file of examples for the L)etter command of the program mail. The fields available for insertion anywhere in the letter are: ~ prefix to the name : (*PR*) ~ first name : (*FN*) ~ middle initial : (*MN*) ~ last name : (*LN*) ~ suffix to the name : (*SU*) ~ title : (*TI*) ~ company name : (*CN*) ~ phone number : (*PN*) ~ street address : (*AD*) ~ city : (*CI*) ~ state : (*ST*) ~ country : (*CO*) ~ zip : (*ZI*) ~ whole misc field : (*MI*) ~ misc sub-fields : (*M0*), (*M1*), (*M2*), (*M3*), (*M4*), ~ (*M5*), (*M6*), (*M7*), (*M8*), (*M9*) In addition to these other fixed fields there is one variable field called the 'Greeting' (in this case : (*GR*)). This field can be set up to a predetermined subset of the whole name by using the 5 STANDARD FLAGS (44-48), or will default to an appropriate greeting (ie Mr. Smith if possible or Bob or etc...) ~These fields may be left justified: ~(*GR*) ~(* right justified::60*) ~(* GR:60*) ~(* or centered::60 *) ~(* GR:60 *) ~in any number of spaces. The fields may be combined with or without regular text into larger tokens and these tokens may be left, right, or center justified just as individual tokens: ~(* (*PR*) (*FN*) (*MN*) (*LN*) (*SU*):60 *) The right justification is automatic and text is taken from succsesive lines as necessary to make up paragraphs. In fact, the text for this paragraph is stored as consecutive lines of single words. This is important when introducing tokens can upset the length of the line. Lines can be input upto 255 characters in length with complete integrity upon output. {%30/Flagged paragraphs are structures which allow individual records or groups of record to include specifed words, sentences, or paragraphs in text. Flags may be nested any number deep but tokens may only be nested one level deep. {%31/This sentence has the flag 31 tied to it. %}{%32/33/ This sentence has the flags 32 and 33 tied to it. %}{%-32/You can specify sentences or paragraphs to be added if certain flags are NOT set. %} In fact you can specify any number of flags to be set or NOT set, and you can also determine if ALL specified flags (or NOT flags) are necessary to include the paragraph or only ONE of the specified flags is needed. %} [:l20:][:r20:]Spacing and Margin commands may be included in the text which will [:s3:]affect the output at the first opportunity and will last until a [:s2:][:r30:]new paragraph is started. At the beginning of each and every paragraph [:s1:][:l30:]the spacing and margins are assigned to their default values. This is an example of these spacing and margin commands which can be used for various purposes. Within the program the records can be processed in a sequential manner. Records can be selected for output to mailing labels or letters singly, or by wildcard from any field, or to match a flag mask, or any combination therof. The records may also be sorted by any field within the record. The program has been made fail-safe by allowing one to Abort or Update upon leaving or to individually Restore any record changed. The program is self-initializing if the files are already present. If not it allows one to specify the file upon which it will act, and the disk upon which the output format data file will go. %} ======================================================================================== DOCUMENT :usus Folder:VOL11:mail.form.text ======================================================================================== ~+----------------------------------------------------------+ ~| Name: (* (*PR*) (*FN*) (*MN*)= =(*LN*) (*SU*):47*) | ~| (* (*TI*)=; =(*CN*):47*) | ~| Address: (* (*AD*):47*) | ~| (* (*CI*)=, =(*ST*)=, =(*CO*)=, =(*ZI*):47*) | ~+----------------------------------------------------------+ ~| Phone: (* PN:47*) | ~+----------------------------------------------------------+ ~| Greeting: (* GR:47*) | ~+----------------------------------------------------------+ ~| Misc [0]: (* M0:47*) | ~| Misc [1]: (* M1:47*) | ~| Misc [2]: (* M2:47*) | ~| Misc [3]: (* M3:47*) | ~| Misc [4]: (* M4:47*) | ~| Misc [5]: (* M5:47*) | ~| Misc [6]: (* M6:47*) | ~| Misc [7]: (* M7:47*) | ~| Misc [8]: (* M8:47*) | ~| Misc [9]: (* M9:47*) | ~+----------------------------------------------------------+ ~| Flags : (*{%1/1 %}{%2/2 %}{%3/3 %}{%4/4 %}{%5/5 %}{%6/6 %}:47 *) | ~| (*{%7/7 %}{%8/8 %}{%9/9 %}{%10/10 %}{%11/11 %}{%12/12 %}:47 *) | ~| (*{%13/13 %}{%14/14 %}{%15/15 %}{%16/16 %}{%17/17 %}{%18/18 %}:47 *) | ~| (*{%19/19 %}{%20/20 %}{%21/21 %}{%22/22 %}{%23/23 %}{%24/24 %}:47 *) | ~| (*{%25/25 %}{%26/26 %}{%27/27 %}{%28/28 %}{%29/29 %}{%30/30 %}:47 *) | ~| (*{%31/31 %}{%32/32 %}{%33/33 %}{%34/34 %}{%35/35 %}{%36/36 %}:47 *) | ~| (*{%37/37 %}{%38/38 %}{%39/39 %}{%40/40 %}{%41/41 %}{%42/42 %}:47 *) | ~| (*{%43/43 %}{%44/44 %}{%45/45 %}{%46/46 %}{%47/47 %}{%48/48 %}:47 *) | ~+----------------------------------------------------------+ ======================================================================================== DOCUMENT :usus Folder:VOL11:mail.info.data ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL11:mail.init.text ======================================================================================== {Mail.Init - convert a text file to MAIL data file} { 23-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } {$S+} { V-} {pragma needed on Apple} PROGRAM MailInit; {the format accepted is that output by the print labels option of MAILER} {this will allow movement from the earlier supported mailing list system} { format is maps to MAIL component: name prefix, fname, minit, lname, suffix or title address line 1 company name address line 2 address address line 3 city, zip or post code information miscellaneous which reflects the output format for labels printed at 6 lines per inch } TYPE rec1 = RECORD code :STRING[6]; lname :STRING[15]; fname :STRING[10]; minit :STRING[2]; prefx :STRING[5]; suffx :STRING[6]; title :STRING[15]; coname :STRING[30]; phone :STRING[15]; address :STRING[30]; city :STRING[15]; state :STRING[2]; country :STRING[15]; zip :STRING[8]; misc :STRING[90]; flags :ARRAY[1..48] OF BOOLEAN; END; VAR disk1 : FILE OF rec1; finp : TEXT; fname1,fname2 : STRING; iname,addr1,addr2,addr3: STRING; info : STRING[90]; numrecs,FLAGNO,at,temp : INTEGER; ch : CHAR; InputOK : BOOLEAN; PROCEDURE Fixit(VAR s: STRING); BEGIN temp := 0; WHILE temp0 DO BEGIN IF i >= factor THEN BEGIN s := CONCAT(s,COPY(numstr,i DIV factor,1)); i := i - (i DIV factor)*factor; startedstring := TRUE; END ELSE IF startedstring THEN s := CONCAT(s,'0'); factor := factor DIV 10; END; IF LENGTH(s) = 0 THEN s := '0'; END; (*$I-*) FUNCTION Chkfiles(var s : STRING; suffix:string) : BOOLEAN; VAR intb : BOOLEAN; BEGIN intb := TRUE; RESET(disk1,s); IF IORESULT <> 0 THEN begin close(disk1); s:=concat(s,suffix); reset(disk1,s); if ioresult<>0 then intb := FALSE; end; CLOSE(disk1); Chkfiles := intb; END; (*$I+*) PROCEDURE Uppercase(VAR s: STRING); VAR t : INTEGER; BEGIN FOR t := 1 TO LENGTH(s) DO IF s[t] IN ['a'..'z'] THEN s[t] := CHR(ORD(s[t])-32); END; FUNCTION Val(s : STRING) : INTEGER; VAR i,j,k: INTEGER; BEGIN j := 0; k := 0; i := 1; IF LENGTH(s)<>0 THEN BEGIN IF (LENGTH(s)>0) AND (s[1] = '-') THEN BEGIN k := k + 1;i := -1; END; IF k0 THEN DELETE(tstring,POS('.',tstring),1); IF (tstring='MR') OR (tstring='MRS') OR (tstring='MISS') OR (tstring='DR') OR (tstring='MS') OR (tstring='PROF') OR (tstring='SIR') THEN BEGIN disk1^.prefx := token[1]; Decrntokens; END; END; PROCEDURE Chksuffix; VAR cflg : BOOLEAN; temp:integer; BEGIN WHILE POS(' ',postoken) = 1 DO DELETE(postoken,1,1); tstring := postoken; Uppercase(tstring); if pos('.',tstring)<>0 then delete(tstring,pos('.',tstring),1); IF (tstring = 'PHD') OR (tstring = 'MD' ) OR (tstring = 'DDS') OR (tstring = 'II' ) OR (tstring = 'III') OR (tstring = 'IV' ) OR (tstring = 'V' ) OR (tstring = 'MA' ) OR (tstring = 'BA' ) OR (tstring = 'BS' ) OR (tstring = 'BSC') OR (tstring = 'MS' ) OR (tstring = 'MSC') OR (tstring = 'AA' ) OR (tstring = 'EE' ) OR (tstring = 'EDS') THEN BEGIN disk1^.suffx := postoken; END ELSE BEGIN IF LENGTH(postoken)<=15 THEN disk1^.title := postoken ELSE BEGIN disk1^.title := ' '; FOR temp := 1 TO 15 DO disk1^.title[temp] := postoken[temp]; END; END; END; PROCEDURE Firstname; BEGIN IF ntokens <= 1 THEN EXIT(Firstname); IF LENGTH(token[1])<= 10 THEN disk1^.fname := token[1] ELSE {take initial} disk1^.fname := CONCAT(COPY(token[1],1,1),'.'); END; PROCEDURE Middleinitial; BEGIN IF ntokens <= 2 THEN EXIT(Middleinitial); IF LENGTH(token[2])>2 THEN BEGIN {take initial} disk1^.minit := COPY(token[2],1,1); disk1^.minit := CONCAT(disk1^.minit,'.'); END ELSE disk1^.minit := token[2]; END; PROCEDURE Lastname; var temp:integer; BEGIN IF ntokens = 0 THEN EXIT(Lastname); IF ntokens <= 3 THEN BEGIN IF LENGTH(token[ntokens])<=15 THEN disk1^.lname := token[ntokens] ELSE BEGIN disk1^.lname := ' '; FOR temp := 1 TO 15 DO disk1^.lname[temp] := token[ntokens][temp]; END; ntokens := 0; END ELSE BEGIN IF LENGTH(token[3])<=15 THEN disk1^.lname := token[3] ELSE BEGIN disk1^.lname := ' '; FOR temp := 1 TO 15 DO disk1^.lname[temp] := token[3][temp]; END; ntokens := ntokens - 3; END; END; PROCEDURE Anymore; BEGIN IF ntokens<>0 THEN {there is more in the name} begin {do nothing at present} end; END; BEGIN ntokens := 0; postoken := ''; IF POS(',',iname) > 4 THEN BEGIN postoken := COPY(iname,POS(',',iname)+1,LENGTH(iname)-POS(',',iname)); DELETE(iname,POS(',',iname),LENGTH(iname)-POS(',',iname)+1); END; IF LENGTH(postoken)<>0 THEN Chksuffix; {now suffix coped with convert . in name to spaces for tokenisation} while pos('.',iname)<>0 do iname[pos('.',iname)]:=' '; WHILE (ntokens<10) AND (LENGTH(iname)>0) DO BEGIN ntokens := ntokens + 1; token[ntokens] := ''; WHILE POS(' ',iname)=1 DO DELETE(iname,1,1); IF POS(' ',iname)<>0 THEN BEGIN token[ntokens] := COPY(iname,1,POS(' ',iname)-1); DELETE(iname,1,POS(' ',iname)); END ELSE BEGIN token[ntokens] := iname; iname := ''; END; IF LENGTH(token[ntokens]) = 0 THEN ntokens := ntokens - 1; END; IF ntokens = 0 THEN EXIT(Getname); IF ntokens = 1 THEN BEGIN IF LENGTH(token[1])<=15 THEN disk1^.lname := token[1] ELSE BEGIN disk1^.lname := ' '; FOR temp := 1 TO 15 DO disk1^.lname[temp] := token[1][temp]; END; EXIT(Getname); END; Chkprefix; Firstname; Middleinitial; Lastname; Anymore; END; PROCEDURE Chgformat; var addrcity,addrzip:string; poscomma:integer; BEGIN Zerodisk1; Getname; numrecs:=numrecs+1; disk1^.misc := info; IF LENGTH(addr1)<=30 THEN disk1^.coname := addr1 ELSE BEGIN disk1^.coname := ' '; FOR temp := 1 TO 30 DO disk1^.coname[temp] := addr1[temp]; END; IF LENGTH(addr2)<=30 THEN disk1^.address := addr2 ELSE BEGIN disk1^.address := ' '; FOR temp := 1 TO 30 DO disk1^.address[temp] := addr2[temp]; END; addrcity:=addr3; addrzip:=''; poscomma:=POS(',',addr3); if poscomma>1 then begin addrcity:=COPY(addr3,1,poscomma-1); if poscomma<>length(addr3) then addrzip:=COPY(addr3,poscomma+1,length(addr3)-poscomma); {remove leading spaces} while pos(' ',addrzip)=1 do delete(addrzip,1,1); end; IF LENGTH(addrcity)<=15 THEN disk1^.city := addrcity ELSE BEGIN disk1^.city := ' '; FOR temp := 1 TO 15 DO disk1^.city[temp] := addrcity[temp]; END; IF LENGTH(addrzip)<=8 THEN disk1^.zip := addrzip ELSE BEGIN disk1^.zip := ' '; FOR temp := 1 TO 8 DO disk1^.zip[temp] := addrzip[temp]; END; IF FLAGNO<>0 THEN disk1^.Flags[FLAGNO]:=true; SEEK(disk1,numrecs); PUT(disk1); END; FUNCTION Notblankname : BOOLEAN; BEGIN WHILE POS(' ',iname)=1 DO DELETE(iname,1,1); Notblankname := NOT (iname='');; END; PROCEDURE MailFile(VAR Filename:STRING); VAR ch : CHAR; t1,t2 : STRING[15]; tmpstr:STRING; {$I-} PROCEDURE Makefile( s : STRING); VAR tafile : FILE; tarry : packed array [1..512] of char; Res,num,blkasked,written,temp : INTEGER; BEGIN WRITE('Making: ',s); REWRITE(tafile,s); Res:=IORESULT; IF Res<>0 THEN begin Writeln; Writeln('Error making file ',s,' IOResult=',Res); end else begin fillchar(tarry,512,chr(0)); temp := POS('[',s); {no block number if max area to be claimed} IF temp=0 THEN blkasked:=0 else blkasked:=VAL(COPY(s,temp+1,LENGTH(s)-temp)); {-9999 is fault return from VAL} if blkasked<0 then blkasked:=0; num:=0; REPEAT if (num mod 10)=0 then WRITE('.'); written:=BLOCKWRITE(tafile,tarry,1); num:=num+written; UNTIL (num=blkasked) or (written=0) or (IORESULT<>0); WRITELN; if (blkasked<>0) and (num<>blkasked) then WRITELN('Could only initialise ',num,' blocks.') else WRITELN(num,' blocks initialised.'); CLOSE(tafile,lock); Res:=IORESULT; IF Res<>0 THEN Writeln('Error closing file ',s,'IOResult=',Res); end; END; {$I+} PROCEDURE Getmfile; BEGIN IF LENGTH(filename)=0 THEN filename := 'MAIL.DATA'; IF POS(':',filename)=0 THEN BEGIN WRITELN; WRITE('Give volume for file ',filename,' ( for #5, to quit):'); READLN(t1); IF LENGTH(t1)> 0 THEN IF t1[1] = CHR(27) THEN EXIT(MailInit); IF LENGTH(t1)=0 THEN t1 := '#5:'; IF (t1='4') OR (t1='5') OR (t1 = '9') OR (t1='10') OR (t1 = '11') OR (t1='12') THEN t1 := CONCAT('#',t1,':'); IF POS(':',t1)=0 THEN t1 := CONCAT(t1,':'); filename := CONCAT(t1,filename); END; WRITELN; WRITELN('The file can hold approximately 4 records in every 3 blocks.'); WRITE('How many blocks for this file ( to quit):'); READLN(t2); IF LENGTH(t2)> 0 THEN IF t2[1]=CHR(27) THEN EXIT(MailInit); temp := Val(t2); {-9999 indicates bad string or null response} if temp<0 then temp:=0; IF (temp<5) OR (LENGTH(t2)>3) THEN t2 := ''; IF (temp<>0) THEN BEGIN IF (temp<10) AND (LENGTH(t2)<>1) THEN STR(temp,t2); IF (temp>=10) AND (temp<100) AND (LENGTH(t2)<>2) THEN STR(temp,t2); IF (temp>=100) AND (LENGTH(t2)<>3) THEN STR(temp,t2); END; END; BEGIN WRITELN; WRITELN('Enter to create new MAIL.DATA, to quit,'); WRITE (' or another filename to use for data:'); READLN(filename); IF LENGTH(filename)<>0 THEN IF filename[1]=CHR(27) THEN EXIT(MailInit); IF filename='' THEN filename:='MAIL.DATA'; IF ChkFiles(filename,'') then BEGIN WRITE('File ',filename,' already exists. Destroy it (Y/N):'); REPEAT READ(KEYBOARD,CH); UNTIL CH IN ['Y','y','N','n']; Writeln(CH); IF (CH='Y') OR (CH='y') THEN BEGIN {$I-} RESET(disk1,filename); CLOSE(disk1,PURGE); {$I+} END ELSE EXIT(MailInit); END; IF NOT Chkfiles(filename,'') THEN BEGIN REPEAT Getmfile; if length(t2)>0 then tmpstr := CONCAT(filename,'[',t2,']') else tmpstr:=filename; Makefile(tmpstr); UNTIL Chkfiles(filename,''); END; END; BEGIN WRITELN; WRITELN('----------------------------------------------------------------'); WRITELN('ERCC WORDSET - MAIL Initialisation Utility 1.1 - 23-Feb-82'); WRITELN('----------------------------------------------------------------'); WRITELN; InputOK:=FALSE; REPEAT WRITE('Enter the input filename ( to quit):'); READLN(fname2); if fname2<>'' then begin if fname2[1]=chr(27) {ESC} then EXIT(MailInit); InputOK:=Chkfiles(fname2,'.TEXT'); end; if NOT InputOK then writeln('File ',fname2,' does not exist.'); UNTIL InputOK; RESET(finp,fname2); MailFile(fname1); WRITELN; WRITELN('Give a Flag number to be set on each record.'); WRITELN(' 0 means set no flag'); WRITE (' 1-48 are legal'); WRITELN; REPEAT WRITE('Flag number:'); READLN(FLAGNO); UNTIL (FLAGNO>=0) and (FLAGNO<=48); WRITELN; {$I-} REWRITE(disk1,fname1); if ioresult<>0 then begin writeln('Cannot open output file.'); exit(MailInit); end; {$I-} numrecs:= 0; WHILE NOT EOF(finp) DO BEGIN Pget; IF Notblankname THEN Chgformat; END; Wnew0rec; {puts count information in rec 0} CLOSE(disk1,lock); CLOSE(finp); END. ======================================================================================== DOCUMENT :usus Folder:VOL11:mail.lett.text ======================================================================================== ~ Edinburgh Regional Computing Centre ~ 59, George Square ~ Edinburgh EH8 9JU \\ ~Dear (*GR*), thankyou for attending our demonstration of the Off-Load UCSD p-System based Office Workstation. We have noted your interest in (*M0*). ~ Yours sincerely, ~ ~ Dr. Austin Tate ~ Micro Support Unit ======================================================================================== DOCUMENT :usus Folder:VOL11:mail.read.text ======================================================================================== Contents of this volume Austin Tate, ERCC 22-Feb-82 ------------------------------------------------------------------------- This volume holds a mailing address data base, mailing label and forms letter production utility called MAIL along with associated text files and utilities. MAIL was initially written by Patrick Horton at Associated Computer Industries. It was subsequently updated and modified by Austin Tate at the Edinburgh Regional Computing Centre. The copyright was transfered to Austin Tate in February 1982 by ACI. The files available are: MAIL.TEXT The main program which has include files for the rest MAIL1.TEXT The include files follow. MAIL2A.TEXT MAIL2B.TEXT MAIL3.TEXT MAIL4.TEXT MAIL5.TEXT MAIL6.TEXT MAIL7.TEXT MAIL8.TEXT MAIL9.TEXT SCREENOPSX.TEXT The MAIL program uses a UNIT SCREENOPS for screen SCREENOPSA.TEXT control. In version IV and other systems which provide a compatible SCREENOPS UNIT just use that. If one is not available on your system, the two files provided should provide enough of the SCREENOPS functions to allow MAIL to work. SCREENOPSX should work with any VDU which uses FF (ASCII 12 decimal) as the Clear Screen and Home control character. SCREENOPSA is specifically for the Apple II and will get the control characters from the *SYSTEM.MISCINFO for UCSD II.1. MAIL.INIT.TEXT A utility to initialise a MAIL data base from a text file holding names and addresses. See the documentation for more details. MAIL.DOC.TEXT The documentation. It was prepared with the UCSD Advanced Systems Editor (ASE) from Volition Systems and may be too large to edit with the standard in-memory UCSD editor. You should be able to list it though. MAIL.READ.TEXT This note. MAIL.E.G.TEXT A "form letter" which serves as an example of the use of MAIL for building your own form letters. MAIL.LETT.TEXT A sample straightforward form letter, you could model your own on this. MAIL.FORM.TEXT A "form" which can be used as a form letter to print the information held i the data base about an individual. Usefule for reports, etc. MAILINITEG.TEXT An example file which can be used as input to the MAIL.INIT utility to create a MAIL data base from existing name and address lists. Use this as a sample to get the format correct. MAIL.CODE On some disks, the code files for the MAIL and MAIL.INIT.CODE MAIL.INIT programs may be present. MAIL.DATA On some disks, the data files created (by default) MAIL.INFO.DATA by the MAIL program may be present. If they are present, the MAIL system will use these and not ask you for your own mail files. Rename or destroy these two to start your own mailing lists. Preparation ----------- The MAIL and MAIL.INIT programs have been made to be compatible with a wide range of UCSD systems. However, some changes are required to the sources to allow compilation on pre-version IV UCSD systems. 1. Choose a suitable SCREENOPS UNIT if your system does not provide one and compile it to SCREENOPS.CODE on the prefix disk. The MAIL sources assume that the inerface pert of SCREENOPS can be found in SCREENOPS.CODE. 2. For the Apple II, edit the compiler directive at the head of file MAIL.TEXT to include the V- option. This is marked in the sources. 3. For UCSD versions which do not provide many segment slots (e.g., II.0 Apple Pascal 1.0, etc) edit the SEGMENT PROCEDURE declarations in MAIL6.TEXT - for Add and Change procedures - to be normal PROCEDURES. The sources are marked appropriately. This will have the effect of cutting down on heap space available for sorting, etc. so try to use the maximum number of segments that you can. 4. Now you should be able to compile MAIL. Run the program and it will deal with all necessary file initialisation. You can pre-initialise the mail data base from a text file holding names and addresses with the utility MAIL.INIT (prior to running MAIL)if you wish. ======================================================================================== DOCUMENT :usus Folder:VOL11:mail.text ======================================================================================== {Mail - Main program} { 22-Feb-82 AT } { *** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *** ** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ** ** ** ** program : MAIL - Text processing mailing label data manager. ** ** ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** ** ** description: This program maintains a data file of name-address ** ** information. By combining this data with a word- ** ** processor form letters may be produced. ** ** ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** ** ** ** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ** *** * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *** } (*$S+*) (* V- needed for Apple also*) PROGRAM Mail; USES {$U ScreenOps.Code} SCREENOPS; CONST Spaces30=' '; TYPE labelrec = RECORD code :STRING[6]; lname :STRING[15]; fname :STRING[10]; minit :STRING[2]; prefx :STRING[5]; suffx :STRING[6]; title :STRING[15]; coname :STRING[30]; phone :STRING[15]; address :STRING[30]; city :STRING[15]; state :STRING[2]; country :STRING[15]; zip :STRING[8]; misc :STRING[90]; flags :ARRAY[1..48] OF BOOLEAN; END; linkedrec = RECORD recpart : labelrec; lpart : ^linkedrec; END; linkrec2 = RECORD intpart : INTEGER; lpart2 : ^linkrec2; END; bstring = STRING[255]; justification = (left,center,right); VAR odisk : TEXT; infile : TEXT; disk : FILE OF labelrec; heaptr : ^INTEGER; ptr,first : ^linkedrec; {lists of backup records kept on heap} first2,ptr2 : ^linkrec2; format : FILE OF RECORD spacing : 1..3; infilename,ofilename : STRING[30]; llmgin,lrmgin, lspage,lpwid,lvtab, lpin,lchar,lpsiz, mwide,mvtab,mmgin : INTEGER; rolodex,poption,foption,loption,option : BOOLEAN; meanings : ARRAY[1..48] OF STRING[30]; fflags : ARRAY[1..48] OF BOOLEAN; ffeed : boolean; LDirCh : char; joption : boolean; END; mailarry : ARRAY[1..4] OF labelrec; wfield : (p,f,n,l,u,c,t,h,a,i,s,y,z,m); outmode : (reg,ad); {regular display or display during add operation} stdflg : ARRAY[1..5] OF INTEGER; tmpstr : STRING[100]; wildcard : STRING[90]; ffilename,filename : STRING; tname,field : STRING[30]; tlname : STRING[15]; command:CHAR; temp,temp1,temp2,columat,increment, orignrecs,ladd,column,numrecs,recnumber : INTEGER; firstflg,pflg,eflg,cnflg,otrecflg,orecflg: BOOLEAN; FUNCTION Val(s : STRING):INTEGER; FORWARD; FUNCTION Chkfiles(s : STRING):BOOLEAN; FORWARD; FUNCTION Wildok : BOOLEAN; FORWARD; FUNCTION Chkflgs : BOOLEAN; FORWARD; PROCEDURE Uppercase(VAR s : STRING); FORWARD; PROCEDURE Rdata(a,x,y,l : INTEGER; VAR s :bstring); FORWARD; PROCEDURE Getint(x,y : INTEGER; VAR t1 : INTEGER); FORWARD; PROCEDURE Wild1(wch:char); FORWARD; PROCEDURE Wild2; FORWARD; PROCEDURE Str(i : INTEGER; VAR s:STRING); FORWARD; Procedure Reporterr(st1,st2:string;res:integer); FORWARD; Procedure MakeFile(s:string); forward; Procedure Gtstdflgs; forward; Procedure WNew0Rec; forward; Procedure Step; forward; Procedure Krunch; forward; Procedure Outrec; forward; (*$I MAIL1.TEXT *) {Init - holds version and date} (*$I MAIL2a.TEXT *) {2a and 2b are the LETTER segment} (*$I MAIL2b.TEXT *) (*$I MAIL3.TEXT *) {1 thru 6 contain segments} (*$I MAIL4.TEXT *) (*$I MAIL5.TEXT *) (*$I MAIL6.TEXT *) {on version II.0 remove segments} (*$I MAIL7.TEXT *) {first non segment procedures} (*$I MAIL8.TEXT *) (*$I MAIL9.TEXT *) PROCEDURE Str; VAR startedstring : BOOLEAN; factor : INTEGER; numstr : STRING[9]; BEGIN s := ''; IF i < 0 THEN BEGIN s := '-'; i := - i; END; numstr := '123456789'; startedstring := FALSE; factor := 10000; WHILE factor<>0 DO BEGIN IF i >= factor THEN BEGIN s := CONCAT(s,COPY(numstr,i DIV factor,1)); i := i - (i DIV factor)*factor; startedstring := TRUE; END ELSE IF startedstring THEN s := CONCAT(s,'0'); factor := factor DIV 10; END; IF LENGTH(s) = 0 THEN s := '0'; END; BEGIN (* Mail *); Firstflg := TRUE; {for Init} Init; {will leave recordnumber=0} command := '$'; {initial dummy value} REPEAT pflg := TRUE; REPEAT IF (numrecs <> 0) AND (NOT(command IN ['?',',','.','<','>','+','-'])) THEN BEGIN if recnumber < 1 then recnumber := 1; IF recnumber > numrecs THEN recnumber := numrecs; recnumber:=recnumber-increment; {set up so that step will move to next genuine record or current record} Step; {if recnumber=1 will find first genuine record} outmode := reg; Outrec; END; SC_Clr_Line(0); IF increment=1 THEN WRITE('>'); IF increment=-1 THEN WRITE('<'); IF pflg THEN WRITE('Mail: A)dd, C)hange, D)elete, F)ind, 1)st, '' '')step, O)ptions, Q)uit ? ') ELSE WRITE('Mail: L)etter, M)labels, S)ort, I)nit, K)runch, R)estore, Z)ero ? '); REPEAT READ(KEYBOARD,command); if (command>='a') AND (command<='z') THEN command:=chr(ord(command)-32); UNTIL command in ['A','C','D','F','1',' ','M','Q','I','K','L', 'S','R','O','Z','?',',','.','<','>','+','-']; write(command); IF command = '?' THEN pflg := NOT pflg; IF (numrecs=0) THEN BEGIN IF command='A' THEN Add; IF command='O' THEN Options; END ELSE CASE command OF 'A' : Add; 'C' : Change; 'D' : Delte; 'F' : Find; 'I' : Initialize; 'K' : Krunch; 'L' : Letter; 'O' : Options; 'M' : Mlabels; 'R' : Restore; ' ' : Step; 'S' : Sortit; 'Z' : Zero; '1' : recnumber:=0; '-','<',',' : increment := -1; '+','>','.' : increment := 1; END; UNTIL command='Q'; UNTIL Quit; END. (* Mail *) ======================================================================================== DOCUMENT :usus Folder:VOL11:mail1.text ======================================================================================== {Mail1 - Init (holds version number and date} { 22-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } SEGMENT PROCEDURE Init; PROCEDURE Rights; BEGIN SC_Clr_Screen; WRITELN; WRITELN('----------------------------------------------------------------'); WRITELN('ERCC WORDSET - MAIL - Text processing mailing label data manager'); WRITELN(' 1.4 22-Feb-82'); WRITELN('----------------------------------------------------------------'); WRITELN; WRITELN('authors : Patrick R. Horton, Associated Computer Industries'); WRITELN(' Austin Tate, Edinburgh Regional Computing Centre'); WRITELN; WRITELN('description: This program maintains a data file of name-address'); WRITELN(' information. Selected data may be merged with a'); WRITELN(' document to produce form letters. Mailing labels'); WRITELN(' can be printed.'); WRITELN; WRITELN('Copyright : (C) 1982, Austin Tate, ERCC'); WRITELN; WRITELN('document : ERCC hosts in file MICROS.DOC_MAIL'); WRITELN; WRITELN('----------------------------------------------------------------'); REPEAT GOTOXY(0,22); UNTIL NOT(Space_Wait(TRUE)); END; PROCEDURE Initformat; BEGIN IF Chkfiles('#4:MAIL.INFO.DATA') THEN BEGIN ffilename := '#4:MAIL.INFO.DATA'; RESET(format,ffilename); END ELSE IF Chkfiles('#5:MAIL.INFO.DATA') THEN BEGIN ffilename := '#5:MAIL.INFO.DATA'; RESET(format,ffilename); END ELSE BEGIN WRITELN; WRITELN; WRITELN('The file MAIL.INIT.DATA was not found.'); WRITE('Give volume for file MAIL.INFO.DATA ( for #5, to quit):'); READLN(ffilename); if length(ffilename)>0 then if ffilename[1]=CHR(27) then Exit(Mail); IF LENGTH(ffilename)=0 THEN ffilename := '#5:'; IF (ffilename = '4') OR (ffilename='5') OR (ffilename = '9') OR (ffilename='10') OR (ffilename = '11') OR (ffilename='12') THEN ffilename := CONCAT('#',ffilename,':'); IF POS(':',ffilename)=0 THEN ffilename := CONCAT(ffilename,':'); ffilename := CONCAT(ffilename,'MAIL.INFO.DATA[4]'); Makefile(ffilename); {$I-} RESET(format,ffilename); if IORESULT<>0 then begin ReportErr('Leaving Mail to take corrective action.','',IORESULT); EXIT(MAIL); end; {$I+} {********} WITH format^ DO BEGIN infilename := '*MAIL.E.G.TEXT'; ofilename := '#2:'; llmgin := 10; lrmgin := 10; lpin := 6; lchar := 80; lpsiz := 23; mwide := 1; mvtab := 4; mmgin := 0; rolodex := FALSE; FOR temp := 1 TO 48 DO BEGIN fflags[temp] := FALSE; meanings[temp] := ''; END; meanings[48] := 'Suffx'; meanings[47] := 'Lname'; meanings[46] := 'Minit'; meanings[45] := 'Fname'; meanings[44] := 'Prefx'; poption := TRUE; foption := TRUE; loption := TRUE; option := FALSE; ffeed:=FALSE; LDirCh:='~'; joption:=TRUE; lspage := 1; lpwid := 4; lvtab := 2; spacing := 1; END; SEEK(format,0); PUT(format); END; SEEK(format,0); GET(format); CLOSE(format); END; PROCEDURE Initmail; VAR ch : CHAR; t1,t2 : STRING[15]; PROCEDURE Getmfile; BEGIN IF LENGTH(filename)=0 THEN filename := 'MAIL.DATA'; IF POS(':',filename)=0 THEN BEGIN WRITELN; WRITE('Give volume for file ',filename,' ( for #5, to quit):'); READLN(t1); IF LENGTH(t1)> 0 THEN IF t1[1] = CHR(27) THEN EXIT(Mail); IF LENGTH(t1)=0 THEN t1 := '#5:'; IF (t1='4') OR (t1='5') OR (t1 = '9') OR (t1='10') OR (t1 = '11') OR (t1='12') THEN t1 := CONCAT('#',t1,':'); IF POS(':',t1)=0 THEN t1 := CONCAT(t1,':'); filename := CONCAT(t1,filename); END; WRITELN; WRITELN('The file can hold approximately 4 records in every 3 blocks.'); WRITE('How many blocks for this file ( to quit):'); READLN(t2); IF LENGTH(t2)> 0 THEN IF t2[1]=CHR(27) THEN EXIT(Mail); temp := Val(t2); {-9999 indicates bad string or null response} if temp<0 then temp:=0; IF (temp<5) OR (LENGTH(t2)>3) THEN t2 := ''; IF (temp<>0) THEN BEGIN IF (temp<10) AND (LENGTH(t2)<>1) THEN STR(temp,t2); IF (temp>=10) AND (temp<100) AND (LENGTH(t2)<>2) THEN STR(temp,t2); IF (temp>=100) AND (LENGTH(t2)<>3) THEN STR(temp,t2); END; END; BEGIN IF NOT FirstFlg THEN {filename set on first Init} RESET(disk,filename) ELSE IF Chkfiles('#5:mail.data') THEN BEGIN filename := '#5:mail.data'; RESET(disk,filename); END ELSE IF Chkfiles('#4:mail.data') THEN BEGIN filename := '#4:mail.data'; RESET(disk,filename); END ELSE BEGIN WRITELN; WRITELN; WRITELN('The file MAIL.DATA was not found.'); WRITELN('Enter to create new MAIL.DATA, to quit,'); WRITE (' or another filename to use for data:'); READLN(filename); IF LENGTH(filename)<>0 THEN IF filename[1]=CHR(27) THEN EXIT(Mail); IF NOT Chkfiles(filename) THEN BEGIN REPEAT Getmfile; if length(t2)>0 then tmpstr := CONCAT(filename,'[',t2,']') else tmpstr:=filename; Makefile(tmpstr); UNTIL Chkfiles(filename); RESET(disk,filename); numrecs := 0; Wnew0rec; CLOSE(disk); END; RESET(disk,filename); END; END; BEGIN {Init} recnumber := 0; columat := 0; increment := 1; cnflg := FALSE; wildcard := ''; wfield := n; first := NIL; first2 := NIL; MARK(heaptr); IF FirstFlg THEN begin Rights; SC_Clr_Screen; Initformat; Initmail; Firstflg:=FALSE; end; SEEK(disk,0); GET(disk); numrecs := Val(disk^.zip); orignrecs := numrecs; ladd := 0; Gtstdflgs; SC_Clr_Screen; {assert recnumber=0 and increment=1} {Step in main program will find first genuine record} END (* Init *); ======================================================================================== DOCUMENT :usus Folder:VOL11:mail2a.text ======================================================================================== {Mail2A - Letter part 1} { 22-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } SEGMENT PROCEDURE Letter; {DirStr is the directive character for letter processing - default is '~'} VAR DirStr : STRING[1]; tline,line,oline : bstring; lmarg,pmarg,Lettername : STRING[60]; {limits max left and para maragins} token,greet : STRING[90]; {length is maximum of fields} ljustify,sjustify : justification; tpmgin,temp3,temp4,pageat, pmgin,tlmgin,tlsize, nlwg,numtoadd,linat,lmgin,lsize : INTEGER; epar,newpar,pgflg,FileEnd, LastPageWritten : BOOLEAN; spc : 1..3; ch,tempch : char; FUNCTION Flgsok : BOOLEAN; VAR intb : BOOLEAN; numarray : ARRAY[1..48] OF (t,f,n); BEGIN temp3 := POS('{%',line)+2; tline := COPY(line,temp3,LENGTH(line)-temp3+1); intb := FALSE; FOR temp := 1 TO 48 DO numarray[temp] := n; REPEAT temp3 := POS('/',tline); temp := VAL(tline); IF (temp3 <> 0) AND (temp3<5) THEN DELETE(tline,1,temp3); IF (temp3<5) AND (temp>0) AND (temp<=48) THEN numarray[temp] := t; IF (temp3<5) AND (temp<0) AND (temp>=-48) THEN numarray[-1*temp] := f; UNTIL (temp3 = 0) OR (temp3>4); IF format^.loption THEN BEGIN intb := TRUE; FOR temp := 1 to 48 DO BEGIN IF numarray[temp]=t THEN IF NOT disk^.flags[temp] THEN intb := FALSE; IF numarray[temp]=f THEN IF disk^.flags[temp] THEN intb := FALSE; END; END ELSE BEGIN FOR temp := 1 TO 48 DO BEGIN IF numarray[temp]=t THEN IF disk^.flags[temp] THEN intb := TRUE; IF numarray[temp]=f THEN IF NOT(disk^.flags[temp]) THEN intb := TRUE; END; END; Flgsok := intb; IF intb THEN BEGIN temp4 := POS('{%',line); tline := COPY(line,1,temp4-1); DELETE(line,1,temp4+1); WHILE (POS('/',line)<5) AND (POS('/',line)<>0) DO DELETE(line,1,POS('/',line)); line := CONCAT(tline,line); END; END; PROCEDURE Skptpt; VAR tline : STRING[255]; level : INTEGER; BEGIN tline := COPY(line,1,POS('{%',line)-1); DELETE(line,1,POS('{%',line)+1); level := 1; REPEAT IF (POS('%}',line)=0) AND (POS('{%',line)=0) THEN IF NOT EOF(infile) THEN READLN(infile,line) ELSE line := ''; IF (POS('{%',line)<>0) AND (((POS('%}',line)<>0) AND (POS('%}',line)>POS('{%',line)) OR (POS('%}',line)=0))) THEN BEGIN level := level + 1; DELETE(line,1,POS('{%',line)+1); END ELSE IF (POS('%}',line)<>0) AND (((POS('{%',line)<>0) AND (POS('{%',line)>POS('%}',line)) OR (POS('{%',line)=0))) THEN BEGIN level := level - 1; DELETE(line,1,POS('%}',line)+1); END; UNTIL (level=0) OR EOF(infile); line := CONCAT(tline,line); END; PROCEDURE Prflgs; BEGIN REPEAT WHILE (POS('%}',line)<>0) AND ((POS('{%',line)=0) OR (POS('{%',line)>POS('%}',line))) DO DELETE(line,POS('%}',line),2); WHILE POS('{%',line)<>0 DO IF NOT Flgsok THEN Skptpt; UNTIL (POS('{%',line)=0) AND (POS('%}',line)=0); END; PROCEDURE Chkorquit; var ch1:char; BEGIN IF format^.foption THEN BEGIN IF format^.ofilename<>'#2:' THEN WRITELN; WRITE(' to continue, to quit:'); REPEAT READ(KEYBOARD,ch1); UNTIL (ch1=CHR(27)) OR (ch1=' '); WRITELN; IF ch1 = CHR(27) THEN BEGIN SC_Clr_Screen; CLOSE(infile); CLOSE(odisk,lock); EXIT(Letter); END; END; END; PROCEDURE Getgreet; type farray = array [1..48] of boolean; procedure greet1(var greet:string; var farr:farray); begin IF (stdflg[1]<>0) THEN IF farr[stdflg[1]] AND (LENGTH(disk^.prefx)<>0) THEN greet := CONCAT(greet,disk^.prefx); IF (stdflg[2]<>0) THEN IF farr[stdflg[2]] AND (LENGTH(disk^.fname)<>0) THEN BEGIN IF LENGTH(greet)<>0 THEN greet := CONCAT(greet,' '); greet := CONCAT(greet,disk^.fname); END; IF (stdflg[3]<>0) THEN IF farr[stdflg[3]] AND (LENGTH(disk^.minit)<>0) THEN BEGIN IF LENGTH(greet)<>0 THEN greet := CONCAT(greet,' '); greet := CONCAT(greet,disk^.minit); END; IF (stdflg[4]<>0) THEN IF farr[stdflg[4]] AND (LENGTH(disk^.lname)<>0) THEN BEGIN IF LENGTH(greet)<>0 THEN greet := CONCAT(greet,' '); greet := CONCAT(greet,disk^.lname); END; IF (stdflg[5]<>0) THEN IF farr[stdflg[5]] AND (LENGTH(disk^.suffx)<>0) THEN BEGIN IF LENGTH(greet)<>0 THEN greet := CONCAT(greet,' '); greet := CONCAT(greet,disk^.suffx); END; end; BEGIN greet := ''; temp1 := 0; greet1(greet,disk^.flags); {try from actual record} {if not try from the entries S(et in O(ptions F(lags} if length(greet)=0 then greet1(greet,format^.fflags); IF LENGTH(greet)=0 THEN IF (LENGTH(disk^.lname)<>0) and (length(disk^.prefx)<>0) THEN greet := CONCAT(disk^.prefx,' ',disk^.lname); IF LENGTH(greet)=0 THEN IF (LENGTH(disk^.fname)>1) THEN begin IF (disk^.fname[2]<>'.') THEN {first name present and not an initial} greet := disk^.fname; end; IF LENGTH(greet)=0 THEN greet := 'Sir'; END; FUNCTION Hasmgin : BOOLEAN; VAR intb : BOOLEAN; BEGIN intb := FALSE; WHILE ( ( POS(':]',token)0) ) OR ( ( POS('[:',token)=0 ) AND (POS(':]',token)<>0) ) DO DELETE(token,POS(':]',token),2); IF (POS(':]',token)<>0) AND (POS('[:',token)<>0) THEN intb := TRUE; Hasmgin := intb; END; procedure SetPLMargins(p,l:integer); begin if length(pmarg)<>p then pmarg:=copy(concat(Spaces30,Spaces30),1,p); if length(lmarg)<>l then lmarg:=copy(concat(Spaces30,Spaces30),1,l); end; function ValorDefault(Val,Default:integer):integer; begin if val=-9999 then ValOrDefault:=Default else ValorDefault:=Val; end; PROCEDURE Getmgin; BEGIN IF token[POS('[:',token)+2] IN ['L','l'] THEN BEGIN temp := tlmgin; tlmgin := ValOrDefault(Val(COPY(token,POS('[:',token)+3,3)),lmgin); tlsize := tlsize + temp - tlmgin; END ELSE IF token[POS('[:',token)+2] IN ['R','r'] THEN BEGIN tlsize := format^.lchar - tlmgin - ValOrDefault(Val(COPY(token,POS('[:',token)+3,3)), format^.lrmgin); END ELSE IF token[POS('[:',token)+2] IN ['P','p'] THEN BEGIN tpmgin := ValOrDefault(Val(COPY(token,POS('[:',token)+3,3)),pmgin); END ELSE IF token[POS('[:',token)+2] IN ['S','s'] THEN BEGIN temp := Val(COPY(token,POS('[:',token)+3,3)); IF (temp>0) AND (temp<=3) THEN spc := temp; END; IF tlmgin<0 THEN tlmgin := format^.llmgin; IF tlsize<=0 THEN tlsize := format^.lchar-format^.lrmgin-format^.llmgin; DELETE(token,POS('[:',token), POS(':]',token)-POS('[:',token)+2); IF ((NOT newpar) AND (LENGTH(oline)tpmgin) or (lmgin<>tlmgin) then begin pmgin := tpmgin; lmgin := tlmgin; SetPLMargins(pmgin,lmgin); end; END; END; PROCEDURE Rjustify; VAR srt,srted,pspace,lwg : ARRAY[0..50] OF INTEGER; PROCEDURE Addtoall(i : INTEGER); VAR lstcharspace : BOOLEAN; BEGIN temp1 := 0; lstcharspace := FALSE; WHILE temp1 < LENGTH(oline) DO BEGIN temp1 := temp1 + 1; IF oline[temp1]<>' ' THEN IF lstcharspace THEN BEGIN FOR temp2 := 1 TO i DO INSERT(' ',oline,temp1); temp1 := temp1 + i; lstcharspace := FALSE; END ELSE ELSE lstcharspace := TRUE; END; END; PROCEDURE Addrems(i : INTEGER); VAR prevhi,temp3 : INTEGER; BEGIN FOR temp1 := 1 TO i DO BEGIN prevhi := 0; FOR temp2 := 1 TO i DO IF srted[temp2] > prevhi THEN BEGIN prevhi := srted[temp2]; temp3 := temp2; END; INSERT(' ',oline,pspace[srted[temp3]]+ (srted[temp3]-1)*(numtoadd DIV nlwg)); srted[temp3] := 0; END; END; PROCEDURE Sortlwg; VAR prevhi : INTEGER; BEGIN FOR temp1 := 1 TO nlwg DO srt[temp1] := lwg[temp1]; FOR temp1 := 1 TO nlwg DO BEGIN prevhi := 0; FOR temp2 := 1 TO nlwg DO IF srt[temp2]>prevhi THEN BEGIN prevhi := srt[temp2]; srted[temp1] := temp2; END; srt[srted[temp1]] := 0; END; END; BEGIN (* Rjustify *) temp1 := 0; nlwg := 0; WHILE temp1 < LENGTH(oline) DO BEGIN temp1 := temp1 + 1; IF oline[temp1]=' ' THEN BEGIN nlwg := nlwg + 1; pspace[nlwg] := temp1; END; END; pspace[0] := 0; pspace[nlwg+1] := LENGTH(oline)+1; FOR temp1 := 1 TO nlwg DO lwg[temp1] := pspace[temp1+1] - pspace[temp1-1] - 1; Sortlwg; numtoadd := lsize - LENGTH(oline); IF newpar THEN numtoadd := numtoadd - format^.lpin; IF nlwg <> 0 THEN BEGIN IF numtoadd DIV nlwg >= 1 THEN Addtoall(numtoadd DIV nlwg); IF numtoadd MOD nlwg >= 1 THEN Addrems(numtoadd MOD nlwg); END; END; procedure PutTopMargin; begin for temp:=1 to format^.lvtab do writeln(odisk); linat:=format^.lvtab; end; PROCEDURE Chkpage; VAR ch1 : CHAR; BEGIN linat := linat + ORD(spc); IF pgflg OR FileEnd OR ((epar OR newpar) AND ((linat+5+format^.lpwid)>format^.lpsiz)) OR (linat+5>format^.lpsiz) THEN BEGIN if NOT(LastPageWritten) then begin FOR temp := linat TO format^.lpsiz-3 DO WRITELN(odisk); IF NOT(FileEnd AND (pageat=format^.lspage)) THEN WRITE(odisk,lmarg,' ':(lsize DIV 2)-3,'- ',pageat,' -'); FOR temp1 := 1 TO 3 DO WRITELN(odisk); if format^.ffeed then write(odisk,chr(12)); {formfeed} ChkorQuit; if NOT(FileEnd) then begin PutTopMargin; pageat := pageat + 1; end else LastPageWritten:=true; pgflg := FALSE; end; END; END; PROCEDURE Outline; BEGIN IF (format^.joption) AND (POS('\\',line)<>1) AND (NOT(FileEnd)) AND (NOT(epar)) AND (POS(DirStr,line)=0) THEN Rjustify; IF newpar THEN WRITE(odisk,pmarg); WRITE(odisk,lmarg,oline); FOR temp4 := 1 TO ORD(spc) DO WRITELN(odisk); newpar := FALSE; IF format^.ofilename <> '#2:' THEN WRITE('.'); IF format^.poption THEN Chkpage; IF (NOT epar) AND (POS(DirStr,line)=0) THEN oline := token ELSE oline := ''; {these may have been altered within the line just output} lsize := tlsize; pmgin := tpmgin; lmgin := tlmgin; SetPLMargins(pmgin,lmgin); END; PROCEDURE Chgtokens; VAR ltoken,leqpart,lfield : bstring; seqpart, legalfchrs,legal2chrs, stoken : STRING[90]; {max length of fields} lfsize,sfsize,lposinline,sposinline : INTEGER; rflg,lflg : BOOLEAN; PROCEDURE Putone(just : justification; ins : bstring; fsz,pos : INTEGER; VAR ln : bstring); BEGIN tline := ''; FOR temp1 := 2 TO fsz - LENGTH(ins) DO tline := CONCAT(tline,' '); CASE just OF right : BEGIN INSERT(ins,ln,pos); INSERT(tline,ln,pos); END; center : BEGIN INSERT(COPY(tline,1,(LENGTH(tline)+1) DIV 2),ln,pos); INSERT(ins,ln,pos); INSERT(COPY(tline,1,(LENGTH(tline)) DIV 2),ln,pos); END; left : BEGIN INSERT(tline,ln,pos); INSERT(ins,ln,pos); END; END; END; PROCEDURE Getmtoken; VAR tline : STRING[90]; BEGIN temp1 := temp2 - 15; tline := disk^.misc; FOR temp3 := 1 TO temp1 DO IF POS('\',tline)<>0 THEN BEGIN stoken := COPY(tline,1,POS('\',tline)-1); DELETE(tline,1,POS('\',tline)); END ELSE BEGIN stoken := tline; tline := ''; END; END; PROCEDURE Chg1(VAR s : bstring); BEGIN tmpstr := COPY(stoken,1,2); Uppercase(tmpstr); temp1 := POS(tmpstr,'GRPRFNMNLNSUTICNADCISTZIPNCOMIM0M1M2M3M4M5M6M7M8M9'); temp2 := (temp1 + 1) DIV 2; IF temp2 * 2 <> temp1 + 1 THEN temp2 := 0; stoken := ''; WITH disk^ DO CASE temp2 OF 1 : stoken := greet; 2 : stoken := prefx; 3 : stoken := fname; 4 : stoken := minit; 5 : stoken := lname; 6 : stoken := suffx; 7 : stoken := title; 8 : stoken := coname; 9 : stoken := address; 10: stoken := city; 11: stoken := state; 12: stoken := zip; 13: stoken := phone; 14: stoken := country; 15: stoken := misc; 16,17,18,19,20,21,22,23,24,25 : Getmtoken; END; IF LENGTH(stoken)<>0 THEN INSERT(seqpart,s,sposinline); IF NOT( (LENGTH(stoken)=0) AND (NOT rflg) AND (NOT lflg)) THEN Putone(sjustify,stoken,sfsize,sposinline,s); END; ======================================================================================== DOCUMENT :usus Folder:VOL11:mail2b.text ======================================================================================== {Mail2B - Letter part 2} { 19-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } PROCEDURE Getstoken(VAR s : bstring); VAR tmpstr : STRING[90]; BEGIN temp1 := POS('(*',s); sposinline := temp1; stoken := ''; stoken := COPY(s, temp1+2 , POS('*)',s)-temp1-2); DELETE(s,POS('(*',s),POS('*)',s)-POS('(*',s)+2); seqpart := ''; IF temp1 <= LENGTH(s) THEN BEGIN IF s[temp1]='=' THEN BEGIN tmpstr := COPY(s,temp1,LENGTH(s)-temp1+1); DELETE(tmpstr,1,1); IF POS('=',tmpstr)>1 THEN seqpart := COPY(tmpstr,1,POS('=',tmpstr)-1); IF LENGTH(tmpstr)=0 THEN temp2 := 1 ELSE IF POS('=',tmpstr)=0 THEN temp2 := LENGTH(tmpstr)+1 ELSE temp2 := POS('=',tmpstr)+1; IF temp2 <> 0 THEN DELETE(s,temp1,temp2); END; END; rflg := FALSE; lflg := FALSE; IF POS(' ',stoken)=1 THEN BEGIN DELETE(stoken,1,1); lflg := TRUE; END; IF LENGTH(stoken)<>0 THEN IF stoken[LENGTH(stoken)] = ' ' THEN BEGIN DELETE(stoken,LENGTH(stoken),1); rflg := TRUE; END; IF lflg AND rflg THEN sjustify := center ELSE IF lflg THEN sjustify := right ELSE sjustify := left; sfsize := 0; IF POS(':',stoken)<>0 THEN IF POS(':',stoken)<> LENGTH(stoken) THEN BEGIN tmpstr := COPY(stoken, POS(':',stoken)+1, LENGTH(stoken)-POS(':',stoken)); sfsize := 30; sfsize := Val(tmpstr); DELETE(stoken,POS(':',stoken), LENGTH(stoken)-POS(':',stoken)+1); END ELSE DELETE(stoken,LENGTH(stoken),1); END; FUNCTION Hastoken(VAR s : bstring) : BOOLEAN; VAR intb : BOOLEAN; BEGIN (* Hastoken *) intb := FALSE; WHILE (POS('*)',s)<>0) AND ((POS('(*',s)=0) OR (POS('(*',s)>POS('*)',s))) DO DELETE(s,POS('*)',s),2); IF ((POS('(*',s)<>0) AND (POS('*)',s)<>0)) AND (POS('(*',s)0) DO BEGIN ltoken := CONCAT(ltoken,COPY(line,lposinline,1)); IF LENGTH(ltoken)>1 THEN BEGIN IF (ltoken[LENGTH(ltoken)]=')') AND (ltoken[LENGTH(ltoken)-1]='*') THEN level := level - 1; IF (ltoken[LENGTH(ltoken)]='*') AND (ltoken[LENGTH(ltoken)-1]='(') THEN level := level + 1; END; DELETE(line,lposinline,1); END; IF (ltoken[LENGTH(ltoken)]=')') AND (LENGTH(ltoken)>1) THEN IF (ltoken[LENGTH(ltoken)-1]='*') THEN DELETE(ltoken,LENGTH(ltoken)-1,2); IF ltoken[LENGTH(ltoken)]=' ' THEN BEGIN DELETE(ltoken,LENGTH(ltoken),1); rflg := TRUE; END; IF lflg AND rflg THEN ljustify := center ELSE IF lflg THEN ljustify := right ELSE ljustify := left; lfsize := 0; temp1 := SCAN(-LENGTH(ltoken),=':',ltoken[LENGTH(ltoken)]); IF temp1<>-LENGTH(ltoken) THEN BEGIN lfsize := Val(COPY(ltoken,LENGTH(ltoken)+temp1+1,-temp1)); DELETE(ltoken,LENGTH(ltoken)+temp1,-temp1+1); END; leqpart := ''; IF lposinline'=') DO BEGIN leqpart := CONCAT(leqpart,COPY(line,lposinline,1)); DELETE(line,lposinline,1); END; IF leqpart[LENGTH(leqpart)]='=' THEN DELETE(line,lposinline,1); IF leqpart[LENGTH(leqpart)]='=' THEN DELETE(leqpart,LENGTH(leqpart),1); END; END (* Getltoken *); FUNCTION Hasltoken: BOOLEAN; VAR intb : BOOLEAN; BEGIN intb := FALSE; WHILE (POS('*)',line)<>0) AND ((POS('(*',line)=0) OR (POS('(*',line)>POS('*)',line))) DO DELETE(line,POS('*)',line),2); lposinline := POS('(*',line); DELETE(line,lposinline,2); lflg := FALSE; rflg := FALSE; IF line[lposinline] =' ' THEN BEGIN DELETE(line,lposinline,1); lflg := TRUE; END; IF (POS(COPY(line,lposinline,1),legalfchrs)=0) OR (POS(COPY(line,lposinline+1,1),legal2chrs)=0) OR (line[lposinline+2] IN ['A'..'Z','a'..'z']) OR (NOT (line[lposinline+2] IN [':',' ','*'])) THEN BEGIN intb := TRUE; Getltoken; END ELSE BEGIN IF lflg THEN INSERT(' ',line,lposinline); INSERT('(*',line,lposinline); END; Hasltoken := intb; END; BEGIN (* Chgtokens *) legalfchrs := 'gpfmlstcacszpcmGPFMLSTCACSZPCM'; legal2chrs := 'rrnnnuinditinoiRRNNNUINDITINOI0123456789'; REPEAT IF POS('(*',line)<>0 THEN BEGIN IF Hasltoken THEN BEGIN WHILE (POS('(*',ltoken)<>0) AND Hastoken(ltoken) DO Chg1(ltoken); IF LENGTH(ltoken)<>0 THEN INSERT(leqpart,line,lposinline); Putone(ljustify,ltoken,lfsize,lposinline,line); END ELSE IF Hastoken(line) THEN Chg1(line); END; UNTIL POS('(*',line)=0; END; PROCEDURE Getnext; VAR eqflg : BOOLEAN; chsonline:integer; {temp count of chs put on the line for comma decisions} BEGIN REPEAT READLN(infile,line); Prflgs; IF LENGTH(line)>0 THEN Chgtokens; eqflg := FALSE; IF POS('^',line)=1 THEN BEGIN DELETE(line,1,1); pgflg := TRUE; END; IF POS('=',line)=1 THEN BEGIN DELETE(line,1,1); eqflg := TRUE; END; IF POS(DirStr,line)=0 THEN WHILE POS(' ',line)=1 DO DELETE(line,1,1) ELSE IF eqflg THEN BEGIN tline := line; WHILE POS(DirStr,tline)<>0 DO DELETE(tline,POS(DirStr,tline),1); WHILE POS(' ',tline)=1 DO DELETE(tline,1,1); IF LENGTH(tline)=0 THEN line := ''; END; UNTIL EOF(infile) OR (NOT eqflg) OR ((LENGTH(line)<>0) AND eqflg); IF POS('\\',line)=1 THEN WITH disk^ DO {insert mailing label in letter} BEGIN {linat alters in here by 2 to 4 - ignored if poption FALSE} Outline; WRITE(odisk,lmarg); IF LENGTH(prefx)<>0 THEN WRITE(odisk,prefx,' '); WRITE(odisk,fname,' '); IF LENGTH(minit)<>0 THEN WRITE(odisk,minit,' '); WRITE(odisk,lname); IF LENGTH(suffx)<>0 THEN WRITE(odisk,', ',suffx); WRITELN(odisk); Linat:=linat+1; IF (LENGTH(title)<>0) OR (LENGTH(coname)<>0) THEN BEGIN WRITE(odisk,lmarg,title); IF (LENGTH(title)<>0) AND (LENGTH(coname)<>0) THEN WRITE(odisk,', '); WRITELN(odisk,coname); linat := linat + 1; END; WRITELN(odisk,lmarg,address); linat:=linat+1; WRITE(odisk,lmarg,city); chsonline:=length(city); IF (chsonline<>0) and (length(state)<>0) THEN WRITE(odisk,', '); IF (LENGTH(state)<>0) THEN WRITE(odisk,state,'.'); chsonline:=chsonline+length(state); {approx length only} if length(country)+length(zip)<>0 then begin if chsonline<>0 then write(odisk,', '); write(odisk,country); chsonline:=chsonline+length(country); {approx only} IF (chsonline<>0) and (length(zip)<>0) THEN WRITE(odisk,', '); WRITELN(odisk,zip); linat:=linat+1; end; Getnext; END; END; procedure LInitParams; BEGIN with format^ do begin lmgin := llmgin; pmgin := lpin; SetPLMargins(pmgin,lmgin); lsize := (lchar-llmgin)-lrmgin; spc := spacing; {set up temporaries - these are reset within a line with [: :] barckets} tlmgin := lmgin; tpmgin := pmgin; tlsize := lsize; end; END; PROCEDURE Getline; BEGIN IF NOT EOF(infile) THEN REPEAT Getnext; IF POS(DirStr,line)=0 THEN WHILE POS(' ',line)=1 DO DELETE(line,1,1); epar := (LENGTH(line)=0); {blank line encountered ends para} {flush last line if its contains something} IF (epar OR (POS(DirStr,line)<>0)) AND (oline<>'') THEN Outline; IF epar THEN begin LInitParams; epar := FALSE; end; WHILE (NOT(FileEnd)) AND ((LENGTH(line)=0) OR (POS(DirStr,Line)<>0)) DO BEGIN IF LENGTH(line)=0 THEN newpar := TRUE; IF POS(DirStr,line)<>0 THEN newpar := FALSE; WHILE POS(DirStr,line)<>0 DO DELETE(line,POS(DirStr,line),1); WRITE(odisk,lmarg,line); FOR temp4 := 1 TO ORD(spc) DO WRITELN(odisk); if EOF(infile) then begin FileEnd:=true; line:=''; end; IF format^.poption THEN Chkpage; if NOT(FileEnd) then begin Getnext; IF POS(DirStr,line)=0 THEN WHILE POS(' ',line)=1 DO DELETE(line,1,1); end; END; UNTIL EOF(infile) OR (POS('\\',line)<>1); END; PROCEDURE Getoken; BEGIN token := ''; REPEAT IF POS(' ',line)<>0 THEN BEGIN token := COPY(line,1,POS(' ',line)-1); DELETE(line,1,POS(' ',line)) END ELSE BEGIN token := line; line := ''; END; WHILE Hasmgin DO Getmgin; WHILE POS(' ',token)=1 DO DELETE(token,1,1); IF (LENGTH(token)=0) AND (LENGTH(line)=0) THEN Getline; UNTIL (LENGTH(token)<>0) OR EOF(infile); END; FUNCTION Addable : BOOLEAN; BEGIN temp := lsize; IF newpar THEN temp := temp - pmgin; Addable := NOT(LENGTH(token)=0) AND (LENGTH(token)+LENGTH(oline)+10 THEN oline := CONCAT(oline,' ',token) ELSE oline := token; END; PROCEDURE Oletter; BEGIN {$I-} RESET(infile,LetterName); IF IORESULT<>0 THEN Reporterr('Cannot open input file ',LetterName,IORESULT) else begin SC_Clr_Screen; IF format^.ofilename <> '#2:' THEN WRITE('Processing a letter'); LInitParams; pageat := format^.lspage; newpar := TRUE; pgflg := FALSE; epar := FALSE; oline := ''; token := ''; FileEnd:=false; LastPageWritten:=false; PutTopMargin; Getgreet; WHILE NOT EOF(infile) DO BEGIN Getline; WHILE LENGTH(line)>0 DO BEGIN Getoken; IF LENGTH(oline)'' then Outline; {force out remainder of line} CLOSE(infile); end; {$I+} if format^.ofilename<>'#2:' then begin writeln; writeln('Finished with this letter.'); end; END; PROCEDURE Wparta; var ch2:char; BEGIN repeat SC_Clr_Line(1); SC_Clr_Line(0); WRITELN('Wildcard: P)refix, F)name, mi(N)it, L)name, s(U)ffix, T)itle, C)mpny, '); WRITE(' #)ph, A)dd, c(I)ty, S)tate, cntr(Y), Z)ip, M)isc, Q)uit:'); READ(KEYBOARD,ch2); until (ch2 IN ['P','p','F','f','N','n','L','l','U','u','T','t','M','m', 'C','c','#','A','a','I','i','S','s','Y','y','Z','z','Q','q']); if (ch2 in ['Q','q']) then EXIT(Letter); SC_Clr_Line(1); SC_Clr_Line(0); Wild1(ch2); increment:=1; FOR recnumber := recnumber TO numrecs DO BEGIN SEEK(disk,recnumber); GET(disk); Wild2; IF (disk^.code='Perm ') OR (disk^.code='Add ') OR (disk^.code='Change') THEN IF Wildok THEN BEGIN Oletter; if NOT(format^.poption) then Chkorquit; END; END; END; procedure GetLetterName; var ch:char; ok,newname:boolean; begin Lettername:=format^.infilename; SC_Clr_Line(1); SC_Clr_Line(0); Write('Do you wish to use the letter in ',LetterName,' (Y/N):'); repeat read(KEYBOARD,ch); until ch in ['Y','y','N','n']; write(ch); newname:=((ch='N') or (ch='n')); ok:=false; repeat if newname then begin SC_Clr_Line(1); write('Give file holding the letter ', '( to quit):'); readln(LetterName); if length(LetterName)>0 then if Lettername[1]=CHR(27) then Exit(Letter); UpperCase(LetterName); if (Length(LetterName)<=5) or (POS('.TEXT',LetterName)<>(Length(LetterName)-4)) then LetterName:=CONCAT(LetterName,'.TEXT'); end; newname:=true; {in case check fails} if chkfiles(LetterName) then ok:=true else begin SC_Clr_Line(0); write('Cannot open input file ',LetterName); end; until ok; end; BEGIN (* Letter *) GetLettername; SC_Clr_Line(1); SC_Clr_Line(0); WRITE('Letter: A)ll, S)ingle, W)ildcard, Q)uit:'); repeat READ(KEYBOARD,ch); until ch in ['A','a','S','s','W','w','Q','q']; write(ch); if not(ch in ['Q','q']) then begin tempch:=format^.LDirCh; if NOT (tempch IN ['!','#','$','%','&','@','|','~']) then tempch:='~'; DirStr:=' '; DirStr[1]:=tempch; {$I-} REWRITE(odisk,format^.ofilename); IF IORESULT<>0 THEN Reporterr('Cannot open output file ',format^.ofilename,IORESULT) else begin CASE ch OF 'W','w' : Wparta; 'A','a' : begin increment:=1; FOR recnumber := recnumber TO numrecs DO BEGIN SEEK(disk,recnumber); GET(disk); IF (disk^.code='Perm ') OR (disk^.code='Add ') OR (disk^.code='Change') THEN IF Chkflgs THEN BEGIN Oletter; if NOT(format^.poption) then Chkorquit; END; END; end; 'S','s' : BEGIN SEEK(disk,recnumber); GET(disk); Oletter; END; END; CLOSE(odisk,lock); IF IORESULT<>0 THEN Reporterr('Cannot close output file ',format^.ofilename,IORESULT); end; {$I+} end; END; ======================================================================================== DOCUMENT :usus Folder:VOL11:mail3.text ======================================================================================== {Mail3 - Mlabels} { 19-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } SEGMENT PROCEDURE MLabels; VAR finame,fconame : ARRAY[1..4] OF STRING[33]; at,numreps : INTEGER; ch,ch2:char; PROCEDURE Gfnaco; VAR tfname : STRING[10]; BEGIN FOR temp := 1 TO columat DO WITH Mailarry[temp] DO BEGIN IF LENGTH(lname)+LENGTH(fname)+LENGTH(minit) = 0 THEN finame[temp] := ' ' ELSE BEGIN finame[temp] := ''; fconame[temp] := ''; temp1 := LENGTH(lname); IF LENGTH(prefx)<>0 THEN temp1 := temp1 + LENGTH(prefx) + 1; IF LENGTH(suffx)<>0 THEN temp1 := temp1 + LENGTH(suffx) + 1; IF LENGTH(minit)<>0 THEN temp1 := temp1 + LENGTH(minit) + 1; IF 330 THEN finame[temp] := CONCAT(minit,' ',finame[temp]); IF LENGTH(tfname)<>0 THEN finame[temp] := CONCAT(tfname,' ',finame[temp]); IF LENGTH(prefx)<>0 THEN finame[temp] := CONCAT(prefx,' ',finame[temp]); IF (LENGTH(suffx)<>0) AND ((LENGTH(finame[temp])+2+LENGTH(suffx))<=33) THEN finame[temp] := CONCAT(finame[temp],', ',suffx); END; fconame[temp] := coname; IF LENGTH(coname)+LENGTH(title)<=31 THEN {room to put on title} begin if length(title)<>0 then begin if length(coname)<>0 then fconame[temp]:= CONCAT(title,', ',coname) else fconame[temp] := title; end; end; END; END; PROCEDURE Plabel; var filler:string[7]; BEGIN IF format^.ofilename = '#2:' THEN SC_Clr_Screen; Gfnaco; WITH format^ DO BEGIN FOR temp := 1 TO mvtab DO WRITELN(odisk); IF rolodex THEN FOR temp := 1 TO columat DO WITH mailarry[temp] DO BEGIN WRITE(odisk,phone,' ':(33-LENGTH(phone)),' ':mmgin); END; IF rolodex THEN WRITELN(odisk); FOR temp := 1 TO columat DO IF LENGTH(fconame[temp]) <> 0 THEN BEGIN WRITE(odisk,finame[temp],' ':mmgin); IF LENGTH(finame[temp])<33 THEN WRITE(odisk,' ':(33-LENGTH(finame[temp]))); END ELSE WRITE(odisk,' ':33,' ':mmgin); WRITELN(odisk); FOR temp := 1 TO columat DO BEGIN IF LENGTH(fconame[temp])<>0 THEN BEGIN WRITE(odisk,fconame[temp],' ':mmgin); IF LENGTH(fconame[temp])<33 THEN WRITE(odisk,' ':(33-LENGTH(fconame[temp]))); END ELSE BEGIN WRITE(odisk,finame[temp],' ':mmgin); IF LENGTH(finame[temp])<33 THEN WRITE(odisk,' ':(33-LENGTH(finame[temp]))); END; END; WRITELN(odisk); FOR temp := 1 TO columat DO BEGIN WRITE(odisk,mailarry[temp].address,' ':mmgin); WRITE(odisk,' ':(33-LENGTH(mailarry[temp].address))); END; WRITELN(odisk); FOR temp := 1 TO columat DO WITH mailarry[temp] DO begin WRITE(odisk,city); filler:=''; if (length(city)<>0) and (length(state)<>0) then write(odisk,', ') else {needs 2 spaces on end of line to align} filler:=' '; write(odisk,state, ' ':(31-LENGTH(city)-LENGTH(state)),' ':mmgin,filler); end; WRITELN(odisk); FOR temp := 1 TO columat DO WITH mailarry[temp] DO BEGIN WRITE(odisk,country); IF (LENGTH(country) = 0) THEN WRITE(odisk,zip:29,' ',' ':mmgin) ELSE begin if length(zip)=0 then filler:=' ' else filler:=', '; WRITE(odisk,filler,zip:(28-LENGTH(country)),' ',' ':mmgin); end; END; WRITELN(odisk); END; END; PROCEDURE Printone; BEGIN WITH format^ DO BEGIN IF NOT eflg THEN BEGIN columat := columat + 1; mailarry[columat] := disk^; END; GOTOXY(0,22); IF (NOT eflg) AND (columat < mwide) THEN EXIT(Printone); Plabel; columat := 0; END; END; {$I-} BEGIN repeat SC_Clr_Line(1); SC_Clr_Line(0); WRITE('MLabels: A)ll matching flag criteria, S)ingle, R)epeat, W)ildcard, Q)uit:'); READ(KEYBOARD,ch); until ch in ['A','a','S','s','W','w','R','r','Q','q']; write(ch); if (ch='Q') or (ch='q') then exit(MLabels); REWRITE(odisk,format^.ofilename); if IORESULT<>0 then Reporterr('Cannot open output file ',format^.ofilename,IORESULT) else begin eflg := FALSE; CASE ch OF 'W','w' : BEGIN repeat SC_Clr_Line(0); WRITELN('Wildcard: P)refix, F)name, mi(N)it, ', 'L)name, s(U)ffix, T)itle, C)mpny,'); WRITE(' #)ph, A)dd, c(I)ty, S)tate, cntr(Y), ', 'Z)ip, M)isc, Q)uit:'); READ(KEYBOARD,ch2); until ch2 in ['P','p','F','f','N','n','L','l','U','u','T','t','M','m', 'C','c','#' ,'A','a','I','i','S','s','Y','y','Z','z', 'Q','q']; write(ch2); if ch2 in ['Q','q'] THEN BEGIN CLOSE(odisk); EXIT(MLabels); END; SC_Clr_Line(1); SC_Clr_Line(0); Wild1(ch2); FOR recnumber := 1 TO numrecs DO BEGIN SEEK(disk,recnumber); GET(disk); IF (disk^.code='Perm ') OR (disk^.code='Add ') OR (disk^.code='Change') THEN BEGIN Wild2; IF Wildok THEN Printone; END; END; IF columat <> 0 THEN BEGIN eflg := TRUE; Printone; END; END; 'A','a' : BEGIN FOR recnumber := 1 TO numrecs DO BEGIN SEEK(disk,recnumber); GET(disk); IF (disk^.code='Perm ') OR (disk^.code='Add ') OR (disk^.code='Change') THEN IF Chkflgs THEN Printone; END; IF columat <> 0 THEN BEGIN eflg := TRUE; Printone; END; END; 'R','r' : BEGIN SEEK(disk,recnumber); GET(disk); repeat SC_Clr_Line(0); WRITE('Enter number of repetitions (max 100):'); numreps:=0; {value returned if integer is illegal} Getint(0,0,numreps); until (numreps<=100) and (numreps>=0); if numreps>0 then FOR at := 1 TO numreps DO Printone; IF columat<>0 THEN BEGIN eflg := TRUE; Printone; END; END; 'S','s' : BEGIN SEEK(disk,recnumber); GET(disk); Printone; END; END; CLOSE(odisk,lock); if IORESULT<>0 then ReportErr('Cannot close output file ',format^.ofilename,IORESULT); end; END; {$I+} ======================================================================================== DOCUMENT :usus Folder:VOL11:mail4.text ======================================================================================== {Mail4 - Options} { 22-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } SEGMENT PROCEDURE Options; VAR illflg : BOOLEAN; ch:char; {$I-} PROCEDURE Dumpflgs; BEGIN WITH format^ DO BEGIN column := 0; REWRITE(odisk,ofilename); IF IORESULT<>0 THEN Reporterr('Cannot open output file ',ofilename,IORESULT) else begin if ofilename='#2:' then begin SC_Clr_screen; gotoxy(0,2); end; WRITELN(odisk,'Descriptions and Flags Set'); WRITELN(odisk,'----------------------------------------------------------'); FOR temp := 1 TO 48 DO BEGIN column := column + 1; WRITE(odisk,temp:2,'.',meanings[temp]); IF fflags[temp] THEN BEGIN WRITE(odisk,'........................':(21-LENGTH(meanings[temp]))); WRITE(odisk,'* '); END ELSE WRITE(odisk,' ':24-LENGTH(meanings[temp])); IF column = 3 THEN BEGIN column := 0;WRITELN(odisk);END; END; CLOSE(odisk,lock); if IORESULT<>0 then Reporterr('Cannot close output file ',ofilename,IORESULT) end; END {with format^}; END; {$I+} PROCEDURE Chgfflgs; var ch,ch1:char; BEGIN WITH disk^,format^ DO REPEAT; SC_Clr_Screen; temp1 := 2; column := 0; FOR temp := 1 TO 48 DO BEGIN temp1 := temp1 + 1; GOTOXY(column * 27,temp1); WRITE(temp:2,'.',meanings[temp]); IF fflags[temp] THEN BEGIN WRITE('.............................':(21-LENGTH(meanings[temp]))); WRITE('*'); END; IF temp1 = 18 THEN BEGIN temp1 := 2;column := column + 1;END; END; WRITELN; WRITE('Matching option: '); IF option THEN WRITELN('A)ny positive match') ELSE WRITELN('E)xact matches only'); repeat SC_Clr_Line(0); WRITE('Match Flags: D)ump, O)ption, R)emove, S)et, Q)uit:'); READ(KEYBOARD,ch1); until ch1 in ['D','d','O','o','R','r','S','s','Q','q']; write(ch1); CASE ch1 OF 'D','d' : Dumpflgs; 'O','o' : BEGIN repeat SC_Clr_Line(0); WRITE('Flag option: E)xact matches only, ', 'A)ny positive match, Q)uit:'); READ(KEYBOARD,ch); until ch in ['E','e','A','a','Q','q']; write(ch); CASE ch OF 'E','e' : format^.option := FALSE; 'A','a' : format^.option := TRUE; END; END; 'R','r' : BEGIN SC_Clr_Line(0); WRITE('Enter flagnumber to be removed:'); Getint(0,0,temp); IF (temp>0) AND (temp<=48) THEN fflags[temp] := FALSE; END; 'S','s' : BEGIN SC_Clr_Line(0); WRITE('Enter flagnumber to be set:'); Getint(0,0,temp); IF (temp>0) AND (temp<=48) THEN fflags[temp] := TRUE; END; END (* CASE *) UNTIL ch1 IN ['Q','q']; illflg := TRUE; END (* Chgfflg *); PROCEDURE Chgmeanings; BEGIN WITH format^ DO REPEAT SC_Clr_Screen; column := 0;temp1 := 2; FOR temp := 1 TO 48 DO BEGIN temp1 := temp1 + 1; GOTOXY(column*26,temp1); WRITE(temp:2,'. ',meanings[temp]); IF temp1 = 18 THEN BEGIN temp1 := 2;column := column + 1;END; END; SC_Clr_Line(0); WRITE('Number of Description to change, 0 to Quit:'); Getint(0,0,temp); SC_Clr_Line(0); IF (temp>0) AND (temp<=48) THEN BEGIN SC_Clr_Line(0); WRITE('Enter new description #',temp:2,':'); Rdata(0,28,0,20,format^.meanings[temp]); END; UNTIL temp = 0; illflg := TRUE; END; PROCEDURE Chgspacing; VAR ch1 : CHAR; BEGIN WITH format^ DO BEGIN repeat GOTOXY(32,7); READ(KEYBOARD,ch1); until ch1 in ['S','s','D','d','T','t']; CASE ch1 OF 's','S' : spacing := 1; 'd','D' : spacing := 2; 't','T' : spacing := 3; END; GOTOXY(32,7); CASE spacing OF 1 : WRITELN('single'); 2 : WRITELN('double'); 3 : WRITELN('triple'); END; END; END; PROCEDURE PutJOption; BEGIN GOTOXY(41,9); WRITE('Justification'); GOTOXY(71,9); if format^.joption then write(':yes') else write(':no'); END; function lyes(x,y:integer):boolean; var yes:boolean; ch1:char; BEGIN repeat GOTOXY(x,y); READ(KEYBOARD,ch1); until ch1 in ['Y','y','N','n']; yes:=((ch1='Y') or (ch1='y')); GOTOXY(x,y); IF yes THEN WRITELN('yes') ELSE WRITELN('no '); lyes:=yes; END; PROCEDURE Chglmgins; var ch:char; BEGIN repeat repeat SC_Clr_Line(0); WRITE('Letter margins: L)eft, R)ight, T)op, P)aragraph, J)ustify, Q)uit:'); READ(KEYBOARD,ch); until ch in ['L','l','R','r','T','t','P','p','J','j','Q','q']; write(ch); CASE ch OF 'P','p' : repeat Getint(32,11,format^.lpin); until format^.lpin<=60; 'T','t' : begin Getint(32,10,format^.lvtab); gotoxy(40,10); write('Bottom of page margin is fixed :5'); end; 'L','l' : repeat Getint(32,8,format^.llmgin); until format^.llmgin<=60; 'R','r' : BEGIN Getint(32,9,format^.lrmgin); PutJOption; END; 'J','j' : format^.joption:=lyes(72,9); END; until ch in ['Q','q']; END; PROCEDURE Chglopts; var ch1,ch2:char; BEGIN repeat repeat SC_Clr_Line(0); WRITE('Letter options: P)age, S)top-pages, ', 'F(eed pages, M(atch for flag paras, Q)uit:'); READ(KEYBOARD,ch2); until ch2 in ['M','m','F','f','P','p','S','s','Q','q']; write(ch2); WITH format^ DO CASE ch2 OF 'M','m' : BEGIN GOTOXY(32,17); READ(ch1); CASE ch1 OF 's','S' : loption := FALSE; 'a','A' : loption := TRUE; END (* CASE *); GOTOXY(32,17); IF loption THEN WRITELN('all ') ELSE WRITELN('single'); END; 'F','f' : ffeed:=lyes(32,16); 'S','s' : foption:=lyes(32,15); 'P','p' : poption:=lyes(32,14); END (* CASE *) until ch2 in ['Q','q']; END; PROCEDURE Chgletter; VAR ch1,ch2 : CHAR; BEGIN repeat Repeat SC_Clr_Line(0); WRITE('Letter: C)hrs/ln, L)ns/Pg, M)gin, D)irCh, O)pt, P)g#, ', 'S)pacing, W)idow, Q)uit:'); READ(KEYBOARD,ch1); until ch1 in ['C','c','D','d','L','l','M','m', 'O','o','P','p','S','s','W','w','Q','q']; write(ch1); CASE ch1 OF 'D','d' : begin repeat gotoxy(32,4); read(KEYBOARD,Ch2); until Ch2 in [' ','!','#','$','%','&','@','|','~']; {excludes characters used elsewhere in Mail} if Ch2<>' ' then begin format^.lDirCh:=Ch2; write(Ch2); end; end; 'C','c' : Getint(32,5,format^.lchar); 'L','l' : Getint(32,6,format^.lpsiz); 'M','m' : Chglmgins; 'O','o' : Chglopts; 'S','s' : Chgspacing; 'W','w' : Getint(32,13,format^.lpwid); 'P','p' : Getint(32,12,format^.lspage); END; until ch1 in ['Q','q']; END; PROCEDURE Chgtype; var ch:char; BEGIN repeat GOTOXY(32,23); READ(KEYBOARD,ch); until ch in ['E','e','R','r']; CASE ch OF 'E','e' : format^.rolodex := FALSE; 'R','r' : format^.rolodex := TRUE; END (* CASE *); GOTOXY(32,23); IF format^.rolodex THEN WRITE('rolodex ') ELSE WRITE('envelope'); END (* Chgtype *); PROCEDURE Chglabels; var ch1:char; BEGIN repeat repeat SC_Clr_Line(0); WRITE('Mailing labels: N)wide, V)tab, L)margin, T)ype, Q)uit:'); READ(KEYBOARD,ch1); until ch1 in ['N','n','V','v','L','l','N','n','T','t','Q','q']; write(ch1); CASE ch1 OF 'N','n' : Getint(32,22,format^.mwide); 'V','v' : Getint(32,20,format^.mvtab); 'L','l' : Getint(32,21,format^.mmgin); 'T','t' : Chgtype; END; until ch1 in ['Q','q']; END; FUNCTION Fquit:BOOLEAN; var ch:char; BEGIN repeat SC_Clr_Line(0); WRITE('Quit Option:'); WRITE(' E)xit without updating, R)eturn to give more options, U)pdate:'); READ(KEYBOARD,ch); until ch in ['E','e','R','r','U','u']; write(ch); CASE ch OF 'E','e' : BEGIN SEEK(format,0); GET(format); END; 'U','u' : BEGIN SEEK(format,0); PUT(format); END; END; Fquit:=((ch<>'r') AND (ch<>'R')); END; PROCEDURE Foutput; procedure fout1; var ch:char; begin WITH format^ DO BEGIN SC_Clr_Screen; WRITELN; WRITELN('Input filename :',infilename); WRITELN('Output filename :',ofilename); WRITELN; ch:=LDirCh; if NOT (ch IN ['!','#','$','%','&','@','|','~']) then ch:='~'; WRITELN('*Letter Format - Directive char:',ch); WRITELN(' Number of characters to a line:',lchar); WRITELN(' Number of lines to a page :',lpsiz); WRITE (' Spacing (s, d or t):'); CASE spacing OF 1 : WRITELN('single'); 2 : WRITELN('double'); 3 : WRITELN('triple'); END; WRITELN(' Left column margin :',llmgin); WRITE (' Right column margin :',lrmgin); PutJOption; WRITELN; WRITE (' Top of page margin :',lvtab); WRITELN(' Bottom of page margin is fixed:5'); WRITELN(' Paragraph margin :',lpin); WRITELN(' Starting page number :',lspage); end {with format^} end {of Fout1}; procedure pyesno(yes:boolean); begin if yes then writeln('yes') else writeln('no'); end; procedure fout2; begin with format^ do begin WRITELN(' Paragraph widow :',lpwid); WRITE (' Pagination (y or n):'); pyesno(poption); WRITE (' Stop between pages (y or n):'); pyesno(foption); WRITE (' Form feed each page (y or n):'); pyesno(ffeed); WRITE (' Match for flag paras (a or s):'); if loption then writeln('all') else writeln('single'); WRITELN; WRITELN('*Mailing Labels Format -'); WRITELN(' Vertical tab between rows :',mvtab); WRITELN(' Left margin before each label :',mmgin); WRITELN(' Number of labels across page :',mwide); WRITE (' Type (r or e):'); IF rolodex THEN WRITE('rolodex') ELSE WRITE('envelope'); END; end {of fout2}; BEGIN fout1; {routines split to reduce individual code sizes} fout2; END {of Foutput}; BEGIN RESET(format,ffilename); SEEK(format,0); GET(format); WITH format^ DO REPEAT; illflg := TRUE; REPEAT IF illflg THEN Foutput; illflg := FALSE; repeat SC_Clr_Line(0); WRITE('Options: D)scrps, F)lags, M)labels, L)etter, I)nput, O)utput, Q)uit:'); READ(KEYBOARD,ch); until ch in ['D','d','F','f','M','m','L','l','I','i','O','o','Q','q']; write(ch); CASE ch OF 'D','d' : Chgmeanings; 'F','f' : Chgfflgs; 'I','i' : BEGIN REPEAT Rdata(1,17,1,30,infilename); UpperCase(infilename); if (Length(infilename)<=5) or (POS('.TEXT',infilename)<>(Length(infilename)-4)) then infilename := CONCAT(infilename,'.TEXT'); UNTIL Chkfiles(infilename); END; 'L','l' : Chgletter; 'M','m' : Chglabels; 'O','o' : Rdata(1,17,2,30,format^.ofilename); END; UNTIL ch IN ['Q','q']; UNTIL Fquit; Gtstdflgs; CLOSE(format); END; ======================================================================================== DOCUMENT :usus Folder:VOL11:mail5.text ======================================================================================== {Mail15 - Sortit} { 19-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } SEGMENT PROCEDURE Sortit; var sortch:char; {global holds type of sort} TYPE lptr = ^lrec; lrec = RECORD key1 : STRING[6]; key2 : STRING[30]; recfrom : INTEGER; link : lptr; END; VAR linkedrec : lrec; first,ptr,tptr,hptr : lptr; heaptr : ^INTEGER; ch : CHAR; tfrecord : labelrec; rectoaddto,recat : INTEGER; PROCEDURE Getkeys(recnumber : INTEGER); BEGIN SEEK(disk,recnumber); GET(disk); WRITE('.'); NEW(ptr); WITH disk^,ptr^ DO BEGIN key1 := code; CASE sortch OF 'P','p' : key2 := prefx; 'F','f' : key2 := fname; 'N','n' : key2 := minit; 'L','l' : key2 := lname; 'U','u' : key2 := suffx; 'T','t' : key2 := title; 'C','c' : key2 := coname; '#' : key2 := phone; 'A','a' : key2 := address; 'I','i' : key2 := city; 'S','s' : key2 := state; 'Y','y' : key2 := country; 'Z','z' : key2 := zip; 'M','m' : key2 := COPY(misc,1,30); {sort on first 30 chs of Misc only} END; recfrom := recnumber; END; END; FUNCTION Atrecbelowtheonetobeadded: BOOLEAN; VAR intb : BOOLEAN; BEGIN intb := FALSE; IF ptr^.key1>tptr^.key1 THEN intb := TRUE ELSE IF (ptr^.key1=tptr^.key1) AND (ptr^.key2NIL) AND intb DO IF Atrecbelowtheonetobeadded THEN intb := FALSE ELSE BEGIN hptr := tptr; tptr := tptr^.link; END; ptr^.link := tptr; IF tptr = first THEN first := ptr ELSE hptr^.link := ptr; tptr := first; END; FUNCTION Inrightplace : BOOLEAN; VAR intb : BOOLEAN; BEGIN intb := TRUE ; IF ptr^.recfrom <> rectoaddto THEN intb := FALSE; Inrightplace := intb; END; PROCEDURE Puttptratlinkedrecthatwillgototemp(temp : INTEGER); VAR temp1 : INTEGER; BEGIN tptr := first; temp1 := 1; WHILE (tptr<>NIL) AND (temp1rectoaddto DO BEGIN SEEK(disk,tptr^.recfrom); GET(disk); WRITE('.'); SEEK(disk,temp); PUT(disk); WRITE('.'); temp2 := tptr^.recfrom; tptr^.recfrom := temp; temp := temp2; Puttptratlinkedrecthatwillgototemp(temp); END; tptr^.recfrom := temp; disk^ := tfrecord; SEEK(disk,temp); PUT(disk); WRITE('.'); END; PROCEDURE DoSort; BEGIN (* DoSort *) temp := 0; MARK(heaptr); first := nil; FOR recat := 1 TO numrecs DO BEGIN Getkeys(recat); {assumes sortch set globally} Addtolinkedlist; END; ptr := first; rectoaddto := 0; REPEAT rectoaddto := rectoaddto + 1; IF NOT Inrightplace THEN Putinrightplace; ptr := ptr^.link; UNTIL ptr=nil; RELEASE(Heaptr); END {of DoSort}; PROCEDURE Getsortfield; BEGIN repeat SC_Clr_Screen; WRITELN('Sort: P)refix, F)name, mi(N)it, L)name, s(U)ffix, T)itle, C)mpny,'); WRITE(' #)ph, A)ddress, c(I)ty, S)tate, cntr(Y), Z)ip, M)isc, Q)uit:'); READ(KEYBOARD,sortch); until (sortch IN ['P','p','F','f','N','n','L','l','S','s','T','t','C','c', '#','A','a','I','i','Y','y','Z','z','M','m','u','U','Q','q']); write(sortch); if sortch in ['Q','q'] then EXIT(Sortit); END; PROCEDURE Findnewnumrecs; BEGIN FOR temp := numrecs DOWNTO 1 DO BEGIN SEEK(disk,temp); GET(disk); WRITE('.'); IF (disk^.code = 'Perm ') OR (disk^.code = 'Add ') THEN BEGIN numrecs := temp; temp := 1; END; END; Wnew0rec; END; BEGIN {of sortit} Getsortfield; {sets sortch} Krunch; WRITELN; WRITE('Sorting '); DoSort; Findnewnumrecs; Init; END {of Sortit}; ======================================================================================== DOCUMENT :usus Folder:VOL11:mail6.text ======================================================================================== {Mail6 - Add, Change} { 19-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } {SEGMENT except on II.0} PROCEDURE Add; var ch:char; oldladd:integer; PROCEDURE Findnextdel; BEGIN SEEK(disk,ladd); GET(disk); WHILE (ladd0 THEN BEGIN SC_Clr_Screen; WRITELN('Caution: no more room in file, please krunch or reallocate.'); repeat gotoxy(0,1); until not space_wait(TRUE); numrecs := numrecs - 1; ladd := numrecs; recnumber := numrecs; EXIT(Add); END; (*$I+*) Wnew0rec; END; recnumber := ladd; END; PROCEDURE Getadd; procedure GAddPrompts; begin SC_Clr_Screen; WRITELN; WRITELN; WRITELN('prefix :'); WRITELN('f name :'); WRITELN('m init :'); WRITELN('l name :'); WRITELN('suffix :'); WRITELN('title :'); WRITELN('company :'); WRITELN('phone :'); WRITELN('address :'); WRITELN('city :'); WRITELN('state :'); WRITELN('country :'); WRITELN('zip/post:'); WRITELN('misc :'); end; BEGIN WITH disk^ DO BEGIN GAddPrompts; prefx := ' '; fname := ' '; minit := ' '; lname := ' '; {length 15} suffx := ' '; title := lname; coname := Spaces30; {constant string} phone := lname; address:= Spaces30; city := lname; state := ' '; country := lname; zip := ' '; misc := CONCAT(Spaces30,Spaces30,Spaces30); {length 90} Rdata(0,9,2,5,prefx); Rdata(0,9,3,10,fname); Rdata(0,9,4,2,minit); Rdata(0,9,5,15,lname); Rdata(0,9,6,6,suffx); Rdata(0,9,7,15,title); Rdata(0,9,8,30,coname); Rdata(0,9,9,15,phone); Rdata(0,9,10,30,address); Rdata(0,9,11,15,city); Rdata(0,9,12,2,state); Rdata(0,9,13,15,country); Rdata(0,9,14,8,zip); Rdata(0,9,15,90,misc); WITH format^ DO BEGIN FOR temp := 1 TO 48 DO flags[temp] := FALSE; REPEAT column := 0; temp1 := 0; SC_Clr_Screen; FOR temp := 1 TO 48 DO BEGIN temp1 := temp1 + 1; GOTOXY(27*column,temp1+5); WRITE(temp:2,'.',meanings[temp]); IF flags[temp] THEN BEGIN WRITE('........................':21-LENGTH(meanings[temp])); WRITE('*'); END; IF temp1 = 16 THEN BEGIN temp1 := 0;column := column + 1;END; END; SC_Clr_Line(0); WRITE('Flag to set (0 to quit) :'); temp:=-1; {return value if integer not legal} Getint(0,0,temp); IF (temp>0) AND (temp<=48) THEN flags[temp] := TRUE; UNTIL temp = 0; END (* WITH format^ *); END; (* WITH disk^ *) END (* Getadd *); BEGIN oldladd:=ladd; {save in case of exit} Findnextdel; Getadd; outmode := ad; Outrec; SC_Clr_Line(1); SC_Clr_Line(0); writeln('N)o will abort this A)dd attempt. ', 'N.B. you can A)dd now then C)hange fields.'); WRITE('O.K. to A)dd (Y/N):'); repeat READ(keyboard,ch); until ch in ['Y','y','N','n']; write(ch); IF (ch='N') or (ch='n') THEN BEGIN IF recnumber = numrecs THEN numrecs := numrecs - 1; ladd:=oldladd; EXIT(Add); END; disk^.code := 'Add '; SEEK(disk,recnumber); PUT(disk); NEW(ptr2); ptr2^.intpart := recnumber; ptr2^.lpart2 := first2; first2 := ptr2; END (* Add *); {SEGMENT except on II.0} PROCEDURE Change; var ch:char; PROCEDURE Chgflg; var ch1:char; BEGIN REPEAT; WITH disk^,format^ DO BEGIN SC_Clr_Screen; column := 0; temp1 := 2; FOR temp := 1 TO 48 DO BEGIN temp1 := temp1 + 1; GOTOXY(column*27,temp1); WRITE(temp:2,'.',meanings[temp]); IF flags[temp] THEN BEGIN WRITE('........................':(21-LENGTH(meanings[temp]))); WRITE('*'); END; IF temp1 = 18 THEN BEGIN temp1 := 2;column := column + 1;END; END; repeat SC_Clr_Line(0); WRITE('Chgflags for ',lname,': R)emove, S)et, Q)uit:'); READ(KEYBOARD,ch1); until ch1 in ['R','r','S','s','Q','q']; write(ch1); CASE ch1 OF 'R','r' : BEGIN SC_Clr_Line(0); WRITE('Enter flagnumber to be removed:'); temp:=-1; {return value if integer not legal} Getint(0,0,temp); IF (temp>0) AND (temp<=48) THEN flags[temp] := FALSE; END; 'S','s' : BEGIN SC_Clr_Line(0); WRITE('Enter flagnumber to be set:'); temp:=-1; {return value if integer not legal} Getint(0,0,temp); IF (temp>0) AND (temp<=48) THEN flags[temp] := TRUE; END; END (* CASE *) END (* WITH *); UNTIL ch1 IN ['Q','q']; END (* Chgflg *); PROCEDURE Chgcase(cch:char); VAR tlname2 : STRING[15]; BEGIN CASE cch OF 'G','g' : Chgflg; 'P','p' : BEGIN WRITE('Enter new prefix:'); Rdata(0,19,0,5,disk^.prefx); END; 'F','f' : BEGIN WRITE('Enter new forename:'); Rdata(0,19,0,10,disk^.fname); END; 'N','n' : BEGIN WRITE('Enter new middle initials:'); Rdata(0,25,0,2,disk^.minit); END; 'L','l' : BEGIN WRITE('Enter new last name:'); Rdata(0,20,0,15,disk^.lname); END; 'U','u' : BEGIN WRITE('Enter new suffix:'); Rdata(0,17,0,6,disk^.suffx); END; 'T','t' : BEGIN WRITE('Enter new title:'); Rdata(0,16,0,15,disk^.title); END; 'C','c' : BEGIN WRITE('Enter new company:'); Rdata(0,18,0,30,disk^.coname); END; '#' : BEGIN WRITE('Enter new phone #:'); Rdata(0,18,0,15,disk^.phone); END; 'A','a' : BEGIN WRITE('Enter new address:'); Rdata(0,18,0,30,disk^.address); END; 'I','i' : BEGIN WRITE('Enter new city:'); Rdata(0,15,0,15,disk^.city); END; 'S','s' : BEGIN WRITE('Enter new state:'); Rdata(0,16,0,2,disk^.state); END; 'Y','y' : BEGIN WRITE('Enter new country:'); Rdata(0,18,0,15,disk^.country); END; 'Z','z' : BEGIN WRITE('Enter new ZIP/post code:'); Rdata(0,24,0,8,disk^.zip); END; 'M','m' : BEGIN WRITE('Enter new misc:'); Rdata(0,15,0,90,disk^.misc); END; END (* CASE *); END; BEGIN IF disk^.code = 'Perm ' THEN BEGIN NEW(ptr); NEW(ptr2); STR(recnumber,disk^.code); ptr^.recpart := disk^; ptr2^.intpart := recnumber; ptr^.lpart := first; ptr2^.lpart2 := first2; first := ptr; first2 := ptr2; disk^.code := 'Change'; SEEK(disk,recnumber); PUT(disk); END (* IF *); REPEAT outmode := ad; Outrec; repeat SC_Clr_Line(1); SC_Clr_Line(0); WRITELN('Change: P)refix, F)name, mi(N)it, L)name, s(U)ffix, T)itle, C)mpny,'); WRITE(' #)ph, A)dd, c(I)ty, S)tate, cntr(Y), Z)ip, M)isc, fla(G)s, Q)uit:'); READ(KEYBOARD,ch); until ch in ['P','p','F','f','N','n','L','l','U','u','T','t','C','c', '#', 'A','a','I','i','S','s','Y','y','Z','z','M','m', 'G','g','Q','q']; SC_Clr_Line(1); SC_Clr_Line(0); Chgcase(ch); UNTIL ch IN ['Q','q']; {top 2 lines already clear} WRITELN('N)o will leave the record in its original state.'); WRITE('O.K. to C)hange (Y/N):'); repeat READ(keyboard,ch); until ch in ['Y','y','N','n']; write(ch); IF (ch='Y') or (ch='y') THEN BEGIN SEEK(disk,recnumber);PUT(disk);END ELSE BEGIN SEEK(disk,recnumber);GET(disk);END; END; (* Change *) ======================================================================================== DOCUMENT :usus Folder:VOL11:mail7.text ======================================================================================== {Mail7 - Chkfiles, Uppercase, Gtstdflgs, Val, Rdata, Getint, WNew0Rec, Wild1, Wild2, Wildok, Chkflgs, Outrec} { 19-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } (*$I-*) FUNCTION Chkfiles{(s : STRING) : BOOLEAN}; BEGIN RESET(infile,s); Chkfiles:=(IORESULT=0); CLOSE(infile); END; (*$I+*) PROCEDURE Uppercase{(VAR s: STRING)}; VAR t : INTEGER; BEGIN FOR t := 1 TO LENGTH(s) DO IF s[t] IN ['a'..'z'] THEN s[t] := CHR(ORD(s[t])-32); END; PROCEDURE Gtstdflgs; BEGIN FOR temp := 1 TO 5 DO stdflg[temp] := 0; FOR temp := 1 TO 48 DO BEGIN tmpstr := format^.meanings[temp]; Uppercase(tmpstr); IF tmpstr='PREFX' THEN stdflg[1] := temp; IF tmpstr='FNAME' THEN stdflg[2] := temp; IF tmpstr='MINIT' THEN stdflg[3] := temp; IF tmpstr='LNAME' THEN stdflg[4] := temp; IF tmpstr='SUFFX' THEN stdflg[5] := temp; END; END; FUNCTION Val{ (s : STRING) : INTEGER}; VAR i,j,k: INTEGER; good,goodch: BOOLEAN; BEGIN j := 0; k := 0; i := 1; good:=false; {good when at least one digit found} goodch:=true;{false when a non digit or non '-' found} IF LENGTH(s)<>0 THEN BEGIN IF (LENGTH(s)>1) AND (s[1] = '-') THEN BEGIN k := k + 1;i := -1;END; while (k0) AND (y<>0) by BAT} BEGIN SC_Erase_to_EOL(x,y); GOTOXY(x,y); WRITE(' ':l,'<'); GOTOXY(x,y); END; READLN(tmpstr); UNTIL LENGTH(tmpstr)<=l; {remove control characters} i:=1; while i<=length(tmpstr) do begin {tmpstr length alters in loop} if tmpstr[i]<' ' then delete(tmpstr,i,1) else i:=i+1; end; IF NOT((POS('^',tmpstr)=1) AND (length(tmpstr)=1)) THEN s := tmpstr; IF a<>0 THEN {write out field again} BEGIN SC_Erase_to_EOL(x,y); GOTOXY(x,y); WRITE(s); END; END; PROCEDURE Getint{(x,y : INTEGER; VAR t1 :INTEGER)}; {read an integer from position x,y on screen} {if x=o and y=0 read from current position on screen} {if character illegal, return previous value of t1} VAR temp1,temp2,t3 : INTEGER; tmpstr : STRING; BEGIN t3 := t1; tmpstr :=''; temp2 := 6; {max legal integer length - ie 999999} temp1 := 0; {no refresh after read} IF (x<>0) OR (y<>0) THEN BEGIN temp2 := 3; {max legal integer length - ie 999} temp1 := 1; {and allow refresh of integer after read} END; Rdata(temp1,x,y,temp2,tmpstr); IF LENGTH(tmpstr) = 0 THEN t1 := t3 ELSE begin t1 := VAL(tmpstr); if t1=-9999 then t1:=t3; end; IF NOT ((x=0) AND (y=0)) THEN {altered from (x<>0) AND (y<>0) by BAT} BEGIN SC_Erase_to_EOL(x,y); GOTOXY(x,y); WRITE(t1); END; END; PROCEDURE Wnew0rec; BEGIN disk^.code := 'Perm '; STR(numrecs,disk^.zip); SEEK(disk,0); PUT(disk); END (* wnew0rec *); PROCEDURE Wild1{(wch:char)}; BEGIN CASE wch OF 'P','p' : BEGIN wfield := p; WRITE('Enter prefix:'); Rdata(0,13,0,5,wildcard); END; 'F','f' : BEGIN wfield := f; WRITE('Enter forename:'); Rdata(0,15,0,10,wildcard); END; 'N','n' : BEGIN wfield := n; WRITE('Enter middle initials:'); Rdata(0,22,0,2,wildcard); END; 'L','l' : BEGIN wfield := l; WRITE('Enter last name:'); Rdata(0,16,0,15,wildcard); END; 'U','u' : BEGIN wfield := u; WRITE('Enter suffix:'); Rdata(0,13,0,6,wildcard); END; 'T','t' : BEGIN wfield := t; WRITE('Enter title:'); Rdata(0,12,0,15,wildcard); END; 'C','c' : BEGIN wfield := c; WRITE('Enter company name:'); Rdata(0,19,0,30,wildcard); END; '#' : BEGIN wfield := p; WRITE('Enter phone number:'); Rdata(0,19,0,15,wildcard); END; 'A','a' : BEGIN wfield := a; WRITE('Enter address:'); Rdata(0,14,0,30,wildcard); END; 'I','i' : BEGIN wfield := i; WRITE('Enter city:'); Rdata(0,11,0,30,wildcard); END; 'S','s' : BEGIN wfield := s; WRITE('Enter state:'); Rdata(0,12,0,2,wildcard); END; 'Y','y' : BEGIN wfield := y; WRITE('Enter country:'); Rdata(0,14,0,30,wildcard); END; 'Z','z' : BEGIN wfield := z; WRITE('Enter zip/post code:'); Rdata(0,22,0,8,wildcard); END; 'M','m' : BEGIN wfield := m; WRITE('Enter misc field:'); Rdata(0,17,0,90,wildcard); END; END; END; PROCEDURE Wild2; BEGIN CASE wfield OF p : field := disk^.prefx; f : field := disk^.fname; n : field := disk^.minit; l : field := disk^.lname; u : field := disk^.suffx; t : field := disk^.title; c : field := disk^.coname; h : field := disk^.phone; a : field := disk^.address; i : field := disk^.city; s : field := disk^.state; y : field := disk^.country; z : field := disk^.zip; m : field := disk^.misc; END; END; FUNCTION Wildok{ : BOOLEAN}; { $ as last ch of wildcard means match anything remaining in field} { added 29-June-81 by Austin Tate last changed 8 july 81} VAR intb : BOOLEAN; wlast:char; temp1,wlen,flen:integer; BEGIN wlen:=length(wildcard); flen:=length(field); intb:=TRUE; {two null strings match - this ensures that null wildcard is not indexed} if wlen=0 then intb:=(flen=0) else begin wlast:=wildcard[wlen]; IF LENGTH(field)>=LENGTH(wildcard) THEN BEGIN temp1:=1; if flen>wlen then intb:=(wlast='$'); {must be $ on end as wildcard shorter than field} while intb and (temp1'?' then intb:=(field[temp1]=wildcard[temp1]); temp1:=temp1+1; end; {assert temp1=wlen} if intb then {check wildcard end matches or is ? or was $} {length checks for $ endings passed earlier } begin if (wlast<>'?') and (wlast<>'$') then intb:=(field[wlen]=wlast); end; END ELSE BEGIN {assert flen'?' then intb:=(field[temp1]=wildcard[temp1]); temp1:=temp1+1; end; END; end; Wildok := intb; END; FUNCTION Chkflgs{ : BOOLEAN}; VAR intb : BOOLEAN; BEGIN intb := TRUE; FOR temp := 1 TO 48 DO IF format^.fflags[temp] THEN intb := FALSE; IF NOT intb THEN BEGIN IF format^.option THEN intb := FALSE ELSE intb := TRUE; FOR temp := 1 TO 48 DO BEGIN IF format^.option THEN BEGIN {any positive match} IF format^.fflags[temp] AND disk^.flags[temp] THEN intb := TRUE; END ELSE BEGIN {exact matches only} IF format^.fflags[temp] AND NOT disk^.flags[temp] THEN intb := FALSE; END (* ELSE *); END (* FOR *); END; Chkflgs := intb; END; PROCEDURE Outrec; procedure Outr1; begin IF outmode <> ad THEN BEGIN SEEK(disk,recnumber);GET(disk);END; SC_Clr_Screen; gotoxy(0,2); WITH format^,disk^ DO BEGIN WRITELN('prefix :',prefx); WRITELN('f name :',fname); WRITELN('m init :',minit); WRITELN('l name :',lname); WRITELN('suffix :',suffx); WRITELN('title :',title); WRITELN('company :',coname); WRITELN('phone :',phone); WRITELN('address :',address); WRITELN('city :',city); WRITELN('state :',state); WRITELN('country :',country); WRITELN('zip/post:',zip); WRITELN('misc :',misc); end {of with format^,disk^}; end {of outr1}; procedure outr2; begin with format^,disk^ do begin IF outmode <> ad THEN BEGIN GOTOXY(0,18); WRITE('code: ',code); WRITE(' recnumber: ',recnumber); WRITE(' flags matching option: '); IF format^.option THEN WRITELN('A)ny positive match') ELSE WRITELN('E)xact matches only'); WRITE('currently at column ',columat); WRITELN(' will dump labels at ',mwide); WRITE('match flags set : '); temp1 := 0; FOR temp := 1 TO 48 DO IF fflags[temp] THEN BEGIN temp1 := temp1 + 1; WRITE(temp:2,' '); IF temp =12 THEN BEGIN temp1 := 0;WRITELN;END; IF temp1 = 18 THEN BEGIN temp1 := 0;WRITELN;END; END; END; GOTOXY(55,2);WRITE('record flags set:'); GOTOXY(55,3);WRITE('-----------------'); temp1 := 0; column := 0; FOR temp := 1 TO 48 DO IF flags[temp] THEN BEGIN temp1 := temp1 + 1; GOTOXY(57+column*3,temp1+3); WRITE(temp:2); IF temp1 = 10 THEN BEGIN column := column + 1;temp1 := 0;END; END; END (* WITH format^,disk^ *); end {of outr2}; BEGIN Outr1; {split for code size} Outr2; END (* Outrec *); ======================================================================================== DOCUMENT :usus Folder:VOL11:mail8.text ======================================================================================== {Mail8 - Delte, Find, Step, Zero, Restore} { 19-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } PROCEDURE Delte; BEGIN temp1 := increment; IF (recnumber<1) OR (recnumber>numrecs) THEN EXIT(Delte); IF recnumber <= ladd THEN ladd := recnumber - 1; IF disk^.code = 'Perm ' THEN BEGIN NEW(ptr); STR(recnumber,disk^.code); ptr^.recpart := disk^; ptr^.lpart := first; first := ptr; END; WITH disk^ DO BEGIN code := ' '; END; SEEK(disk,recnumber); PUT(disk); Step; IF (disk^.code<>'Add ') AND (disk^.code<>'Change ') AND (disk^.code<>'Perm ') THEN BEGIN increment := -increment; Step; END; IF (disk^.code<>'Add ') AND (disk^.code<>'Change ') AND (disk^.code<>'Perm ') THEN SC_Clr_Screen; increment := temp1; END; (* Delte *) PROCEDURE Find; VAR high,low:INTEGER; ch2:char; tempwildok:BOOLEAN; PROCEDURE Findnext; VAR oldrec : INTEGER; BEGIN SC_Clr_Screen; WRITE('Searching '); temp := recnumber; REPEAT WRITE('.'); oldrec := recnumber; Step; Wild2; tempwildok:=Wildok; UNTIL (oldrec=recnumber) OR tempwildok OR (recnumber=numrecs) OR (recnumber=1); if NOT tempwildok then begin writeln; writeln; write('Not Found ...'); repeat until NOT Space_Wait(TRUE); end; IF (NOT tempwildok) OR (oldrec=recnumber) THEN recnumber := temp; SEEK(disk,recnumber); GET(disk); END; BEGIN repeat SC_Clr_Line(1); SC_Clr_Line(0); IF increment = 1 THEN WRITE('>') ELSE WRITE('<'); WRITELN('Find: P)refix, F)name, mi(N)it, L)name, s(U)ffix, T)itle, C)mpny,'); WRITE (' #)ph, A)dd, c(I)ty, S)tate, cntr(Y), Z)ip, M)isc,', ' (^), R)ec#, Q(uit:'); READ(KEYBOARD,ch2); until ch2 in ['P','p','F','f','N','n','L','l','U','u','T','t','C','c', '#', 'A','a','I','i','S','s','Y','y','Z','z','M','m', '^','R','r','Q','q']; SC_Clr_Line(1); SC_Clr_Line(0); IF ch2 IN ['r','R'] THEN BEGIN WRITE('Enter record number:'); recnumber:=-1; {returned value if integer illegal} Getint(0,0,recnumber); IF recnumber < 1 THEN recnumber := 1; IF recnumber > numrecs THEN recnumber := numrecs; recnumber := recnumber - increment; SEEK(disk,recnumber); GET(disk); Step; END ELSE begin IF not(ch2 in ['Q','q']) then BEGIN Wild1(ch2); Findnext; END end; END (* Find *); PROCEDURE Step; VAR temp : INTEGER; BEGIN temp := recnumber; REPEAT temp := temp + increment; IF (temp>numrecs) THEN temp := numrecs; IF (temp<1) THEN temp := 1; SEEK(disk,temp); GET(disk); UNTIL (disk^.code='Perm ') OR (disk^.code='Add ') OR (disk^.code='Change') OR ((increment=-1) and (temp=1)) OR ((increment=1) and (temp=numrecs)); IF (disk^.code='Perm ') OR (disk^.code='Add ') OR (disk^.code='Change') THEN recnumber := temp; SEEK(disk,recnumber); GET(disk); END (* step *); PROCEDURE Zero; var tmpstr:string; BEGIN WRITELN; WRITE('Caution: Type YES if you mean to destroy ', 'the present contents of the file:'); READLN(tmpstr); Uppercase(tmpstr); IF tmpstr<>'YES' THEN EXIT(Zero); numrecs := 0; ladd := 0; orignrecs := 0; SC_Clr_Screen; Wnew0rec; END (* zero *); PROCEDURE Restore; BEGIN IF disk^.code<>'Change' THEN EXIT(Restore); ptr := first; WHILE (ptr<>NIL) DO BEGIN IF Val(ptr^.recpart.code)=recnumber THEN BEGIN disk^ := ptr^.recpart; ptr^.recpart.code := '000000'; disk^.code := 'Perm '; SEEK(disk,recnumber); PUT(disk); ptr := NIL; END ELSE ptr := ptr^.lpart; END; END; ======================================================================================== DOCUMENT :usus Folder:VOL11:mail9.text ======================================================================================== {Mail9 - ReportErr, Makefile, Abort, Upate, Quit, Krunch, Initialise} { 19-Feb-82 AT } { ** program : MAIL - Text processing mailing label data manager. ** ** authors : Patrick R. Horton, Associated Computer Industries ** ** Austin Tate, Edinburgh Regional Computing Centre ** ** Copyright : (C) 1982, Austin Tate, ERCC ** ** Permission to use this program for non-profit purposes ** ** is hereby granted, provided that this note is included. ** ** Enquiries concerning uses for other purposes should be ** ** directed to the copyright owner. ** } PROCEDURE Reporterr{(st1,st2:string; res:integer)}; begin SC_Clr_Line(1); SC_Clr_Line(0); write(st1,st2); gotoxy(60,0); write('IOResult=',res); repeat gotoxy(0,1); until not space_wait(TRUE); end; {$I-} PROCEDURE Makefile{( s : STRING)}; VAR tafile : FILE; tarry : packed array [1..512] of char; Res,num,blkasked,written,temp : INTEGER; BEGIN WRITE('Making: ',s); REWRITE(tafile,s); Res:=IORESULT; IF Res<>0 THEN begin Writeln; Writeln('Error making file ',s,' IOResult=',Res); end else begin fillchar(tarry,512,chr(0)); temp := POS('[',s); {no block number if max area to be claimed} IF temp=0 THEN blkasked:=0 else blkasked:=VAL(COPY(s,temp+1,LENGTH(s)-temp)); {-9999 is fault return from VAL} if blkasked<0 then blkasked:=0; num:=0; REPEAT if (num mod 10)=0 then WRITE('.'); written:=BLOCKWRITE(tafile,tarry,1); num:=num+written; UNTIL (num=blkasked) or (written=0) or (IORESULT<>0); WRITELN; if (blkasked<>0) and (num<>blkasked) then WRITELN('Could only initialise ',num,' blocks.') else WRITELN(num,' blocks initialised.'); CLOSE(tafile,lock); Res:=IORESULT; IF Res<>0 THEN Writeln('Error closing file ',s,'IOResult=',Res); end; END; {$I+} PROCEDURE Abort; BEGIN if (ptr<>NIL) or (ptr2<>NIL) then begin SC_Clr_Screen; WRITE('Restoring records '); end; ptr := first; ptr2 := first2; WHILE ptr2 <> NIL DO BEGIN recnumber := ptr2^.intpart; SEEK(disk,recnumber); GET(disk); disk^.code := ' '; SEEK(disk,recnumber); PUT(disk); WRITE('.'); ptr2 := ptr2^.lpart2; END; WHILE ptr<>NIL DO BEGIN disk^ := ptr^.recpart; recnumber := Val(disk^.code); disk^.code := 'Perm '; WRITE('.'); SEEK(disk,recnumber); PUT(disk); ptr := ptr^.lpart; END; numrecs := orignrecs; Wnew0rec; RELEASE(heaptr); END (* Abort *); PROCEDURE Update; BEGIN SC_Clr_Screen; WRITE('Updating '); temp := 0; ptr2 := first2; WHILE ptr2 <> NIL DO BEGIN recnumber := ptr2^.intpart; SEEK(disk,recnumber); GET(disk); disk^.code := 'Perm '; SEEK(disk,recnumber); PUT(disk); WRITE('.'); ptr2 := ptr2^.lpart2; END; RELEASE(heaptr); END; FUNCTION Quit:BOOLEAN; var ch:char; BEGIN unitclear(2); {flush keyboard type ahead before allowing quit} repeat SC_Clr_Screen; WRITE('Quit: E)xit without updating, R)eturn to Mail, U)pdate:'); READ(KEYBOARD,ch); UNTIL ch IN ['E','e','U','u','R','r']; WRITE(ch); CASE ch OF 'a','A' : abort; 'u','U' : update; END (* case *); WRITELN; Quit:=not ((ch='R') OR (ch='r')); END (* Quit *); PROCEDURE Krunch; BEGIN Update; Init; END; PROCEDURE Initialize; BEGIN Abort; Init; END; ======================================================================================== DOCUMENT :usus Folder:VOL11:mailiniteg.text ======================================================================================== Ann Macintosh ERCC 59, George Square Edinburgh Ken Currie ERCC 59, George Square Edinburgh Kathy Buckner ERCC 59, George Square Edinburgh Austin Tate ERCC 59 George Square Edinburgh, EH8 9JU ======================================================================================== DOCUMENT :usus Folder:VOL11:screenopsa.text ======================================================================================== {$S+} unit SCREENOPS; {A restricted implementation of version IV's SCREENOPS.} {Al Hayden Aug 1981. Last changed Austin Tate 19-Jan-82} {Apple version which picks up the syscom variables. For version II.1} { This is defined for version IV on pages 127..131 of the UCSD architecture guide. If you have a version IV system, it should be used. This unit is intended for use by version II users who will upgrade later, to allow them to write compatable software. If you want to play with this lot or modify it, the source (it's very simple) is available from ERCC Micro Support Unit. } interface type SC_Long_String = string[255]; {used to pass prompt-lines around} SC_ChSet = set of char; {holds a list of chars to match with} var SC_f:file; {unfortunately has to be public - so different user interface} procedure SC_Clr_Line (Y :integer); {Clears line number Y within the current text port.} procedure SC_Clr_Screen; {Clears the screen.} procedure SC_Erase_to_EOL (X, Line :integer); {Starting at position (X, Line) within the current text port, everything to the end of the line is erased.} function Space_Wait (Flush :boolean) :boolean; {This repeatedly reads from the keyboard until a or the ESC character is recieved. Before doing this it does a UNITCLEAR to 1 and 2 if Flush is true, and writes 'Type to continue'. It returns true if a was not read. Note: ESC replaces the ALTMODE character. } function SC_Prompt (Line :SC_Long_String; X_Cursor, Y_Cursor, X_Pos, Where :integer; Return_on_Match :SC_ChSet; No_Char_Back :boolean; Break_Char :char) :char; {This function displays the prompt-line, Line, in the current text-port at (X_pos, Where). The cursor is placed at (X_Cursor, Y_Cursor) after the prompt is printed. If X_Cursor is less than 0, the cursor is placed at the end of the prompt. If a character is being prompted for, No_Char_Back should be sent as false. The keyboard is repeatedly read until the character matches one within Return_on_Match.} implementation CONST NUL=0; TYPE CRTCommand=(ErasEOS,ErasEOL,LeadIn); VAR CRTInfo: packed array [CRTCommand] of Char; Prefixed: array [CRTCommand] of Boolean; procedure GetCRTInfo; var buffer: packed array [0..511] of char; i,j,byte: integer; begin {$I-} Reset(SC_f,'*SYSTEM.MISCINFO'); i:=IORESULT; j:=BLOCKREAD(SC_f,buffer,1); if (IORESULT<>0) or (i<>0) or (j<>1) then WRITELN('*SYSTEM.MISCINFO must be available.'); close(SC_f); {$I+} {the following values got from APPLE3:DISKIO.TEXT} {in that there are also values for UP,DOWN,LEFT and RIGHT} byte:=ord(buffer[72]); {prefix info byte} CRTInfo[LeadIn ]:=buffer[62]; Prefixed[LeadIn ]:=FALSE; CRTInfo[ErasEOS]:=buffer[64]; Prefixed[ErasEOS]:=ODD(Byte DIV 8); CRTInfo[ErasEOL]:=buffer[65]; Prefixed[ErasEOL]:=ODD(Byte DIV 4); end; procedure CRT(C:CRTCommand); var nul:packed array [0..1] of char; begin if prefixed[C] then unitwrite(1,CRTInfo[LeadIn],1,0,12); unitwrite(1,CRTInfo[C],1,0,12); nul[0]:=chr(0); nul[1]:=chr(0); unitwrite(1,nul,2,0,12); {at least 2 fillers to allow for gotoxy using nuls} end; procedure SC_Clr_Line {Y :integer}; begin gotoXY (0, Y); if CrtInfo[ErasEOL]=CHR(NUL) then begin write (' ':79); gotoXY (0, Y); end else CRT(ErasEOL); end; {of SC_Clr_Line} procedure SC_Clr_Screen; var COUNT :integer; begin if CrtInfo[ErasEOS]=CHR(NUL) then begin gotoXY (0, 23); { Slow but safe bit for screens } for COUNT := 1 to 24 do writeln;{ which don't recognise form-feeds } gotoXY (0, 0); end else begin gotoXY(0,0); CRT(ErasEOS); end; end; {of SC_Clr_Screen} procedure SC_Erase_to_EOL {X, Line :integer}; begin gotoXY (X, Line); if CrtInfo[ErasEOL]=CHR(NUL) then begin write (' ':(80 - X)); gotoXY (X, Line); end else CRT(ErasEOL); end; {of SC_Erase_to_EOL} function Space_Wait {Flush :boolean} {:boolean}; const ESC = 27; var CH :char; begin if Flush then begin unitclear (1); unitclear (2); end; write ('Type to continue'); repeat read (KEYBOARD, CH) until (CH = ' ') or (CH = chr (ESC)); if CH = ' ' then Space_Wait := false else Space_Wait := true; end; function SC_Prompt {Line :SC_long_String;.....; Break_Char :char}{ :char}; const BS = 8; {back-space} BEL = 7; {bell} var CH :char; {command character} begin if No_Char_Back then {no command to be read} CH := chr (0) {so nothing sent} else begin SC_Clr_Line (Where); write (LINE); {put up prompt line} if X_Cursor >= 0 then gotoXY (X_Cursor, Y_Cursor); {place cursor} repeat read (KEYBOARD, CH); {read character, invisibly} if CH in ['a'..'z'] then CH := chr (ord (CH) - 32); {upper case} if CH >= ' ' then {if it's a printable character} begin write (CH); write (chr (BS)); {echo character, then sit on it} end else write (chr (BEL)); {illegal character, so bleep} until CH in Return_on_Match; end; SC_Prompt := CH; {valid character now returned} end; {of SC_Prompt} begin GetCRTInfo; {initialise SYSCOM variables} end. {of unit SCREENOPS} ======================================================================================== DOCUMENT :usus Folder:VOL11:screenopsx.text ======================================================================================== {$S+} unit SCREENOPS; {A restricted implementation of version IV's SCREENOPS.} {Al Hayden Aug 1981. Last changed Austin Tate 28-Sep-81} {Terak, SuperBrain, normal Apple monitor output, or any screen which accepots form feed as the clear and home character} { This is defined for version IV on pages 127..131 of the UCSD architecture guide. If you have a version IV system, it should be used. This unit is intended for use by version II users who will upgrade later, to allow them to write compatable software. If you want to play with this lot or modify it, the source (it's very simple) is available from ERCC Micro Support Unit. } interface type SC_Long_String = string[255]; {used to pass prompt-lines around} SC_ChSet = set of char; {holds a list of chars to match with} procedure SC_Clr_Line (Y :integer); {Clears line number Y within the current text port.} procedure SC_Clr_Screen; {Clears the screen.} procedure SC_Erase_to_EOL (X, Line :integer); {Starting at position (X, Line) within the current text port, everything to the end of the line is erased.} function Space_Wait (Flush :boolean) :boolean; {This repeatedly reads from the keyboard until a or the ESC character is recieved. Before doing this it does a UNITCLEAR to 1 and 2 if Flush is true, and writes 'Type to continue'. It returns true if a was not read. Note: ESC replaces the ALTMODE character. } function SC_Prompt (Line :SC_Long_String; X_Cursor, Y_Cursor, X_Pos, Where :integer; Return_on_Match :SC_ChSet; No_Char_Back :boolean; Break_Char :char) :char; {This function displays the prompt-line, Line, in the current text-port at (X_pos, Where). The cursor is placed at (X_Cursor, Y_Cursor) after the prompt is printed. If X_Cursor is less than 0, the cursor is placed at the end of the prompt. If a character is being prompted for, No_Char_Back should be sent as false. The keyboard is repeatedly read until the character matches one within Return_on_Match.} implementation { procedure SC_Clr_Screen requires modification to suit terminal used } procedure SC_Clr_Line {Y :integer}; begin gotoXY (0, Y); write (' ':79); gotoXY (0, Y); end; {of SC_Clr_Line} procedure SC_Clr_Screen; { "Comment out" the bit of code you don't want } var COUNT :integer; begin {-----------------------------------------------------------------------} { This bit's for "normal" terminals} write (chr (12)); gotoXY (0,0); { accepting the form-feed character} { (Ascii 12). } {-----------------------------------------------------------------------} { gotoXY (0, 23); } { Slow but safe bit for screens } { for COUNT := 1 to 24 do writeln; } { which don't recognise form-feeds } { gotoXY (0, 0); } {-----------------------------------------------------------------------} end; {of SC_Clr_Screen} procedure SC_Erase_to_EOL {X, Line :integer}; begin gotoXY (X, Line); write (' ':(80 - X)); gotoXY (X, Line); end; {of SC_Erase_to_EOL} function Space_Wait {Flush :boolean} {:boolean}; const ESC = 27; var CH :char; begin if Flush then begin unitclear (1); unitclear (2); end; write ('Type to continue'); repeat read (KEYBOARD, CH) until (CH = ' ') or (CH = chr (ESC)); if CH = ' ' then Space_Wait := false else Space_Wait := true; end; function SC_Prompt {Line :SC_long_String;.....; Break_Char :char}{ :char}; const BS = 8; {back-space} BEL = 7; {bell} var CH :char; {command character} begin if No_Char_Back then {no command to be read} CH := chr (0) {so nothing sent} else begin SC_Clr_Line (Where); write (LINE); {put up prompt line} if X_Cursor >= 0 then gotoXY (X_Cursor, Y_Cursor); {place cursor} repeat read (KEYBOARD, CH); {read character, invisibly} if CH in ['a'..'z'] then CH := chr (ord (CH) - 32); {upper case} if CH >= ' ' then {if it's a printable character} begin write (CH); write (chr (BS)); {echo character, then sit on it} end else write (chr (BEL)); {illegal character, so bleep} until CH in Return_on_Match; end; SC_Prompt := CH; {valid character now returned} end; {of SC_Prompt} end. {of unit SCREENOPS} ======================================================================================== DOCUMENT :usus Folder:VOL11:vol11.doc.text ======================================================================================== Volume 11 of the USUS Library A sophisticated mailing list program from Austin Tate of USUS(UK) and a couple of games CONTENTS.TEXT 4 A little info about the UK submission MAIL.DOC.TEXT 100 Documentation for MAIL. MAIL.E.G.TEXT 10 A sample source document MAIL.LETT.TEXT 4 A sample form letter MAIL.INFO.DATA 4 A sample form SCREENOPSX.TEXT 12 A Screen Control unit for version II.0 SCREENOPSA.TEXT 14 A Screen Control unit for Apple MAIL.TEXT 18 The main program MAIL1.TEXT 16 an include file MAIL2A.TEXT 32 MAIL2B.TEXT 32 MAIL3.TEXT 16 MAIL4.TEXT 26 MAIL5.TEXT 14 MAIL6.TEXT 20 MAIL7.TEXT 22 MAIL8.TEXT 12 MAIL9.TEXT 10 MAILINITEG.TEXT 4 A sample data form MAIL.FORM.TEXT 6 A sample form MAIL.READ.TEXT 12 Documentation on the files in MAIL MAIL.INIT.TEXT 32 Converts a text file into a MAIL data file CHASE.TEXT 22 A reworked version of the game on Volume 3 BLACKJACK.TEXT 22 A reworked version of the game on Volume 3. This BJACK.1.TEXT 16 one splits pairs, doubles down, and has insurance. VOL11.DOC.TEXT 8 You're reading it. 26/26 files, 494 blocks used, 0 unused, 0 in largest Please transfer the text below to a disk label if you copy this volume. USUS Volume 11 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Some notes from the editor: MAIL See the file MAIL.READ.TEXT for detailed info. BLACKJACK I liked the blackjack program in the now withdrawn Volume 3 so much that I fixed many of its shortcomings and resubmitted it here. It now acts like a real blackjack game instead of double dealing like it did before (or was that really more realistic?). It now can handle insurance and doubledown and split pairs. It isn't very clean, I was still learning Pascal when I hacked on it but it does work. I can now play three hands in five seconds and usually win a little, but every so often the program takes me for a ride. It's just telling me that I really shouldn't go to Vegas after all. CHASE This was also on volume 3. Kids love it. It has been modified to give a better game setup and fix some other minor bugs. It also uses the H-19 keypad for motion control but any keypad will work. regards - george schreyer ======================================================================================== DOCUMENT :usus Folder:VOL12:analyze.text ======================================================================================== { ANALYZE: Analyze and summarize execution time performance measurements from an AUGMENTed Pascal program. PROGRAM HISTORY: S. Matwin and M. Missala, 1975: Polish Academy of Sciences Computer Centre, Pkin, Warsaw, Poland. Modified, Generalized, and Renamed by: A. B. Mickel and H. U. Rubenstein, 1977. University of Minnesota Computer Center, Minneapolis, MN 55455 USA. Published in Pascal News, No. 12., 1978 June. Overhauled for UCSD Pascal and interactive environment by: James L. Gagne, September, 1981. Datamed Research, Inc., 1433 Roscomare Road, Los Angeles, CA 90077 USA. JLG's changes from the PUG version are denoted with empty comment braces. Patched by George Schreyer, lines changed noted by gws Oct 1981 The names and organizations given here must not be deleted in any use of this program. (Note added 9/81: this program is not known to be copyright.) Internal documentation: Analyze reads two files. Inter2 (UCSD filename is fixed: "AUG.PROCNAMES") is the file containing the "module" (procedure/function) names which are used when the results are sorted and written out (up to 10 characters only). Timing (UCSD filename: "TIMING.DAT") is the file containing the execution trace of the program being monitored. Both files are expected to be on the default disk. Within ANALYZE, the procedure named processbody does the actual analysis by determining every time interval: time interval = time of exit - time of entry Gotoexits were handled specially in the PUG version. These features have been removed from the UCSD version, but for now special provisions for the EXIT procedure have not been installed. } PROGRAM Analyze; CONST AlfaLeng = 10; MaxNames = 1000; TYPE Alfa = PACKED ARRAY [1..AlfaLeng] OF Char; TagRange = 0..MaxNames; Measurement = PACKED RECORD Tag: TagRange; Mark: (Entry, ExitP, GotoEntry); HiTime, LoTime: integer END; {} DblInt = RECORD Hi, Lo: integer END; Counter = RECORD Count, SubRtnCount: integer; Name: Alfa; {} TimeSpent: DblInt END; VAR MaxTag: TagRange; {} LastDot: char; {} JustOne, TotalCalls, TotalTime, StartingTime: DblInt; ch: char; FudgeFactor, TimeOverhead: real; Modules: ARRAY [TagRange] OF Counter; Timing: FILE OF Measurement; {} OutFile: text; PROCEDURE Sort(min, max: tagrange); {Quicksort with bounded recursion depth, used to alphebatize module names. Requires min < max.} VAR low, high: integer; MidKey: Alfa; Temp: Counter; BEGIN REPEAT {pick split point} MidKey := Modules[(min + max) DIV 2].Name; low := min; high := max; REPEAT {partition} WHILE Modules[low].Name < MidKey DO low := low + 1; WHILE Modules[high].Name > MidKey DO high := high - 1; IF low <= high THEN BEGIN Temp := Modules[low]; Modules[low] := Modules[high]; Modules[high] := Temp; low := low + 1; high := high - 1 END UNTIL low > high; {recursively sort shorter sub-segment} IF high - min < max - low THEN BEGIN IF min < high THEN Sort(min,high); min := low END ELSE BEGIN IF low < max THEN Sort(low,max); max := high END UNTIL max <= min END; PROCEDURE ConvertTime(VAR i: DblInt); {convert time to signed dbl int'rs} BEGIN WITH i, Timing^ DO IF Tag > 0 THEN BEGIN Hi := HiTime*2; Lo := LoTime; IF ((HiTime > 0) AND (Hi < 0)) OR ((HiTime < 0) AND (Hi > 0)) THEN Hi := Hi + 32767 + 1; {throw away sign bit if a carry} IF (Hi < 0) AND (Lo > 0) THEN BEGIN Lo := Lo + 32767 + 1; Hi := Hi - 1 END ELSE IF (Hi > 0) AND (Lo < 0) THEN BEGIN Lo := Lo + 32767 + 1; Hi := Hi + 1 END END END; PROCEDURE AddDblInt(VAR i1, i2: DblInt); {add i1 and i2; sum in i1} VAR Sum: DblInt; BEGIN WITH Sum DO BEGIN Hi := i1.Hi + i2.Hi; Lo := i1.Lo + i2.Lo; IF (i1.Hi > 0) AND (i2.Hi > 0) AND (Hi < 0) THEN Hi := Hi + 32767 + 1; IF (i1.Lo > 0) AND (i2.Lo > 0) AND (Lo < 0) THEN BEGIN Lo := Lo + 32765 + 3; Hi := Hi + 1 END END; i1 := Sum; END; PROCEDURE SubDblInt(VAR i1, i2: DblInt); {subtract i2 from i1; diffrnc in i1} VAR Diff: DblInt; BEGIN WITH Diff DO BEGIN Hi := i1.Hi - i2.Hi; Lo := i1.Lo - i2.Lo; IF (i1.Hi < 0) AND (i2.Hi < 0) AND (Hi > 0) THEN Hi := Hi + 32767 + 1; IF (i1.Lo < 0) AND (i2.Lo < 0) AND (Lo > 0) THEN BEGIN Lo := Lo + 32765 + 3; Hi := Hi - 1 END END; i1 := Diff END; { PROCEDURE WriteTime(i: DblInt; Stop: boolean); VAR r: real; BEGIN WITH i DO BEGIN Write(Hi, '/', Lo, ' = '); r := (Lo/60) + Hi * (32768.0/60); Write(r, '; '); IF Stop THEN Readln END END; } PROCEDURE ProcessBody; {process timing file of dynamic measurements.} VAR ModuleTag: TagRange; SubCnt: integer; NoGoto, SameModule: boolean; {} Temp1, Temp2, ModulTime: DblInt; BEGIN ModuleTag := Timing^.Tag; SubCnt := 0; {} WITH ModulTime DO BEGIN Hi := 0; Lo := 0 END; ConvertTime(Temp1); Get(Timing); WHILE (Timing^.Mark = entry) AND (Timing^.Tag > 0) AND NOT EOF(Timing) DO BEGIN {} ConvertTime(Temp2); AddDblInt(ModulTime,Temp2); {} SubDblInt(ModulTime, Temp1); ProcessBody; {} ConvertTime(Temp1); SubCnt := SubCnt + 1; {} NoGoto := Timing^.Mark <> GotoEntry; {} SameModule := Timing^.Tag = ModuleTag; {gws} {IF SameModule OR NoGoto THEN} Get(timing); END; {} ConvertTime(Temp2); AddDblInt(ModulTime,Temp2); {} SubDblInt(ModulTime, Temp1); AddDblInt(TotalCalls,JustOne); {} IF TotalCalls.Lo MOD 50 = 0 THEN Write('.'); {} IF TotalCalls.Lo MOD 2500 = 0 THEN Writeln; WITH Modules[ModuleTag] DO BEGIN Count := Count + 1; AddDblInt(TimeSpent, ModulTime); SubRtnCount := SubRtnCount + SubCnt; END END; PROCEDURE Initialize; {initialization placed here: JLG} VAR Tag: TagRange; i: integer; s: string; Inter2: FILE OF Alfa; BEGIN {} Writeln('Welcome to ANALYZE, the program timing analyzer.'); Writeln; {} Writeln( ' You should be using this program only after having run Pascal source'); {} Writeln( 'text through AUGMENT to add the time-keeping function, then compiled and run'); {} Writeln( 'the new program. The data files AUG.PROCNAMES and TIMING.DAT must both be'); {} Writeln( 'the default disk, or the program will die.'); Writeln; {} Reset(Inter2, 'AUG.PROCNAMES'); Reset(Timing,'TIMING.DAT'); IF EOF(Timing) {} THEN BEGIN Writeln('*FATAL ERROR* timing file empty'); Exit(Program) END; {} Writeln( 'Please enter the destination of the timing analysis (e.g., "PRINTER:"):'); {} Write('--> ':12); Readln(s); {} FOR i := 1 TO Length(s) DO {} IF s[i] IN ['a'..'z'] THEN s[i] := CHR(ORD(s[i]) + ORD('A') - ORD('a')); {} IF POS('.TEXT',s) = 0 THEN s := CONCAT(s,'.TEXT'); Rewrite(OutFile, s); Tag := 1; WHILE NOT EOF(Inter2) DO BEGIN WITH Modules[Tag] DO BEGIN Name := Inter2^; Get(Inter2); Count := 0; SubRtnCount := 0; TimeSpent.Hi := 0; TimeSpent.Lo := 0 END; Tag := Tag + 1 END; MaxTag := Tag - 1; Writeln (MaxTag,' module names found.'); Writeln; Write('How many msec overhead per timing record write? '); Readln(TimeOverhead); Writeln; FudgeFactor := TimeOverhead * 60.0 / 1000.0; {} TotalCalls.Hi := 0; TotalCalls.Lo := 0; {} JustOne.Hi := 0; JustOne.Lo := 1; ConvertTime(StartingTime); {} Writeln('Reading timing data (one dot = 100 entries):'); END; PROCEDURE PrintResults; {all output pulled into this procedure: JLG} VAR Tag: TagRange; i, j: integer; {} TotalT, TCalls, TSpent, PerCent: Real; BEGIN Writeln(OutFile,' Performance Measurement Summary for Pascal Program: ', Modules[1].Name); Writeln(OutFile); Writeln(OutFile,'execution time':62); Writeln(OutFile,'calls':27, '(msec)':21, '(sec)':9); Writeln(OutFile,'module':9, 'times':13, 'percent':11, 'subroutn':12, 'average':14,'module':10, 'percent':11); Writeln(OutFile,'name':8, 'called':15, 'of total':11, 'calls':11, 'per call':15,'total':8, 'of total': 13); Writeln(OutFile,' ----------', '------':12, '--------':11,'------':11, '--------':15, '------':9, '--------':12); {} WITH TotalCalls DO TCalls := 1.0 + Lo - 1.0 + (32768.0 * Hi); {} WITH TotalTime DO TotalT := (Lo/60.0) + Hi*(32768.0/60.0) - (FudgeFactor * 2.0 * TCalls); {} IF TotalCalls.Lo + TotalCalls.Hi = 0 {} THEN Writeln(OutFile,'Program did not execute; no timing data.') {} ELSE FOR Tag := 1 TO MaxTag DO WITH Modules[Tag] DO BEGIN {} PerCent := (Count / TCalls) * 100.0; {} Write(OutFile,Name:11, Count:12); {} IF Count = 0 THEN Write(Outfile,'-----':11, '-----':11) ELSE Write(Outfile, PerCent:11:3, SubRtnCount:11); {} WITH TimeSpent DO TSpent := (Lo/60.0) + (Hi/60.0)*32768.0 - FudgeFactor * (1.0 + SubRtnCount); {} IF Count = 0 THEN Writeln(OutFile,'-----':15, '-----':9, '-----':12) {} ELSE BEGIN Write(OutFile,((TSpent/Count)*1000.0):15:2,TSpent:9:3); IF TotalT = 0 THEN Writeln(OutFile,'-----':12) {} ELSE Writeln(OutFile,((TSpent / TotalT) *100.0):12:3) END END; Writeln(OutFile,' ==========', '======':12, '========':11, '======':11, '========':15, '======':9, '========':12); Writeln(OutFile,'TOTALS':9, TCalls:14:1, '100.000':11, {} ((TotalT/TCalls)*1000.0):26:2, TotalT:9:3, '100.000':12) END; BEGIN {program} {} Initialize; ProcessBody; {} ConvertTime(TotalTime); SubDblInt(TotalTime, StartingTime); IF MaxTag > 1 THEN BEGIN Writeln(CHR(7)); Write('Do you want your report alphabetized by procedure name (Y/N)? '); REPEAT READ(ch) UNTIL (ch IN ['y','Y','n','N']); IF (ch IN ['y','Y']) THEN Sort(1, MaxTag) END; PrintResults; Close(OutFile, LOCK); END. ======================================================================================== DOCUMENT :usus Folder:VOL12:augment.text ======================================================================================== {AUGMENT - AUGMENT PASCAL PROGRAMS WITH CODE TO GATHER EXECUTION TIME PERFORMANCE MEASUREMENTS. PROGRAM HISTORY: S. MATWIN AND M. MISSALA, 1975 POLISH ACADEMY OF SCIENCES COMPUTER CENTRE, PKIN, WARSAW, POLAND. REFERENCE: "A SIMPLE MACHINE INDEPENDENT TOOL FOR OBTAINING ROUGH MEASURES OF PASCAL PROGRAMS." SIGPLAN NOTICES, 1976 AUGUST, 42-45. MODIFIED, GENERALIZED, AND RENAMED FROM "PROFILE" TO "AUGMENT" BY: A. B. MICKEL AND H. U. RUBENSTEIN, 1977. UNIVERSITY OF MINNESOTA COMPUTER CENTER, MINNEAPOLIS, MN 55455 USA. PUBLISHED IN PASCAL NEWS, NO. 12, 1978 JUNE. MODIFIED FOR UCSD PASCAL BY: JAMES GAGNE, 1981. DATAMED RESEARCH, INC., 1433 ROSCOMARE ROAD, LOS ANGELES, CA 90077, USA. MODIFICATIONS MARKED WITH EMPTY COMMENT SIGNS. THE NAMES AND ORGANIZATIONS GIVEN HERE MUST NOT BE DELETED IN ANY USE OF THIS PROGRAM. [NOTE ADDED 26 SEPT 1981: THIS PROGRAM IS NOT KNOWN TO BEAR ANY FORM OF COPYRIGHT. JLG] futher modification to allow include files, units and lower case identifiers and EXIT (somewhat kludged) by George Schreyer. changes marked by "gws". corrections to gws modifications by Jim Gagne, 12 Nov 81; marked by "|" in empty comment brackets.} PROGRAM AUGMENT; CONST BeginSy = 1; CaseSy = 2; EndSy = 3; ExternSy = 4; {gws} ExitSy = 5; FortranSy = 6; ForwardSy = 7; FuncSy = 8; GotoSy = 9; LabelSy = 10; ProcSy = 11; ProgramSy = 12; VarSy = 13; MaxModules = 2000; LLMax = 120; {line length max} LLMin = 72; {line length min} AlfaLeng = 10; TYPE Alfa = PACKED ARRAY [1..AlfaLeng] OF char; CodeType = (Entry, ExitP, GotoEntry, Declare); Symbols = BeginSy..VarSy; NameNode = RECORD Name: Alfa; Link: ^ NameNode END; ModuleCnt = 0..MaxModules; LabelPtr = ^ LabelNode; LabelNode = RECORD Labl: 0..9999; DeclaredIn: ModuleCnt; Next: LabelPtr END; VAR IdLen, LastIdLen: 0..AlfaLeng; {identifier length} Sy: Symbols; Number: 0..9999; {|} {BadNames,}ReadingLabels, InEOLN, InEOF, Trace, WantsComments: boolean; {gws} WantsInclude,TempInclude : boolean; {indicates reading include file} LineLength, ColCnt, InBuffPtr, IncBuffPtr, LastInBuff, LastIncBuff: integer; ch: char; BadList: ^ NameNode; {list of excepted module names} Count: ModuleCnt; {running count of modules} {|} DotCount: integer; {count of dots marking lines read} ChBuf: ARRAY [1..AlfaLeng] OF char; Identifier: Alfa; TimeVolume: string[10]; Key: ARRAY [Symbols] OF Alfa; InBuff, IncBuff: PACKED ARRAY [0..1023] OF char; {} Infile, {input file: source program} {Note: all references to "Input" have been changed to "Infile". JLG} {gws} Incfile: file; {Include file} Inter, {output file: augmented program} Except: text; {file of excepted module names} Inter2: FILE OF Alfa; {file of all module names} PROCEDURE WriteFatalError(message: string); {procedure added: JLG} BEGIN Writeln; Writeln(CHR(7), '*FATAL ERROR* -- ', message, '.'); close(Inter,lock); {gws so we can see what blew up} EXIT(Program) END; PROCEDURE NextCh; {|} {rewritten using block i/o for more speed...jlg} VAR GoodRead: boolean; BEGIN IF WantsInclude THEN BEGIN IF IncBuffPtr > LastIncBuff THEN BEGIN GoodRead := BlockRead(IncFile, IncBuff, 2) = 2; IF GoodRead THEN BEGIN LastIncBuff := 1023 + SCAN(-1023,<>CHR(0),IncBuff[1023]); IncBuffPtr := 0; IF LastIncBuff < 1 THEN GoodRead := false; END; IF NOT GoodRead THEN BEGIN WantsInclude := false; LastIncBuff := 1023; Close(IncFile); IncBuffPtr := 1024; DotCount := 0; Writeln; Writeln(' --> back to source file'); END END; IF WantsInclude THEN BEGIN ch := IncBuff[IncBuffPtr]; IncBuffPtr := IncBuffPtr + 1; IF ch <> CHR(13) THEN InEOLN := false ELSE BEGIN ch := ' '; InEOLN := true; ColCnt := 0; IF DotCount >= 0 THEN BEGIN Write('.'); Dotcount := Dotcount + 1 END; IF DotCount > 50 THEN BEGIN Writeln; Dotcount := 0 END END END END; IF NOT WantsInclude THEN BEGIN IF InBuffPtr > LastInBuff THEN IF BlockRead(InFile, InBuff, 2) <> 2 THEN InEOF := true ELSE BEGIN LastInBuff := 1023 + SCAN(-1023,<>CHR(0),InBuff[1023]); InBuffPtr := 0; IF LastInBuff < 1 THEN InEOF := true; END; IF NOT InEOF THEN BEGIN ch := InBuff[InBuffPtr]; InBuffPtr := InBuffPtr + 1; IF ch <> CHR(13) THEN InEOLN := false ELSE BEGIN ch := ' '; InEOLN := true; ColCnt := 0; IF DotCount >= 0 THEN BEGIN Write('.'); Dotcount := Dotcount + 1 END; IF DotCount > 50 THEN BEGIN Writeln; Dotcount := 0 END END END END; END; PROCEDURE Advance; BEGIN IF InEOLN THEN BEGIN Writeln(Inter); NextCh; IF ch = CHR(16) THEN BEGIN NextCh; IF ch = ' ' THEN NextCh ELSE IF ch = '!' THEN ch := ' ' ELSE BEGIN Write(Inter, CHR(16), pred(ch)); ch := ' ' END END END ELSE BEGIN Write(Inter, ch); NextCh END END; PROCEDURE ReadId; {} VAR i: integer; BEGIN IdLen := 0; REPEAT IF IdLen < AlfaLeng THEN BEGIN IdLen := IdLen + 1; ChBuf[IdLen] := ch END; NextCh {} UNTIL NOT (ch IN ['0'..'9', 'A'..'Z', '_', 'a'..'z']); IF IdLen >= LastIdLen THEN LastIdLen := IdLen ELSE REPEAT ChBuf[LastIdLen] := ' '; LastIdLen := LastIdLen - 1 UNTIL LastIdLen = IdLen; {} {PACK(chbuf, 1, Identifier;} {gws} FOR i := 1 TO AlfaLeng DO IF ChBuf[i] in ['a'..'z'] THEN Identifier[i] := chr(ord(ChBuf[i]) - 32) ELSE Identifier[i] := ChBuf[i] END; PROCEDURE WriteId; VAR i: integer; BEGIN {} FOR i := 1 TO IdLen DO Write(Inter, ChBuf[i]) END; PROCEDURE Comment; BEGIN {gws} REPEAT WHILE ch <> '*' DO Advance; Advance UNTIL ch = ')'; Advance END; PROCEDURE StdComment; BEGIN {gws} WHILE ch <> '}' DO Advance; Advance END; PROCEDURE DumpComment; BEGIN REPEAT WHILE ch <> '*' DO BEGIN IF ch = CHR(16) THEN NextCh; NextCh END; NextCh UNTIL ch = ')'; Write(Inter,'*)'); NextCh END; PROCEDURE DumpStdComment; BEGIN WHILE ch <> '}' DO BEGIN IF ch = CHR(16) THEN NextCh; NextCh END; Advance END; PROCEDURE GetInclude; {procedure added: GWS} VAR i: integer; Message,IncName : string; Strg : string; BEGIN IncName := ''; Strg := ' '; {|} WHILE (ch IN [' ','#',':', '0'..'9','.','A'..'Z','a'..'z']) AND (Length(IncName) < 80) DO BEGIN IF ch IN ['a'..'z'] THEN ch := CHR(ORD(ch) + ORD('A') - ORD('a')); IF ch <> ' ' THEN BEGIN Strg[1] := ch; IncName := concat(Incname,Strg) END; NextCh; END; {$I-} Reset(Incfile,IncName); {|} IF (IORESULT > 0) AND (POS('.TEXT',IncName) = 0) THEN Reset(IncFile, CONCAT(IncName, '.TEXT')); i := IORESULT; IF i = 0 THEN i := BlockRead(IncFile, IncBuff, 2, 0) - 2; {$I+} IF i = 0 THEN BEGIN Writeln; Writeln(' --> ',IncName); TempInclude := true END ELSE WriteFatalError(concat('Include File ',IncName,' not found')) END;{-} FUNCTION CheckDirective: boolean; {procedure added: GWS; rewritten: JLG} VAR GotDirective: boolean; BEGIN Advance; GotDirective := false; IF ch = '+' THEN Trace := true ELSE IF ch = '-' THEN Trace := false ELSE IF ch = '$' THEN BEGIN NextCh; GotDirective := true; {|} IF ch <> 'I' THEN Write(Inter,'$') {|} ELSE BEGIN {|} NextCh; IF ch IN ['-','+'] THEN Write(Inter,'$I') ELSE GetInclude END END; CheckDirective := GotDirective END; FUNCTION SkipComments: boolean; {function added: JLG} VAR Found: boolean; BEGIN Found := true; IF ch = '(' THEN BEGIN Advance; {|} IF ch <> '*' THEN Found := false ELSE IF CheckDirective OR WantsComments THEN Comment ELSE DumpComment END ELSE IF ch = '{' THEN IF CheckDirective OR WantsComments THEN StdComment ELSE DumpStdComment ELSE Found := false; SkipComments := found; IF TempInclude THEN {block added: gws} BEGIN TempInclude := false; Writeln(Inter); WantsInclude := true; NextCh END; END; FUNCTION NoKey(Id: alfa): boolean; {binary search} VAR i, j: integer; BEGIN i := BeginSy; j := VarSy; REPEAT Sy := (i + j) DIV 2; IF Key[Sy] <= Id THEN i := Sy + 1; IF Key[Sy] >= Id THEN j := Sy - 1 UNTIL i > j; NoKey := Key[Sy] <> Id END; PROCEDURE SkipOver; {renamed: JLG} {Find next identifier (or number if reading labels). Skip strings & comments.} {} BEGIN WHILE NOT InEOF DO BEGIN WHILE NOT InEOLN DO {} IF SkipComments THEN {ignore} ELSE IF ch = ' ' THEN BEGIN IF Trace THEN Write(' '); Advance END {|} ELSE IF ch = CHR(16) THEN BEGIN Advance; Advance END ELSE IF ch = '''' THEN BEGIN REPEAT Advance UNTIL ch = ''''; Advance; IF Trace THEN Write('''') END {} ELSE IF ch IN ['A'..'Z', 'a'..'z'] THEN BEGIN ReadId; ReadingLabels := false; IF Trace THEN Write(Identifier); {} IF NoKey(Identifier){AND NOT BadNames} {}{|} THEN BEGIN IF Trace THEN Writeln; WriteId END {|} ELSE BEGIN IF Trace THEN Writeln('(',Sy,')'); Exit(SkipOver) END END ELSE IF ch IN ['0'..'9'] THEN IF ReadingLabels {|} THEN BEGIN NextCh; EXIT(SkipOver) END ELSE REPEAT Advance {} UNTIL NOT (ch IN ['0'..'9', 'A'..'Z', '_', 'a'..'z']) ELSE Advance; Writeln(Inter); NextCh END END; PROCEDURE ComplModule(LastL: LabelPtr); { Process the block of a program, procedure, or function to find the appropriate code insertion points. LastL is the head of the list of labels whose scope applies to the block. ComplModule must parse label, var, proce- dure, and function declarations, as well as goto statements and the compound statement forming the statement part of each module. } VAR Depth: integer; Params: boolean; L: LabelPtr; GotoLabel: 0..9999; Looking: boolean; Tag: ModuleCnt; Name: Alfa; PROCEDURE InsertNewText(Code: CodeType; ITag: integer); BEGIN {modified for UCSD Time functn} CASE Code OF Entry: BEGIN Write(Inter, 'WITH Timing^ DO BEGIN xi:=', ITag, ';'); {} Writeln(Inter, 'Time(xh,xl);xm:=0 END;Put(Timing);') END; ExitP: BEGIN Writeln(Inter,';'); Write(Inter, 'WITH Timing^ DO BEGIN xi:=', ITag, ';'); {} Writeln(Inter, 'Time(xh,xl);xm:=1 END;Put(Timing);'); {} IF ITag = 1 THEN Writeln(Inter, 'Close(Timing,lock);') END; GotoEntry: BEGIN Write(Inter, 'WITH Timing^ DO BEGIN xi:=',L^.DeclaredIn,';'); {} Writeln(Inter, 'Time(xh,xl);xm:=2 END;Put(Timing);') END; Declare:BEGIN Write(Inter, 'Timing:FILE OF PACKED RECORD '); {} Writeln(Inter, 'xi:0..2000;xm:0..2;xh,xl:integer END;'); {} Writeln(Inter) END END END; FUNCTION NameOK: Boolean; { Check procedure or function name against list of names to be excluded.} VAR n: ^NameNode; Looking: boolean; BEGIN n := BadList; Looking := true; WHILE (n <> nil) AND Looking DO BEGIN Looking := n^.Name <> Name; n := n^.Link END; NameOK := Looking END; BEGIN {ComplModule} {} WHILE NOT (ch IN ['A'..'Z','a'..'z']) DO IF NOT SkipComments THEN Advance; ReadId; Name := Identifier; WriteId; Tag := Count; Params := false; WHILE NOT Params AND (ch <> ';') DO IF ch = '(' THEN BEGIN Advance; IF ch = '*' THEN Comment ELSE Params := true END ELSE IF ch = '{' THEN StdComment ELSE Advance; IF Params THEN WHILE ch <> ')' DO {read through parameter list) {} IF NOT SkipComments THEN Advance; {} Write(Inter, ch); NextCh; SkipOver; IF Trace THEN Write('!'); IF Sy IN [ForwardSy, ExternSy, FortranSy] THEN WriteId ELSE BEGIN Count := Count + 1; IF Count = MaxModules {} THEN WriteFatalError('Too many procedures/functions to process'); {} Inter2^ := Name; Put(Inter2); IF Sy = LabelSy {label declaration} THEN BEGIN {read local labels} WriteId; ReadingLabels := true; SkipOver; REPEAT New(L); L^.Labl := Number; L^.DeclaredIn := Tag; Write(Inter, Number:4); L^.Next := LastL; LastL := L; SkipOver UNTIL NOT ReadingLabels END; WHILE Sy IN [CaseSy, EndSy] DO {type declaration} BEGIN WriteId; SkipOver END; IF NOT (Sy IN [BeginSy, FuncSy, ProcSy]) THEN WriteId; IF Sy = VarSy THEN BEGIN SkipOver; WHILE Sy IN [CaseSy, EndSy] DO BEGIN WriteId; SkipOver END; END; IF Tag = 1 THEN InsertNewText(Declare,1); {main program} WHILE Sy IN [FuncSy, ProcSy] DO BEGIN WriteId; ComplModule(LastL) END; IF Sy = BeginSy {statement part} THEN BEGIN Depth := 1; WriteID; Writeln; Write(Name,' <',Tag:4,' >'); {|} DotCount := 0; IF Tag = 1 THEN Writeln(Inter,' rewrite(Timing,''',TimeVolume,'TIMING.DAT'');') ELSE Writeln(Inter); IF NameOK THEN InsertNewText(Entry, Tag) END {} ELSE WriteFatalError('"BEGIN" expected'); REPEAT {look for last EndSy} SkipOver; IF Sy = GotoSy THEN BEGIN {check against local labels} ReadingLabels := true; SkipOver; GotoLabel := Number; ReadingLabels := false; Looking := true; L := LastL; WHILE (L <> nil) AND Looking DO IF L^.Labl = GotoLabel THEN Looking := false ELSE L := L^.Next; {} IF Looking THEN {WriteFatalError('undeclared label')} ELSE BEGIN {modified for local labels only per UCSD: JLG} {} (* IF L^.DeclaredIn <> Tag {} THEN BEGIN {exit goto} {} Writeln(Inter, 'BEGIN'); {} IF NameOK THEN InsertNewText(GotoEntry,Tag) {} END; *) Write(Inter, 'GOTO ', GotoLabel); {} { IF L^.DeclaredIn <> Tag THEN Writeln(Inter, ' END') } END END {gws} ELSE IF Sy = ExitSy {gws} THEN BEGIN {|} Write(Inter,' BEGIN '); InsertNewText(ExitP,Tag); {|} REPEAT IF ch = CHR(16) THEN BEGIN NextCh; NextCh END; NextCh {gws} UNTIL NOT (ch IN ['(',' ']); ReadId; {gws} IF NOT NoKey (Identifier) THEN {|} BEGIN IF Sy = ProgramSy THEN {gws} BEGIN {|} InsertNewText(ExitP,1); Writeln(Inter,'EXIT(PROGRAM)') {gws} END {|} END {gws} ELSE Writeln(Inter,'EXIT(',Identifier,')'); {gws} Write(Inter,'END;'); NextCh; {gws} END ELSE IF Sy IN [BeginSy, CaseSy] THEN BEGIN Depth := Depth + 1; WriteId; IF Trace THEN Write(Inter,'{',Depth,'}') END ELSE If Sy = EndSy THEN BEGIN Depth := Depth - 1; IF Depth <> 0 THEN BEGIN WriteId; IF Trace THEN Write(Inter,'{',Depth,'}') END END {} ELSE WriteFatalError('"END" expected') UNTIL Depth = 0; IF NameOK THEN InsertNewText(ExitP,Tag); Write(Inter, 'END'); IF Trace THEN Write(Inter,' {p/f}'); END; SkipOver END; PROCEDURE Initialize; {all init moved here: JLG} FUNCTION Yes(prompt: string): boolean; {added: JLG} VAR ch: char; BEGIN Write(prompt, ' (Y/N)? '); REPEAT Read(keyboard, ch) UNTIL ch IN ['y','Y','n','N']; IF ch IN ['y', 'Y'] THEN BEGIN Yes := true; Writeln('Yes') END ELSE BEGIN Yes := false; Writeln('No') END END; PROCEDURE AllCaps(VAR s: string); {added: JLG} VAR i: integer; BEGIN FOR i := 1 TO Length(s) DO IF s[i] IN ['a'..'z'] THEN s[i] := CHR(ORD(s[i]) + ORD('A') - ORD('a')) END; FUNCTION GotFile(WantsInput: boolean; prompt: string; VAR f: text): boolean; VAR i: integer; {function added: JLG} s: string; BEGIN REPEAT Writeln('Please enter the name of ', prompt, ' ( to skip):'); Write('--> ':12); Readln(s); Allcaps(s); IF (s = '') OR (s = ' ') THEN s := '' ELSE IF WantsInput THEN BEGIN {$I-} Reset(f,s); i := IORESULT; IF (i > 0) AND (POS('.TEXT',s) = 0) THEN BEGIN s := CONCAT(s, '.TEXT'); Reset(f,s); i := IORESULT END; IF i > 0 THEN BEGIN Reset(f, CONCAT('#5:',s)); i := IORESULT END; IF i > 0 THEN BEGIN Reset(f, CONCAT('#4:',s)); i := IORESULT END; {$I+} IF i > 0 THEN BEGIN s := ''; Write(CHR(7),'Can''t open input file...') END END ELSE BEGIN {$I-} IF POS('.TEXT',s) = 0 THEN s := CONCAT(s, '.TEXT'); Rewrite(f,s); i := IORESULT; {$I+} IF i > 0 THEN BEGIN s := ''; Write(CHR(7),'Can''t open output file...') END END UNTIL (s = '') OR (i = 0); GotFile := i = 0 END; PROCEDURE GetBadNames; {added: JLG} VAR n: ^ NameNode; s: string; PROCEDURE PutName; {added: JLG} VAR i: integer; BEGIN IF (s <> '') AND (s <> ' ') THEN BEGIN New(n); FOR i := 1 TO AlfaLeng DO IF i > Length(s) THEN n^.Name[i] := ' ' ELSE n^.Name[i] := s[i]; n^.Link := BadList; BadList := n END END; PROCEDURE ReadBadNames; {moved & rewritten: JLG} VAR i: 1..AlfaLeng; BEGIN IF GotFile(true, 'the "exceptions" file', except) THEN BEGIN Writeln( 'The following names will not be AUGMENTed with timing information:'); Writeln; WHILE NOT EOF(except) DO BEGIN Readln(except, s); Writeln(s:25); PutName END END END; BEGIN BadList := nil; IF Yes('Do you wish to enter procedures/function names NOT to process') THEN IF Yes('Are these names in a disk-based file (1 per line)') THEN ReadBadNames ELSE BEGIN Writeln( 'If you wish to skip over certain procedures or functions now,'); Writeln( 'Enter the one such procedure/function name per line (no blanks);'); Writeln('Enter a blank line (ie, just type ) when done:'); REPEAT Write(' ':16); Readln(s); PutName UNTIL (s = '') OR (s = ' ') END END; BEGIN {Initialize} IF NOT GotFile(true, 'the source file to be processed', Infile) THEN EXIT(Program); IF BlockRead(InFile, InBuff, 2) <> 2 THEN WriteFatalError('can''t read source file'); IF NOT GotFile(False, 'the destination of the Pascal source', Inter) THEN EXIT(Program); {$I-} Rewrite(Inter2, 'AUG.PROCNAMES'); IF IORESULT > 0 THEN Rewrite(Inter2, '#5:AUG.PROCNAMES'); IF IORESULT > 0 THEN WriteFatalError('can''t open procedure name file'); {$I+} {|} Writeln( 'To which volume do you wish to direct the timing file ( for Prefix)?'); {|} Write('--> ':12); Readln(TimeVolume); {|} WantsComments := Yes('Want to keep ALL comments in AUGMENTed file'); {|} WHILE POS(' ', TimeVolume) > 0 DO DELETE(TimeVolume,POS(' ',TimeVolume),1); {|} TempInclude := false; WantsInclude := false; {gws} {|} InEOLN := false; InEOF := false; InBuffPtr := 1024; LastInBuff := 1023; {|} IncBuffPtr := 1024; LastIncBuff := 1023; DotCount := -1; {|} NextCh; Count := 1; ColCnt := 1; LineLength := LLMax; {|} Trace := Yes('Want to trace AUGMENT''s scanner'); LastIdLen := AlfaLeng; Key[BeginSy ] := 'BEGIN '; Key[CaseSy ] := 'CASE '; Key[EndSy ] := 'END '; Key[ExitSy ] := 'EXIT '; Key[ExternSy ] := 'EXTERNAL '; Key[FortranSy] := 'FORTRAN '; Key[ForwardSy] := 'FORWARD '; Key[FuncSy ] := 'FUNCTION '; Key[GotoSy ] := 'GOTO '; Key[LabelSy ] := 'LABEL '; Key[ProcSy ] := 'PROCEDURE '; Key[ProgramSy] := 'PROGRAM '; Key[VarSy ] := 'VAR '; GetBadNames; SkipOver; ReadingLabels := false; Writeln; END; PROCEDURE DoAugment; BEGIN {DoAugment} Initialize; IF Sy = ProgramSy THEN BEGIN Write(Inter, 'PROGRAM'); ComplModule(nil) END ELSE WriteFatalError('"PROGRAM" expected') END; BEGIN {program} DoAugment; Writeln; Writeln; Writeln('Process complete.'); Close(Inter, lock); Close(Inter2, lock) END. ======================================================================================== DOCUMENT :usus Folder:VOL12:bench.byte.text ======================================================================================== { L PRINTER:} {$R-} (* BYTE Benchmark - see issue Sept '81 for data on other machines/languages*) (* Eratosthenes Sieve Prime Number Program in (UCSD) PASCAL *) (* With obvious UCSD optimisations, eg make the main computation a procedure to get SSTLs, turn range checking off *) (* Making such changes to a benchmark is clearly not in the spirit of comparative testing. However, the changes shown do serve to show how you might speed up your own programs - or teach you to beware of benchmarks!! USUS(UK) Library Reviewer *) PROGRAM benchbyte; CONST size = 8190; VAR flags : ARRAY [0..size] OF BOOLEAN; PROCEDURE do_it; VAR i,prime,k,count,iter : INTEGER; BEGIN WRITELN('10 iterations'); FOR iter := 1 TO 10 DO BEGIN count := 0; FILLCHAR(flags,SIZEOF(flags),CHR(ORD(TRUE))); FOR i := 0 TO size DO IF flags[i] THEN BEGIN prime := i+i+3; k := i + prime; WHILE k <= size DO BEGIN flags[k] := FALSE; k := k + prime; END; count := count + 1; WRITELN(prime); END; END; WRITELN(count,' primes'); END; BEGIN do_it; END. ======================================================================================== DOCUMENT :usus Folder:VOL12:bench.pcw.text ======================================================================================== {$R-} program benchpcw; (* Personal Computer World Pascal Benchmark self timed version *) const num_loops = 10000; var j : integer; starth,startl,endh,endl : integer; procedure doneit; var t,s,e : real; begin s:=ABS(startl); e:=ABS(endl); t:=ABS(e-s)/60; writeln(': ',t:4,' seconds'); end; procedure magnifier; var k : integer; begin write('Magnifier '); time(starth,startl); for k := 1 to num_loops do ; time(endh,endl); doneit; end; procedure forloop; var j,k : integer; begin write('Forloop '); time(starth,startl); for k := 1 to num_loops do for j := 1 to 10 do; time(endh,endl); doneit; end; procedure whileloop; var j,k : integer; begin write('Whileloop '); time(starth,startl); for k := 1 to num_loops do begin j := 1; while j <= 10 do j:=j+1 end; time(endh,endl); doneit; end; procedure repeatloop; var j,k : integer; begin write('Repeatloop '); time(starth,startl); for k := 1 to num_loops do begin j := 1; repeat j:=j+1 until j > 10; end; time(endh,endl); doneit; end; procedure literalassign; var j,k,l : integer; begin write('Literalassign '); time(starth,startl); for k := 1 to num_loops do for j := 1 to 10 do l:=0; time(endh,endl); doneit; end; procedure memoryaccess; var j,k,l : integer; begin write('Memoryaccess '); time(starth,startl); for k := 1 to num_loops do for j := 1 to 10 do l:=j; time(endh,endl); doneit; end; procedure realarithmetic; var k : integer; x : real; begin write('Realarithmetic'); time(starth,startl); for k := 1 to num_loops do x := k/2*3+4-5; time(endh,endl); doneit; end; procedure realalgebra; var k : integer; x : real; begin write('Realalgebra '); time(starth,startl); for k := 1 to num_loops do x := k/k*k+k-k; time(endh,endl); doneit; end; procedure vector; var k,j : integer; matrix : array [0..10] of integer; begin write('Vector '); time(starth,startl); matrix[0] := 1; for k := 1 to num_loops do for j := 1 to 10 do matrix[j] := matrix[j-1]; time(endh,endl); doneit; end; procedure equalif; var j,k,l : integer; begin write('Equalif '); time(starth,startl); for k := 1 to 10000 do for j := 1 to 10 do if j < 6 then l := 1 else l := 0; time(endh,endl); doneit; end; procedure unequalif; var j,k,l : integer; begin write('Unequalif '); time(starth,startl); for k := 1 to 10000 do for j := 1 to 10 do if j < 2 then l := 1 else l := 0; time(endh,endl); doneit; end; procedure none5; begin j := 1 end; procedure none4; begin none5 end; procedure none3; begin none4 end; procedure none2; begin none3 end; procedure none1; begin none2 end; procedure noparameters; var j,k : integer; begin write('Noparameters '); j := 0; for k := 1 to num_loops do none1; time(endh,endl); doneit; end; procedure value5 (i : integer); begin i := 1 end; procedure value4 (i : integer); begin value5(i) end; procedure value3 (i : integer); begin value4(i) end; procedure value2 (i : integer); begin value3(i) end; procedure value1 (i : integer); begin value2(i) end; procedure value; var j,k : integer; begin write('Value '); j := 0; for k := 1 to num_loops do value1(j); time(endh,endl); doneit; end; procedure refer5 ( var i : integer); begin i := 1 end; procedure refer4 ( var i : integer); begin refer5(i) end; procedure refer3 ( var i : integer); begin refer4(i) end; procedure refer2 ( var i : integer); begin refer3(i) end; procedure refer1 ( var i : integer); begin refer2(i) end; procedure reference; var j,k : integer; begin write('Reference '); j := 0; for k := 1 to num_loops do refer1(j); time(endh,endl); doneit; end; procedure maths; var k : integer; x,y : real; begin write('Maths '); time(starth,startl); for k := 1 to num_loops do begin x := sin(k); y := exp(x); end; time(endh,endl); doneit; end; begin writeln; writeln; writeln; magnifier; forloop; whileloop; repeatloop; literalassign; memoryaccess; realarithmetic; realalgebra; vector; equalif; unequalif; noparameters; value; reference; maths; end. ======================================================================================== DOCUMENT :usus Folder:VOL12:bench.swap.text ======================================================================================== PROGRAM benchswap; (* Process swap benchmark - a VAX does >6000 swaps/sec *) CONST nswap =10000; VAR sem1,sem2,main : SEMAPHORE; c : CHAR; pid : PROCESSID; t11,t12,t21,t22 : INTEGER; PROCESS one; VAR i : INTEGER; BEGIN FOR i := 1 TO nswap DIV 2 DO BEGIN SIGNAL(sem2); WAIT(sem1); END; SIGNAL(main); END; PROCESS two; VAR i : INTEGER; BEGIN FOR i := 1 TO nswap DIV 2 DO BEGIN SIGNAL(sem1); WAIT(sem2); END; SIGNAL(main); END; BEGIN WRITELN('Type to go'); READ(c); TIME(t11,t12); SEMINIT(sem1,0); SEMINIT(sem2,0); SEMINIT(main,0); START(one,pid); START(two,pid); WAIT(main); WAIT(main); TIME(t21,t22); WRITELN('Done'); t22:=t22-t12; IF t22 > 0 THEN WRITELN((t22+30)DIV 60 ,' seconds ',ROUND((60/t22)*nswap),' swaps/sec'); END. ======================================================================================== DOCUMENT :usus Folder:VOL12:bench.usus.text ======================================================================================== program benchusus; (* Self timed version of Jon Bondy's benchmark See USUS News *) type rec2_type = record next : ^rec2_type; end; var num_loops : integer; i,j,k,l, test : integer; r,s,t : real; starth,startl,endh,endl : integer; a : array[1..100] of integer; b : array[1..100] of real; ch : char; rec1 : record firsti, secondi : integer; firstr, secondr : real; end; root, ptr : ^rec2_type; cset : set of char; (* printr : interactive; *) procedure prompt; procedure prompt1; { too big for 1200 bytes otherwise... } var line:integer; begin gotoxy(0,23); for line:=1 to 24 do writeln; gotoxy(0,0); writeln('Select a test or enter "0" for all tests.'); writeln('Enter a negative number to quit.'); writeln; end; begin prompt1; writeln(' 1. null for loops (to). 2. null for loops (downto).'); writeln(' 3. integer increments (for loop). 4. null while loops.'); writeln(' 5. null repeat loops. 6. integer adds.'); writeln(' 7. integer multiplys. 8. integer divides.'); writeln(' 9. real increments. 10. real adds.'); writeln('11. real multiplies. 12. real divides.'); writeln('13. integer transfers. 14. integer array transfers.'); writeln('15. real transfers. 16. real array transfers.'); writeln('17. integer record transfers. 18. real record transfers.'); writeln('19. integer if comparisons. 20. real if comparisons.'); writeln('21. case statements. 22. procedure calls.'); writeln('23. proc calls with integer param.24. proc calls with real param.'); writeln('25. proc calls with a local var. 26. set unions.'); writeln('27. set differences. 28. set IN''s.'); writeln('29. pointer transfers. 30. NOOP''s.'); write('Test:'); end; { prompt } procedure doneit; var t,s,e : real; begin writeln('Done.'); s:=ABS(startl); e:=ABS(endl); t:=ABS(e-s)/60; writeln('Time = ',t:4,' seconds'); (*writeln(printr,t);*) end; procedure dummy1; begin end; procedure dummy2(i : integer); begin end; procedure dummy3(r: real); begin end; procedure dummy4; var i : integer; begin end; procedure test1; begin write('1 . ',numloops,' null for loops (to).'); time(starth,startl); for i := 1 to num_loops do begin end; time(endh,endl); doneit; end; procedure test2; begin write('2. ',numloops, ' null for loops (downto).'); time(starth,startl); for i := num_loops downto 1 do begin end; time(endh,endl); doneit; end; procedure test3; begin write('3. ',numloops, ' integer increments (for loop).'); time(starth,startl); for i := 1 to num_loops do begin j := j + 1; end; time(endh,endl); doneit; end; procedure test4; begin write('4. ',numloops,' null while loops.'); j := 0; time(starth,startl); while (j < num_loops) do begin j := j + 1; end; time(endh,endl); doneit; end; procedure test5; begin write('5. ',numloops,' null repeat loops.'); j := 0; time(starth,startl); repeat j := j + 1 until (j = num_loops); time(endh,endl); doneit; end; procedure test6; begin write('6. ',numloops,' integer adds.'); time(starth,startl); for i := 1 to num_loops do begin j := j + k; end; time(endh,endl); doneit; end; procedure test7; begin write('7. ',numloops,' integer multiplys.'); time(starth,startl); for i := 1 to num_loops do begin j := k * l; end; time(endh,endl); doneit; end; procedure test8; begin write('8. ',numloops,' integer divides.'); time(starth,startl); for i := 1 to num_loops do begin j := k div l; end; time(endh,endl); doneit; end; procedure test9; begin write('9. ',numloops,' real increments.'); time(starth,startl); for i := 1 to num_loops do begin r := r + 1.0 end; time(endh,endl); doneit; end; procedure test10; begin write('10. ',numloops,' real adds.'); time(starth,startl); for i := 1 to num_loops do begin r := r + s; end; time(endh,endl); doneit; end; procedure test11; begin write('11. ',numloops,' real multiplies.'); time(starth,startl); for i := 1 to num_loops do begin r := s * t; end; time(endh,endl); doneit; end; procedure test12; begin write('12. ',numloops,' real divides.'); time(starth,startl); for i := 1 to num_loops do begin r := s / t; end; time(endh,endl); doneit; end; procedure test13; begin write('13. ',numloops,' integer transfers.'); time(starth,startl); for i := 1 to num_loops do begin j := k; end; time(endh,endl); doneit; end; procedure test14; begin j := 5; k := 12; write('14. ',numloops, ' integer array transfers.'); time(starth,startl); for i := 1 to num_loops do begin a[j] := a[k]; end; time(endh,endl); doneit; end; procedure test15; begin write('15. ',numloops,' real transfers.'); time(starth,startl); for i := 1 to num_loops do begin r := s; end; time(endh,endl); doneit; end; procedure test16; begin j := 5; k := 12; write('16. ',numloops,' real array transfers.'); time(starth,startl); for i := 1 to num_loops do begin b[j] := b[k]; end; time(endh,endl); doneit; end; procedure test17; begin write('17. ',numloops, ' integer record transfers.'); time(starth,startl); for i := 1 to num_loops do begin rec1.firsti := rec1.secondi; end; time(endh,endl); doneit; end; procedure test18; begin write('18. ',numloops, ' real record transfers.'); time(starth,startl); for i := 1 to num_loops do begin rec1.firstr := rec1.secondr; end; time(endh,endl); doneit; end; procedure test19; begin j := 5; k := 12; write('19. ',numloops, ' integer if comparisons.'); time(starth,startl); for i := 1 to num_loops do if (j < k) then begin end; time(endh,endl); doneit; end; procedure test20; begin r := 5.0; s := 12.0; write('20. ',numloops,' real if comparisons.'); time(starth,startl); for i := 1 to num_loops do if (r < s) then begin end; time(endh,endl); doneit; end; procedure test21; begin j := 2; write('21. ',numloops,' case statements.'); time(starth,startl); for i := 1 to num_loops do case j of 1 : begin end; 2 : begin end; 3 : begin end; 4 : begin end; end; time(endh,endl); doneit; end; procedure test22; begin write('22. ',numloops,' procedure calls.'); time(starth,startl); for i := 1 to num_loops do dummy1; time(endh,endl); doneit; end; procedure test23; begin write('23. ',numloops, ' procedure calls with integer parameter.'); time(starth,startl); for i := 1 to num_loops do dummy2(i); time(endh,endl); doneit; end; procedure test24; begin write('24. ',numloops, ' procedure calls with real parameter.'); time(starth,startl); for i := 1 to num_loops do dummy3(r); time(endh,endl); doneit; end; procedure test25; begin write('25. ',numloops, ' procedure calls with a local variable.'); time(starth,startl); for i := 1 to num_loops do dummy4; time(endh,endl); doneit; end; procedure test26; begin write('26. ',numloops,' set unions.'); time(starth,startl); for i := 1 to num_loops do cset := cset + ['a','b']; time(endh,endl); doneit; end; procedure test27; begin write('27. ',numloops,' set differences.'); time(starth,startl); for i := 1 to num_loops do cset := cset - ['a','b']; time(endh,endl); doneit; end; procedure test28; begin write('28. ',numloops,' set IN''s.'); time(starth,startl); for i := 1 to num_loops do if (ch in cset) then begin end; time(endh,endl); doneit; end; procedure test29; begin new(root); { create a loop of list elements } new(root^.next); root^.next^.next := root; ptr := root; write('29. ',numloops,' pointer transfers.'); time(starth,startl); for i := 1 to num_loops do ptr := ptr^.next; time(endh,endl); doneit; end; procedure test30; begin write('30. ',numloops,' NOOP''s.'); time(starth,startl); for i := 1 to num_loops do begin pmachine(156); end; time(endh,endl); doneit; end; begin { main } j := 100; k := 200; l := 300; r := 400; s := 500; t := 600; (*rewrite(printr,'printer:');*) write('Enter number of loops per test : '); readln(num_loops); repeat prompt; write('Enter test number : '); readln(test); if (test >= 0) then case test of 0 : begin test1; test2; test3; test4; test5; test6; test7; test8; test9; test10; test11; test12; test13; test14; test15; test16; test17; test18; test19; test20; test21; test22; test23; test24; test25; test26; test27; test28; test29; test30; end; 1 : test1; 2 : test2; 3 : test3; 4 : test4; 5 : test5; 6 : test6; 7 : test7; 8 : test8; 9 : test9; 10 : test10; 11 : test11; 12 : test12; 13 : test13; 14 : test14; 15 : test15; 16 : test16; 17 : test17; 18 : test18; 19 : test19; 20 : test20; 21 : test21; 22 : test22; 23 : test23; 24 : test24; 25 : test25; 26 : test26; 27 : test27; 28 : test28; 29 : test29; 30 : test30; end; if test>=0 then begin write('Type to continue'); readln; end; until (test < 0); end. ======================================================================================== DOCUMENT :usus Folder:VOL12:contents.text ======================================================================================== USUS(UK) SOFTWARE LIBRARY VOLUME 2 23rd March 1982 Material submitted to the USUS(UK) Software Libary by Austin Tate, ERCC 25-Feb-82 ----------------------------------------------------------------------- Most of the material on this disk uses UCSD version IV.0 facilities such as COMMANDIO, SCREENOPS and segments procedures in Units and won't work under II.0. The files on this disk are as follows:- Window Manager -------------- WINDOWS.TEXT The main file for the Window Manager Unit. W.IMPLN.TEXT The implementation part of the Unit. W.SEGS.TEXT The segment procedures for the Unit. W.IO.TEXT The I/O routines in the implementation of the Unit. WFILER.TEXT A simple Filer utility using window management. This can act as a demonstration and source of ideas. W.DOC.TEXT A short paper about the window manager and WFiler. OffLoad Office Workstation -------------------------- The individual utilities in OffLoad are not present on the disk as they are copyrighted by others. However, the command interpreter and other files may help to construct a suitable system for your own environment. Other utilities may be obtained from the USUS Software Library and commercial sources. OFF.START.TEXT The *SYSTEM.STARTUP program OFFLOAD.TEXT The command interpreter --> *OFFLOAD.CODE OFF.INFO.TEXT The information file for the workstation MAKE.PAGE.TEXT A trivial program to create NEW.PAGE.TEXt containing a form feed character only. The NEW.TEXT and NEW.PAGE.TEXT files have then had the following S(et E(nvironment options set. F(illing False, A(uto indent False, R(ight margin 70, C(ommand Character is ".", T(oken searches is False. NEW.TEXT A sample file to set up the editor "environment" for an empty file with reasonable margins, etc. NEW.PAGE.TEXT A sample file to set up the editor "environment" for a file with reasonable margins, etc. and a single newpage (formfeed) character. EDIT.E.G.TEXT A sample editor file for practicing editing. HELP.DISK.TEXT Help texts used by the OffLoad startup program and HELP.KEYS.TEXT OffLoad Command Interpreter. HELP.OFF.TEXT HELP.UTIL.TEXT OFF.READ.TEXT A Read Me file about the creation of an OffLoad system. OFF.DOC.TEXT A summary of the way the OffLoad system is configured at ERCC, the Utilities used, etc. ______________________________________________________________________________ The following material was submitted by Chris Lee, INMOS 10-Feb-82: CPROC.TEXT A 'toy' command interpreter which may be used as an example of how to use COMMANDIO facilities in UCSD version IV. VOLS.SMAC A sample 'Monitor' file which can be used to put a VOLS command into CPROC. BENCH.BYTE.TEXT Byte Benchmarks. BENCH.PCW.TEXT Personal Computer World Benchmarks. BENCH.USUS.TEXT Jon Bondy's USUS News Benchmarks. BENCH.SWAP.TEXT process swapping benchmark for version IV. PRINT.MEM.TEXT simple program to print memavail for USUS bench. PRINT.HEAP.TEXT program to print free space on heap. Could be used as a base for an algorithm to optimise the use of heap space in a program. CONTENTS.TEXT This list. ======================================================================================== DOCUMENT :usus Folder:VOL12:cproc.text ======================================================================================== { L cplist.text} {$U-} PROGRAM cproc; (* Chris Lee, INMOS, 10-Feb-82 *) (* A toy program whcih demonstrates how to use COMMANDIO routine to implement a user interface of your choice. This program builds a menu by searching all volumes online for files of name xxx.UTIL or xxx.SMAC. UTIL files should be renamed CODE files SMAC files should be renamed M(onitor or TEXT files The menu is drawn down the right side of the screen. To select an entry start typing it. As soon as enough has been typed to make the selection unambiguous the program types the rest. As soon as a definite error has occurred it is reported, and all input so far thrown away. Certain functions which are difficult to implement via UTIL or SMAC files are 'built in'. See Build_Menu to see how to add to the built in commands *) USES {$U kernel.code} kernel, {$U *screenops.code} screenops, {$U *commandio.code} commandio; CONST ESC = 27; max_token_length = 15; sc_width = 78; sc_height = 23; TYPE token = STRING[max_token_length]; cmd_types = (c_duff,c_menu,c_macro,c_prog,c_standard); vol_selector = STRING[10]; token_table = RECORD table_size : INTEGER; values : ARRAY [1..20] OF token; END; info_table = ARRAY [1..20] OF RECORD CASE cmd_type : cmd_types OF c_menu:( new_menu : char); c_prog:( vol : vol_selector); END; VAR command : token; table : token_table; info : info_table; ch : char; cmd_no : INTEGER; xstr : STRING; FUNCTION lookup ( target : token ; tokens : token_table) : INTEGER; VAR lo,hi,probe : integer; trial : token; BEGIN WITH tokens DO BEGIN lo:=1; hi:=table_size; WHILE lotrial THEN lo:=probe+1 ELSE hi:=probe; END; lookup:=lo; trial:=copy(values[lo],1,length(target)); IF target<>trial THEN lookup:=-1; trial:=copy(values[lo+1],1,length(target)); IF target=trial THEN lookup:=0 END; END; PROCEDURE insert_token ( value : token ; ctype : cmd_types ; v_id: vol_selector; VAR tokens : token_table ; VAR info : info_table) ; VAR i,lo,hi,probe : integer; trial : token; BEGIN WITH tokens DO BEGIN lo:=1; hi:=table_size; WHILE lotrial THEN lo:=probe+1 ELSE hi:=probe; END; IF table_size<>0 THEN BEGIN trial:=values[lo]; IF value=trial THEN EXIT(insert_token); IF value>trial THEN lo:=lo+1; END; table_size:=table_size+1; FOR i:=table_size DOWNTO lo+1 DO values[i]:=values[i-1]; FOR i:=table_size DOWNTO lo+1 DO info[i]:=info[i-1]; CASE c_type OF c_menu: BEGIN values[lo]:=copy(value,1,length(value)-1); info[lo].new_menu:=value[length(value)]; END; c_macro, c_prog, c_standard: BEGIN values[lo]:=copy(value,1,length(value)); info[lo].vol:=v_id; END; END; info[lo].cmd_type:=c_type; END; END; PROCEDURE build_menu(VAR table : token_table VAR info : info_table); VAR sys_dir : directory; i,j : INTEGER; dot : INTEGER; ctype : token; cname : token; v_id : vol_selector; c_tipe : cmd_types; BEGIN WITH table DO BEGIN table_size:=0; FOR j:=0 TO 12 DO IF j IN [4,5,9..12] THEN BEGIN v_id:='XXX'; {to set length} v_id[1]:='#'; v_id[2]:=chr((j DIV 10)+ord('0')); v_id[3]:=chr((j MOD 10)+ord('0')); unitread(j,sys_dir,sizeof(directory),dirblk); FOR i:=1 TO sys_dir[0].dnumfiles DO WITH sys_dir[i] DO IF length(dtid)>6 THEN BEGIN dot:=length(dtid)-4; ctype:=copy(dtid,dot,5); ctipe:=c_duff; cname:=copy(dtid,1,dot-1); IF ctype='.SMAC' THEN c_tipe:=c_macro ELSE IF ctype='.UTIL' THEN c_tipe:=c_prog; IF ctipe<>c_duff THEN insert_token(cname,c_tipe,v_id,table,info); END; END; insert_token('FILER', c_standard,'F', table,info); insert_token('COMPILE', c_standard,'C', table,info); insert_token('EDIT', c_standard,'E', table,info); insert_token('EXECUTE', c_standard,'X', table,info); insert_token('RUN', c_standard,'R', table,info); insert_token('HALT', c_standard,'I', table,info); END; END; PROCEDURE show_menu(table:token_table); VAR i,x,y : INTEGER; BEGIN y:=1; x:=0; sc_goto_xy(x,y); x:=sc_width-sizeof(token); WITH table DO FOR i:=1 TO table_size DO BEGIN sc_goto_xy(x,y); sc_erase_to_eol(x,y); write(values[i]); y:=y+1; END; END; BEGIN WITH table DO BEGIN {sc_init; sc_clr_screen;} sc_erase_to_eol(0,0); build_menu(table,info); show_menu(table); REPEAT exception(TRUE); sc_goto_xy(0,0); write('?'); command:=''; REPEAT read(keyboard,ch); IF ch IN ['a'..'z'] THEN ch:=chr(ord(ch)-ord('a')+ord('A')); IF ORD(ch)=ESC THEN BEGIN sc_goto_xy(0,0); sc_clr_screen; exception(TRUE); EXIT(PROGRAM); END; write(ch); IF ord(command[0])=0 THEN sc_erase_to_eol(2,0); command[0]:=chr(ord(command[0])+1); command[ord(command[0])]:=ch; cmd_no:=lookup(command,table); UNTIL cmd_no<>0; IF cmd_no<0 THEN BEGIN write(' - not found'); END ELSE BEGIN writeln(copy(values[cmd_no],length(command)+1, length(values[cmd_no])-length(command))); CASE info[cmd_no].cmd_type OF c_macro: BEGIN sc_eras_eos(0,1); exception(TRUE); chain(concat('I=',info[cmd_no].vol,':', values[cmd_no],'.SMAC')); chain('CPROC'); END; c_prog: BEGIN sc_eras_eos(0,1); exception(TRUE); chain(concat(info[cmd_no].vol,':',values[cmd_no],'.UTIL.')); chain('CPROC'); END; c_standard: BEGIN sc_eras_eos(0,1); exception(TRUE); if info[cmd_no].vol='X' then begin gotoxy(0,0); write('Execute what file? '); readln(xstr); {should check availability of code file now} {otherwise the CPROC command interpreter may not} {regain control after the exception} chain(xstr); end else chain(concat('I="',info[cmd_no].vol,'"')); {chain back to command interpreter unless HALTing} if info[cmd_no].vol<>'I' then chain('CPROC'); END; END; END; UNTIL info[cmd_no].cmd_type IN [c_prog,c_macro,c_standard]; END; END. ======================================================================================== DOCUMENT :usus Folder:VOL12:disk_copy.text ======================================================================================== (*$S+*) (*$I-*) (*$C Copyright 1982 (c) Great Western Software all rights reserved *) program disk_copy; (* Copies disks with verification George Schreyer *) var chk_buffer,buffer : packed array [0..15359] of char; ch : char; error : boolean; unitnum : integer; k2,blocks,block,k,k1,i : integer; diska,diskb : file; namea,nameb : string; procedure clear_line; begin write ( chr ( 27 ) , 'K' ); {H-19 dependant} end; procedure space_wait; var ch : char; begin write ( ' to continue' ); repeat read ( keyboard, ch ); until ( ch = ' ' ) and ( not eoln ( keyboard ) ); end; begin writeln; writeln ( ' disk_copy version 2.12 5-Jun-82' ); fillchar(buffer,sizeof(buffer),chr(0)); fillchar(chk_buffer,sizeof(chk_buffer),chr(0)); namea := '#4:'; nameb := '#5:'; writeln; writeln('Disk_copy copies a whole UCSD disk onto another.'); writeln('The source disk is placed in drive 4 and the destination'); writeln('disk is placed in drive 5.'); repeat gotoxy ( 0, 15 ); clear_line; write('type to start the transfer, or to quit '); repeat read(keyboard,ch); until ( ch = ' ' ); if eoln(keyboard) then exit(program); blocks := sizeof(buffer) div 512; reset(diska,namea); rewrite(diskb,nameb); writeln; error := false; block := 0; repeat gotoxy ( 0, 15 ); clear_line; write ( 'reading ...' ); k := blockread(diska,buffer,blocks,block); if ( (k < blocks) and (not eof(diska)) ) or (ioresult <> 0 ) then begin gotoxy ( 0, 15 ); clear_line; write(chr(7),'error reading #5'); space_wait; error := true; end; gotoxy ( 0, 15 ); clear_line; if not error then begin write ( 'writing ...' ); k1 := blockwrite(diskb,buffer,k,block); if ioresult <> 0 then begin gotoxy ( 0,15 ); clear_line; write ( 'error writing #9:' ); space_wait; error := true; end; end; gotoxy ( 0, 15 ); clear_line; if not error then begin write ( 'verifying ...' ); k2 := blockread(diskb,chk_buffer,k,block); block := block + k; if ( buffer <> chk_buffer ) or ( ioresult <> 0 ) then begin gotoxy ( 0, 15 ); clear_line; write(chr(7),'verification error'); space_wait; error := true; end; end; until (k < blocks) or (k1 <> k) or error; close(diskb,lock); close(diska); until false; end. ======================================================================================== DOCUMENT :usus Folder:VOL12:help.disk.text ======================================================================================== B(ackup #4 Make a backup copy of the Off-Load system disk in drive 4. C(opy #5 Copy the user disk in drive #5. N(ew #5 Create a formatted empty user disk in drive #5. T(idy disks Tidy up the disks in both drives to collect together all unused space. Q(uit Return to Off-Load command level. ======================================================================================== DOCUMENT :usus Folder:VOL12:help.keys.text ======================================================================================== SuperBrain/UCSD p-System version IV.0 Keyboard Characters -------------------------------------------------------------------------------- Editor Cursor moving keys 4 arrowed keys to right of keyboard Editor Accept Key Ctrl/C Editor Escape Key ESC Editor X(change Insert Key Ctrl/O for "Open" up one space Editor X(change Delete Key Ctrl/Z for "Zap" one character Delete current line Ctrl/X Delete last character BACKSPACE Stop/Start Screen output key CTRL/S Flush Screen Output Ctrl/F Reboot depress two red keys at same time ======================================================================================== DOCUMENT :usus Folder:VOL12:help.off.text ======================================================================================== E(dit enters the Off-Load text editor. F(iler enters the disk filing utility. L(ist starts the printing utility. P(rose starts the text formatting utility. S(can to list a document to the screen for review. T(ty starts up the communications utility. D(iskaids facilities to initialise new disks, copy disks and tidy disks. See H(elp D(iskaids for details. X(ecute is used to start up other utilities. See H(elp U(tilities for details. Q(uit is used to stop Off-Load. Off-Load is based on the UCSD p-System version IV.0 ======================================================================================== DOCUMENT :usus Folder:VOL12:help.util.text ======================================================================================== *CALC desk top arithmetic calculator. *MAIL system to maintain records of mailing and other general information to allow the printing of mailing labels and the production of personalised letters. *MAIL.INIT utility to initialise MAIL records from a document. *COMPARE check for differences between two documents. *CRACKUP split up large files for editing and join them together again. *COMPACT reduce disk storage space occupied by a document. *SORTMERGE sort a document according to fields of each line. *CONFIGURE utility to alter the operating environment of Off-Load. FUND (cashflow analysis),ENUF(database),etc are available as separate systems. ------------------------------------------------------------------------------- The following two utilities are normally executed using the D(isk-aid commands: B(ackup-#4, C(opy-#5 or N(ew-#5. However, they are directly available. *BOOTER copy the system disk bootstrap. *FORMATDISK initialise a new disk for use on Off-Load. ======================================================================================== DOCUMENT :usus Folder:VOL12:lmformat.text ======================================================================================== {$ l-printer:} PROGRAM lmformat; {$copyright (c) 1981 by Lee Meador, Arlington, TX 76010 } { Program formats Pascal programs by capitalizing keywords and } { making everthing else lower case. This makes a nice listing } { LMFORMAT was run on itself at one time } { You can add any more words you want capitalized to the list } { but be sure to keep it in alphabetical order } { } { Problems: words in comments should be left alone completely } { and single quotes in comments will throw it all off } { a nice feature would change any bracket comments to (**) } { or vice versa but should check for close comment inside } { it could be speeded up with BLOCKREAD and WRITE } { a lot more keywords should be added to these common ones } VAR fin : text; { input file variable } fout : text; { output file variable } line : STRING; { keep the input line here } inname, { input file name from user } outname : STRING; { output file name, too } debug : BOOLEAN; { true to trace program } lineno : INTEGER; { counts the lines of text } PROCEDURE process(VAR line:STRING); { process one line to change SPECIAL words to caps } VAR i : INTEGER; { count chars in the line } inquotes : BOOLEAN; { true when inside quotes } PROCEDURE tryem; { try to change the word beginning at 'I' if its special } PROCEDURE trymatch(trystring:STRING); { try to match (and change to caps) the word in trystring } PROCEDURE changeit; { IT matches! so change the word to all caps } VAR j : INTEGER; { counts chars in the word } BEGIN IF debug THEN WRITELN('ENTERING CHANGEIT', copy(line,i,length(trystring))); FOR j := 0 TO length(trystring)-1 DO IF line[i+j] IN ['a'..'z'] THEN line[i+j] := chr(ord(line[i+j])-32); EXIT(tryem); { dont try to match any more cause we already did } END; BEGIN IF debug THEN WRITELN('ENTERING TRYMATCH -> ',trystring); { if the line is too short, dont bother } IF i+length(trystring)-1 > length(line) THEN EXIT(trymatch); { it has to match and have the next char (after the word) be } { either an non-alphanumberic or off the end of the string } IF (copy(line,i,length(trystring)) = trystring) THEN IF length(line) > i+length(trystring) THEN IF NOT (line[i+length(trystring)] IN ['a'..'z','A'..'Z','0'..'9']) THEN changeit { non-alphanumeric after word } ELSE { null } ELSE changeit; { end of line after word } { maybe we didnt match -- so dont try to match any more if the } { word we are trying is alphbetically after the word in the } { line. The keywords are alphabetized by first letter. } IF line[i] < trystring[1] THEN EXIT(tryem); END; { trymatch } BEGIN IF debug THEN WRITELN('ENTERING TRYEM --> ', copy(line,i,length(line)-(i-1))); { try to match each of these keywords - in alphabetic order } trymatch('and'); trymatch('array'); trymatch('begin'); trymatch('boolean'); trymatch('case'); trymatch('char'); trymatch('close'); trymatch('const'); trymatch('div'); trymatch('downto'); trymatch('do'); trymatch('else'); trymatch('end'); trymatch('exit'); trymatch('external'); trymatch('false'); trymatch('file'); trymatch('forward'); trymatch('for'); trymatch('function'); trymatch('get'); trymatch('gotoxy'); trymatch('goto'); trymatch('if'); trymatch('implementation'); trymatch('integer'); trymatch('interface'); trymatch('in'); trymatch('label'); trymatch('mod'); trymatch('nil'); trymatch('not'); trymatch('of'); trymatch('or'); trymatch('packed'); trymatch('page'); trymatch('procedure'); trymatch('program'); trymatch('put'); trymatch('readln'); trymatch('read'); trymatch('real'); trymatch('record'); trymatch('repeat'); trymatch('reset'); trymatch('rewrite'); trymatch('seek'); trymatch('segment'); trymatch('separate'); trymatch('set'); trymatch('string'); trymatch('then'); trymatch('to'); trymatch('true'); trymatch('type'); trymatch('unit'); trymatch('until'); trymatch('uses'); trymatch('var'); trymatch('while'); trymatch('with'); trymatch('writeln'); trymatch('write'); END; { tryem } BEGIN { process } IF debug THEN WRITELN('ENTERING PROCESS ->'); IF debug THEN WRITELN(' ',line); { change all the letters that arent in quotes to lower case first } inquotes := FALSE; FOR i := 1 TO length(line) DO IF NOT inquotes THEN IF line[i] = '''' THEN inquotes := TRUE ELSE IF line[i] IN ['A'..'Z'] THEN line[i] := chr(ord(line[i])+32) ELSE { null } ELSE IF line[i] = '''' THEN inquotes := FALSE ELSE { null }; { try all the keywords beginning at every position of the line } { we do save a little time by not bothering if the char at a } { position isnt alphabetic -- which all keywords begin with } { then when we finish trying a word we skip to the next } { possible place a match could occur -- next non-alphanum } { Oh yes, dont try to match inside quotes } inquotes := FALSE; FOR i := 1 TO length(line) DO IF NOT inquotes THEN IF line[i] = '''' THEN inquotes := TRUE ELSE IF line[i] IN ['a'..'z'] { dont try non-lc chars } THEN BEGIN tryem; { a possible place -- try it } IF i < length(line) THEN WHILE (line[i+1] IN ['a'..'z','A'..'Z','0'..'9']) AND (i < length(line)-1) DO i := succ(i) { skip alphanums after try } END ELSE { null } ELSE IF line[i]= '''' THEN inquotes := FALSE ELSE { null } { no trying inside quotes } END; { process } BEGIN debug := FALSE; { set to true to print out a trace on console } { open input file } PAGE(output); GOTOXY(0,5); WRITE('Input File name: '); READLN(inname); IF length(inname)=0 THEN inname := 'SYSTEM.WRK.TEXT'; RESET(fin,inname); { then open output file } GOTOXY(0,7); WRITE('Output File name: '); READLN(outname); IF length(outname)=0 THEN outname := 'SYSTEM.WRK.TEXT'; REWRITE(fout,outname); { now read, change and write each line } lineno := 0; WHILE NOT eof(fin) DO BEGIN IF lineno MOD 50 = 0 THEN BEGIN WRITELN; WRITE('<',lineno:4,'> '); END; WRITE('.'); lineno := succ(lineno); READLN(fin,line); process(line); WRITELN(fout,line); END; { finally save the output ... thats it } CLOSE(fout,lock); WRITELN('Your output is on ',outname); END. ======================================================================================== DOCUMENT :usus Folder:VOL12:make.page.text ======================================================================================== PROGRAM MAKEPAGE; VAR X:TEXT; BEGIN REWRITE(X,'#5:NEW.PAGE.TEXT'); WRITE(X,CHR(12)); CLOSE(X,LOCK) END. ======================================================================================== DOCUMENT :usus Folder:VOL12:new.page.text ======================================================================================== ======================================================================================== DOCUMENT :usus Folder:VOL12:new.text ======================================================================================== ======================================================================================== DOCUMENT :usus Folder:VOL12:off.doc.text ======================================================================================== ~Overview~ OffLoad is a collection of administrative aids which are made available on a microcomputer. The system is intended for those users who require a general purpose microcomputer system for some aspect of their work and who wish to use the system for additional administrative functions. The individual components of the OffLoad system have been made as compatible as possible to provide a straightforward, uniform set of facilities to the user. Extensive use is made of "menus" from which choices of action may be made and help information is provided by the system. +-------------+ | Computer | | Network | +-------------+ ^ | v +-------------+ +-----------+ | OffLoad | ------> | Printer | | workstation | +-----------+ +-------------+ ^ | v user The design of the OffLoad workstation allows straightforward integration with facilities available over a computer network. This will enable interpersonal communication facilities (such as electronic mail, viewdata and document transfers) as well as access to more powerful computer based facilities, document archives, printing, etc. ~System Requirements~ The full OffLoad system will run on the UCSD p-System Version IV and it has initially been provided on the Intertec SuperBrain QD microcomputer. Many of the individual components of OffLoad are available as part of the WORDSET Word Processing Facilities or other packages available from the ERCC for UCSD based microcomputers. ~OffLoad Command Level~ The components of the OffLoad system are arranged in a hierarchy. At all levels you are presented with a prompt line giving the options available to you and inviting you to press a key to select one of them. Options are indicated by a form such as E(dit or S(et. Type the letter to the left of the parenthesis to make the appropriate selection. You may return to a higher choice level by typing Q to Q(uit. ~OffLoad Components~ E(ditor to create and modify documents F(iler to examine disk contents, manipulate disks L(ist to print out documents P(rose to format documents S(can to list a document to the screen for review T(ty to communicate with other computers D(iskAids to copy and tidy disks H(elp to provide assistance in the use of OffLoad X(ecute to execute other utilities and programs Crackup splits up large documents and rejoins parts Compact reduce space used by document Calc Desktop arithmetic calculator Compare two documents Sort/Merge Mail Mailing label manager and form letters Configure workstation environment Fund,Enuf,etc Cashflow analysis, Data base management system, etc + others ~OffLoad Parameter Text~ Instead of making arbitrary choices for the default action of the various components of OffLoad, the system will check for the presence of setup information in a text file held on the system disk (*PARAM.INFO). This is set to general, useful values but may be altered by the user with the Editor. An appendix to this document describes the various features which may be set up. Suitable general purpose defaults have already been chosen for the OffLoad system as it is distributed. ~Help~ The OffLoad workstation provides help on several topics. You can get a summary of the OffLoad commands, recall the special keystrokes needed for editor functions, get a list of the Utilities available, etc. A document *HELP.HINT may be created by a user of OffLoad to hold any useful information and this can be recalled in the OffLoad Help facility at any time. ~Editor~ A screen oriented editor is used for the entry of text to the system and for its subsequent modification. The editor displays a screen image which shows a "window" onto the text being edited. The screen image is as close as possible to the current state of the part of the text being entered or modified. Cursor moving keys may be used to move to any position on the screen or to move through the text to cause a different "window" to be shown on the screen. ~DiskAids~ A set of commonly needed disk operations has been provided in an easy to use manner via the DiskAids component of OffLoad. These simplify the copying of entire disks and the setting up of new user disks. Normally these operations would each consist of several steps and necessitate otherwise unnecessary background knowledge of the computer system being used. The DiskAid facilities are: B(ackup-#4 create a backup of the OffLoad System Disk C(opy-#5 create a copy of the User Disk N(ew-#5 create a new, formatted, blank, User Disk T(idy compact unused space on the disks in drives ~Filer~ The Filer is a collection of facilities to examine the list of documents or files on disks (known as disk directories), to copy files, remove files, change the names of files, copy entire disks, etc. Floppy disks are prone to damage from dust, grease, etc, so there are aids for checking disks are sound and recovering parts of disks found to be faulty (see the appendix on handling floppy disks for more information on disk handling and recovering from errors). The "DiskAids" facilities in OffLoad are intended to provide a straightforward method of manipulating entire disks, to take back-up copies of disks, etc. ~LIST~ LIST is a utility for listing text to a printer. Simple paginated output is possible using a format which you may specify in the OffLoad parameter information text. However, the OffLoad workstation is set up so that, by default, A4 paginated output will be produced. The document to be listed may consist of several separate parts. These can be given to LIST by separating them by commas. Text may be underlined and characters printed in an alternative font using the LIST utility. ~PROSE - Text Formatter~ More sophisticated text formatting is possible using the text formatter PROSE. Directives may be placed in the text to produce a wide variety of output styles. Without directives PROSE will attempt to produce a reasonably formatted document according to a default description. Sample directive texts for PROSE are provided with the OffLoad System. ~Scan - review a long text~ The S(can) option of OffLoad is a simple method of reviewing a text file which is too long to edit. It lists the document on the screen. ~TTY - Communications~ TTY can be used to enable the microcomputer to act as a video terminal to a host computer. The microcomputer is connected to the network via a Terminal Control Processor, either directly or via an accoustic coupler and telephone to the host computer. The normal conventions for logging on to and using the host computer should then be followed. It is possible to enter a "local mode" of the TTY program and to P(ut documents to the host computer from the micro- computer's disks or to G(et documents back from the host computer to the microcomputer's disks. The F(iler option allows the microcomputer's disk directories to be examined, documents removed, etc. from within TTY. TTY forms a part of the ERCC X-Talk communication facilities. ~X(execute)~ Less commonly used components of the OffLoad system do not appear on the main options menu list. These can be used by typing X and giving the component name. ~CRACKUP~ CRACKUP can be used to break up a large document into several manageable pieces suitable for editing. This may be necessary where a document is brought onto the workstation from elsewhere (e.g., from another computer). In addition, should it ever be desirable to put together all the separate sections of a large document (e.g., for sending to someone on a different computer) CRACKUP will also perform that operation. ~COMPACT~ The Editor and some other OffLoad utilities represent documents in a reduced form. In some cases, such as receipt of documents from a host computer via the G(et document) facilities of the TTY communication package, the document created will be larger than strictly necessary. If this causes inconvenience, such as making the document too large to edit, perform a COMPACT operation on the document and the leading spaces will be converted to their reduced form, and all trailing spaces on lines will be removed. ~CALC~ CALC enables simple arithmetic calculations to be performed. A display can be maintained showing the current values of a set of "variables" which can be used to hold intermediate results. Help information is available in the utility. ~COMPARE~ This is a utility to compare 2 similar documents and to produce a report of the differences between them. It is normally used to compare a revision of a document against an original. ~SORT/MERGE~ SORT/MERGE is a general package which is able to perform a number of operations on lines of text (usually in some fixed format or list) or on other types of files. The OffLoad system includes one version of this facility which allows a document consisting of single line records to be sorted according to up to 6 'keys' or ordering fields. ~MAIL~ MAIL is a utility to manage a data base of name, address and other information. The data base may be added to, changed and entries deleted. It is possible to search through the data base for records satisfying certain criteria. Mailing labels may be produced and record entries merged into standard letters to produce "form" letters. ~CONFIGURE~ CONFIGURE can be used to set characteristics of the OffLoad workstation hardware. Normally, information for the ports for connection to a printer and to other computers can be set in CONFIGURE. See the manual for the particular hardware in use for details. ~FUND (Cash Flow Analysis), ENUF (database), etc.~ FUND, ENUF, etc. are systems provided on the UCSD p-System in which OffLoad operates. They are not provided directly in OffLoad due to limitations on disk space. However, they may be used as separate systems. FUND is a utility to maintain a list of transactions by Cost Centres (e.g., grants or departmental groupings) and Cost Codes (e.g., expenditure headings). Transactions may be entered and later examined. Reports may be generated to the screen or to a printer giving income, expenditure, cash balances and committed expenditure for various cost centres or cost codes. ENUF - the Edinburgh User Friendly Data Base Management System - is a flexible, easy to use, general purpose data base management system. It may be used in many situations where record processing is required. ~FORMATDISK, BOOTER, etc~ These utilities are normally called via the OffLoad DiskAids component. However, they can be called separately if required to format disks or to copy the bootstrap area of disks. ~User Provided Programs~ There are several general purpose tools to aid in providing programs suitable for administrative functions. In particular, there are facilities to provide ISAM (Indexed Sequential Access Method) file support and "electronic form" oriented front ends to programs. ======================================================================================== DOCUMENT :usus Folder:VOL12:off.info.text ======================================================================================== SuperBrain QD OffLoad Info Text. 23-July-81 1 *FORMATDISK PI="FD,Q" *BOOTER PI="4,5,," 690 690 4 -1 ======================================================================================== DOCUMENT :usus Folder:VOL12:off.read.text ======================================================================================== OffLoad Command Interpreter - 19-Feb-82 - Austin Tate ----------------------------------------------------- The following files are on the disk: OFF.START.TEXT The *SYSTEM.STARTUP program OFFLOAD.TEXT The command interpreter --> *OFFLOAD.CODE ------------------------- OFF.INFO.TEXT The information file for the workstation ------------------------- NEW.TEXT A sample file to set up the editor "environment" for an empty file with reasonable margins, etc. NEW.PAGE.TEXT A sample file to set up the editor "environment" for a file with reasonable margins, etc. and a single newpage (formfeed) character. EDIT.E.G.TEXT A sample editor file for practicing editing. ------------------------- HELP.DISK.TEXT Help texts used by the OffLoad startup program and HELP.KEYS.TEXT OffLoad Command Interpreter. HELP.OFF.TEXT HELP.UTIL.TEXT ------------------------- OFF.READ.TEXT This document. OFF.DOC.TEXT A summary of the OffLoad System as configures at ERCC, the utilities used, etc. Preparation ----------- _______________________________________________________________________ Notes from the reviewer: Offload REQUIRES a version IV.0 system with CHAIN (found in the system unit COMMANDIO). It also uses ScreenOps, which is distributed with your IV.0 system, to operate properly. I couldn't find the documentation for setting up OFF.INFO.TEXT, but the program fumbles around and more or less works without it. If you really want to have some some fun, set up the window manager F(iler utility (found on this disk as WINDOWS and WFILER) first and call it *FILER.CODE. - gws ________________________________________________________________________ 1. Compile the OFF.START program and rename it *SYSTEM.STARTUP. 2. Compile OFFLOAD to *OFFLOAD.CODE. 3. Put all the other text files on the Boot Disk. 4. Edit the *OFF.INFO.TEXT information file to hold the relevant parameters for your workstation - disk size in blocks, command sequences to copy disks, copy bootstraps, format disks, etc. Change the version number at the top and bottom of this file whenever you change the *OFF.INFO.TEXT file and it will be reloaded the next time *OFFLOAD runs. 5. Rename or copy *SYSTEM.EDITOR to *EDITOR.CODE and *SYSTEM.FILER to *FILER.CODE. 6. Reboot and watch the fun. ======================================================================================== DOCUMENT :usus Folder:VOL12:off.start.text ======================================================================================== program offstart; USES {$U *screenops.code} SCREENOPS, {$U *commandio.code} COMMANDIO; {Off-Load Office Workstation startup program} {Copyright Austin Tate 18-Aug-81} {User may provide a code file *STARTUP.CODE to be run after} {this program but before the main Off-Load command interpreter} const bel=7; var ch:char; xstr:string; SCInfo:sc_info_type; procedure line(Y:integer); var i:integer; begin if Y>=0 then GOTOXY(0,Y); {else put line on end of present text} for i:=1 to 4 do write('--------------------'); end; function exists(fname,suffix:string):boolean; var g:file; begin if (length(fname)=0) then exists:=false else begin {$I-} reset(g,concat(fname,suffix)); exists:=(IORESULT=0); {$I+} end; end; procedure help(fname:string); var f:text; st:string[255]; begin if (length(fname)=0) then writeln(fname,' is an illegal help text file name.') else begin {$I-} reset(f,concat(fname,'.TEXT')); if (IORESULT<>0) then writeln(fname,' help text is not on disk.') else begin while not eof(f) do begin readln(f,st); if IORESULT=0 then writeln(st); end; end; {$I+} end; end; procedure title; begin line(0); writeln('O F F - L O A D - Office Workstation'); line(2); end; procedure getdate; var xstr:string; begin {get date} SC_Use_Info(SC_Get,SC_Info); xstr:=' '; with SC_Info.SC_Date do begin case Month of 1: xstr:='Jan'; 2: xstr:='Feb'; 3: xstr:='Mar'; 4: xstr:='Apr'; 5: xstr:='May'; 6: xstr:='Jun'; 7: xstr:='Jul'; 8: xstr:='Aug'; 9: xstr:='Sep'; 10: xstr:='Oct'; 11: xstr:='Nov'; 12: xstr:='Dec'; end; gotoxy(56,21); write('Date is set to '); write(Day:2,'-',xstr,'-',Year:2); end; end; begin sc_clr_screen; xstr:=''; title; help('*Help.Off'); line(-1); title; SC_Eras_EOS(0,21); gotoxy(0,21); if Redirect('P=#5') then Write('The default volume is drive #5.') else begin exception(TRUE); write('The volume prefix could not be set.'); end; if exists('*STARTUP','.CODE') then chain('*STARTUP'); {user provided startup} getdate; SC_Clr_Line(22); write('Type ''D'' to set date, to continue'); SC_GetC_Ch(ch,['D',' ']); if ch='D' then begin write(' ........ Date will be set within Filer'); chain('*FILER PI="D"'); end; Chain('*OFFLOAD'); end. ======================================================================================== DOCUMENT :usus Folder:VOL12:offload.text ======================================================================================== program offload; USES {$U *screenops.code} SCREENOPS, {$U *commandio.code} COMMANDIO; {Off-Load Office Workstation command interpreter} {Copyright Austin Tate 20-Aug-81} {user may provide a file *Help.Hint.Text containing any items} {desired as H(elp H(ints text } const bel=7; paramrevision=1; {revision number of parameter file *OFF.INFO.TEXT} type paramrec=record headrevision:integer; formatstr:string; bootstr:string; quitstr:string; SDiskBlocks:string[7]; {string version of diskblocks} diskblocks:integer; usercopyto:integer; {volume to copy user disk to} {4 on a 2 disk dsystem} sstoggle:string[15]; endrevision:integer; {-ve of headrevision as a check} end; var param:paramrec; ch,esc:char; xstr:string; terminal:boolean; procedure loadparams; var ok:boolean; f:file of paramrec; g:text; ires1,ires2:integer; begin {$I-} ok:=false; reset(f,'*OFF.INFO.DATA'); if ioresult=0 then begin {get done by reset} param:=f^; with param do begin ok:=((headrevision=paramrevision) and (endrevision=-paramrevision)); end; end; if not ok then close(f,purge) else close(f); if not ok then begin SC_Clr_Screen; Write('Reading *OFF.INFO.....'); reset(g,'*OFF.INFO.TEXT'); if ioresult=0 then begin with param do begin readln(g,xstr); {initial comment line} readln(g,headrevision); readln(g,formatstr); readln(g,bootstr); readln(g,quitstr); readln(g,Sdiskblocks); readln(g,diskblocks); ires1:=ioresult; readln(g,usercopyto); ires2:=ioresult; readln(g,sstoggle); readln(g,endrevision); close(g); end; if ((param.headrevision=paramrevision) and (param.endrevision=-paramrevision) and (ires1=0) and (ires2=0)) then begin rewrite(f,'*OFF.INFO.DATA'); f^:=param; put(f); close(f,lock); ok:=true; end; end; if not ok then begin Writeln(' but it was was unavailable or out of date.'); repeat until not space_wait(TRUE); end; end; {$I+} end; procedure line(Y:integer); var i:integer; begin if Y>=0 then GOTOXY(0,Y); {else put line on end of present text} for i:=1 to 4 do write('--------------------'); end; function exists(fname,suffix:string):boolean; var g:file; begin if (length(fname)=0) then exists:=false else begin {$I-} reset(g,concat(fname,suffix)); exists:=(IORESULT=0); {$I+} end; end; procedure help(fname:string); var f:text; st:string[255]; begin line(2); if (length(fname)=0) then writeln(fname,' is an illegal help text file name.') else begin {$I-} reset(f,concat(fname,'.TEXT')); if (IORESULT<>0) then writeln(fname,' text is not on disk.') else begin while not eof(f) do begin readln(f,st); if IORESULT=0 then writeln(st); end; end; {$I+} end; line(-1); {line on end of text} line(2); {repeated in case of scroll} end; PROCEDURE CopyDisk; CONST FromVol=5; ToVol=4; INC1=10; {TRANSFER THIS MANY BLOCK AT A TIME - MAKE AS LARGE AS SPACE ALLOWS} VAR I,ERRORS,SECTOR,BLOCK,INCR,LGTH,MAX1:INTEGER; ARR:PACKED ARRAY[0..INC1,1..512] OF CHAR; CH:CHAR; MaxBlocks:integer; BEGIN {DiskBlocks is global} {TRANSFER BLOCKS 0..(DiskBlocks-1)} MaxBlocks:=param.DiskBlocks; WRITELN; WRITELN('Copy will copy the entire contents of the User Disk in drive #', FromVol); WRITELN(' to a disk which has previously been N(ew-#5 ed in drive #', ToVol); WRITELN; IF ToVol=4 THEN WRITELN('You should remove the OFFLOAD System Disk from drive #4.'); WRITELN; WRITELN('Put a disk which has already been N(ew-#5 ed in drive #',ToVol); WRITELN('Note that the entire contents of this disk will be overwritten'); REPEAT GotoXY(0,8); WRITE('Type to continue, to abort'); READ(KEYBOARD,CH); UNTIL Ch in [ESC,' ']; IF Ch=ESC then EXIT(CopyDisk); GOTOXY(0,10); WRITELN('Copy starting..'); {$I-} BLOCK:=0; INCR:=INC1; LGTH:=512*INCR; MAX1:=MaxBlocks-INCR; REPEAT UNITREAD(FromVol,ARR,LGTH,BLOCK,0); IF IORESULT<>0 THEN {try again - block at a time} FOR I:=1 TO INCR DO BEGIN UNITREAD(FromVol,ARR[I],512,BLOCK+I-1,0); {BLOCK BY BLOCK} IF IORESULT<>0 THEN BEGIN WRITELN('Failed to read from disk in drive ',FromVol, ' Block=',BLOCK+I-1,' IOResult=',IORESULT); ERRORS:=ERRORS+1; END; END; UNITWRITE(ToVol,ARR,LGTH,BLOCK,0); IF IORESULT<>0 THEN {try again - block at a time} FOR I:=1 TO INCR DO BEGIN UNITWRITE(ToVol,ARR[I],512,BLOCK+I-1,0); IF IORESULT<>0 THEN BEGIN WRITELN('Failed to write to disk in drive ',ToVol, ' Block=',BLOCK+I-1,' IOResult=',IORESULT); ERRORS:=ERRORS+1; END; END; BLOCK:=BLOCK+INCR; IF BLOCK>MAX1 THEN BEGIN INCR:=MaxBlocks-BLOCK; {PART TRANSFER AT END} LGTH:=512*INCR; END; UNTIL BLOCK=MaxBlocks; {$I+} WRITELN; WRITE('Copy Complete'); IF ERRORS>0 then WRITE('..number of errors detected=',ERRORS); WRITELN; IF ToVol=4 THEN begin Line(21); SC_Eras_EOS(0,22); WRITE('Return the OFFLOAD System Disk to drive #4.'); REPEAT GotoXY(0,23); UNTIL NOT Space_Wait(TRUE); end; END; procedure Disker; var ch:char; terminal:boolean; i:integer; begin Terminal:=false; xstr:=''; SC_Clr_Screen; Repeat SC_Clr_Line(1); SC_Clr_Line(0); ch:=SC_Prompt('Disk aids: B(ackup-#4 C(opy-#5 N(ew-#5 T(idy H(elp Q(uit:', -1,0,0,0, ['B','C','N','T','H','Q'], FALSE,' '); SC_Clr_Screen; case ch of 'B':begin writeln; writeln('Backup will copy the Off-Load system disk in drive #4'); writeln(' to a disk placed in drive #5.'); writeln; write('The operation will take several minutes. '); writeln('Insert a blank disk in drive #5.'); write('Type to continue, to abort'); SC_GetC_Ch(ch,[' ',esc]); if ch=' ' then begin with param do begin if formatstr<>'' then chain(formatstr); {eg, *FORMATDISK PI="FD,Q"} if bootstr<>'' then chain(bootstr); {eg, *BOOTER PI="4,5,,"} end; xstr:='*FILER PI="T#4,#5,YQ"'; end; end; 'C':CopyDisk; 'N':begin writeln; writeln('New will initialise a blank user disk in drive #5.'); writeln; repeat gotoxy(0,3); write('Give new volume name (7 characters max.):'); readln(xstr); while pos(' ',xstr)<>0 do delete(xstr,pos(' ',xstr),1); i:=pos(':',xstr); if i<>0 then delete(xstr,i,(length(xstr)-i)+1); if xstr[1]=esc then xstr:=''; until (length(xstr)=0) or (length(xstr)<=8); if length(xstr)>0 then begin writeln; write('The operation will take about one minute. '); writeln('Insert a blank disk in drive #5.'); write('Type to continue, to abort'); SC_GetC_Ch(ch,[' ',esc]); if ch=' ' then begin with param do begin if formatstr<>'' then chain(formatstr); xstr:=concat('*FILER PI="Z#5,N',SDiskBlocks, ',',xstr,':,YQ"'); end; end else xstr:=''; end; end; 'T':begin writeln; write('Tidy will compact unused space on the disks in'); writeln(' drives #4 and #5.'); writeln; write('Type to continue, to abort'); SC_GetC_Ch(ch,[' ',esc]); if ch=' ' then xstr:='*FILER PI="K#4,YK#5,YQ"'; end; 'H':help('*help.disk'); 'Q':terminal:=true; end; if (ch<>'H') and (length(xstr)=0) then SC_Clr_Screen; until (length(xstr)>0) or (terminal); end; procedure Scanner; var i:integer; tempstr:string; begin {To S(can document use T(ransfer from file to CONSOLE: in F(iler } SC_Clr_Screen; WRITELN; WRITELN('Scan will display the document to the screen - it goes quite fast.'); WRITELN(' You may stop and start the display by using the stop/start'); WRITELN(' toggle key - ',param.sstoggle); WRITELN; GotoXY(0,5); WRITE('Give name of document to be scanned:'); READLN(tempstr); IF length(tempstr)>0 then begin if tempstr[1]=ESC then tempstr:=''; end; if length(tempstr)>0 then begin {check file exists} for i:= 1 to length(tempstr) do begin if (tempstr[i]>='a') and (tempstr[i]<='z') then tempstr[i]:=CHR((ORD(tempstr[i])-ORD('a'))+ORD('A')); end; if not exists(tempstr,'') then begin if exists(tempstr,'.TEXT') then tempstr:=concat(tempstr,'.TEXT') else begin tempstr:=''; WRITELN('File specified cannot be found on disk.'); end; end else begin if (length(tempstr)<6) or (pos('.TEXT',tempstr)<>length(tempstr)-4) then begin tempstr:=''; WRITELN('File specified is not a Text Document.'); end; end; {if tempstr<>'' we have a text file which exists} if tempstr<>'' then xstr:=concat('*FILER PI="T',tempstr,',CONSOLE:,Q"'); end; end; procedure Helper; var ch:char; terminal:boolean; begin Terminal:=false; SC_Clr_Screen; Repeat SC_Clr_Line(1); ch:=SC_Prompt('Help: C(ommands H(ints K(eystrokes U(tilities Q(uit:', -1,0,0,0, ['C','H','K','U','Q'], FALSE,' '); if ch<>'Q' then SC_Clr_Screen; case ch of 'C': help('*Help.Off'); 'H': help('*Help.Hint'); {for any user provided text} 'K': help('*Help.Keys'); 'U': help('*Help.Util'); 'Q': terminal:=true; end; until terminal; end; begin exception(TRUE); {turn off all redirection and chaining to clear buffers} {also prevents a build up of *OFFLOAD calls by user } esc:=chr(27); Loadparams; sc_clr_screen; terminal:=false; repeat xstr:=''; sc_clr_line(1); {in case of abortive X(ecute} ch:=sc_prompt(concat('Off-Load: E(dit F(ile L(ist P(rose S(can ', 'T(ty X(ecute D(iskaids H(elp Q(uit [1.0]'), -1,0, {place cursor at end of prompt} 0,0, {place prompt at top of textport} ['E','F','L','P','S','T','D','H','Q','X'], FALSE, {character is being prompted} ' '); {break ch in prompt is space} write(ch); case ch of 'E':xstr:='*EDITOR'; 'F':xstr:='*FILER'; 'L':xstr:='*LIST'; 'P':xstr:='*PROSE'; 'S':Scanner; 'T':xstr:='*TTY'; 'D':Disker; 'H':Helper; 'X':begin writeln; write('Execute what file:'); readln(xstr); if xstr<>'' then begin {now check that the .CODE file exists} {to save return to UCSD outer level} if not exists(xstr,'.CODE') then begin SC_Clr_Line(0); Write(Xstr,' is not an executable file.'); repeat SC_Clr_Line(1); until NOT Space_Wait(TRUE); Xstr:=''; end; end; end; 'Q':terminal:=true; end; until (terminal) or (xstr<>''); if not terminal then begin chain(xstr); Chain('*OFFLOAD'); sc_clr_screen; end else chain(param.Quitstr); end. ======================================================================================== DOCUMENT :usus Folder:VOL12:param.info.text ======================================================================================== LST CHANNEL =6 LST FORMAT =[A4] LST OPTIONS =[O12] PROSE.OUTPUT=(S12) ======================================================================================== DOCUMENT :usus Folder:VOL12:print.heap.text ======================================================================================== program printheap; (* Noddy program to print a summary of free heap space. Could be turned into a routine for use in tuning/debugging programs which make intensive use of the heap Version IV.0 specific*) uses {$U KERNEL.CODE} kernel; type dummy = array [0..100] of integer; var cur_ptr : mem_ptr; avail_ptr : mem_ptr; empty : integer; junkk1, junkk2, junkk3, junkk4, junkk5: ^dummy; begin (*new(junkk1); new(junkk2); new(junkk3); new(junkk4); new(junkk5); dispose(junkk2); dispose(junkk4); dispose(junkk3); dispose(junkk1); dispose(junkk5);*) moveleft(emptyheap,empty,2); cur_ptr:=heap_info.top_mark; writeln; writeln('Heap Top = ',heap_info.heap_top.t,' Empty Heap = ',empty); while cur_ptr.m <> NIL do begin writeln('Heap Mark At - ',cur_ptr.t,' Size - ',cur_ptr.m^.n_words); writeln('Last Avail = ',cur_ptr.m^.last_avail.t); avail_ptr:=cur_ptr.m^.avail_list; while avail_ptr.m <> NIL do begin writeln(' Block At - ',avail_ptr.t,' Size - ',avail_ptr.m^.n_words); avail_ptr:=avail_ptr.m^.avail_list; end; cur_ptr:=cur_ptr.m^.prev_mark; end; writeln; writeln('Permanent Heap'); if permlist.m = NIL then writeln('Null') else begin cur_ptr:=permlist; while cur_ptr.m <> NIL do begin writeln('Block At - ',cur_ptr.t,' Size - ',cur_ptr.m^.n_words); cur_ptr:=cur_ptr.m^.avail_list; end; end; end. ======================================================================================== DOCUMENT :usus Folder:VOL12:print.mem.text ======================================================================================== program printmem; (* Noddy program for use with Jon Bondy's benchmark See USUS News*) var ptr : ^integer; begin new(ptr); dispose(ptr); writeln(memavail ,' words of memory available'); writeln(varavail('') ,' words really available'); end. ======================================================================================== DOCUMENT :usus Folder:VOL12:r.analyze.text ======================================================================================== { ANALYZE: Analyze and summarize execution time performance measurements from an AUGMENTed Pascal program. PROGRAM HISTORY: S. Matwin and M. Missala, 1975: Polish Academy of Sciences Computer Centre, Pkin, Warsaw, Poland. Modified, Generalized, and Renamed by: A. B. Mickel and H. U. Rubenstein, 1977. University of Minnesota Computer Center, Minneapolis, MN 55455 USA. Published in Pascal News, No. 12., 1978 June. Overhauled for UCSD Pascal and interactive environment by: James L. Gagne, September, 1981. Datamed Research, Inc., 1433 Roscomare Road, Los Angeles, CA 90077 USA. JLG's changes from the PUG version are denoted with empty comment braces. Patched by George Schreyer, lines changed noted by gws Oct 1981 The names and organizations given here must not be deleted in any use of this program. (Note added 9/81: this program is not known to be copyright.) Internal documentation: Analyze reads two files. Inter2 (UCSD filename is fixed: "AUG.PROCNAMES") is the file containing the "module" (procedure/function) names which are used when the results are sorted and written out (up to 10 characters only). Timing (UCSD filename: "TIMING.DAT") is the file containing the execution trace of the program being monitored. Both files are expected to be on the default disk. Within ANALYZE, the procedure named processbody does the actual analysis by determining every time interval: time interval = time of exit - time of entry Gotoexits were handled specially in the PUG version. These features have been removed from the UCSD version, but for now special provisions for the EXIT procedure have not been installed. } PROGRAM Analyze; CONST AlfaLeng = 10; MaxNames = 1000; TicksPerSec = 60.0; {clock increments ("ticks") per second} PrinterName = '#8:'; {name of standard printer} TYPE Alfa = PACKED ARRAY [1..AlfaLeng] OF Char; TagRange = 0..MaxNames; Measurement = PACKED RECORD Tag: TagRange; Mark: (Entry, ExitP, GotoEntry); HiTime, LoTime: integer END; {} DblInt = RECORD Hi, Lo: integer END; Counter = RECORD Count, SubRtnCount: integer; Name: Alfa; {} TimeSpent: Real END; VAR MaxTag: TagRange; {} LastDot: char; {} JustOne, TotalCalls: DblInt; ch: char; TotalTime, StartingTime, FudgeFactor: real; TimeOverhead: real; {sec's req'd to write each timing datum} Modules: ARRAY [TagRange] OF Counter; Timing: FILE OF Measurement; {} OutFile: text; PROCEDURE Sort(min, max: tagrange); {Quicksort with bounded recursion depth, used to alphebatize module names. Requires min < max.} VAR low, high: integer; MidKey: Alfa; Temp: Counter; BEGIN REPEAT {pick split point} MidKey := Modules[(min + max) DIV 2].Name; low := min; high := max; REPEAT {partition} WHILE Modules[low].Name < MidKey DO low := low + 1; WHILE Modules[high].Name > MidKey DO high := high - 1; IF low <= high THEN BEGIN Temp := Modules[low]; Modules[low] := Modules[high]; Modules[high] := Temp; low := low + 1; high := high - 1 END UNTIL low > high; {recursively sort shorter sub-segment} IF high - min < max - low THEN BEGIN IF min < high THEN Sort(min,high); min := low END ELSE BEGIN IF low < max THEN Sort(low,max); max := high END UNTIL max <= min END; FUNCTION RealTime: Real; {convert time to real number} VAR Hi, Lo: integer; BEGIN WITH Timing^ DO IF Tag <= 0 THEN Realtime := 0 ELSE BEGIN Hi := HiTime*2; Lo := LoTime; IF Hi < 0 THEN Hi := Hi + 32767 + 1; {throw away sign bit if a carry} IF Lo < 0 THEN BEGIN Lo := Lo + 32767 + 1; Hi := Hi + 1 END; IF Hi < 0 THEN Hi := 0; RealTime := Lo + 32768.0 * Hi END END; PROCEDURE AddDblInt(VAR i1, i2: DblInt); {add i1 and i2; sum in i1} VAR Sum: DblInt; BEGIN WITH Sum DO BEGIN Hi := i1.Hi + i2.Hi; Lo := i1.Lo + i2.Lo; IF (i1.Hi > 0) AND (i2.Hi > 0) AND (Hi < 0) THEN Hi := Hi + 32767 + 1; IF (i1.Lo > 0) AND (i2.Lo > 0) AND (Lo < 0) THEN BEGIN Lo := Lo + 32765 + 3; Hi := Hi + 1 END END; i1 := Sum; END; PROCEDURE SubDblInt(VAR i1, i2: DblInt); {subtract i2 from i1; diffrnc in i1} VAR Diff: DblInt; BEGIN WITH Diff DO BEGIN Hi := i1.Hi - i2.Hi; Lo := i1.Lo - i2.Lo; IF (i1.Hi < 0) AND (i2.Hi < 0) AND (Hi > 0) THEN Hi := Hi + 32767 + 1; IF (i1.Lo < 0) AND (i2.Lo < 0) AND (Lo > 0) THEN BEGIN Lo := Lo + 32765 + 3; Hi := Hi - 1 END END; i1 := Diff END; PROCEDURE ProcessBody; {process timing file of dynamic measurements.} VAR ModuleTag: TagRange; NoGoto, SameModule: boolean; SubCnt: integer; {} Temp1, Temp2, ModulTime: Real; BEGIN ModuleTag := Timing^.Tag; ModulTime := 0.0; SubCnt := 0; Temp1 := RealTime + FudgeFactor; Get(Timing); WHILE (Timing^.Mark = entry) AND (Timing^.Tag > 0) AND NOT EOF(Timing) DO BEGIN {} Temp2 := RealTime; ModulTime := ModulTime + Temp2 - Temp1 - FudgeFactor; {} ProcessBody; Temp1 := RealTime; SubCnt := SubCnt + 1; {} NoGoto := Timing^.Mark <> GotoEntry; {} SameModule := Timing^.Tag = ModuleTag; {gws} {IF SameModule OR NoGoto THEN} Get(timing); END; {} Temp2 := RealTime; ModulTime := ModulTime + Temp2 - Temp1; {} AddDblInt(TotalCalls,JustOne); {} IF TotalCalls.Lo MOD 50 = 0 THEN Write('.'); {} IF TotalCalls.Lo MOD 2500 = 0 THEN Writeln; WITH Modules[ModuleTag] DO BEGIN Count := Count + 1; TimeSpent := TimeSpent + ModulTime; SubRtnCount := SubRtnCount + SubCnt; END END; PROCEDURE Initialize; {initialization placed here: JLG} VAR Tag: TagRange; i: integer; s: string; Inter2: FILE OF Alfa; BEGIN {} Writeln('Welcome to ANALYZE, the program timing analyzer.'); Writeln; {} Writeln( ' You should be using this program only after having run Pascal source'); {} Writeln( 'text through AUGMENT to add the time-keeping function, then compiled and run'); {} Writeln( 'the new program. The data files AUG.PROCNAMES and TIMING.DAT must both be'); {} Writeln( 'on the default disk, or the program will die.'); Writeln; {} Reset(Inter2, 'AUG.PROCNAMES'); Reset(Timing,'TIMING.DAT'); IF EOF(Timing) {} THEN BEGIN Writeln('*FATAL ERROR* timing file empty'); Exit(Program) END; {} Writeln( 'Please enter the destination of the timing analysis ( for printer):'); {} Write('--> ':12); Readln(s); {} WHILE POS(' ',s) > 0 DO DELETE(s,POS(' ',s),1); {} FOR i := 1 TO Length(s) DO {} IF s[i] IN ['a'..'z'] THEN s[i] := CHR(ORD(s[i]) + ORD('A') - ORD('a')); {} IF s = '' THEN s := PrinterName {} ELSE IF POS('.TEXT',s) = 0 THEN s := CONCAT(s,'.TEXT'); Rewrite(OutFile, s); Tag := 1; WHILE NOT EOF(Inter2) DO BEGIN WITH Modules[Tag] DO BEGIN Name := Inter2^; Get(Inter2); Count := 0; SubRtnCount := 0; TimeSpent := 0.0 END; Tag := Tag + 1 END; MaxTag := Tag - 1; {} Writeln (MaxTag,' module names found.'); {} Writeln( 'The timing process slows down actual program execution because of the'); {} Writeln('overhead required to record timing information.'); {} Writeln( 'Please enter the avg # of milliseconds overhead per timing datum: '); {} Readln(TimeOverhead); FudgeFactor := TimeOverhead * TicksPerSec / 1000.0; {} TotalCalls.Hi := 0; TotalCalls.Lo := 0; {} JustOne.Hi := 0; JustOne.Lo := 1; StartingTime := RealTime; {} Writeln('Reading timing data (one dot = 100 entries):'); Writeln; END; PROCEDURE PrintResults; {all output pulled into this procedure: JLG} { procedure overhauled 15 Nov 81} VAR Tag: TagRange; i, j: integer; TCalls, TSpent, PerCent, MSCnvt: Real; BEGIN Writeln(OutFile,' ':9,'Performance Measurement Summary for Pascal Program: ', Modules[1].Name); Writeln(Outfile, ' ':9, '(Assumes ', TimeOverhead:5:2, ' milliseconds of overhead per time measure)'); Writeln(OutFile); Writeln(OutFile,'execution time':69); Writeln(OutFile,'calls':31, '(msec)':40, '(sec)':9); Writeln(OutFile,'module':9, 'times':9, 'percent':11,'subroutine':14, 'average':12, 'module':10, 'percent':11); Writeln(OutFile,'name':8, 'called':11, 'of total':11, 'calls':11, 'per call':15, 'total':8, 'of total': 13); Writeln(OutFile,' ----------', '------':8, '--------':11,'------':11, '--------':15, '------':9, '--------':12); MSCnvt := 1000.0 / TicksPerSec; {millisec per 60hz clock tick} TCalls := 1.0 + TotalCalls.Lo - 1.0 + (32768.0 * TotalCalls.Hi); TotalTime := 0.0; FOR Tag := 1 TO MaxTag DO WITH Modules[Tag] DO IF Count > 0 THEN IF TimeSpent < 0.0 THEN TimeSpent := 0.0 ELSE TotalTime := TotalTime + TimeSpent; IF TotalCalls.Lo + TotalCalls.Hi = 0 THEN Writeln(Outfile,'Program did not execute; no timing data.') ELSE FOR Tag := 1 TO MaxTag DO WITH Modules[Tag] DO BEGIN PerCent := (Count / TCalls) * 100.0; Write(OutFile,Name:11, Count:8); IF Count = 0 THEN Writeln(Outfile,'-----':11, '-----':11, '-----':15, '-----':9, '-----':12) ELSE BEGIN Write(Outfile, PerCent:11:3, SubRtnCount:11); Write(OutFile,((TimeSpent/Count)*MSCnvt):15:2, TimeSpent/TicksPerSec:9:3); IF TotalTime = 0 THEN Writeln(OutFile,'-----':12) ELSE Writeln(OutFile,((TimeSpent / TotalTime) *100.0):12:3) END END; Writeln(OutFile,' ==========', '======':8, '========':11, '======':11, '========':15, '======':9, '========':12); Writeln(OutFile,'TOTALS':9, TCalls:10:1, '100.000':11, ((TotalTime/TCalls)*MSCnvt):26:2, TotalTime/TicksPerSec:9:3, '100.000':12) END; BEGIN {program} Initialize; ProcessBody; IF MaxTag > 1 THEN BEGIN Writeln(CHR(7)); Write('Do you want your report alphabetized by procedure name (Y/N)? '); REPEAT READ(ch) UNTIL (ch IN ['y','Y','n','N']); Writeln; IF (ch IN ['y','Y']) THEN Sort(1, MaxTag) END; PrintResults; Close(OutFile, LOCK); END. ======================================================================================== DOCUMENT :usus Folder:VOL12:startup.text ======================================================================================== (*$S+*) (*$C Copyright (c) 1982 Great Western Software all rights reserved*) (* This is a startup program which will run under version IV.0 only. It uses KERNEL to access SYSCOMREC where great and wonderous things can be done. KERNEL is distributed as KERNEL.CODE with the IV.0 system. The program allows you to set the date just like with the F(iler, preset the prefix (with the help of COMMANDIO) and displays a somewhat silly salutation message. The message is H-19 dependant as it uses the graphics character set of the H-19. Install this program as SYSTEM.STARTUP and you're in business. George Schreyer *) program put_date; uses kernel, commandio; const prompt_line = 21; type date_string = string [ 10 ]; var datex : daterec; x,y : integer; day_string, month_string, year_string : string; temp_date,date : string; iday, imonth, iyear : integer; k : integer; file_length: integer; dirx : directory; dum_buff : packed array [ 0..23 ] of char; {this array fills up 24 bytes of memory just above the allocation for dirx so that the blockread of exactly four blocks will not overwrite something important.} disk : file; done,quit : boolean; volid : string; procedure eeol; begin with syscom^ do begin if crtctrl.prefixed[2] then write ( crtinfo.prefix ); write ( crtctrl.eraseeol ); end; end; procedure eeos; begin with syscom^ do begin if crtctrl.prefixed[3] then write ( crtinfo.prefix ); write ( crtctrl.eraseeos ); end; end; procedure get_date (var date : daterec ); begin date := thedate; end; procedure p_date (date : daterec ); begin thedate := date; end; procedure int_to_str ( number : integer; var strg : string ); var ch : char; neg : boolean; i : integer; begin strg := '00000'; neg := false; if number < 0 then begin neg := true; number := number * ( -1 ); end; for i := 1 to 5 do begin ch := chr ( ( number mod 10 ) + ( ord ( '0' ) ) ); number := number div 10; strg [ 6 - i ] := ch; end; while pos( '0', strg ) = 1 do delete ( strg, 1, 1 ); if strg = '' then strg := '0' else if neg then strg := concat ( '-',strg ); end; procedure decode_date(day,month,year:integer); begin case month of 1: month_string:='Jan'; 2: month_string:='Feb'; 3: month_string:='Mar'; 4: month_string:='Apr'; 5: month_string:='May'; 6: month_string:='Jun'; 7: month_string:='Jul'; 8: month_string:='Aug'; 9: month_string:='Sep'; 10:month_string:='Oct'; 11:month_string:='Nov'; 12:month_string:='Dec' end; daystring := ''; yearstring := ''; int_to_str(day,daystring); int_to_str(year,yearstring); end; procedure str_to_int( var data : string; var number : integer; var was_integer: boolean); {converts input string to a positive integer} var i : integer; begin was_integer := true; number := 0; i := 0; if data <> '' then repeat i := i + 1; if data [i] in ['0'..'9'] then number := 10 * number + (ord(data[i]) - ord('0')) else was_integer := false; until ( not was_integer ) or ( i = length(data)) else was_integer := false; end; procedure check_month ( month_string : string; var month : integer ); var i : integer; begin month := 0; if length ( month_string ) > 0 then begin for i := 1 to length ( month_string ) do if month_string [ i ] in [ 'a'..'z' ] then month_string [ i ] := chr ( ord ( month_string [ i ] ) - 32 ); if month_string = 'JAN' then month := 1; if month_string = 'FEB' then month := 2; if month_string = 'MAR' then month := 3; if month_string = 'APR' then month := 4; if month_string = 'MAY' then month := 5; if month_string = 'JUN' then month := 6; if month_string = 'JUL' then month := 7; if month_string = 'AUG' then month := 8; if month_string = 'SEP' then month := 9; if month_string = 'OCT' then month := 10; if month_string = 'NOV' then month := 11; if month_string = 'DEC' then month := 12; end; end; procedure space_wait; var ch : char; begin write ( ' to continue ' ); repeat read ( keyboard, ch ); until ( ch = ' ' ) and ( not eoln ( keyboard ) ); gotoxy ( 0, prompt_line + 1 ); eeol; end; function take_apart_date ( var date : date_string; var day : integer; var month : integer; var year : integer ): boolean; var i : integer; day_ok, month_ok, year_ok : boolean; temp : string [ 1 ]; begin year_ok := true; day_ok := true; monthok := true; take_apart_date := true; day_string := ''; month_string := ''; year_string := ''; temp := ' '; i := 1; repeat temp [ 1 ] := date [ i ]; if i in [ 1, 2 ] then begin if ( i = 2 ) and ( not ( ord ( temp [ 1 ] ) in [ ord ( '0' )..ord ( '9' ) ] ) ) then begin day_string := concat ( '0', day_string ); date := concat ( '0', date ); end else day_string := concat ( day_string, temp ); end; if i in [ 4, 5, 6 ] then month_string := concat ( month_string , temp ); if i in [ 8, 9, 10 ] then year_string := concat ( year_string, temp ); i := succ ( i ); until i > length ( date ); if length ( day_string ) > 0 then str_to_int ( day_string, day, day_ok ); if ( day_ok ) and ( day in [ 1..31 ] ) then begin if length ( month_string ) > 0 then check_month ( month_string, month ); if month in [ 1..12 ] then begin if length ( year_string ) > 0 then str_to_int ( year_string, year, year_ok ); if ( not ( year in [ 0..99 ] ) ) or ( not year_ok ) then begin write ( 'year invalid ' ); space_wait; take_apart_date := false; date := ''; year := 100; end; end else begin write ( ' month invalid ' ); space_wait; take_apart_date := false; date := ''; month := 0; end; end else begin write ( 'day invalid ' ); space_wait; take_apart_date := false; date := ''; day := 0; end; end; procedure banner; {just a silly message using H-19 graphics, delete this whole procedure or write your own if you don't have an H-19} PROCEDURE FINISH; BEGIN GOTOXY( x + 16, y + 3 ); WRITE('W e l c o m e'); GOTOXY( x + 21, y + 5 ); WRITE('t o'); GOTOXY( x + 10, y + 7 ); WRITE('George''s Computer Center'); GOTOXY( x , y + 12 ); WRITE('UCSD Pascal p-system version IV.01 presiding'); END; procedure write_a ( x, y, n : integer ); var j : integer; begin gotoxy ( x, y ); for j := 1 to n do write ( 'a' ); end; procedure write_bar ( x, y, n : integer ); var j : integer; begin gotoxy ( x, y ); for j := 1 to n do begin write ( chr ( 96 ), chr ( 10 ), chr ( 8 ) ); end; end; BEGIN WRITELN(CHR(27),'t'); {sets keypad shifted mode} WRITELN(CHR(27),'x5'); WRITELN(CHR(27),'F'); x := 17; y := 3; gotoxy ( x, y ); write ( 'f' ); write_a ( x + 1, y, 42 ); write ( 'c' ); gotoxy ( x + 2, y + 1 ); write ( 'f' ); write_a ( x + 3, y + 1, 38 ); write ( 'c' ); write_a ( x + 1, y + 10, 42 ); write ( 'd' ); write_a ( x + 3, y + 9, 38 ); write ( 'd' ); write_bar ( x, y + 1, 9 ); write ( 'e' ); write_bar ( x + 2, y + 2, 7 ); write ( 'e' ); write_bar ( x + 43, y + 1, 9 ); write_bar ( x + 41, y + 2, 7 ); WRITE(CHR(27),'G'); FINISH; WRITE(CHR(27),'y5'); volid := '#5'; done := redirect ( concat ( 'P=',volid ) ); gotoxy ( x + 15 , y + 14 ); write ( 'Prefix is ', volid, ':' ); END; procedure write_date_to_disk; begin reset ( disk, '*' ); k := blockread ( disk, dirx, 4, 2 ); dirx[0].dlastboot := datex; k := blockwrite ( disk, dirx, 4, 2 ); close ( disk, lock ); end; begin gotoxy ( 0, 0 ); eeos; banner; quit := false; file_length := 0; get_date ( datex ); with datex do begin iday := day; imonth := month; iyear := year; decode_date ( iday, imonth, iyear ); end; date := concat ( day_string, '-', month_string, '-', year_string ); if pos ( '-', date ) = 2 then date := concat ( '0', date ); with datex do begin if not take_apart_date ( date, iday, imonth, iyear ) then begin write ( 'date in memory invalid' ); exit ( program ); end; gotoxy ( 0,prompt_line -1 ); writeln ( 'Today is ', date ); write ( imonth, ' ', iday, ' ', iyear ); repeat gotoxy ( 0, prompt_line ); eeol; write ( 'New date ? ' ); readln ( temp_date ); if length ( temp_date ) = 0 then exit ( program ); if take_apart_date ( temp_date, iday, imonth, iyear ) then begin day := iday; month := imonth; year := iyear; p_date ( datex ); quit := true; write_date_to_disk; end; until quit; end; end. ======================================================================================== DOCUMENT :usus Folder:VOL12:vol12.doc.text ======================================================================================== Volume 12 of the USUS Library Contributions from the UK and some other stuff A lot of these programs require version IV.0 or timer support WINDOWS.TEXT 20 A screen window unit. Slow but nice. Needs IV.0. W.SEGS.TEXT 28 an include file W.IO.TEXT 20 ditto W.IMPLN.TEXT 32 ditto WFILER.TEXT 26 A demonstration program for WINDOWS. Acts like the Filer W.DOC.TEXT 22 Documentation for WINDOWS. OFFLOAD.TEXT 24 A command line interpreter which replaces the USCD c command prompt. Needs IV.0 OFF.INFO.TEXT 4 an include file for OFFLOAD OFF.START.TEXT 8 ditto OFF.READ.TEXT 8 instructions for using OFFLOAD OFF.DOC.TEXT 26 Documentation for OFFLOAD HELP.DISK.TEXT 4 A help file for OFFLOAD HELP.KEYS.TEXT 4 ditto HELP.OFF.TEXT 4 ditto HELP.UTIL.TEXT 6 ditto NEW.PAGE.TEXT 4 A data file for OFFLOAD NEW.TEXT 4 ditto PARAM.INFO.TEXT 4 ditto MAKE.PAGE.TEXT 4 A utility for OFFLOAD PRINT.MEM.TEXT 4 Part of the benchmarks. Displays memory available. PRINT.HEAP.TEXT 6 Analyzes heap usage. Needs IV.0 and timer support. BENCH.USUS.TEXT 22 Jon Bondy's benchmark with some added goodies. BENCH.PCW.TEXT 12 Personal Computer World benchmark. Needs timer support. BENCH.SWAP.TEXT 4 Segment swap benchmark. Needs IV.0 and timer support. BENCH.BYTE.TEXT 6 The infamous Byte benchmark CPROC.TEXT 16 Another command line interpreter. Needs IV.0 CONTENTS.TEXT 10 More info about the stuff from the UK VOLS.SMAC 4 Data for CPROC STARTUP.TEXT 20 A startup program which sets the prefix and date. AUGMENT.TEXT 42 A program which adds timing info to a Pascal source file so that timing data can be obtained. ANALYZE.TEXT 24 Analyzes the results of AUGMENT. Needs timer support. R.ANALYZE.TEXT 24 Ditto except uses reals. DISK_COPY.TEXT 8 A disk copy and verification program. LMFORMAT.TEXT 18 A simple Pascal source formatter. VOL12.DOC.TEXT 8 You're reading it. 35/35 files, 492 blocks used, 2 unused, 2 in largest Please transfer the text below to a disk label if you copy this volume. USUS Volume 12 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Some notes from the editor: The WINDOW unit Austin Tate of USUS(UK) sent us this window manager unit. It is well documented and it works pretty well if not a little slowly. The demo program which (sort of) acts like the F(iler has a few problems, but it gets the point across. You MUST have version IV.0 for this stuff to work. OFFLOAD Many business systems don't need the UCSD command prompt (after all, how much A(ssembling does a retailer do anyway?). OFFLOAD shows how the standard prompt can be supressed and replaced by custom command prompts which do more closely what is necessary in a given application. I found the documentation on how to set up some of the cryptic data files somewhat lacking, but I got most of it to work. BENCHMARKS There are copies of some benchmark programs on this disk. It would be nice if we could collect data taken from many systems to see how well each works, but alas, even the benchmarks are not standardized. The infamous Byte benchmark is so prone to "tuning" that its data is almost meaningless. This version has range checking disabled. Some of the other benchmarks require IV.0 or timer support so that many systems cannot run them. The "USUS" benchmark (by Jon Bondy) has been augmented with several new tests and requires only a stopwatch. AUGMENT and ANALYZE These programs allow you to which part of your program is taking so much time, as if you didn't know already. AUGMENT processes your source and inserts instructions at the beginning and end of each procedure to cause your program to time itself. ANALYZE then processes the timing information and displays a report of how many times each procedure was accessed and how long it took. You need timer support. The program has been extensively hacked by myself and Jim Gagne and still doesn't support units but at least now it handles (ugh) GOTO's and EXIT's and include files. To get valid timing data you may find it necessary to separate user interface and data crunching into separate routines, which you really should do anyway. DISK_COPY I copy USUS disks with this program and it hasn't failed me yet. It reads a buffer full and then writes the buffer to disk. It then re-reads the destination disk to see if the data is correct. It won't correct for a bad master disk unless there is a CRC error nor will it discover some occurances of bad memory but it catches almost all of the typical problems (new disks are getting worse and worse, even "good" brands will have bad blocks right out of the box). CPROC I couldn't get this to work, it immediatly crashes my system (trap to location 4 on an LSI-11/23) when it is executed, but I suspect my IV.0 system as it has a tendency to crash. STARTUP This is a startup program which allows the prefix and date to be set. It is IV.0 specific. There is a II.0 version on volume 13. LMFORMAT This program processes a Pascal source file and translates everything to lower case EXCEPT reserved words. It makes things look a little nicer. regards - george schreyer ======================================================================================== DOCUMENT :usus Folder:VOL12:vols.smac ======================================================================================== fv ======================================================================================== DOCUMENT :usus Folder:VOL12:w.doc.text ======================================================================================== This document describes an early version of the Window Manager and Window Filer (March 1981). At the end is a note of the Window Functions available in the most recent version (February 1982). __________________________________________________________________________ A note by the reviewer: The window manager unit uses SEGMENT procedures WITHIN a UNIT which is forbidden in UCSD version II.0. You MUST use version IV.0 or another version which allows this construct to even compile the window manager. A UNIT, ScreenOps, is used by the window manager. Your version IV.0 system came with a file, ScreenOps.code, which you should install in your SYSTEM.LIBRARY before WINDOWS is compiled. - gws __________________________________________________________________________ ~A Window Manager for the UCSD p-System~ Austin Tate Microcomputer Support Unit Edinburgh Regional Computing Centre 1. ~Introduction~ There has been a great deal of interest recently in the use of computer displays which allow a screen to be divided into a number of separate areas or 'windows' such as are used in the Xerox environment (Alto, 1979). Examples of software environments based on the Alto using windows include Smalltalk (a summary of several environments is given in Goldberg, 1979) and the Lisp Programmer's Assistant (Teitelman, 1977). In these systems, separate windows are often 'attached' to separate, possibly concurrent, processes. As part of the development of course materials for a series of seminars on Electronic Office Systems, the author has developed a demonstration Window Manager package for the portable UCSD p-System for microcomputers (Softech). Although the hardware on which this system is being used is too slow for this software to be used in a production environment it does provide a realistic demonstration of the types of facilities we can expect to be available on future personal computers. For example, the Three Rivers Computer Corporation's 'PERQ' computer (Three Rivers) includes a 'Raster Op' microcoded instruction to facilitate various windows on the screen. The window manager package has been used in a demonstration program which provides some of the facilities of the UCSD Filer utility. 2. ~Structure of the Package~ The Window Manager is written as a UCSD Pascal Unit. A Unit provides a publically available set of constants, variables, procedures, etc. and gives implementation details of how these 'interfaces' are provided. The listing of the window manager interface section is provided in Appendix I. The structure of the implementation relies heavily on an internal data structure for individual windows not visible to the user. This includes the following items: a) position of top left corner of window in screen coordinates b) size of window in horizontal and vertical directions c) position of current input or output portion in the window in window coordinates (i.e. position of ~this~ windows' cursor). d) a data structure for lines of text in the window. These are allocated from a heap of lines. e) a list structure pointer to show order in which windows were displayed to ensure they currectly overlap if moved, killed, etc. f) flags to show various characteristics of the window. E.g. if horizontal scrolling is allowed, whether the window has a 'heading' line, etc. Given this data structure and a carefully chosen interface, the package itself is straightforward to write. The actual implementation and testing took less than 40 man/hours. The Window Manager is about 1000 lines of commented Pascal code. It is straightforward to build the implementation gradually providing the more estoteric procedures later. 3. ~Window Frames~ Due to the different capabilities of video displays, it was found desirable to write the Window Manager in such a way that window frames were handled in a separately implemented Unit. The interface section for this FRAMES unit is provided in Appendix II. A straightforward, but rather unimpressive looking, character framing capability is possible on normal character displays. However, where graphics facilities can be used, e.g. on the Terak 8510a microcomputer (Terak), these can be exploited to provide quite impressive looking frames and header backgrounds. The Terak frames package was generated in a few hours by Ken Currie of ERCC. The frame unit for the Terak is approximately 120 lines of commented Pascal code. 4. ~The 'Window' Filer~ The Window Filer is a demonstration utility which provides a subset of the facilities available in the UCSD p-System Filer component. It employs the window manager package for all input and output. It was generated in a few hours by adding simple window initialisation code and altering the (already localised) input and output instruction in on existing program which provided the subset of UCSD filer facilities. There are facilities to view the volumes on-line or the directories of floppy disk volumes in brief or detailed forms, to remove files from disk, to create text files on disk, to view the system date, etc. Displays are created in separate areas of the screen known as 'windows'. The window filer is entered by X(executing) WFILER at the UCSD command (outer) level. Several standard windows will appear. A 'message' window at the top of the screen where prompts to a user will normally appear, a list of commands and a 'typescript' window in which user input is normally solicited. There is a 'window cursor' (@ sign) on the screen (initially in the centre of the screen. The system expects a single character command as detailed in the commands list (e.g. "V" to get a list of volumes on-line). At any time, the four cursor control (arrowed) keyed can be used to move the window cursor to a new position. In addition, CTRL/0 (for "Over") can be used to bring the window area in which the window cursor currently resides into full view. Windows may be M(oved) and K(illed) within WFILER. The use of screen windows to simulate moving sheets of paper on a desk to access information needed for some work can be shown by using a (create file) function. While input is being typed to a file, the window manager can be directed to bring windows of interest on top. 5. ~Availability~ The window manager unit is not considered to be a potential tool at present. However, for demonstration purposes it is being submitted to the UCSD p-System Users Society Software Library. If it passes the relevant review procedure it will subsequently become available to members of USUS. 6. ~References~ Alto Thacker, C.P., McGeight, E.M., Lampson, B.W., Sproull, R.F. and Boggs, D.R. (1979) Alto: a personal computer. In Siewiorek, D., Bell, C.G., and Newell, A., Computer Structures, Readings and Examples. Second Edition, McGraw-Hill. Goldberg Goldberg, A. (1979) Educational uses of a Dynabook. Computers and Education Vol.8 pp 247-266. Softech UCSD p-System User's Manual. Softech Microsystems Inc. 9494, Black Mountain Road, San Diego, California 92126. Teitelman Teitelman, W. (1977) A display oriented programmer's assistant. Proceedings of the 5th International Joint Conference on Artificial Intelligence, pp 905-915. Terak Terak 8510/a brochure. Terak Corporation, 14151, North 76th Street, Scottsdale, Arizona 85260. Three Rivers PERQ brochure. Three Rivers Computer Corporation. 160, North Craig Street, Pittsburg, Pennsylvania 15213. Current Release - Window Manager Functions ------------------------------------------ Enter Window Manager Mode using ESC. In this mode you can type: ESC or to leave this Mode or to make a 'mark' move cursor 1..9 move cursor over screen S(how window under cursor K(ill window under cursor H(ide window under cursor M(ove window under cursor to 'mark' A(lter window under cursor to fit within next two 'marks' ? give this help window ======================================================================================== DOCUMENT :usus Folder:VOL12:w.impln.text ======================================================================================== {w.impln - Implementation part of Window Manager} {Copyright 22-Feb-82 Austin Tate, ERCC} USES SCREENOPS; CONST CONSOLE=1; SYSTERM=2; MaxLine=72; {<<<<< reduce this if you have stack overflow problems} ScreenWidth=78; XScreenWidth=79; ScreenHeight=24; Bel=7; Bs=8; Cr=13; {for bottom corners, if quote slopes on your VDU,} {a reasonable alternative is + } TLChr='.';TRChr='.';BLChr='''';BRChr=''''; TEChr='_';REChr='|';LEChr='|';BEChr='-'; TYPE ScreenPos=0..255; LineId=0..MaxLine; {all cursor values have a base of 0} WFormat=PACKED RECORD CurrY,CurrX:ScreenPos; {cursor position for this window} {scroll when CurrY is incremented to SizeY} {Cursor sits at position of NEXT ch output} {to the window will be written} SizeY,SizeX:ScreenPos; {Size of window - 1 to N} StartLine:LineId; {index to first line of text in window} {window always has 1 line minimum, 2 if headed} AtX,AtY:ScreenPos; {top left corner of window} CurrPan,OldPan:ScreenPos;{amount window 'panned' by} OldSizeY,OldSizeX, OldAtY,OldAtX:ScreenPos; Cleared:BOOLEAN; Options:WindowAttributes;{what user can do, does it have a heading} OldPrevWindow, PrevWindow:Window; {index to window array to give the previous} {window in show order - NoWindow at end} {Also used prechained to hold free window list} END; LINEREC=RECORD Contents:STRING[ScreenWidth]; NextLine:LineId; END; VAR OldXMin,OldXMax, CurrLine, OldWSequence, WSequence:INTEGER; {Start of list of shown windows - last shown at head} {NoWindow at end} FreeLine,FreeWindow:INTEGER; {Free lists - 0 at end of line list} { NoWindow at end of window list} WX,WY:INTEGER; {Current Window Manager Cursor Coords - screen coord} RealX,RealY:INTEGER;{Actual Cursor Position - -ve implies not known} WCursPlaced:BOOLEAN;{true if window cursor is on the screen} ScreenValid:BOOLEAN;{true if no Hides or Shows since last RePaint} WCursor:CHAR; {window manager cursor character} SCursBuff:CHAR; {Character underneath the Window Cursor position} SCursIn:Window; {Window in which cursor currently resides} Windows:ARRAY [1..MaxWindow] OF WFormat; Lines:ARRAY[1..MaxLine] OF LineRec; ClearLine:STRING[ScreenWidth]; {line containing spaces for clearances,etc} {all forward declarations needed for Window Manager} PROCEDURE SaveSequence; FORWARD; PROCEDURE PlaceCursor; FORWARD; PROCEDURE RemoveCursor; FORWARD; PROCEDURE FGOTOXY(X,Y:INTEGER); FORWARD; {$I w.segs} {end of SEGMENT PROCEDURES} PROCEDURE SaveSequence; VAR WTemp:Window; BEGIN WTemp:=WSequence; OldWsequence:=WSequence; WHILE (WTemp<>NoWindow) DO BEGIN WITH Windows[WTemp] DO BEGIN OldAtX:=AtX; OldAtY:=AtY; OldSizeX:=SizeX; OldSizeY:=SizeY; OldPan:=CurrPan; OldPrevWindow:=PrevWindow; Cleared:=FALSE; WTemp:=Windows[WTemp].PrevWindow; END; END; END; PROCEDURE WStartUp; BEGIN WMStartUp; END; PROCEDURE WInit; BEGIN WMInit; END; FUNCTION WNew{(WatX,WatY,WSizeX,WSizeY:INTEGER; WControls:WindowAttributes; WHeading:STRING):Window}; {Get new window} VAR W:Window; Offset,Top,i:INTEGER; BEGIN IF (FreeWindow=NoWindow) OR (FreeLine=0) OR ((HasHeading IN WControls) AND (WSizeY=1)) OR (WSizeY<1) OR (WSizeX<1) OR (WatY<0) OR (WatY>=ScreenHeight) OR (WatX<0) OR (WatX>=ScreenWidth) THEN WNew:=NoWindow ELSE BEGIN W:=FreeWindow; FreeWindow:=Windows[FreeWindow].PrevWindow; WITH Windows[W] DO BEGIN IF WSizeX>ScreenWidth THEN SizeX:=ScreenWidth ELSE SizeX:=WSizeX; IF WSizeY>ScreenHeight THEN SizeY:=ScreenHeight ELSE SizeY:=WSizeY; AtX:=WatX; AtY:=WatY; {Move so whole window on screen if necessary} IF AtX+SizeX>ScreenWidth THEN AtX:=ScreenWidth-SizeX; IF AtY+SizeY>ScreenHeight THEN AtY:=ScreenHeight-SizeY; CurrX:=0; CurrY:=0; CurrPan:=0; PrevWindow:=NoWindow; {Get one blank line for initial text buffer} StartLine:=FreeLine; FreeLine:=Lines[FreeLine].NextLine; Lines[Startline].NextLine:=0; {end of chain} Lines[StartLine].Contents:=ClearLine; Options:=WControls-[HasHeading]; IF (HasHeading IN WControls) AND (WHeading<>'') AND (FreeLine<>0) AND (SizeY>1) THEN BEGIN Options:=Options+[HasHeading]; CurrY:=1; {Get line for Heading - chain on front of first text line} i:=FreeLine; FreeLine:=Lines[FreeLine].NextLine; Lines[i].NextLine:=StartLine; StartLine:=i; WITH Lines[StartLine] DO BEGIN Contents:=ClearLine; IF CanPan IN Options THEN Offset:=1 ELSE Offset:=0; Top:=LENGTH(WHeading); IF Top>(ScreenWidth-Offset) THEN Top:=ScreenWidth-Offset; FOR i:=1 TO Top DO Contents[Offset+i]:=WHeading[i]; END; END; END; WNew:=W; END; END; PROCEDURE AddToFree(LineNo:INTEGER); {restore to Free Line List all lines chained to LineNo} VAR Next,i:INTEGER; BEGIN Next:=LineNo; WHILE Next<>0 DO BEGIN i:=Lines[Next].NextLine; Lines[Next].NextLine:=FreeLine; FreeLine:=Next; Next:=i; END; END; FUNCTION InShow(W:Window):BOOLEAN; VAR WTemp:Window; Seen:BOOLEAN; BEGIN WTemp:=WSequence; Seen:=FALSE; WHILE (WTemp<>NoWindow) AND NOT Seen DO BEGIN Seen:=(WTemp=W); WTemp:=Windows[WTemp].PrevWindow; END; InShow:=Seen; END; PROCEDURE LinesClear(W:Window); VAR LineNo:INTEGER; BEGIN WITH Windows[W] DO BEGIN CurrX:=0; CurrPan:=0; IF HasHeading IN Options THEN BEGIN LineNo:=Lines[StartLine].NextLine; CurrY:=1; END ELSE BEGIN LineNo:=StartLine; CurrY:=0; END; WITH Lines[LineNo] DO BEGIN AddToFree(NextLine); NextLine:=0; {End of chain} Contents:=ClearLine; END; Cleared:=TRUE; END; END; PROCEDURE WAlter{(W:Window; WatX,WatY,WSizeX,WSizeY:INTEGER; WControls:WindowAttributes; WHeading:STRING)}; {Get new window} VAR Offset,Top,i:INTEGER; BEGIN {Window must not be in show when WAlter called} IF (W<>NoWindow) AND NOT InShow(W) THEN WITH Windows[W] DO BEGIN Options:=(Options*[HasHeading])+(WControls-[HasHeading]); IF (WSizeX>0) THEN SizeX:=WSizeX; IF (SizeX>ScreenWidth) THEN SizeX:=ScreenWidth; IF (WSizeY>0) THEN SizeY:=WSizeY; IF (SizeY>ScreenHeight) THEN SizeY:=ScreenHeight; IF (HasHeading IN Options) and (SizeY<2) THEN SizeY:=2; IF (WatX>=0) AND (WatX=0) AND (WatY=SizeX) THEN CurrX:=SizeX-1; {Zero pan position if possible} IF (CurrX=SizeY THEN BEGIN CurrY:=SizeY-1; IF CanScroll IN Options THEN LinesClear(W); END; IF (HasHeading IN Options) AND (HasHeading IN WControls) AND (WHeading<>'') THEN BEGIN WITH Lines[StartLine] DO BEGIN Contents:=ClearLine; {allow for Pan indicator on heading} IF CanPan IN Options THEN Offset:=1 ELSE Offset:=0; Top:=LENGTH(WHeading); IF Top>(ScreenWidth-Offset) THEN Top:=ScreenWidth-Offset; FOR i:=1 TO Top DO Contents[Offset+i]:=WHeading[i]; END; END; END; END; FUNCTION XYOverWindow(X,Y:INTEGER; W:Window):BOOLEAN; BEGIN IF W=NoWindow THEN XYOverWindow:=FALSE ELSE WITH Windows[W] DO BEGIN XYOverWindow:=((X>=AtX-1) AND (X<=AtX+SizeX) AND (Y>=AtY-1) AND (Y<=AtY+SizeY)); END; END; FUNCTION WInWindow{(X,Y:INTEGER):Window}; VAR W:Window; Found:BOOLEAN; BEGIN {returns window in which position X,Y occurs - NoWindow if none} {X,Y in screen coordinates} Found:=FALSE; W:=WSequence; {Start of show list} WHILE (W<>NoWindow) AND NOT Found DO BEGIN Found:=XYOverWindow(X,Y,W); IF NOT Found THEN W:=Windows[W].PrevWindow; END; WInWindow:=W; END; FUNCTION WChAtXY{(X,Y:INTEGER; W:Window):CHAR}; VAR LineNo,Xindex,i:INTEGER; BEGIN {return Ch under screen position X,Y in W} {space returned if X,Y not in Window, or NoWindow} {Ch need not be in view at the time of call} IF (W=NoWindow) OR NOT XYOverWindow(X,Y,W) THEN WChAtXY:=' ' ELSE WITH Windows[W] DO BEGIN IF Y=AtY-1 THEN BEGIN IF X=AtX-1 THEN WChAtXY:=TLChr ELSE IF X=AtX+SizeX THEN WChAtXY:=TRChr ELSE WChAtXY:=TEChr; END ELSE IF Y=AtY+SizeY THEN BEGIN IF X=AtX-1 THEN WChAtXY:=BLChr ELSE IF X=AtX+SizeX THEN WChAtXY:=BRChr ELSE WChAtXY:=BEChr; END ELSE IF X=AtX-1 THEN WChAtXY:=LEChr ELSE IF X=AtX+SizeX THEN WChAtXY:=REChr ELSE BEGIN i:=Y-AtY; IF i>=0 THEN LineNo:=StartLine ELSE LineNo:=0; WHILE (LineNo<>0) AND (i>0) DO BEGIN LineNo:=Lines[LineNo].NextLine; i:=i-1; END; IF LineNo=0 THEN WChAtXY:=' ' ELSE BEGIN IF (X<0) OR (X>(ScreenWidth-1)) OR (X=AtX+SizeX) THEN WChAtXY:=' ' ELSE IF (LineNo<>StartLine) OR NOT(HasHeading IN Options) OR NOT(CanPan IN Options) THEN WChAtXY:=Lines[LineNo].Contents[(X-AtX+CurrPan)+1] ELSE BEGIN IF (X=AtX) AND (CurrPan<>0) THEN {more to left} WChAtXY:='<' ELSE IF (X=AtX+SizeX-1) AND (CurrPan+SizeX(ScreenWidth-1) THEN WX:=ScreenWidth-1; IF Y<0 THEN WY:=0 ELSE WY:=Y; IF WY>(ScreenHeight-1) THEN WY:=ScreenHeight-1; END; PROCEDURE FGOTOXY{X,Y:INTEGER}; BEGIN {This is here to allow experimentation with asynchronous gotoxy's, without having to modify *SYSTEM.PASCAL} GOTOXY(X,Y); END; PROCEDURE WMGoToXY(X,Y:INTEGER); BEGIN IF (RealX<>X) OR (RealY<>Y) THEN BEGIN FGOTOXY(X,Y); RealX:=X; RealY:=Y; END; END; PROCEDURE RemoveCursor; BEGIN IF WCursPlaced THEN BEGIN {Replace position WX,WY on Screen by SCursBuff} WMGoToXY(WX,WY); WRITE(SCursBuff,CHR(Bs)); WCursPlaced:=FALSE; END; END; PROCEDURE PlaceCursor; VAR W:Window; BEGIN IF NOT WCursPlaced THEN BEGIN {Cursor was last in window SCursIn. It is likely it is still there} {Check if WX,WY are still in the same window range} SCursIn:=WInWindow(WX,WY); IF SCursIn=NoWindow THEN SCursBuff:=' ' ELSE SCursBuff:=WChAtXY(WX,WY,SCursIn); WMGoToXY(WX,WY); WRITE(WCursor,CHR(Bs)); WCursPlaced:=TRUE; END; END; PROCEDURE GetLine; {Get CurrY line of current window} VAR LineNo,i,nl:INTEGER; BEGIN IF WSequence=NoWindow THEN EXIT(GetLine); WITH Windows[WSequence] DO BEGIN LineNo:=Startline; i:=CurrY; OldXMin:=CurrX; OldXMax:=CurrX; END; WHILE i>0 DO BEGIN nl:=Lines[LineNo].NextLine; IF nl=0 THEN BEGIN {get a blank line to extend text} IF FreeLine=0 THEN BEGIN {Stay on last real line} nl:=LineNo; WITH Windows[WSequence] DO CurrY:=CurrY-i; i:=0; {to terminate loop} END ELSE BEGIN {new line really available} nl:=FreeLine; WITH Lines[nl] DO BEGIN Contents:=ClearLine; FreeLine:=NextLine; NextLine:=0; END; Lines[LineNo].NextLine:=nl; END; END; LineNo:=nl; i:=i-1; END; CurrLine:=LineNo; END; PROCEDURE FlushOutput; VAR RightX,LeftX,LineNo:INTEGER; BEGIN IF WSequence=NoWindow THEN EXIT(FlushOutput); WITH Windows[WSequence] DO BEGIN IF (OldXMin<>OldXMax) AND (OldXMax>=CurrPan) AND (OldXMin<=CurrPan+SizeX-1) THEN BEGIN LeftX:=OldXMin; RightX:=OldXMax; IF LeftX=SizeX THEN RightX:=SizeX+CurrPan; WMGoToXY(AtX+LeftX-CurrPan,AtY+CurrY); UNITWRITE(CONSOLE,Lines[CurrLine].Contents[LeftX+1], RightX-LeftX,,1); RealX:=AtX+RightX-CurrPan; OldXMin:=CurrX; OldXMax:=CurrX; END; END; END; PROCEDURE WDispose{(W:Window)}; {Dispose of old window} BEGIN {Window must not be in show when WDispose called} IF (W<>NoWindow) AND NOT InShow(W) THEN BEGIN IF NOT ScreenValid THEN RePaint; {Because info will be destroyed} AddToFree(Windows[W].StartLine); Windows[W].PrevWindow:=FreeWindow; FreeWindow:=W; END; END; FUNCTION Intersects(W1,W2:Window):BOOLEAN; {does W1 intersect with W2} VAR WatX,WatY,WSizeX,WSizeY:INTEGER; BEGIN WITH Windows[W1] DO BEGIN WatX:=AtX; WatY:=AtY; WSizeX:=SizeX; WSizeY:=SizeY; END; WITH Windows[W2] DO BEGIN Intersects:=(((AtX+SizeX)>=WatX) AND (AtX<(WAtX+WSizeX)) AND ((AtY+SizeY)>=WatY) AND (AtY<(WatY+WSizeY))); END; END; PROCEDURE WShow{(W:Window)}; {Display window and set it as "current" one} VAR LineNo,StartX,EndX,IndY,i:INTEGER; Seen,Obscured:BOOLEAN; WTemp:Window; BEGIN IF (WSequence=W) OR (W=NoWindow) THEN EXIT(WShow); FlushOutput; {If already on show remove from sequence list first} WTemp:=WSequence; Seen:=FALSE; Obscured:=FALSE; WHILE WTemp<>NoWindow DO BEGIN Obscured:=Obscured OR Intersects(W,WTemp); IF Windows[WTemp].PrevWindow=W THEN BEGIN Seen:=TRUE; Windows[WTemp].PrevWindow:=Windows[W].PrevWindow; WTemp:=NoWindow; {to escape from WHILE} END ELSE WTemp:=Windows[WTemp].PrevWindow; END; Windows[W].PrevWindow:=WSequence; WSequence:=W; {add to show list head} IF Obscured OR NOT Seen THEN ScreenValid:=FALSE; GetLine; {IF NOT ScreenValid THEN Repaint;} END; FUNCTION RemoveFromSeq(W:Window):BOOLEAN; Var WTemp:Window; Removed:BOOLEAN; BEGIN Removed:=FALSE; IF (W<>NoWindow) AND (W=WSequence) THEN BEGIN WSequence:=Windows[WSequence].PrevWindow; Removed:=TRUE; END ELSE BEGIN WTemp:=WSequence; WHILE (WTemp<>NoWindow) AND NOT Removed DO BEGIN IF Windows[WTemp].PrevWindow=W THEN BEGIN Windows[WTemp].PrevWindow:=Windows[W].PrevWindow; Removed:=TRUE; END ELSE WTemp:=Windows[WTemp].PrevWindow; END; END; RemoveFromSeq:=Removed; END; PROCEDURE WHide{(W:Window)}; {remove window from screen - it is not disposed of} VAR i:INTEGER; BEGIN FlushOutput; IF W<>NoWindow THEN IF RemoveFromSeq(W) THEN BEGIN IF SCursIn=W THEN SCursIn:=NoWindow; GetLine; ScreenValid:=FALSE; END; {IF NOT ScreenValid THEN Repaint;} END; PROCEDURE WClearAndShow{(W:Window)}; {Clear Window and "Show" it} BEGIN IF W=NoWindow THEN EXIT(WClearAndShow); FlushOutput; LinesClear(W); WShow(W); ScreenValid:=FALSE; GetLine; {IF NOT ScreenValid THEN Repaint;} END; PROCEDURE WClear; {clear "current" window} BEGIN WClearAndShow(WSequence); END; {$I w.io} ======================================================================================== DOCUMENT :usus Folder:VOL12:w.io.text ======================================================================================== {w.io - insert into implementation part of Window Manager} {Copyright 22-Feb-82 Austin Tate, ERCC} PROCEDURE WGotoXY{(X,Y:INTEGER)}; {Set Window cursor to X,Y} BEGIN {X,Y are relative to top left of window - base of 0} IF WSequence<>NoWindow THEN WITH Windows[WSequence] DO BEGIN IF HasHeading IN Options THEN Y:=Y+1; IF X<0 THEN CurrX:=0 ELSE IF X=ScreenWidth THEN CurrX:=ScreenWidth-1 ELSE CurrX:=X; ScreenValid:=FALSE; END ELSE CurrX:=SizeX-1; IF Y<>CurrY THEN BEGIN IF Y<0 THEN CurrY:=0 ELSE IF Y0) THEN BEGIN ScreenValid:=FALSE; CurrPan:=0; END; IF SizeY<2 THEN BEGIN {cannot have heading - so don't check for this} Lines[StartLine].Contents:=ClearLine; Cleared:=TRUE; ScreenValid:=FALSE; END ELSE BEGIN IF (CurrY+1)>=SizeY THEN BEGIN IF (CanScroll IN Options) AND (SizeY>1) THEN BEGIN {else overprint} FirstFree:=StartLine; IF HasHeading IN Options THEN FirstFree:=Lines[FirstFree].NextLine; LastFree:=FirstFree; Freed:=1; FOR i:= 2 TO SizeY DIV 3 DO BEGIN Freed:=Freed+1; LastFree:=Lines[LastFree].NextLine; END; IF HasHeading IN Options THEN Lines[StartLine].NextLine:=Lines[LastFree].NextLine ELSE StartLine:=Lines[LastFree].NextLine; Lines[LastFree].NextLine:=0; AddToFree(FirstFree); Cleared:=TRUE; ScreenValid:=FALSE; CurrY:=CurrY-Freed+1; GetLine; END; END ELSE IF FreeLine<>0 THEN BEGIN {free line - else overprint on bottom line} CurrY:=CurrY+1; CurrLine:=Lines[CurrLine].NextLine; IF CurrLine=0 THEN GetLine; {get a further line} END; END; END; IF NOT ScreenValid THEN RePaint; END; PROCEDURE WClrEOL; VAR LastNonSpace:INTEGER; BEGIN IF NOT ScreenValid THEN RePaint; IF WSequence<>NoWindow THEN BEGIN WITH Windows[WSequence],Lines[CurrLine] DO BEGIN IF CurrX' ', Contents[ScreenWidth]); IF LastNonSpace>CurrX THEN BEGIN FILLCHAR(Contents[CurrX+1],LastNonSpace-CurrX,' '); OldXMax:=LastNonSpace; END; END; END; END; PROCEDURE WWriteLn; BEGIN IF NOT ScreenValid THEN RePaint; IF WSequence<>NoWindow THEN BEGIN WScroll; WClrEOL; END; END; PROCEDURE WClrEOS; VAR X,Y,Line:INTEGER; BEGIN IF NOT ScreenValid THEN RePaint; IF WSequence<>NoWindow THEN BEGIN WITH Windows[WSequence] DO BEGIN X:=CurrX; Y:=CurrY; Line:=CurrLine; WClrEOL; WHILE CurrY0 THEN BEGIN {erase last ch} IF Contents[CurrX]<>' ' THEN BEGIN Contents[CurrX]:=' '; IF CurrX<=OldXMin THEN OldXMin:=CurrX-1; END; CurrX:=CurrX-1; END; END {Backspace} ELSE BEGIN {$R-} s[0]:=CHR(1); {$R^} s[1]:=Ch; WWriteStr(s); END; END; END; PROCEDURE WWriteStr{(Str:STRING)}; {write Str at cursor position in window} VAR i,j,Actual:INTEGER; Ch:CHAR; Continue:BOOLEAN; BEGIN IF WSequence=NoWindow THEN EXIT(WWriteStr); IF NOT ScreenValid THEN RePaint; WITH Windows[WSequence],Lines[CurrLine] DO BEGIN i:=1; j:=LENGTH(Str); IF CurrX+j>=ScreenWidth THEN j:=ScreenWidth-CurrX; Continue:=TRUE; WHILE (j>=1) AND Continue DO IF Contents[CurrX+j]=Str[j] THEN j:=j-1 ELSE Continue:=FALSE; Continue:=TRUE; WHILE (i<=j) AND Continue DO IF Contents[CurrX+i]=Str[i] THEN i:=i+1 ELSE Continue:=FALSE; IF OldXMin=OldXMax THEN BEGIN OldXMin:=CurrX+i-1; OldXMax:=OldXMin; END; Actual:=j-i+1; IF Actual>0 THEN BEGIN MOVELEFT(Str[i],Contents[CurrX+i],Actual); IF CurrX+j>=OldXMax THEN OldXMax:=CurrX+j; END; CurrX:=CurrX+LENGTH(Str); IF CurrX>=ScreenWidth THEN CurrX:=ScreenWidth-1; END; {WITH} END; PROCEDURE WWriteInt{(Int,Width:INTEGER)}; {write Int at cursor posn in window} VAR i,j:INTEGER; buff:STRING; BEGIN i:=10000; j:=1; {$R-} buff[0]:=CHR(80); {to avoid range check problems} {$R^} IF Int<0 THEN BEGIN Int:=-Int; IF Int<0 THEN BEGIN WWriteStr('-32768'); EXIT(WWriteInt); END; buff[j]:='-'; j:=j+1; Width:=Width-1; END; WHILE (Int DIV i=0) AND (i<>1) DO BEGIN Width:=Width+1; i:=i DIV 10; END; Width:=Width-5; WHILE Width>0 DO BEGIN buff[j]:=' '; j:=j+1; Width:=Width-1; END; REPEAT buff[j]:=(CHR(ORD('0')+Int DIV i)); j:=j+1; Int:=Int-(Int DIV i)*i; i:=i DIV 10; UNTIL i=0; {$R-} buff[0]:=CHR(j-1); {$R^} WWriteStr(buff); END; PROCEDURE WReadCh{(VAR Ch:CHAR: Echo:BOOLEAN)}; {get character from keyboard} VAR NewPan,X,Y:INTEGER; Key:PACKED ARRAY [0..1] OF CHAR; BEGIN {Window functions can only take place within WReadCh} {Echo is controlled by user - non printable chs echo as bell} {First ensure screen is valid} FlushOutput; IF NOT ScreenValid THEN RePaint; REPEAT {Set X,Y of cursor in current window} IF WSequence=NoWindow THEN BEGIN X:=WX; Y:=WY; {No Window on screen} END ELSE WITH Windows[WSequence] DO BEGIN IF CurrX>=ScreenWidth THEN CurrX:=ScreenWidth-1; IF CanPan IN Options THEN BEGIN NewPan:=CurrPan; WHILE CurrX=SizeX DO BEGIN IF SizeX<3 THEN NewPan:=NewPan+1 ELSE BEGIN NewPan:=NewPan+(SizeX DIV 3); IF NewPan+SizeX>ScreenWidth THEN NewPan:=ScreenWidth-SizeX; END; END; CurrPan:=NewPan; IF CurrPan<>OldPan THEN BEGIN ScreenValid:=FALSE; RePaint; END; X:=AtX+CurrX-CurrPan; END ELSE BEGIN IF CurrX>=SizeX THEN X:=(AtX+SizeX)-1 ELSE X:=AtX+CurrX; END; IF CurrY>=SizeY THEN Y:=(AtY+SizeY)-1 ELSE Y:=AtY+CurrY; END; WMGoToXY(X,Y); UNITREAD(SYSTERM,Key[0],1); Ch:=Key[0]; IF Ch=CHR(27) THEN WindowFunction; UNTIL Ch<>CHR(27); IF Echo THEN BEGIN IF ((ORD(Ch) MOD 128)>=ORD(' ')) OR (Ch=CHR(Bs)) THEN WWriteCh(Ch) ELSE BEGIN IF Ch=CHR(Cr) THEN WWriteLn ELSE WRITE(CHR(Bel)); {cannot handle other control codes} END; END; END; PROCEDURE WReadLnStr{(VAR Str:STRING)}; {get a string from keyboard - echoed} VAR STemp:STRING; Len:INTEGER; Ch:CHAR; BEGIN {string is ended by newline. Only edit ch allowed is backspace} {non printable chs are not returned - but echo as bell} (* 1 2 3 4 5*) (*12345678901234567890123456789012345678901234567890*) STR:=CONCAT(' ', ' '); {overlay onto a bed of spaces} Len:=0; REPEAT WReadCh(Ch,TRUE); IF (Ch=CHR(Bs)) AND (Len>0) THEN Len:=Len-1 ELSE BEGIN IF ((ORD(Ch) MOD 128)>=ORD(' ')) THEN BEGIN IF Len0); IF Ok THEN BEGIN Neg:=((Str[1]='-') AND (LENGTH(Str)>1)); IF Neg THEN k:=2 ELSE k:=1; FOR i:=k TO LENGTH(Str) DO BEGIN j:=ORD(Str[i])-ORD('0'); IF (j<0) OR (j>9) THEN Ok:=FALSE; IF Ok THEN Val:=Val*10+j; END; END; If Ok THEN BEGIN IF Neg THEN Val:=-Val; StrToInt:=Val; END ELSE StrToInt:=-MAXINT; END; PROCEDURE WReadLnInt{(VAR Int:INTEGER)}; {Get an integer from keyboard - echoed} VAR STemp:STRING; Ch:CHAR; BEGIN {integer is ended by newline. Only edit ch allowed is backspace} {non printable chs are not returned - but echo as bell} WReadLnStr(STemp); Int:=StrToInt(STemp); END; PROCEDURE WReadLn{(Echo:BOOLEAN)}; {Read up to next newline from keyboard} VAR Ch:CHAR; BEGIN {non printable chs echo as bell} REPEAT WReadCh(Ch,Echo) UNTIL Ch=CHR(Cr); END; FUNCTION WCurrentWindow{:Window}; {Returns current window - one last shown - may be NoWindow} BEGIN WCurrentWindow:=WSequence; END; ======================================================================================== DOCUMENT :usus Folder:VOL12:w.segs.text ======================================================================================== {w.segs - Segment procedures for Window Manager} {Copyright 22-Feb-82 Austin Tate, ERCC} SEGMENT PROCEDURE WMStartup; {Initialise Window Manager System} VAR i:INTEGER; BEGIN Sc_Clr_Screen; WCursor:=CHR(64); {At symbol} {Symbol for Window Manager Cursor} FOR i:=1 TO (MaxLine-1) DO Lines[i].NextLine:=i+1; Lines[MaxLine].NextLine:=0; FreeLine:=1; FOR i:=1 TO (MaxWindow-1) DO Windows[i].PrevWindow:=i+1; Windows[MaxWindow].PrevWindow:=NoWindow; FreeWindow:=1; {$R-} ClearLine[0]:=CHR(ScreenWidth); {$R^} FOR i:=1 TO ScreenWidth DO ClearLine[i]:=' '; WSequence:=NoWindow; OldWSequence:=NoWindow; SCursBuff:=' '; SCursIn:=NoWindow; WX:=0; WY:=0; RealX:=-1; RealY:=-1; WCursPlaced:=FALSE; ScreenValid:=FALSE; END; SEGMENT PROCEDURE WMInit; BEGIN Sc_Clr_Screen; OldWSequence:=NoWindow; ScreenValid:=FALSE; END; SEGMENT PROCEDURE RePaint; VAR LineNo,FirstChanged,LastChanged, LastNonSpace,OldLastNonSpace,X,Y:INTEGER; WTemp,LastObscured,OldLastObscured:Window; ClearX,ClearY,ClearTo:INTEGER; OkToClear,PartialClear:BOOLEAN; RevSequence,OldRevSequence:ARRAY [0..MaxWindow] OF Window; NextWLine,OldNextWLine:ARRAY [0..MaxWindow] OF INTEGER; OldBuff,Buff,IOBuff:PACKED ARRAY [-1..XScreenWidth] OF CHAR; BEGIN IF ScreenValid THEN EXIT(RePaint); {Nothing to do} RemoveCursor; {We are going to reconstruct 'before' and 'after' images of the screen line by line. Each window will place its contribution to a composite screen line in a screen line buffer. This is done in reverse show order to get overlapping right.} {First build two access vectors for the windows, containing 'show' sequences} LastObscured:=0; OldLastObscured:=0; WTemp:=WSequence; WHILE WTemp<>NoWindow DO BEGIN RevSequence[LastObscured]:=WTemp; LastObscured:=LastObscured+1; WTemp:=Windows[WTemp].PrevWindow; END; WTemp:=OldWSequence; WHILE WTemp<>NoWindow DO BEGIN OldRevSequence[OldLastObscured]:=WTemp; OldLastObscured:=OldLastObscured+1; WTemp:=Windows[WTemp].OldPrevWindow; END; {Build screen lines 'before' and 'after', and compute I/O need to make the screen change from 'before' to after'} OkToClear:=FALSE; FOR Y:=0 TO ScreenHeight-1 DO BEGIN FILLCHAR(Buff[-1],XScreenWidth+2,' '); {Each window, in reverse show sequence, places its contribution into the composite line buffer} FOR X:=LastObscured-1 DOWNTO 0 DO BEGIN WITH Windows[RevSequence[X]] DO BEGIN IF (Y>=AtY) AND (Y<(AtY+SizeY)) THEN BEGIN {It has somthing to give} IF Y=AtY THEN LineNo:=StartLine ELSE LineNo:=NextWLine[X]; IF LineNo<>0 THEN BEGIN NextWLine[X]:=Lines[LineNo].NextLine; {Get window's contibution to this line} IF (LineNo=StartLine) AND (HasHeading IN Options) THEN BEGIN {Don't pan title lines} MOVELEFT(Lines[LineNo].Contents[1],Buff[AtX],SizeX); {Put pan indicators on title line if there is one} IF (CanPan IN Options) THEN BEGIN IF CurrPan<>0 THEN Buff[Atx]:='<'; IF (CurrPan+SizeX)=OldAtY) AND (Y<(OldAtY+OldSizeY)) THEN BEGIN IF Y=OldAtY THEN LineNo:=StartLine ELSE LineNo:=OldNextWLine[X]; IF LineNo<>0 THEN OldNextWLine[X]:=Lines[LineNo].NextLine; {When a window has been cleared then we forget what was on the screen before the clear took place - see more below} IF Cleared AND NOT((HasHeading IN Options) AND (Y=OldAtY)) THEN LineNo:=0; IF LineNo<>0 THEN BEGIN IF (LineNo=StartLine) AND (HasHeading IN Options) THEN BEGIN MOVELEFT(Lines[LineNo].Contents[1],OldBuff[OldAtX],OldSizeX); IF (CanPan IN Options) THEN BEGIN IF OldPan<>0 THEN OldBuff[OldAtx]:='<'; IF (OldPan+OldSizeX)' ',Buff[ScreenWidth-1]); IF Buff<>OldBuff THEN BEGIN {Screen must change} IF LastNonSpace>=0 THEN BEGIN {Non-blank line which was not blank before} FirstChanged:=0; LastChanged:=LastNonSpace; WHILE ((FirstChangedFirstChanged) AND (Buff[LastChanged]=OldBuff[LastChanged])) DO LastChanged:=LastChanged-1; {Catch up on deferred line clearing} IF OkToClear THEN FOR X:=ClearY TO ClearTo DO BEGIN Sc_Erase_To_Eol(ClearX,X); ClearX:=0; END; OkToClear:=FALSE; PartialClear:=FALSE; {Blat the screen, asynchronously} FGOTOXY(FirstChanged,Y); {**ALSO ENSURES THAT NEXT ASSIGN IS OK**} IOBuff:=Buff; UNITWRITE(CONSOLE,IOBuff[FirstChanged], LastChanged-FirstChanged+1,,1); {Check if a clear to EOL is needed, but don't do it now} OldLastNonSpace:=ScreenWidth-1 +SCAN(-(ScreenWidth),<>' ',OldBuff[ScreenWidth-1]); IF LastNonSpace=0 THEN BEGIN {Unchanged non-blank line} {If there are any deferred clears do them now} IF OkToClear THEN BEGIN FOR X:=ClearY TO ClearTo DO BEGIN Sc_Erase_To_Eol(ClearX,X); ClearX:=0; END; OkToClear:=FALSE; PartialClear:=FALSE; END END ELSE BEGIN {Unchanged blank line} {Try to avoid doing a clear to EOL for this line} IF OkToClear THEN IF NOT PartialClear THEN BEGIN PartialClear:=TRUE; ClearTo:=Y-1; END END END; END; IF OkToClear THEN Sc_Eras_Eos(ClearX,ClearY); {Save info need to compute before image on next call} SaveSequence; ScreenValid:=TRUE; RealX:=-1; RealY:=-1; END; SEGMENT PROCEDURE WHelp; VAR WTop,WPopup:Window; BEGIN WTop:=WSequence; WPopup:=WNew(WX,WY,36,15,[CanMove,CanKill,CanAlter],''); IF WPopup=NoWindow THEN WRITE(CHR(Bel)) ELSE BEGIN WShow(WPopup); WWriteStr('Help - Window Manager Revn '); WWriteStr(WVersion); WWriteLn; WWriteStr('------------------------------------'); WWriteLn; WWriteStr('Enter Window Manager Mode using ESC.'); WWriteLn; WWriteStr(' In this mode you can type:'); WWriteLn; WWriteStr('ESC or to leave this Mode or'); WWriteLn; WWriteStr(' to make a ''mark'''); WWriteLn; WWriteStr(' move cursor'); WWriteLn; WWriteStr('1..9 move cursor over screen'); WWriteLn; WWriteStr('S(how window under cursor'); WWriteLn; WWriteStr('K(ill window under cursor'); WWriteLn; WWriteStr('H(ide window under cursor'); WWriteLn; WWriteStr('M(ove window under cursor to ''mark'''); WWriteLn; WWriteStr('A(lter window under cursor to fit'); WWriteLn; WWriteStr(' within next two ''marks'''); WWriteLn; WWriteStr('? give this help window'); WShow(WTop); END; END; SEGMENT PROCEDURE WindowFunction; VAR WTemp,WTop:Window; WF:sc_key_command; Ch:CHAR; Temp,X1,Y1,X2,Y2:INTEGER; Key:PACKED ARRAY [0..1] OF CHAR; PROCEDURE ZoneMove(Y,X,ZY,ZX:INTEGER); BEGIN WX:=(ScreenWidth DIV (ZX*2))*((2*(X-1))+1); WY:=(ScreenHeight DIV (ZY*2))*((2*(Y-1))+1); END; BEGIN PlaceCursor; UNITREAD(SYSTERM,Key[0],1); Ch:=Key[0]; { (known as 'MARK') or ESC cause an exit from WindowFunction} WHILE (Ch<>' ') AND (Ch<>CHR(27)) DO BEGIN WF:=sc_map_crt_command(Ch); RemoveCursor; CASE WF OF sc_up_key : IF WY>0 THEN WY:=WY-1; sc_down_key : IF WY<(ScreenHeight-1) THEN WY:=WY+1; sc_right_key: IF WX<(ScreenWidth -1) THEN WX:=WX+1; sc_left_key : IF WX>0 THEN WX:=WX-1; sc_not_legal: BEGIN CASE Ch OF {numbers used to allow rapid cursor moves by a keypad 7 8 9 4 5 6 1 2 3 added by Chris Lee} '7' : ZoneMove(1,1,3,3); '8' : ZoneMove(1,2,3,3); '9' : ZoneMove(1,3,3,3); '4' : ZoneMove(2,1,3,3); '5' : ZoneMove(2,2,3,3); '6' : ZoneMove(2,3,3,3); '1' : ZoneMove(3,1,3,3); '2' : ZoneMove(3,2,3,3); '3' : ZoneMove(3,3,3,3); 'A', 'a' : BEGIN WTop:=WSequence; WTemp:=SCursin; IF WTemp<>NoWindow THEN BEGIN IF (CanAlter IN Windows[WTemp].Options) THEN BEGIN WindowFunction; {get one corner - wait for 'mark'} X1:=WX; Y1:=WY; WindowFunction; {get opposite corner - wait for 'mark'} X2:=WX; Y2:=WY; WHide(WTemp); IF X2NoWindow THEN BEGIN IF (WSequence<>SCursIn) AND (CanHide IN Windows[SCursin].Options) THEN WHide(SCursIn) ELSE WRITE(CHR(Bel)) {cannot hide current window} END ELSE WRITE(CHR(Bel)) END; 'K', 'k': BEGIN WTemp:=SCursIn; IF (WTemp<>NoWindow) AND (WTemp<>WSequence) THEN BEGIN IF CanKill IN Windows[WTemp].Options THEN BEGIN WHide(WTemp); WDispose(WTemp); END ELSE WRITE(CHR(Bel)) END ELSE WRITE(CHR(Bel)) END; 'M', 'm': BEGIN WTop:=Wsequence; WTemp:=SCursIn; IF WTemp<>NoWindow THEN BEGIN IF CanMove IN Windows[WTemp].Options THEN BEGIN WindowFunction; {get new top left - wait for 'mark'} X1:=WX; Y1:=WY; WHide(WTemp); WAlter(WTemp,X1,Y1,-1,-1, Windows[WTemp].Options,''); WShow(WTemp); WShow(WTop); END ELSE WRITE(CHR(Bel)) END ELSE WRITE(CHR(Bel)); END; 'S', 's' : IF WSequence<>SCursIn THEN BEGIN IF SCursIn<>NoWindow THEN BEGIN WTop:=WSequence; WHide(WSequence); WShow(SCursIn); WShow(WTop); END ELSE WRITE(CHR(Bel)); END; '?' : WHelp; END; IF NOT(Ch IN ['1'..'9','A','a','H','h','K','k','M','m','S','s','?']) THEN WRITE(CHR(Bel)); END; END; {CASE} IF NOT ScreenValid THEN RePaint; PlaceCursor; UNITREAD(SYSTERM,Key[0],1); Ch:=Key[0]; END; RemoveCursor; END; ======================================================================================== DOCUMENT :usus Folder:VOL12:wfiler.text ======================================================================================== PROGRAM WFiler; {revision 22-Feb-82 Austin Tate} USES {$U Windows.code} WindowManager; CONST Bel=7; VAR Ch:CHAR; ScriptWindow,MessWindow,CommWindow:Window; {$I-} PROCEDURE ShowCommand(FirstTime:BOOLEAN); VAR W:Window; BEGIN IF FirstTime THEN BEGIN CommWindow:=WNew(0,2,12,10, [HasHeading,CanHide,CanMove,CanAlter],'Commands....'); WShow(CommWindow); WWriteStr('C(reate file');WWriteLn; WWriteStr('D(ate'); WWriteLn; WWriteStr('E(xt. dir'); WWriteLn; WWriteStr('L(ist dir'); WWriteln; WWriteStr('R(emove'); WWriteLn; WWriteStr('V(olumes'); WWriteLn; WWriteStr('............');WWriteLn; WWriteStr('?(Commands'); WWriteLn; WWriteStr('Q(uit'); END ELSE BEGIN IF WCurrentWindow<>CommWindow THEN WShow(CommWindow); END; END; PROCEDURE ShowMessage(FirstTime:BOOLEAN); VAR W:Window; BEGIN IF FirstTime THEN MessWindow:=WNew(0,0,80,1,[CanMove],'') ELSE WClearAndShow(MessWindow); END; PROCEDURE ShowScript(FirstTime:BOOLEAN); {Script window should always be left at start of a newline} VAR W:Window; BEGIN IF FirstTime THEN BEGIN ScriptWindow:=WNew(0,17,80,7, [HasHeading,CanHide,CanMove,CanAlter,CanScroll,CanPan], 'TypeScript'); WShow(ScriptWindow); END ELSE BEGIN IF WCurrentWindow<>ScriptWindow THEN WShow(ScriptWindow); END; END; PROCEDURE OpenDirWindow(Title:STRING; Detail:BOOLEAN); VAR W:Window; Width,X,Y:INTEGER; BEGIN WXY(X,Y); IF Detail THEN Width:=60 ELSE Width:=31; W:=WNew(X,Y,Width,12, [HasHeading,CanAlter,CanMove,CanKill], CONCAT('Directory of ',Title,':')); WShow(W); END; PROCEDURE OpenVolsWindow; VAR W:Window; X,Y:INTEGER; BEGIN WXY(X,Y); W:=WNew(X,Y,13,13,[HasHeading,CanAlter,CanMove,CanKill],'Volumes'); WShow(W); END; PROCEDURE OpenDateWindow; VAR W:Window; X,Y:INTEGER; BEGIN WXY(X,Y); W:=WNew(X,Y,19,1,[CanMove,CanKill],''); WShow(W); END; PROCEDURE FileH(Action:CHAR); { Assume all input through } { WReadCh input character from source stream } { WReadLnStr input string from source stream up to NL } { } {Assume all output through } { WWriteCh output character to destination stream } { WWriteStr output string to destination stream } { WWriteInt output integer to destination stream } { WWriteLn output a newline to destination stream } {Directory layouts, etc. ideas from various sources including} {UCSD p-System Users' Society Software Library Volume 8 } CONST VIDLENG=7; {NUMBER OF CHARS IN A VOLUME ID} TIDLENG=15; {NUMBER OR CHARS IN A TITLE ID} MAXDIR=77; {MAX NUMBER OF ENTRIES IN A Directory} TYPE DATEREC = PACKED RECORD MONTH: 0..12; {0 IMPLIES DATE NOT MEANINGFUL} DAY: 0..31; {DAY OF MONTH} YEAR: 0..100 {100 IS TEMP DISK FILE FLAG} END {DATEREC}; DIRRANGE = 0..MAXDIR; TID = STRING[TIDLENG]; FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE, INFOFILE,DATAFILE,GRAFFILE,FOTOFILE,SECUREDIR); DIRENTRY = RECORD DFIRSTBLK: INTEGER; {FIRST PHYSICAL DISK ADDR} DLASTBLK: INTEGER; {POINTS AT BLOCK FOLLOWING} CASE DFKIND: FILEKIND OF SECUREDIR, UNTYPEDFILE: {normally in DIR[0]..vol info} (DVID: STRING[VIDLENG]; {NAME OF DISK VOLUME} DEOVBLK: INTEGER; {LASTBLK OF VOLUME} DNUMFILES: DIRRANGE; {NUM FILES IN DIR} DLOADTIME: INTEGER; {TIME OF LAST ACCESS} DLASTBOOT: DATEREC); {MOST RECENT DATE SETTING} XDSKFILE,CODEFILE,TEXTFILE,INFOFILE, DATAFILE,GRAFFILE,FOTOFILE: (DTID: TID; {TITLE OF FILE} DLASTBYTE: 1..512; {NUM BYTES IN LAST BLOCK} DACCESS: DATEREC) {LAST MODIFICATION DATE} END {DIRENTRY}; VAR DI: RECORD CASE BOOLEAN OF TRUE: (RECTORY: ARRAY [DIRRANGE] OF DIRENTRY); FALSE:(RBLOCKS: ARRAY[1..4] OF ARRAY[1..512] OF CHAR) END; Months: ARRAY [0..15] OF STRING[3]; PROCEDURE SPACES(V:INTEGER); BEGIN FOR V:=V DOWNTO 1 DO WWriteCh(' '); END; PROCEDURE DIRINIT(UnitNum:INTEGER); BEGIN UNITREAD(UnitNum,DI.RBLOCKS[1],2048,2); {LOAD DIR} END {DIRINIT} ; FUNCTION GETUNIT:BOOLEAN; VAR UnitNum,I:INTEGER; GOOD:BOOLEAN; INSTRING:STRING; UNames:ARRAY[4:12] OF STRING[3]; BEGIN UNames[4]:='#4'; UNames[5]:='#5'; UNames[6]:=''; UNames[7]:=''; UNames[8]:=''; UNames[9]:='#9'; UNames[10]:='#10'; UNames[11]:='#11'; UNames[12]:='#12'; If WCurrentWindow<>ScriptWindow THEN ShowScript(FALSE); WWriteStr('Volume or Unit: '); WReadLnStr(INSTRING); IF INSTRING<>'' THEN IF INSTRING[LENGTH(INSTRING)]=':' THEN BEGIN {$R-} INSTRING[0]:=PRED(INSTRING[0]); {$R+} END; IF INSTRING='*' THEN INSTRING:='#4'; GOOD:=FALSE; IF INSTRING<>'' THEN BEGIN UnitNum:=3; REPEAT UnitNum:=SUCC(UnitNum); IF INSTRING[1]='#' THEN BEGIN IF INSTRING=UNames[UnitNum] THEN BEGIN DIRINIT(UnitNum); GOOD:=(IORESULT=0); END; END ELSE BEGIN IF UNames[UnitNum]<>'' THEN BEGIN DIRINIT(UnitNum); GOOD:=(IORESULT=0) AND (DI.RECTORY[0].DVID=INSTRING); END; END; UNTIL GOOD OR (UnitNum=12); END; IF NOT GOOD THEN BEGIN WWriteStr('Volume or Unit not on-line.'); WWriteLn; END; GETUNIT:=GOOD; END; PROCEDURE Date(StandAlone:BOOLEAN); BEGIN IF StandAlone THEN BEGIN OpenDateWindow; DirInit(4); {get date on system disk} WWriteStr('Date is:'); END; WITH DI.RECTORY[0] DO BEGIN IF DLASTBOOT.MONTH > 0 THEN BEGIN SPACES(2); WWriteInt(DLASTBOOT.DAY,2); WWriteCh('-'); WWriteStr(Months[DLASTBOOT.MONTH]); WWriteCh('-'); WWriteInt(DLASTBOOT.YEAR,2); END; END; END; PROCEDURE Directory(DETAIL:BOOLEAN); VAR LINES,I,LARGEST,FREEBLKS,USEDAREA,USEDBLKS: INTEGER; GS: STRING; PROCEDURE SENDLN; CONST WDepth=10; VAR CH:CHAR; BEGIN WWriteLn; LINES:=LINES+1; IF LINES=WDepth THEN BEGIN WWriteStr('Press to continue'); REPEAT WReadCh(CH,FALSE); UNTIL CH=' '; WClear; LINES:=0; END; END; PROCEDURE FREECHECK(FIRSTOPEN,NEXTUSED: INTEGER); VAR FREEAREA: INTEGER; BEGIN FREEAREA := NEXTUSED-FIRSTOPEN; IF FREEAREA > LARGEST THEN LARGEST := FREEAREA; IF FREEAREA > 0 THEN BEGIN FREEBLKS := FREEBLKS+FREEAREA; IF DETAIL THEN BEGIN WWriteStr('< UNUSED > '); WWriteInt(FREEAREA,4); SPACES(11); WWriteInt(FIRSTOPEN,6); SENDLN; END END; END {FREECHECK} ; BEGIN IF NOT GETUNIT THEN EXIT(Directory); FREEBLKS := 0; USEDBLKS := 0; LARGEST := 0; GS:=DI.RECTORY[0].DVID; OpenDirWindow(GS,DETAIL); LINES:=0; FOR I := 1 TO DI.RECTORY[0].DNUMFILES DO WITH DI.RECTORY[I] DO BEGIN FREECHECK(DI.RECTORY[I-1].DLASTBLK,DFIRSTBLK); USEDAREA := DLASTBLK-DFIRSTBLK; USEDBLKS := USEDBLKS+USEDAREA; IF DACCESS.YEAR IN [1..99] THEN BEGIN WWriteStr(DTID); SPACES(TIDLENG-LENGTH(DTID)+1); WWriteInt(USEDAREA,4); IF DACCESS.MONTH > 0 THEN BEGIN SPACES(2); WWriteInt(DACCESS.DAY,2); WWriteCh('-'); WWriteStr(Months[DACCESS.MONTH]); WWriteCh('-'); WWriteInt(DACCESS.YEAR,2); END; IF DETAIL THEN BEGIN IF DACCESS.MONTH = 0 THEN SPACES(11); WWriteInt(DFIRSTBLK,6); WWriteInt(DLASTBYTE,6); GS := ' file'; CASE DFKIND OF XDSKFILE: GS := 'Bad block'; CODEFILE: GS := 'Code file'; TEXTFILE: GS := 'Text file'; INFOFILE: GS := 'Info file'; DATAFILE: GS := 'Data file'; GRAFFILE: GS := 'Graf file'; FOTOFILE: GS := 'Foto file' END; SPACES(2); WWriteStr(GS) END; SENDLN; END; END; FREECHECK(DI.RECTORY[I-1].DLASTBLK,DI.RECTORY[0].DEOVBLK); WWriteInt(DI.RECTORY[0].DNUMFILES,0); WWriteStr(' files, '); WWriteInt(USEDBLKS,0); WWriteStr(' blocks used, '); WWriteInt(FREEBLKS,0); WWriteStr(' unused'); IF DETAIL THEN BEGIN WWriteStr(', '); WWriteInt(LARGEST,0); WWriteStr(' in largest area.'); END; END; {Directory} PROCEDURE Vols; VAR UnitNum:INTEGER; BEGIN OpenVolsWindow; WWriteStr(' 1 CONSOLE:'); WWriteLn; WWriteStr(' 2 KEYBOARD:');WWriteLn; WWriteStr(' 3 GRAPHIC:'); FOR UnitNum:=4 TO 12 DO BEGIN IF UnitNum=9 THEN BEGIN WWriteLn; WWriteStr(' 6 PRINTER:'); WWriteLn; WWriteStr(' 7 REMIN:'); WWriteLn; WWriteStr(' 8 REMOUT:'); END; IF UnitNum IN [4,5,9,10,11,12] THEN BEGIN DIRINIT(UnitNum); IF IORESULT=0 THEN BEGIN WWriteLn; WWriteInt(UnitNum,2); SPACES(2); WWriteStr(DI.RECTORY[0].DVID); WWriteCh(':'); END; END; END; END; PROCEDURE RemoveFile; VAR STR:STRING; DFILE:FILE; BEGIN IF WCurrentWindow<>ScriptWindow THEN ShowScript(FALSE); WWriteStr('Remove filename:'); WReadLnStr(STR); RESET(DFILE,STR); IF IORESULT<>0 THEN WWriteStr('File does not exist.') ELSE BEGIN CLOSE(DFILE,PURGE); WWriteStr('File '); WWriteStr(STR); WWriteStr(' removed.'); END; WWriteLn; END; BEGIN Months[ 0] := '???'; Months[ 1] := 'Jan'; Months[ 2] := 'Feb'; Months[ 3] := 'Mar'; Months[ 4] := 'Apr'; Months[ 5] := 'May'; Months[ 6] := 'Jun'; Months[ 7] := 'Jul'; Months[ 8] := 'Aug'; Months[ 9] := 'Sep'; Months[10] := 'Oct'; Months[11] := 'Nov'; Months[12] := 'Dec'; Months[13] := '???'; Months[14] := '???'; Months[15] := '???'; CASE Action OF 'E':Directory(TRUE); 'L':Directory(FALSE); 'V':Vols; 'R':RemoveFile; 'D':Date(TRUE); END; END; PROCEDURE CreateFile; CONST NoSuchFile=10; VAR F:TEXT; Str:STRING; i:INTEGER; Abort:BOOLEAN; BEGIN ShowScript(FALSE); WWriteStr('Create filename:'); WReadLnStr(Str); RESET(F,STR); IF IORESULT<>NoSuchFile THEN WWriteStr('File open error.') ELSE BEGIN REWRITE(F,Str); WWriteStr('Give text - end with @'); WWriteLn; REPEAT WReadLnStr(Str); i:=POS('@',Str); IF i<>0 THEN Str:=COPY(Str,i-1,LENGTH(Str)-1); WRITELN(F,Str); Abort:=(IORESULT<>0); UNTIL (i<>0) OR Abort; IF Abort THEN WWriteStr('File write error.') ELSE BEGIN CLOSE(F,LOCK); IF IORESULT<>0 THEN WWriteStr('File close error.') ELSE WWriteStr('File created okay.'); END; END; WWriteLn; END; {$I+} BEGIN WStartup; {- not used if Window manager in *SYSTEM.PASCAL} {<<<<<<<} {WInit; - needed if Window manager in *SYSTEM.PASCAL} {<<<<<<<} ShowScript(TRUE); WWriteStr('ESC enters Window manager mode - then ? will get help information'); WWriteLn; ShowCommand(TRUE); ShowMessage(TRUE); {does not actually show the window} WCursorXY(30,6); REPEAT ShowMessage(FALSE); WWriteStr('WFiler: give command letter: '); REPEAT WReadCh(Ch,FALSE); IF (Ch>='a') AND (Ch<='z') THEN Ch:=CHR(ORD(Ch)-32); UNTIL Ch IN ['?','C','D','H','R','E','L','V','Q']; WWriteCh(Ch); WWriteLn; IF (Ch='H') OR (Ch='?') THEN ShowCommand(FALSE) ELSE IF (Ch='C') THEN CreateFile ELSE IF (Ch<>'Q') THEN FileH(Ch); UNTIL Ch='Q'; WHide(ScriptWindow); WHide(CommWindow); WHide(MessWindow); WDispose(ScriptWindow); WDispose(CommWindow); WDispose(MessWindow); {other windows left on screen for info in case WindowManager is a System Unit in *SYSTEM.PASCAL} END. ======================================================================================== DOCUMENT :usus Folder:VOL12:windows.text ======================================================================================== { L W.LISTING.TEXT} { R-} UNIT WindowManager; {Austin Tate (ERCC) and Chris Lee (INMOS)} INTERFACE {Window Manager for the UCSD p-System} {Windows are displayed as rectangular areas on the screen, bordered by a frame and optionally headed by a heading. Each window has its own size, screen location, text area, cursor and status information. Each window may be written into and will scroll independently, and may be cleared, moved, changed in size, etc. by a user's program. During any input operation the user may escape into 'Window Manager Mode' (and subsequently return to 'Input Mode', to complete the input). In Window Manager Mode the Window Manager uses a special cursor which is independent of any window. This cursor is used to indicate screen position parameters to the Hide, Show, Alter, Move and Kill commands. Whether or not a particular command may be applied to a particular window is controlled by the user's program. } CONST WVersion='22-Feb-82'; NoWindow=0; MaxWindow=10; TYPE Window=NoWindow..MaxWindow; WindowOptions=(CanHide,CanMove,CanAlter,CanKill, HasHeading,CanScroll,CanPan); WindowAttributes=SET OF WindowOptions; {Initialisation Routines} PROCEDURE WStartup; {Called by *SYSTEM.STARTUP to REALLY initialise} {If window manager is placed in *SYSTEM.PASCAL then you MUST supply a *SYSTEM.STARTUP that calls WStartup. Thereafter any program which uses the window manager should initialise via WInit, the effect of which is to repaint the screen as it was when the last using program terminated. If Window Manager is not in *SYSTEM.PASCAL then use WStartup always} PROCEDURE WInit; {Initialise Window Manager System} {just redisplays all windows} {if Manager is a system unit, all windows survive program changes} {Routines to create, alter, show, clear, hide and dispose of windows} FUNCTION WNew(WatX,WatY,WSizeX,WSizeY:INTEGER; WControls:WindowAttributes; WHeading:STRING):Window; {Get new window} PROCEDURE WAlter(W:Window; WatX,WatY,WSizeX,WSizeY:INTEGER; WControls:WindowAttributes; WHeading:STRING); {Alter existing window} {WatX,WatY,SizeX,SizeY -ve means do not alter} {WControls replaces existing window attributes} {Window must not be in show when WAlter called} PROCEDURE WShow(W:Window); {Display window and set it as "current" one} PROCEDURE WClearAndShow(W:Window); {Clear window, then "Show" it} PROCEDURE WHide(W:Window); {Remove window from screen - it is not disposed of} PROCEDURE WDispose(W:Window); {Dispose of old window} {Window must not be in show when WDispose called} {The following procedures all apply to the "current" last shown window} PROCEDURE WClear; {Clear Window} PROCEDURE WClrEOL; {Clear remainder of current line} PROCEDURE WClrEOS; {Clear remainder of window} PROCEDURE WGotoXY(X,Y:INTEGER); {Set Window cursor to X,Y} {X,Y are relative to top left of window - base of 0, excluding heading} PROCEDURE WWriteCh(Ch:CHAR); {Write Ch at cursor position in window} {Non printable chs map to bell} PROCEDURE WWriteStr(Str:STRING); {Write Str at cursor position in window} {MUST NOT CONTAIN NON PRINTABLE CHARS} PROCEDURE WWriteInt(Int,Width:INTEGER); {Write Int at cursor posn in window} {Equivalent to WRITE(Int:Width) in Pascal} {Width may be 0 (or -ve) to mean as narrow as possible} PROCEDURE WWriteLn; {Write newline at cursor position in window} {If cursor goes below base of window, window is cleared} PROCEDURE WReadCh(VAR Ch:CHAR;Echo:BOOLEAN); {Get character from keyboard} {Window functions can only take place within WReadCh} {Any non window function ch is returned to user } {Echo is controlled by user - non printable chs echo as bell} {Other Window Reading Procedures - below - use WReadCh} PROCEDURE WReadLnStr(VAR Str:STRING); {Get a string from keyboard - echoed} {String is ended by newline. Only edit ch allowed is backspace} {Non printable chs are not returned - but echo as bell} PROCEDURE WReadLnInt(VAR Int:INTEGER); {Get an integer from keyboard - echoed} {Integer is ended by newline. Only edit ch allowed is backspace} {Non printable chs are not returned - but echo as bell} PROCEDURE WReadLn(Echo:BOOLEAN); {Read up to next newline from keyboard} {Non printable chs echo as bell} {the following functions and procedures are utilities on windows} FUNCTION WInWindow(X,Y:INTEGER):Window; {Returns window in which position X,Y occurs - NoWindow if none} {X,Y in screen coordinates} FUNCTION WChAtXY(X,Y:INTEGER; W:Window):CHAR; {Return Ch under screen position X,Y in W} {Space returned if X,Y not in Window, or NoWindow} {Ch need not be in view at time of call} PROCEDURE WXY(VAR X,Y:INTEGER); {Get Coordinates of window manager cursor - in window coordinates} PROCEDURE WCursorXY(X,Y:INTEGER); {Set coordinates of window manager cursor - in window coordinates} FUNCTION WCurrentWindow:Window; {Return Current Window - one last shown - may be NoWindow} {HISTORY Copyright: Austin Tate, ERCC. All rights reserved. This program may be used for non-commercial purposes by users of the UCSD p-System provided that this copyright notice appears in the source. Enquiries for other uses should be directed to the copyright owner. The Window Manager was originally written in March 1981 by Austin Tate, ERCC as a demonstration for a course on Office Systems and Advanced Personal Computers. ------------------------- It was subsequently modified by Chris Lee while at INMOS up to 10-Feb-82. The major changes he made were: I/O optimisation - all I/O is delayed as long as possible, and is done in as large units as possible, via UNITWRITE (asynch!!!), and isn't done at all if what we want is on the screen already. See routines flushoutput and repaint. Repaint certainly pays its way (try moving and altering windows with the original and this version), flushoutput almost certainly doesn't - it makes lines zap out in one swell foop, but stops the dreaded dots. Window Functions - on the operator interface are all handled inside the window manager. During input use ESC to toggle between window manager and input modes (and notice the cursor change when you do). See WindowFunction. Notice that screen position parameters are signalled by moving the cursor and typing ESC or (known as a 'mark' in Window Manager Mode). Eg, to move a window type ESC -- to enter window mode M or m -- to request a move ----> or ESC -- the window moves at this point or ESC -- to return to input mode NB at point ----> WindowFunction calls itself recursively. You can nest window functions (and get into a real mess) if you want). The interface to WNew has changed to allow the programmer to control what WindowFunctions the user may apply to a window. Frames - are drawn by characters. There are CONSTs for the four corners and four sides so if you have forms drawing chars you should be able to make things look pretty Scrolling and Panning - misc minor changes. Scroll by one third of window depth rather than one line. Only re-pan at input time. Both these mods are designed to eliminate unnecessary I/O and repainting. To improve efficiency WWriteStr assumes that only printable chars are in the string. This version was produced during experimentation into window management. Hence the code hasn't been beautified and bugs may be present. ------------------------- The Window Manager as modified by Chris Lee was then altered in some minor respects by Austin Tate prior to release to the UCSD p-System Users' Society (USUS) Software Library in February 1982. } IMPLEMENTATION {$I w.impln} END. ======================================================================================== DOCUMENT :usus Folder:VOL13:declare.text ======================================================================================== {*******************************************************************} { } { RUNON Copyright (C) 1980 Wynn Newhouse and Herb Jellinek. } { All rights reserved. } { } {*******************************************************************} {********************************************************************** Explanation of global CONSTants. MINLINEWIDTH The minimum size that the paper width can be set to. MAXLINEWIDTH The maximum size that the paper width can be set to. (all buffers are this long.) MAXNUMSIZE Maximum number of digits of the page number. MINPAPLEN The minimum size of the paper length. MAXCMDLENGTH The length of the longest dot command plus one (1). A space must be added to the string name of each command. Check this when adding commands. MAX_FILES The maximum number of open INCLUDE files at one time. BORDERSIZE Amount of space reserved at top and bottom of page to serve as border. MINSPACING Minimum spacing between lines, as with typewriters (i.e. spacing 1 means no intervening blank lines) MAXSPACING Maximum spacing between lines. LCOFFSET ORD('a') - ORD('A') : used in case conversion. R_OFFSET Offset from right side of page to start of page number. BLANK_HEADING Number of lines to skip at top of first page. VERSION_NUMBER The current version of RUNON. **********************************************************************} const minlinewidth = 30; maxlinewidth = 132; maxnumsize = 4; minpaplen = 20; maxcmdlength = 12; max_files = 5; bordersize = 14; minspacing = 1; maxspacing = 5; lcoffset = 32; r_offset = 5; blank_heading = 7; uca = 'A'; ucz = 'Z'; lca = 'a'; lcz = 'z'; blank_char = ' '; zero = '0'; nine = '9'; dot = '.'; pound = '#'; underline = '_'; nul = ''; version_number = 'V2'; {********************************************************************** Description of global types. COMMANDTYPE Enumerated type that represents current status to OUT_PROC. ERRORTYPE Type representing error. FILLTYPE Type representing the current filling mode. HARD_SOFT Used to represent 'malleability' in determining flexibility attribute of spaces. OLD_NEW Used in SYSVARS to 'point' to current settings. ATTRIB Attributes that a character may have. CHAR_REC One individual element of internal and output buffers. Represents one character. LINE_OF_RECS An array of CHAR_RECs. BUFFER A LINE_OF_RECS with STart and ENd pointers. LINE_OF_CHARS An array of characters. STRNG A LINE_OF_CHARS with STart and ENd pointers. MISCINFO A record used to hold system values. STACK_ENTRY The current variables that need to be saved when INCLUDEing a file, and recursively calling PROCESS_FILE. **********************************************************************} type commandtype = (brk, fig, indt, pag, tstpag, skp, nofil, cntr, til, inclu, fil, lmar, rmar, onnum, offnum, num, onpag, offpag, papsiz, spc, std, justfy, norm, autop, noauto, autset, upper, lower, same, cmnt); errortype = (badcmd, tooshrt, toowide, toonrrw, badsym, argmsng, nonnum, toolow, toohgh, tilwide, cntwide, figbad, wdlen, dblnam, incerr, filerr, nesdep, aplow, aphgh, cmderr, baddelm, dlmmsng, endlead, badcnt); filltype = (justification, filling, nofilling); cmd_name = packed array [1..maxcmdlength] of char; posint = 0..maxint; hard_soft = (hard, soft); old_new = (old, new); attrib = (u_line, u_case, l_case, xpand); attrib_set = set of attrib; char_rec = record ch : char; malleability : hard_soft; length : posint; atts : attrib_set; end; line_of_recs = packed array [1..maxlinewidth] of char_rec; buffer = record st, en : posint; str : line_of_recs; end; line_of_chars = packed array [1..maxlinewidth] of char; strng = record st, en : posint; str : line_of_chars; end; Miscinfo = record version : old_new; fill_mode : filltype; paging, numbering, ap_mode : boolean; lm, rm : posint; ap_indent, ap_skip, paper_width, paper_length, chars_in_line, printable_lines : posint; spacing : minspacing..maxspacing; end; stack_entry = record name : string; line : posint; in_buf : strng; end; {********************************************************************** Explanation of global variables. F, S0..S5, DEST F is used to test for the existence of a file or volume. S0 and DEST are the file variables for the main input and output files. S1..S5 are used to INCLUDE other source files. FILE_IN, FILE_OUT Actual names of input and output files. SYSVARS Contains commonly-used system values, such as margins, etc. Subject to time-warp effect. PAGEINFO Contains other system information pertinent to output page, such as page number, etc. Not subject to time-warp effect. STD_VALS Contains default values for system initialization. INPUT_BUF Buffer into which characters are initially read from input file. INTERNAL_BUF, OUTPUT_BUF Two buffers that hold intermediate representations of the text. GLOBAL_CASE The case that all text read in is taken to be. Over- ridden by special character commands. N, M Global variables used to represent dot-command parameters. TEXT_DELIMS The set of legal characters that can be used to delimit text parameters for dot commands. LEADIN_CHARS Set of charcters used as first character of all embedded command sequences. DELIM_CHARS Set of control characters plus space and pound sign. These are the valid delimiters. LOCK_OPS, WORD_OPS These are the characters that may follow LEADIN_CHARS. SPACE_CHARS Set of space and pound-sign characters. LC_LETTERS Set of lower-case letters. LOCK_STATUS A set that contain current attributes as set by the scanner, assigned to characters being scanned. LEAD_BLANK Boolean set by READLINE to indicate that first character of INPUT_BUF is a blank. Used to start a new paragraph. BLANKLINE, DOT_COMMAND Flags set by READLINE to indicate status of input buffer. NUMBERS Characters representing digits '0' through '9'. ACT_CMDS 'Constant' set of commands which get routed to output processor. TEXT_CMDS The set of commands that take textual parameters. MORE_INPUT Boolean flag which indicates if the internal buffer contains unprocessed text. VC_IN_LINE Number of visible characters in current output line. IC_IN_LINE Number of invisible characters in current output line. LN_NUMBER Current line number of input file. Used only by ERROR. HARD_SPACE, SOFT_SPACE, BLANK_BUF, BLANK_STRING 'Constant' blank-like thingies, used to reinitialize characters, buffers, etc. CMD_STRINGS The actual string names for each commandtype. Used by GET_COMMAND to match abbreviations. FILE_STACK A stack used to keep track of the level of nesting of INCLUDE files. The file names are saved for error testing purposes. **********************************************************************} var f, s0, s1, s2, s3, s4, s5, dest : text; file_in, file_out : string; sysvars : array [old_new] of miscinfo; pageinfo : record currline, currpage : posint; figure_set, figure_pending : boolean; figure_size : posint; title : strng; end; std_vals : miscinfo; input_buf : strng; internal_buf, output_buf : buffer; global_case : set of u_case..l_case; n, m : posint; text_delims, leadin_chars, delim_chars, space_chars, uc_letters, lc_letters, word_ops, lock_ops : set of char; numbers : set of zero..nine; act_cmds : set of brk..nofil; text_cmds : set of cntr..inclu; lock_status : attrib_set; more_input, blankline, dot_command, lead_blank : boolean; vc_in_line, ic_in_line, ln_number : posint; soft_space, hard_space : char_rec; blank_buf : buffer; blank_string : strng; cmd_strings : packed array [commandtype] of cmd_name; file_stack : record ptr : 0..max_files; stack : packed array[1..max_files] of stack_entry; end; bs : char; ======================================================================================== DOCUMENT :usus Folder:VOL13:defalt_doc.text ======================================================================================== .comment !---------------------------------! .comment ! ! .comment ! RUNON documentation ! .comment ! Default values ! .comment ! ! .comment ! August 3, 1980 ! .comment ! ! .comment !---------------------------------! .skip 2 .center " ^^^&default values\^\& " .skip 1 The following are the values that Runon uses to process the text, until they are reset by the use of dot commands. .spacing 2 .nofill 1. Page numbers on every page except the first 2. Spacing 1 between lines 3. Justification enabled 4. Left margin 10 5. Right margin 70 6. Paper size : Length 66 lines, Width 80 characters 7. Autoparagraph : enabled, skip 1, indent 5 8. Paging enabled 9. Case : same .spacing 1 .justify ======================================================================================== DOCUMENT :usus Folder:VOL13:dopage.text ======================================================================================== {********************************************************************** DO_PAGE is called in order to begin each new page of output, other than the first. If page numbering is in effect, the current page number is written out. If a title exists, it too is written out. The routine also takes care of 'pending figures' - that is, if a figure was too large to fit on the previous page, it is placed at the top of the current one. PUT_TITLE takes care of processing and centering the title. Notice that the global attribute set, LOCK_STATUS, is saved and set to nil before SCANNER is called, and restored afterwards. This ensures that SCANNER will not process the title improperly. Note that the current line, PAGEINFO.CURRLINE, is reset to 0 as the title is output using OUT_PROC, which increments the current line. **********************************************************************} Procedure do_page; const down_skip = 2; var i : posint; Procedure put_title; var temp_buf : buffer; save_status : attrib_set; begin temp_buf := blank_buf; save_status := lock_status; lock_status := []; scanner(pageinfo.title.st, pageinfo.title.en, pageinfo.title.str, temp_buf); lock_status := save_status; center_buffer(temp_buf, 1, sysvars[new].paper_width, pageinfo.title.en, tilwide ); output_buf := temp_buf; out_proc(brk); pageinfo.currline := 0; end; { put_title } begin { do_page } page(dest); writeln(dest); writeln(dest); if sysvars[new].numbering then begin for i := 1 to (sysvars[new].paper_width - maxnumsize - r_offset) do write(dest, blank_char); writeln(dest, pageinfo.currpage:5); end else writeln(dest); writeln(dest); pageinfo.currline := 0; pageinfo.currpage := pageinfo.currpage + 1; if pageinfo.title.en >= pageinfo.title.st then put_title else writeln(dest); for i := 1 to down_skip do writeln(dest); if pageinfo.figure_pending then begin pageinfo.figure_pending := false; putline(pageinfo.figure_size); end; end; { do_page } {********************************************************************** PUT_LINE puts CR/LF pairs into the output file at the end of each output line. It is called by the skip, figure, and page routines. If there is not enough space on the page to skip the desired number of lines (when in paging mode), the routine calls DO_PAGE, which then outputs any pending figure. The essential features of DO_PAGE are simulated here, with the exception of the actual paging itself, when not in paging mode. PUT_LINE is declared FORWARD as it is called by DO_PAGE. There is no possibility of infinite recursion. **********************************************************************} {***********************************************} { } { Forward declaration in SYSGEN file. } {-----------------------------------------------} { } { Procedure putline(n : posint); Forward; } { } {***********************************************} Procedure putline; var crlf : posint; begin pageinfo.currline := pageinfo.currline + n; if sysvars[new].paging then begin if pageinfo.currline < sysvars[new].printable_lines then for crlf := 1 to n do writeln(dest) else do_page; end else { not paging } begin for crlf := 1 to n do writeln(dest); if pageinfo.currline > sysvars[new].printable_lines then begin pageinfo.currline := pageinfo.currline - sysvars[new].printable_lines; pageinfo.currpage := pageinfo.currpage + 1; if pageinfo.figure_pending then begin pageinfo.figure_pending := false; putline(pageinfo.figure_size); end; end end end; { putline } {********************************************************************** SHOVE_BUFFER writes the output buffer to the output file, taking into account the attributes of each character, if it has any. After the buffer has been 'shoved', several important global variables are reset. The current VERSION of SYSVARS is set to point to the NEW values, the 'visible character count' is set to zero, the 'invisible character count' is set to zero, and the output buffer is cleared. If a figure has been set, it is output; otherwise, (spacing factor) number of lines are output. **********************************************************************} Procedure shove_buffer; var i, j : posint; khar : char; attribs : attrib_set; begin for i := 1 to output_buf.en do begin attribs := output_buf.str[i].atts; khar := output_buf.str[i].ch; if attribs <> [] then begin if attribs = [xpand] then for j := 1 to output_buf.str[i].length do write(dest, blank_char) else begin if u_line in attribs then begin write(dest, underline); write(dest, bs); end; if l_case in attribs then begin if khar in uc_letters then khar := chr(ord(khar) + lcoffset); end else if u_case in attribs then if khar in lc_letters then khar := chr(ord(khar) - lcoffset); write(dest, khar); end; { else } end { if attribs } else { no attributes } write(dest, khar); end; { for } sysvars[new].version := new; output_buf := blank_buf; vc_in_line := 0; ic_in_line := 0; if pageinfo.figure_set then begin pageinfo.figure_set := false; putline(pageinfo.figure_size); end else putline(sysvars[new].spacing); end; { shove_buffer } {********************************************************************** MOVE_WORD moves the next word, starting from the STth element of the internal buffer (aka INTERNAL_BUF) into the output buffer (OUTPUT_BUF) starting with its EN+1st element. The aforementioned counters get updated; the ST pointer to one beyond the end of the word in the internal buffer, and the EN pointer to the end of the word in the output buffer. A space is appended to the end of each word. (A word is defined to be any contiguous sequence of characters, delimited by SOFT_SPACEs.) Other variables that get updated are: VC_IN_LINE, which contains the number of visible chars in the output buffer; IC_IN_LINE, which contains the number of invisible characters in the buffer; EO_INPUT, which signals that the internal buffer is empty; and EO_OUTPUT, which signals the output buffer as being full. CHARS_FIT is a function used to determine if a) there is enough space for the visible-length of the word between the margins; b) the total number of characters in the word added to the number of characters already in the buffer does not exceed the length of the buffer. **********************************************************************} Procedure move_word(var eo_input, eo_output : boolean); var vc_in_word, ic_in_word, buf_pos : posint; ablank, aword, ic_only : boolean; curr_char : char_rec; Procedure move_to_output(first_ch, last_ch : posint); var word_len, offset : posint; begin word_len := last_ch - first_ch + 1; for offset := 1 to word_len do output_buf.str[output_buf.en + offset] := internal_buf.str[offset + first_ch - 1]; internal_buf.st := last_ch + 1; output_buf.en := output_buf.en + word_len; end; { move_to_output } Function chars_fit : boolean; begin chars_fit := ((vc_in_line + vc_in_word) <= sysvars[v].chars_in_line) and ((sysvars[v].lm + vc_in_line + vc_in_word + ic_in_word + ic_in_line) <= maxlinewidth); end; { chars_fit } begin { move_word } ic_in_word := 0; vc_in_word := 0; ablank := true; aword := true; buf_pos := internal_buf.st; while ablank and (buf_pos <= internal_buf.en) do if internal_buf.str[buf_pos] = soft_space then buf_pos := buf_pos + 1 else ablank := false; internal_buf.st := buf_pos; if buf_pos > internal_buf.en then eo_input := true else begin ic_only := true; while aword and (buf_pos <= internal_buf.en) do begin curr_char := internal_buf.str[buf_pos]; if curr_char = soft_space then aword := false else begin buf_pos := buf_pos + 1; if curr_char.length > 0 then begin vc_in_word := vc_in_word + curr_char.length; ic_only := false; end else ic_in_word := ic_in_word + 1; end; end; { while } if vc_in_word > sysvars[v].chars_in_line then error(wdlen, buf_pos - 1, input_buf.str); if chars_fit then begin move_to_output(internal_buf.st, buf_pos - 1); vc_in_line := vc_in_line + vc_in_word; ic_in_line := ic_in_line + ic_in_word; if buf_pos > internal_buf.en then eo_input := true; if vc_in_line < sysvars[v].chars_in_line then begin if not(ic_only) then begin vc_in_line := vc_in_line + 1; output_buf.en := output_buf.en + 1; output_buf.str[output_buf.en] := soft_space; end; end else eo_output := true; end else eo_output := true; end { else } end; { move_word } {********************************************************************** JUSTIFY is essentially an implementation of Findlay and Watt's text-justification algorithm (see F & W, p.238). It justifies the text in the output buffer, between the STth and right-marginth positions. **********************************************************************} Procedure justify; var i, gaps, spread, pos : posint; extraspaces : integer; begin i := output_buf.en; while output_buf.str[i] = soft_space do i := i - 1; output_buf.en := i; extraspaces := sysvars[v].rm - (output_buf.en - ic_in_line); if extraspaces > 0 then begin gaps := 0; for i := output_buf.st to output_buf.en do if output_buf.str[i] = soft_space then gaps := gaps + 1; if gaps > 0 then begin pos := output_buf.st; while pos <= output_buf.en do if output_buf.str[pos] = soft_space then begin spread := extraspaces div gaps; if spread > 0 then with output_buf.str[pos] do begin atts := [xpand]; length := spread + 1; end; { with } extraspaces := extraspaces - spread; gaps := gaps - 1; pos := pos + spread + 1; end else pos := pos + 1; end; { if } end; { if } end; { justify } {********************************************************************** This is the top level of the output-processor. CMD contains a representation of the command to be performed. NORM is the case where text is processed normally (i.e. not by explicit command). The modules described: BRK This is the break command. If the output buffer is not empty, it merely causes the output buffer to be written to the destination file. FIG If a figure is set, this errors out; otherwise, it sees if there is room remaining on the page for the figure. If so, the figure is put out immediately, if the current output line is empty. Otherwise, the figure is SET. If there isn't enough room on the current page, the figure is PENDING. INDT Causes a BRK; indents next line N-1 spaces beyond the left margin. PAG Causes a BRK; if it pages on break, does not page output file, else pages file. Ignored in non-paging mode. TSTPAG Tests if at least N lines are left on the current page, and if not, causes a BRK and a PAG. Ignored in non-paging mode. SKP Causes a BRK; puts out N * SPACING blank lines. NORM 'Normal' entry to output processor. If in filling or justification mode, an auto-paragraph is done if AP_MODE and LEAD_BLANK are set. Otherwise, the left margin is put into the output buffer, if it is empty. Then, as many words as possible are put into the output buffer, until the output buffer is full or the internal buffer is empty. If the output buffer is full, the text is then justified, if in justify mode, and shoved out. In nofill mode, the leftmargin is first put into the output buffer, and then the internal buffer is mapped into the output buffer. If the input line is blank, as deter- mined by READLINE, only a carriage return is shoved. If the length of the text in the internal buffer exceeds MAXLINEWIDTH - LM, it is truncated. **********************************************************************} {*******************************************} { } { header is located in SYSGEN file } {-------------------------------------------} { } { Procedure out_proc(cmd : commandtype); } { } { var } { i, j : posint; } { v : old_new; } { eo_input, } { eo_output : boolean; } { } {*******************************************} Procedure put_left_margin; begin output_buf.en := sysvars[new].lm - 1; output_buf.st := sysvars[new].lm; end; { put_left_margin } Procedure break; begin if output_buf.en >= output_buf.st then shove_buffer else sysvars[new].version := new; end; { break } Procedure auto_indent; begin lead_blank := false; break; putline(sysvars[new].ap_skip); n := sysvars[new].ap_indent; if (sysvars[sysvars[new].version].lm + n) > sysvars[sysvars[new].version].rm then error(aphgh, 0, input_buf.str); out_proc(indt); end; { auto_indent } begin { output processor } case cmd of brk : break; fig : if not(sysvars[new].paging) then putline(n) else if (sysvars[new].printable_lines - pageinfo.currline) < n then begin pageinfo.figure_pending := true; pageinfo.figure_size := n; end else if output_buf.st > output_buf.en then putline(n) else begin pageinfo.figure_set := true; pageinfo.figure_size := n; end; indt : begin break; vc_in_line := n; output_buf.st := sysvars[new].lm + n; output_buf.en := sysvars[new].lm + (n - 1); end; pag : begin break; if not((pageinfo.currline = 0) and sysvars[new].paging) then do_page; end; tstpag : if sysvars[new].paging and ((pageinfo.currline + n * sysvars[new].spacing) > sysvars[new].printable_lines) then begin break; if not(pageinfo.currline = 0) then do_page; end; skp : begin break; putline(n * sysvars[new].spacing); end; norm : begin v := sysvars[new].version; if sysvars[v].fill_mode <> nofilling then begin if lead_blank and sysvars[new].ap_mode then begin auto_indent; v := new; end else if output_buf.en = 0 then put_left_margin; eo_input := false; eo_output := false; while not(eo_input) and not(eo_output) do move_word(eo_input, eo_output); more_input := not(eo_input); if eo_output then begin if sysvars[v].fill_mode = justification then justify; shove_buffer; end; end else { nofilling mode } begin if not(blankline) then begin put_left_margin; i := internal_buf.st; j := output_buf.en + 1; while (i <= internal_buf.en) and (j <= maxlinewidth) do begin output_buf.str[j] := internal_buf.str[i]; i := i + 1; j := j + 1; end; { while } output_buf.en := j - 1; end; shove_buffer; end end; { norm } end; { case } end; { out_proc } ======================================================================================== DOCUMENT :usus Folder:VOL13:dot_doc.text ======================================================================================== .comment !----------------------------------! .comment ! ! .comment ! RUNON documentation ! .comment ! Dot Commands ! .comment ! ! .comment ! August 9, 1980 ! .comment ! ! .comment !----------------------------------! .page .center " ^&DOT COMMANDS\& " .justify The dot commands are divided into four types as shown in the table below. They differ in the number and type of their parameters. The parameter, or parameters, if any, must follow the command on the same line. .nofill ^&Example command Parameters\& 1. .BREAK None 2. .INDENT n One numeric parameter required 3. .PAPERSIZE m n Two numeric parameters required 4. .TITLE /text/ Text required .justify All dot commands begin with a period. They may be in upper, lower or mixed case. Commands can be abbreviated indefinitely so long as they are distinct. For example, ^^.includ, .inclu, .incl,\^ and <^.inc are all acceptable abbreviations for <^.include. Notice that <^.in is ^¬\&, because there is a conflict with the <^.indent command. The three case commands (.SAMECASE, .LOWERCASE, .UPPERCASE) affect all text in the source file, including the .CENTER and .TITLE commands. Any command errors will cause an error message to be sent to the terminal, and execution will cease. The following is a list of all current <^runon dot commands. .skip 2 .fill .center " ^&Dot commands\& " .skip 1 .comment !------------------------------------------------------! .comment ! ! .comment ! Below we make extensive use of a little trick ! .comment ! that enables us to format boxes with labels. ! .comment ! Once Runon starts forming a new output line, ! .comment ! any commands that might change the width of the ! .comment ! output line do not take effect until the line is ! .comment ! output. With the left margin set normally, the ! .comment ! label is placed into the output line. Enough ! .comment ! hard spaces are placed on the end of the label ! .comment ! to the desired left margin of the box, minus one. ! .comment ! The left margin is then changed to the desired ! .comment ! setting. Filling proceeds normally from there. ! .comment ! At the end of each box, the margin is reset. ! .comment ! Needless to say, this trick works only in filling ! .comment ! or justification mode. ! .comment ! ! .comment !------------------------------------------------------! <^.autopara######## .leftmargin 28 enables <^autoparagraph mode, in which all source file lines that begin with a space character cause a combination of a <^.skip and an <^.indent to occur. This feature is disabled in <^nofill mode. The distances to skip and indent may be respecified by using the <^.autoset command, described below. .skip 1 .test 7 .leftmargin 10 <^.autoset m n##### .leftmargin 28 sets new skip (m) and indent (n) values for use in autoparagraphing. The skip that is performed is in terms of ^&single lines\& rather than in terms of the spacing factor. The m parameter may range from 0 to 5, and n may range from 1 to the right margin setting. .skip 1 .test 5 .leftmargin 10 <^.break########### .leftmargin 28 causes the current line to be output with no justification, and places the next word of the source text at the beginning of the next line. If the current line is empty, no break is performed. .skip 1 .test 6 .leftmargin 10 <^.center /text/### .leftmargin 28 causes a <^.break, and centers the text on the line following the command in the middle of the output page as determined by the current settings of the left and right margins. If there is nothing, or only spaces, between the text delimiters, an error occurs. .skip 1 .leftmargin 10 <^.comment ...##### .leftmargin 28 the remainder of the line following this command will be ignored. .skip 1 .leftmargin 10 <^.figure n######## .leftmargin 28 leaves n blank lines free to make room for a figure or a diagram. If there are less than n lines left on the page, text continues to fill this page and the diagram is placed at the top of the next page. n can range from 2 to the number of printable lines on a page (defined as page length (usually 66 lines) minus 14 (length of top and bottom borders)). Thus, on a standard size page, the figure parameter may range from 2 to 52. .skip 1 .leftmargin 10 <^.fill############ .leftmargin 28 places as much text on the current line as can fit. This allows the use of a 'ragged-right' margin. All blank lines are discarded, as are 'redundant' spaces, i.e. more than one non-HARD SPACE in a row. .skip 1 .leftmargin 10 <^.justify######### .leftmargin 28 places as much text on the current line as can fit, like <^.fill, and then redistributes the text on the line to create a smooth right margin. As with <^.fill, blank lines and extraneous spaces are discarded. .skip 1 .leftmargin 10 <^.nofill########## .leftmargin 28 causes all text to be output 'as is,' with no filling or justification. Blank lines and spaces are output 'as is'. If a line is longer than the maximum line length minus the current left margin, it is truncated on the right end, without warning. .skip 1 .leftmargin 10 <^.samecase######## .leftmargin 28 causes all text in the source file to be taken as being in the same case as the one in which it appears. This is the default case setting. .skip 1 .testpage 4 .leftmargin 10 <^.lowercase####### .leftmargin 28 causes all text in the source file to be taken as being in lower case. This mode is useful for displays lacking lower case capability (e.g. the Apple II). To output upper case text in lower case mode, use the special characters for capitalization. To have a single upper case character (as the first letter of a sentence, for example), prefix the character with the 'quote' special character ('__'). .skip 1 .leftmargin 10 <^.uppercase####### .leftmargin 28 causes all text in the source file to be taken as being in upper case. This mode is the inverse of <^.lowercase. .skip 1 .leftmargin 10 <^.include /text/## .leftmargin 28 text is taken to be a filename. The file is opened and <^runon proceeds to process the text in the named file. When <^runon finishes that file, processing reverts to the 'interrupted' file. Any and all changes effected by included files will remain in effect. An included file may itself include another file, to a depth of five files. .skip 1 .leftmargin 10 <^.indent n######## .leftmargin 28 causes a <^.break and sets the next line to begin n spaces from the left margin. n can range from 1 to the line width (left margin minus right margin). .skip 1 .leftmargin 10 <^.leftmargin n#### .leftmargin 28 sets the left margin to be the nth column. n must be greater than zero and less than the right margin setting. .skip 1 .leftmargin 10 <^.noautopara###### .leftmargin 28 disables autoparagraph mode. Any leading spaces in the source file have no effect. .skip 1 .leftmargin 10 <^.onnumber######## .leftmargin 28 turns on page numbering. .skip 1 .leftmargin 10 <^.offnumber####### .leftmargin 28 turns off page numbering; continues to keep track of page number. .skip 1 .leftmargin 10 <^.number n######## .leftmargin 28 sets the next page number to n. .skip 1 .leftmargin 10 <^.onpage########## .leftmargin 28 enables paging of output. .skip 1 .leftmargin 10 <^.offpage######### .leftmargin 28 disables paging, titling of output. .skip 1 .testpage 5 .leftmargin 10 <^.page############ .leftmargin 28 causes a page break to occur. Ignored in non-paging mode. If this command appears twice in succession, with no intervening text or skips, the second invocation is ignored. .skip 1 .leftmargin 10 <^.papersize m n### .leftmargin 28 sets the length of the page to m lines, and sets the width to n characters. The left margin is reset to 10, and the right margin is set to the new page width minus 10. m may be no less than 20, and n is resticted to the range 30 to 132. .skip 1 .leftmargin 10 <^.rightmargin n### .leftmargin 28 sets the right margin to the nth column, with a lower limit of the left margin and an upper limit of 132. .skip 1 .leftmargin 10 <^.skip n########## .leftmargin 28 causes a <^.break and skips (n times the spacing factor) lines. If there are fewer than n lines left on the current page, output begins at the top of the next page. n may not be greater than the number of lines on the page; see <^.figure. .skip 1 .leftmargin 10 <^.spacing n####### .leftmargin 28 sets the inter-line spacing. When n is equal to 1, there are no blank lines inserted; when it equals 2 the file is output double-spaced. n may range from 1 to 5. .skip 1 .leftmargin 10 <^.standard######## .leftmargin 28 resets all settings to their default values. The values used are those listed in the Defaults section, with the exception of the case, which must be changed explicitly. .skip 1 .testpage 6 .leftmargin 10 <^.testpage n###### .leftmargin 28 used to preserve pieces of text, to insure they are not broken across page boundaries. If less than (n times spacing factor) lines remain on the current page, a page break occurs. This command is ignored in non-paging mode. .skip 1 .leftmargin 10 <^.title /text/#### .leftmargin 28 takes text to be new title of the document. This title is output at the top of each subsequent page. If there is no text, the title is set to null. .skip 3 .leftmargin 10 .justify When using a command that takes a text parameter, the text must be delimited, shown above using the "/" symbol. The delimiter is taken to be the first non-blank character following the command. If no matching right delimiter is found, an error condition results. .nofill .test 10 The following symbols may be used to delimit text: ! " _# $ % & ' ( ) * + , - . / : ; _< = > ? @ [ _\ ] _^ __ (in short, all the 'graphic' characters save the curly brackets, accent, and vertical bar). .justify The text may contain embedded special characters. See the section entitled <&Special <&Characters for more details. .skip 1 ======================================================================================== DOCUMENT :usus Folder:VOL13:errordata ======================================================================================== bad block or CRC errorillegal device # illegal i/o request data-com timeout volume went off-line file lost in directorybad file name no room on volume volume not found file not found dup directory entry file already open file not open bad input information ring buffer overflow vol write protected illegal block illegal buffer €= or ? not allowed no multiple files ð GEORGERA SETUP OUTPUT INPUT òƒ å‚N^ó£V¤ ======================================================================================== DOCUMENT :usus Folder:VOL13:err_doc.text ======================================================================================== .comment !---------------------------------! .comment ! ! .comment ! RUNON documentation ! .comment ! Error messages ! .comment ! ! .comment ! August 3, 1980 ! .comment ! ! .comment !---------------------------------! .page .center " ^&Errors and Error Messages\& " When an error occurs, the output file is locked, preserving all text processed so far. The offending line of the input file is output to the console, with a pointer to whatever was incorrect. Some messages do not point at anything. Note that errors that point to the title will have incorrect line numbers, because the title is not checked until it is time to print it out. The following is a list of the messages RUNON uses to inform the user of errors and warnings: .noautopara .skip 2 .center " <^unknown <^command " <^runon saw a period ('.') on the current command line, and could not recognize the command following it. .skip 2 .center " <^missing <^parameter " A parameter was expected after the command, but none was found. .skip 2 .center " ^^parameter out of range - too high/low\^ " The numeric parameter is incorrect. See the description of the dot-command for an explanation of the allowable range of the number. .skip 2 .center " ^^numeric parameter required\^ " Text was found where <^runon expected to find a number. .skip 2 .center " ^^bad character following lead-in\^ " <^runon could not recognize the symbol following the '_\', '_^', or '_<' as a valid command. .skip 2 .center " ^^lead-in character illegal at end of text\^ " Using a lead-in character across line boundaries is not allowed. .skip 2 .testpage 3 .center " ^^text wider than margins allow\^ " The piece of text that you are trying to center is too long. .skip 2 .testpage 4 .center " ^^title wider than paper width\^ " The program could not fit the title onto the page, because it was too long for the current paper width. .skip 2 .testpage 3 .center " ^^paper length too short\^ " Paper can be a minimum of 20 lines long. .skip 2 .center " ^^paper too wide\^ " Paper can be a maximum of 132 columns wide. .skip 2 .center " ^^paper width less than right margin\^ " This is a no-no. .skip 2 .center " ^^word too long for present line\^ " The word is too long to fit on one line. You can either change the margins or use a smaller word. .skip 2 .center " ^^figure already set or pending\^ " While RUNON was waiting for a new page so that it could output a pending figure, a request for a new figure came up. Move the FIGURE command down in the file. .skip 2 .center " ^^non-unique abbreviation\^ " The command was too short for <^runon to discern it from other commands. Try a longer abbreviation. .skip 2 .center " ^^file already included\^ " You attempted to include a file that was still in use. This is not allowed because it would lead to an infinite recursion. .skip 2 .center " ^^include file i/o error\^ " Something is not right with the file you tried to include. Either it does not exist or the volume name is incorrect. .skip 2 .center " ^^too many include files\^ " Too many files were active at one time. There is a maximum of five nested levels of include files simultaneously. .skip 2 .center " ^^auto-indent out of range - too low\^ " The minimum setting of the indent parameter is 1. .skip 2 .testpage 3 .center " ^^auto-indent out of range - too high\^ " The auto-indent parameter exceeded the right margin. Note that the line and line number that get printed out are essentially meaningless, in that they indicate the line that <&triggered the auto-paragraph, and <¬ the one that originally set the incorrect parameter. .skip 2 .testpage 3 .center " ^^command error\^ " The command parser found unrecognizable junk on the line. .skip 2 .testpage 3 .center " ^^illegal delimiter for text parameter\^ " The delimiter is not a member of the set of legal text delimiters. Refer to the section on dot commands for more information. .skip 2 .center " ^^missing delimiter for text parameter\^ " <^runon could not find a matching right delimiter for the indicated one. .skip 2 .center " ^^attempt to center non-existent text\^ " The text you centered contained nothing. Don't do that. .standard ======================================================================================== DOCUMENT :usus Folder:VOL13:fit.text ======================================================================================== (*$L-printer:*) program fit; {federal income tax program} { by edward heyman } { 300 center hill rd centerville de 19807 } {keyed in from Feb 1982 Byte by George Schreyer } {From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman appearing in the Feburary 1982 issue of Byte magazine. Copyright 1982 Byte Publications, Inc. Used with permission of Byte Publications, Inc.} {This program is not EXACTLY the original, it has been patched is several places. Specifically, some of the data in TAXTABLE.TEXT has been changed} const maxline = 115; maxtline = 66; minaline = 67; maxaline = 107; minbline = 108; maxbline = 115; esc = 27; type longint = integer [ 9 ]; filename = string [ 15 ]; intstr = string [ 12 ]; namestr = string [ 26 ]; filing_status = 0..5; tline_num = 1..maxline; tlineset = set of tline_num; owner = (h_own, w_own, t_own ); pointer = ^item; item = packed record nptr : pointer; name : string[ 10 ]; amt : integer [ 9 ]; whose : owner; tlnum : tline_num; end; tline = packed record case tag : integer of 1 : (iptr : pointer; hus : integer [ 9 ]; wif : integer [ 9 ]; tot : integer [ 9 ]); 2 : (d1, d2, d3 : integer; taxyear : string [ 4 ]; fs : filing_status; exem : integer ); 3 : (name : namestr ); end; tls = packed array [ 1..maxline ] of tline; taxtable = ( x, y, ys, z ); taxfactors = ( lower, upper, base, percent ); factorarray = array [ 1..16, taxfactors ] of longint; var ch : char; ttable : taxtable; fstat : filing_status; screen, single, same, quit : boolean; day, month, year : integer; specset, dlineset, slineset, spageset, calcset : tlineset; taxray : array [ taxtable ] of factorarray; titles : array [ 1..maxline ] of string [ 30 ]; tlines : tls; max_tax : array [ owner ] of longint; p : file of char; procedure mem; forward; function readint ( len : integer ) : integer; forward; procedure clear; forward; procedure eline; forward; procedure eeol; forward; procedure eeos; forward; procedure wait; forward; procedure pdol ( dol : longint; var stdol : intstr ); forward; procedure center ( st : string; screen : boolean ); forward; procedure readdol ( len : integer; var dolread : longint ); forward; procedure namer ( title : namestr; var st : string; l : integer ); forward; procedure line ( ch : char; long : integer ); forward; (*$I taxstart.text*) (*$I taxrw.text*) (*$I taxprint.text*) (*$I taxcalc.text*) (*$I taxedit.text*) procedure mem; begin writeln ( 'memory available ',memavail ); end; procedure line (* ch : char; long : integer *); var j : integer; begin for j := 1 to long do write ( p, ch ); end; procedure namer (* title : namestr; var st : string; l : integer *); {used to permit string data input TITLE is a prompt, L is the max length of the returned string} begin repeat gotoxy ( 0, 6 ); write ( 'enter ',title,' --> ' ); eeol; readln ( st ); if ( length ( st ) ) > l then begin write ( 'name cannot exceed ', l, ' characters' ); wait; gotoxy ( 0, 7 ); eeol; end; until length ( st ) <= l; writeln; end; function readint (* len : integer ) : integer *); {a long winded routine to allow input of an inter of len digits } const period = '.'; plus = '+'; minus = '-'; dol = '$'; bs = 8; lf = 10; ff = 12; cr = 13; del = 127; space = 32; var charray : array [ 1..10 ] of char; readinteger : integer; position : 1..9; neg : boolean; digits : set of char; begin {readint} digits := [ '0'..'9' ]; for position := 1 to len do write ( '_' ); for position := 1 to len do write ( chr ( bs ) ); position := 1; while position = 1 do begin read ( keyboard, charray [ position ] ); if charray [ position ] in ( digits + [ plus, minus ] ) then begin write ( charray [ position ] ); position := succ ( position ); end; end; while position <= len do begin read ( keyboard, charray [ position ] ); if charray [ position ] in digits then begin write ( charray [ position ] ); position := succ ( position ); end else begin if charray [ position ] = chr ( bs ) then begin write ( chr ( bs ) ); position := pred ( position ); end; if ( charray [ position ] in [ chr ( space ), chr ( cr ) ] ) then len := pred ( position ); end; end; readinteger := 0; if charray [ 1 ] = minus then neg := true else neg := false; for position := 1 to len do begin if charray [ position ] in digits then readinteger := 10 * readinteger + ord ( charray [ position ] ) - ord ( '0' ); end; if neg then readint := -readinteger else readint := readinteger; end; {readint} procedure eeos; {erase to end of screen} begin write ( chr ( 27 ), 'J' ); {for H-19} end; procedure clear; {clear to end of screen} begin gotoxy ( 0, 0 ); eeos; end; procedure eline; {erase entire line} begin write ( chr ( 27 ) , 'l' ); {for H-19} end; procedure eeol; {erase to end of line} begin write ( chr ( 27 ), 'K' ); {for H-19} end; procedure wait; {routine used to halt program while user examines output} var ch : char; begin gotoxy ( 10, 23 ); write ( 'enter to continue' ); repeat read ( keyboard, ch ); until ( ch = chr ( 32 ) ) and ( not eoln ( keyboard ) ); end; procedure center; {routine to print a string in the center of the line} var x, y : 0..132; ch : char; begin ch := ' '; if screen then y := 40 else y := 66; x := y - ( length ( st ) div 2 ); writeln ( ch:x, st ); end; procedure pdol (*dol : longint; var stdol : intstr *); begin str ( dol, stdol ); insert ( '.', stdol, pred ( length ( stdol ) ) ); end; procedure readdol (* len integer; var dolread : longint *); {routine to permit entry of long integer of len digits} const bs = 8; plus = '+'; minus = '-'; var position : 1..10; neg : boolean; esc : char; charray : array [ 1..10 ] of char; digits : set of char; begin {readdol} same := false; quit := false; digits := [ '0'..'9' ]; esc := chr ( 27 ); for position := 1 to len do write ( '_' ); for position := 1 to len do write ( chr ( bs ) ); position := 1; repeat read ( keyboard, charray [ position ] ); until ( charray [ position ] in digits + [ plus, minus, esc, 'Q', 'q' ] ); if ( charray [ position ] = esc ) or ( charray [ position ] in [ 'q','Q' ] ) then if ( charray [ position ] ) in [ 'q', 'Q' ] then begin quit := true; exit ( readdol ); end else begin same := true; exit ( readdol ); end else begin write ( charray [ position ] ); position := succ ( position ); end; while position <= len do begin repeat read ( keyboard, charray [ position ] ); until ( charray [ position ] in ( digits + [ '.', chr ( bs ) ] ) ); if ( charray [ position ] in digits ) then begin write ( charray [ position ] ); position := succ ( position ); end else begin if charray [ position ] = chr ( bs ) then begin write ( chr ( bs ) ); position := pred ( position ); end; if ( charray [ position ] = '.' ) then begin write ( '.' ); len := succ ( position ); end; end; end; dolread := 0; if charray [ 1 ] = minus then neg := true else neg := false; for position := 1 to len do if ( charray [ position ] in digits ) then dolread := 10 * dolread + ord ( charray [ position ] ) - ord ( '0' ); if neg then dolread := -dolread; end; {readdol} begin {fit main} start; writeln; mem; wait; repeat; clear; write ( 'fit command --> P)rint E(dit C(alculate R(read W(rite Q(uit '); repeat read ( keyboard, ch ); until ( ch in [ 'p','P','e','E','c','C','r','R','w','W','q','Q' ] ); case ch of 'E','e' : edit; 'R','r' : begin rw ( 'R' ); fstat := tlines [ 7 ].fs; if fstat in [ 2, 3 ] then single := false; end; 'W','w' : rw ( 'W' ); 'P','p' : printer; 'C','c' : calculate; end; until ch in [ 'Q', 'q' ]; end. {fit main } ======================================================================================== DOCUMENT :usus Folder:VOL13:howto_doc.text ======================================================================================== .comment !---------------------------------! .comment ! ! .comment ! RUNON documentation ! .comment ! Front end ! .comment ! ! .comment ! August 3, 1980 ! .comment ! (Revised February 6, 1981) ! .comment ! ! .comment !---------------------------------! .skip 2 .center " ^^^&running the program\^\& " At the system monitor level, type X (execute), followed by the volume name (if needed) and <^runon. <^runon replies: .nofill <^runon Text Processor [V2] Input file: .justify Let's assume that we have a file named <^foo.text that we want to format. If we type .skip 1 Input file: <&FOO#### .leftmargin 30 will cause <^runon to append <^.text to the name FOO and open the file with that name. If the file is not found, an error message results. Do <¬ supply the <^.text yourself! .leftmargin 10 .nofill If RUNON accepts your file, it replies: .justify Output file:####### .leftmargin 30 if you enter a carriage return at this point, the program appends '/' to the beginning of the input file name, <^.text to the end, and uses the resulting name for the output file. Typing another name at this point, <^fred for example, causes <^runon to use that name for the output file, with a <^.text appended, of course. .leftmargin 10 <^runon will also allow the use of non-.TEXT files for input and output. This feature allows you to completely specify the exact file name(s), overriding any characters that might be appended to it. We may do this by placing a period ('.') at the end of the file name. For example, .nofill Input file: <&<^foo.baz. Output file: <&<^fred. .justify opens <^foo.baz for input and <^fred for output. The period option may be used on the input file name, output file name, or both. .testpage 6 <^runon also allows you to enter both names on a single line. When the program prompts you for an input file, you can enter two file names, seperated by a comma. This suppresses the output file prompt. Typing one filename, followed by a comma and nothing else is the same as typing a carriage return to the output file prompt, as in the first example. .skip 1 .center " <&Examples " .nofill Input file: <&HARRY Output file: _ opens HARRY.TEXT for input, and /HARRY.TEXT for output. Input file: <&HARRY, same effect as above. Input file: <&SAM Output file: <&MARY opens SAM.TEXT for input, MARY.TEXT for output. Input file: <&<^alfred. Output file: _ opens <^alfred for input, <^/alfred for output. Input file: <&<^alfred., same as above Input file: <&<^donna Output file: <^<&alfonzo.memo. opens <^donna.text for input and <^alfonzo.memo for output. .justify And finally, what happens if the file name is too long to add a '/' to it? The answer is that <^runon will add the '/' and then truncate the name to the proper length. For example, .nofill Input file: <&<^toolongname, opens <^toolongnam.text for input and <^/toolongna.text for output. .justify Under no circumstances will <^runon create a filename with more than 15 characters, excluding the volume name, which may be a maximum of seven characters long. If we type .nofill Input file: <^<&toolongname.,anothername. .justify RUNON opens <^toolongname and <^anothername as input and output files, respectively. Note that an entire file name must be specified for input, but only a volume name need be specified on output if the output file is not a block-structured device (e.g. PRINTER:, REMOUT:, etc.). There is no need to suffix it with a period to inhibit the <^.text. For example: .nofill Input file: <&<^zap Output file: <&<^printer: opens ZAP.TEXT for input and PRINTER: (system printer) for output. .justify After <^runon has accepted the files for processing, it will print the names of the input and output files, i.e. .nofill mydisk:letter.text --> mydisk:/letter.text .justify <^runon will also output the names of any .^^include\^d files to the <^console: as it encounters them. ======================================================================================== DOCUMENT :usus Folder:VOL13:initc.text ======================================================================================== {********************************************************************** INIT_CONST initializes all variables that remain constant throughout program execution. These variables are true system constants. **********************************************************************} Procedure init_const; var i : posint; Procedure init_cmd_strings; begin cmd_strings[ autop ] := 'AUTOPARA '; cmd_strings[ autset ] := 'AUTOSET '; cmd_strings[ brk ] := 'BREAK '; cmd_strings[ cntr ] := 'CENTER '; cmd_strings[ cmnt ] := 'COMMENT '; cmd_strings[ fig ] := 'FIGURE '; cmd_strings[ fil ] := 'FILL '; cmd_strings[ indt ] := 'INDENT '; cmd_strings[ inclu ] := 'INCLUDE '; cmd_strings[ justfy ] := 'JUSTIFY '; cmd_strings[ lmar ] := 'LEFTMARGIN '; cmd_strings[ lower ] := 'LOWERCASE '; cmd_strings[ noauto ] := 'NOAUTOPARA '; cmd_strings[ nofil ] := 'NOFILL '; cmd_strings[ num ] := 'NUMBER '; cmd_strings[ offnum ] := 'OFFNUMBER '; cmd_strings[ offpag ] := 'OFFPAGE '; cmd_strings[ onnum ] := 'ONNUMBER '; cmd_strings[ onpag ] := 'ONPAGE '; cmd_strings[ pag ] := 'PAGE '; cmd_strings[ papsiz ] := 'PAPERSIZE '; cmd_strings[ rmar ] := 'RIGHTMARGIN '; cmd_strings[ same ] := 'SAMECASE '; cmd_strings[ skp ] := 'SKIP '; cmd_strings[ spc ] := 'SPACING '; cmd_strings[ std ] := 'STANDARD '; cmd_strings[ tstpag ] := 'TESTPAGE '; cmd_strings[ til ] := 'TITLE '; cmd_strings[ upper ] := 'UPPERCASE '; end; { init_cmd_strings } begin { init_const } init_cmd_strings; with std_vals do begin version := new; fill_mode := justification; paging := true; numbering := true; ap_mode := true; lm := 10; rm := 70; ap_indent := 5; ap_skip := 1; paper_width := 80; paper_length := 66; chars_in_line := rm - lm + 1; printable_lines := paper_length - bordersize; spacing := 1; end; { with } with blank_string do begin st := 1; en := 0; for i := 1 to maxlinewidth do str[i] := blank_char; end; with soft_space do begin ch := blank_char; malleability := soft; length := 1; atts := []; end; { with } with blank_buf do begin st := 1; en := 0; for i := 1 to maxlinewidth do str[i] := soft_space; end; { with } hard_space := soft_space; hard_space.malleability := hard; numbers := [zero..nine]; act_cmds := [brk..nofil]; text_cmds := [cntr..inclu]; text_delims := ['!'..'/'] + [':'..'@'] + ['['..'_']; leadin_chars := ['^', '\', '<', '_']; lock_ops := ['&', '^']; word_ops := ['&', '^']; space_chars := [blank_char, pound]; delim_chars := [chr(1)..chr(32)] + [pound]; uc_letters := [uca..ucz]; lc_letters := [lca..lcz]; bs := chr(8); end; { init_const } {********************************************************************** INIT_VARS initializes all system variables that can change during program execution. **********************************************************************} Procedure init_vars; var i : posint; begin sysvars[new] := std_vals; sysvars[old] := std_vals; with pageinfo do begin currline := 0; currpage := 2; figure_set := false; figure_pending := false; figure_size := 0; title := blank_string; end; internal_buf := blank_buf; output_buf := blank_buf; n := 0; m := 0; global_case := []; lock_status := []; lead_blank := false; blankline := false; dot_command := false; more_input := false; vc_in_line := 0; ic_in_line := 0; ln_number := 0; with file_stack do begin ptr := 0; for i := 1 to max_files do with stack[i] do begin name := nul; line := 0; in_buf := blank_string; end; end; { with } end; { init_vars } {********************************************************************** Error procedure. This routine accepts a parameter of type ERRORTYPE, and prints the corresponding error message on the user's terminal, preceded by the line number of the source line in which the error occurred, and followed by the offending line itself. It is assumed that ERR_POS has been set to the position of the offending item. The routine then closes all open files, and executes an EXIT(RUNON), which ends RUNON execution. ***********************************************************************} Procedure error(err_msg : errortype; err_ptr : posint; err_buf : line_of_chars); var i : posint; Procedure print1; begin case err_msg of badcmd : writeln('Unknown command'); tooshrt : writeln('Paper length too short'); toowide : writeln('Paper width too wide'); toonrrw : writeln('Paper width less than right margin'); badsym : writeln('Bad character following lead-in'); argmsng : writeln('Missing parameter'); nonnum : writeln('Numeric parameter required'); toolow : writeln('Parameter out of range - too low'); toohgh : writeln('Parameter out of range - too high'); tilwide : writeln('Title wider than paper width'); cntwide : writeln('Text wider than margins allow'); figbad : writeln('Figure already set or pending'); end { case } end; { print1 } Procedure print2; begin case err_msg of wdlen : writeln('Word too long for present line'); dblnam : writeln('Non unique abbreviation'); incerr : writeln('File already included'); filerr : writeln('Include file I/O error'); nesdep : writeln('Too many include files'); aplow : writeln('Auto-indent out of range - too low'); aphgh : writeln('Auto-indent out of range - too high'); cmderr : writeln('Command error'); baddelm : writeln('Illegal delimiter for text parameter'); dlmmsng : writeln('Missing delimiter for text parameter'); endlead : writeln('Lead-in character illegal at end of line'); badcnt : writeln('Attemp to center non-existent text'); end; { case } end; { print2 } begin { error } writeln; writeln('ERROR IN LINE ', ln_number:5, ' : '); if err_msg in [badcmd..figbad] then print1 else print2; writeln(err_buf); if err_ptr > 0 then begin for i := 1 to (err_ptr - 1) do write(blank_char); writeln('^'); end; writeln; close(s0); for i := 1 to file_stack.ptr do case i of 1 : close(s1); 2 : close(s2); 3 : close(s3); 4 : close(s4); 5 : close(s5); end; { case } close(dest, lock); exit(RUNON); { so, it's ugly... } end; { error } {********************************************************************** CENTER_BUFFER centers the text found in the ALINE buffer between the parameters LMARG and RMARG. The text is presumed to be left justified in ALINE upon entry to this procedure. The .ST and .EN pointers are changed to point to the centered text. CENTER_BUFFER is called on by PUT_TITLE and TEXT_CMNDS to center the title, and for the .CENTER command. **********************************************************************} Procedure center_buffer(var aline : buffer; lmarg, rmarg : posint; err_pos : posint; err_code : errortype); var textlen, width, offset, i : posint; begin width := rmarg - lmarg + 1; textlen := aline.en; if textlen > width then begin if err_code = tilwide then error(err_code, err_pos, pageinfo.title.str) else error(err_code, err_pos, input_buf.str); end; offset := ((width - textlen) div 2) - 1; for i := textlen downto 1 do aline.str[i + offset + lmarg] := aline.str[i]; aline.st := offset + lmarg + 1; aline.en := offset + lmarg + textlen; for i := (offset + lmarg) downto 1 do aline.str[i] := soft_space; end; { center_buffer } {********************************************************************** SCANNER parses the IN_BUF, placing the 'image' of the line into the OUT_BUF. It processes the special symbols ( ^&, etc.), removes them from the text, and gives each character 'attributes' based on previous occurrences of the special symbols. Note that only quoted characters, and normal (i.e. non-delimiter, non- control) characters have attributes. Further, note that quoted characters may only have U_LINE as an attribute, and that if normal characters do not have case attributes, they assume what- ever global case attribute is in effect as set by the case dot commands, or the default setting. A subprocedure, INTERN, is used to put each character into the internal buffer, setting the print-out length of the character, 'malleability' (both used in the justification process), and the attributes. Note that ASCII control characters are INTERNed with zero length, in order to allow them to be justified 'unnoticed'. **********************************************************************} Procedure scanner( st_pos, en_pos : posint; in_buf : line_of_chars; var out_buf : buffer ); var current_char : char; current_atts : attrib_set; char_num : posint; quote, word_on, lock_on, lock_off : boolean; word_status : attrib_set; Procedure intern(curr_ch : char; density : hard_soft; len : posint; ats : attrib_set ); begin out_buf.en := out_buf.en + 1; with out_buf.str[out_buf.en] do begin ch := curr_ch; malleability := density; length := len; atts := ats end { with } end; { intern } begin { scanner } quote := false; word_on := false; lock_on := false; lock_off := false; word_status := []; For char_num := st_pos to en_pos do begin current_char := in_buf[char_num]; current_atts := word_status + lock_status; if quote then begin intern(current_char, hard, 1, current_atts - [u_case, l_case]); quote := false; end else If word_on then begin if current_char in word_ops then case current_char of '&' : word_status := word_status + [u_line]; '^' : word_status := word_status + [u_case]; end else error(badsym, char_num, in_buf); word_on := false; end else If lock_on then begin if current_char in lock_ops then case current_char of '&' : lock_status := lock_status + [u_line]; '^' : lock_status := lock_status + [u_case]; end else error(badsym, char_num, in_buf); lock_on := false; end else If lock_off then begin if current_char in lock_ops then case current_char of '&' : lock_status := lock_status - [u_line]; '^' : lock_status := lock_status - [u_case]; end else error(badsym, char_num, in_buf); lock_off := false; end else If current_char in leadin_chars then case current_char of '^' : lock_on := true; '\' : lock_off := true; '<' : word_on := true; '_' : quote := true end else If current_char in delim_chars then begin word_status := []; If current_char in space_chars then begin if current_char = pound then intern(blank_char, hard, 1, []) else intern(blank_char, soft, 1, []); end else { ctrl chars } intern(current_char, hard, 0, []); end else begin if (current_atts - [u_case, l_case]) = current_atts then current_atts := current_atts + global_case; intern(current_char, hard, 1, current_atts); end; end; { for } if quote or word_on or lock_on or lock_off then error(endlead, en_pos, in_buf); end; { scanner } ======================================================================================== DOCUMENT :usus Folder:VOL13:intro_doc.text ======================================================================================== .COMMENT !---------------------------------! .COMMENT ! ! .COMMENT ! RUNON DOCUMENTATION ! .COMMENT ! INTRODUCTION ! .COMMENT ! ! .COMMENT ! AUGUST 3, 1980 ! .COMMENT ! ! .COMMENT !---------------------------------! .LOWERCASE .NUMBER 1 .PAGE .CENTER "<&<^INTRODUCTION" <^RUNON IS A "DOCUMENT PROCESSOR" - THAT IS, A PROGRAM THAT ALLOWS EASY FORMATTING OF TEXT, I.E. TERM PAPERS, LETTERS, ETC. _THE TEXT MAY BE FORMATTED TO YOUR SPECIFICATION BY SIMPLY INSERTING <^RUNON COMMANDS AND A FEW SPECIAL CHARACTERS INTO THE TEXT WHEN IT IS ENTERED INTO THE COMPUTER. _THE TEXT IS TYPICALLY PLACED IN A FILE USING A TEXT EDITOR. _WHEN <^RUNON HAS PROCESSED THE TEXT, THE RESULTING DOCUMENT CAN BE STORED IN ANOTHER FILE, OR SENT TO THE PRINTER OR SIMILAR DEVICE. .SKIP 2 .CENTER " ^^^&SOURCE FILE\^\& " _THE SOURCE FILE CONSISTS OF THE RAW TEXT THAT IS TO BE FORMATTED PLUS THE <^RUNON COMMANDS INSERTED IN THE TEXT. _THE <^RUNON COMMANDS IN THE SOURCE FILE DO NOT APPEAR IN THE FINAL DOCUMENT. _THERE ARE TWO GENERAL TYPES OF <^RUNON COMMANDS. _THESE ARE KNOWN AS "DOT COMMANDS" AND "SPECIAL CHARACTERS." _THE DOT COMMANDS ARE PREFIXED WITH A PERIOD, AND MUST START IN THE FIRST COLUMN OF A LINE. _MULTIPLE DOT COMMANDS MAY APPEAR ON A LINE. _THERE ARE CURRENTLY EIGHT SPECIAL CHARACTER SEQUENCES THAT HAVE MEANING TO <^RUNON. _THESE CHARACTERS CONTROL SPACING, CASE AND UNDERLINING. _THEY MAY APPEAR ANYWHERE IN THE TEXT, AND IN PARTICULAR, PREFIXED TO A WORD. _OTHER THAN CERTAIN RESTRICTIONS PLACED ON DOT COMMANDS, THE TEXT MAY BE ENTERED FREELY WITHOUT WORRYING ABOUT SPACING OR LINE WIDTHS. _THE MAIN RESTRICTION IS THAT A PERIOD MAY NOT OCCUR IN THE FIRST COLUMN OF A LINE UNLESS IT IS PREFIXED TO A VALID DOT COMMAND. _UNLESS OTHERWISE SPECIFIED, THE TEXT WILL APPEAR IN THE OUTPUT FILE IN THE SAME CASE IN WHICH IT WAS ENTERED, E.G. LOWER CASE WILL APPEAR AS LOWER CASE. _CONTROL CHARACTERS WILL BE OUTPUT AS NON-PRINTING CHARACTERS IN THE FORMATTED FILE, AND WILL HAVE NO EFFECT ON THE JUSTIFICATION. _N._B. <^RUNON IS A SOPHISTICATED TEXT PROCESSOR WRITTEN IN A HIGH-LEVEL LANGUAGE, AND AS SUCH IS MUCH SLOWER THAN MACHINE-LANGUAGE TEXT PROCESSORS. _HOWEVER, IT IS FAR MORE POWERFUL, MORE MODULAR, AND MORE EXTENSIBLE THAN ANY SUCH LOW-LEVEL PROCESSOR. _WHEN DOING DISK-TO-DISK PROCESSING ON AN <^APPLE <^II, THE PROGRAM RUNS AT A RATE OF ABOUT 1-1/2 MINUTES PER PAGE IN JUSTIFICATION MODE. _ON A _WESTERN _DIGITAL _MICROENGINE (TM), THE PROCESSING RATE IS APPROXIMATELY 20 SECONDS PER PAGE. _ONE WAY TO INCREASE THE PROGRAM'S 'BANDWIDTH,' AS IT WERE, IS TO OUTPUT DIRECTLY TO <^PRINTER: OR <^REMOUT: OR WHATEVER YOU USE FOR HARDCOPY; <^RUNON IS QUITE CAPABLE OF DRIVING MOST PRINTERS AS FAST AS THEY WILL GO. .SAMECASE ======================================================================================== DOCUMENT :usus Folder:VOL13:main.text ======================================================================================== {********************************************************************** READ_FIL_NAMES as it's name implies, reads an input and output file name from the user's terminal. The two names can be seperated by a comma, or a carriage return. If the comma is not followed by a name, or the output file name prompt is given a carriage return, the output name defaults to the input name, and a slash is prefixed to the front. If either or both names are followed by a period, no extensions are added to the end of that name. Otherwise, the extension .TEXT is added to the name. In the case of the default output name, the exten- sion depends upon whether the input name has been followed by a period. If only a volume name is provided for the output name, it need not be followed by a period to inhibit the extension, as this is checked for. If either the file name, or a volume name prefix are too long, (see UCSD Pascal manual) they are truncated without warning. The same is true when adding the .TEXT extension, or the default prefix. When the file names have been formed, they are checked for bad char- acters, and the existance of the appropiate disk files and volume names. An input name must contain a file name, and certain volume names are illegal. The output name need not contain a file name, that is to say, it need only contain a volume name such as PRINTER:. Any output volume name is acceptable so long as it is on line. Any errors resulting from the above operations cause an error message to be sent to the terminal, and the input sequence is started again. READ_FIL_NAMES is exited when the file names are succesfully read, or a blank input name is entered, or the EOF character (ctrl-C) is entered any time during the the input sequence. TEST_FILE tests for the existance of the file name and/or volume name provided. STRIP_SPACES strips any and all spaces out of the file name provided. BAD_CHARS_IN tests if any characters occur in the file name that are not in the set of characters provided. If there are any, they are bad characters. TEST_NAME tests and truncates the length of the volume name, and the file name. To the length of the file name are added the lengths of the default prefix, and the extension, if any. Bad characters are tested for, and on the input name, the volume name if any is compared to the list of illegal volume names. The volume name, file name, and prefix, and extension are then concatenated toegether. MAKE_NAME calls TEST_NAME with the appropiate parameters after deciding if the name passed it is suffixed with a period. ***********************************************************************} Procedure read_fil_names(var in_name, out_name : string; var empty : boolean); const filenamelen = 15; volnamelen = 7; suffix = '.text'; prefix = '/'; inp_delim = ','; vol_delim = ':'; nul = ''; star = '*'; type warningtype = (clear, badinp, badvol, badfil, volerr, filerr, illopp); file_type = (inp, out); char_set = set of char; err_set = set of 1..10; var inp_string : string; delim_pos : posint; fil_chars, vol_chars : char_set; inp_errs, out_errs : err_set; warning : warningtype; err_name : string; default : boolean; Procedure test_file(f_name : string; err_codes : err_set); var error : posint; Function file_status(f_name : string) : posint; begin {$I-} reset(f, f_name); file_status := ioresult; close(f); {$I+} end; { file_status } begin { test_file } error := file_status(f_name); if error in err_codes then case error of 3 : warning := illopp; 9 : warning := volerr; 10 : warning := filerr; end; end; { test_file } Procedure strip_spaces(var astring : string); var blank_pos : posint; begin blank_pos := pos(blank_char, astring); while blank_pos > 0 do begin delete(astring, blank_pos, 1); blank_pos := pos(blank_char, astring); end; end; { strip_spaces } Function bad_chars_in(astring : string; good_chars : char_set) : boolean; var char_pos : posint; illegal_char : boolean; begin char_pos := 1; illegal_char := false; while (char_pos <= length(astring)) and (not illegal_char) do begin if not(astring[char_pos] in good_chars) then illegal_char := true else char_pos := char_pos + 1; end; bad_chars_in := illegal_char; end; { bad_chars_in } Procedure test_name(var f_name : string; prefix, suffix : string; fil_type : file_type); var vol_id, fil_id : string; add_len, vol_pos : integer; begin add_len := length(suffix) + length(prefix); vol_pos := pos(vol_delim, f_name); vol_id := copy(f_name, 1, vol_pos - 1); fil_id := copy(f_name, vol_pos + 1, length(f_name) - vol_pos); if length(vol_id) > volnamelen then vol_id := copy(vol_id, 1, volnamelen); if length(fil_id) > (filenamelen - add_len) then fil_id := copy(fil_id, 1, filenamelen - add_len); if bad_chars_in(vol_id, vol_chars) then warning := badvol else if bad_chars_in(fil_id, fil_chars) then warning := badfil else if (length(fil_id) = 0) and (fil_type = inp) then warning := badinp else if (fil_type = inp) and ((vol_id = '#1') or (vol_id = '#2') or (vol_id = 'remin') or (vol_id = 'remout') or (vol_id = 'console') or (vol_id = 'printer') or (vol_id = 'keyboard')) then warning := illopp else if vol_id <> nul then begin if (vol_pos = length(f_name)) and (fil_type = out) then f_name := concat(vol_id, vol_delim) else f_name := concat(vol_id, vol_delim, prefix, fil_id, suffix); end else f_name := concat(prefix, fil_id, suffix); end; { test_name } Procedure make_name(var fil_name : string; prefix, suffix : string; fil_type : file_type; dsk_errs : err_set); var nam_len : posint; begin nam_len := length(fil_name); if fil_name = dot then warning := badinp else if fil_name[nam_len] = dot then begin delete(fil_name, nam_len, 1); test_name(fil_name, prefix, nul, fil_type) end else test_name(fil_name, prefix, suffix, fil_type); if warning = clear then test_file(fil_name, dsk_errs); end; { make_name } begin { read_fil_names } empty := false; inp_errs := [3, 9, 10]; out_errs := [3, 9]; fil_chars := ['a'..'z'] + ['A'..'Z'] + ['0'..'9'] + ['-', '/', '\', '_', '.']; vol_chars := fil_chars + [pound] + [star]; repeat in_name := nul; out_name := nul; err_name := 'INPUT'; warning := clear; default := false; write('Input file: '); readln(inp_string); strip_spaces(inp_string); if (inp_string = nul) or eof(input) then empty := true else begin delim_pos := pos(inp_delim, inp_string); if delim_pos = 0 then begin in_name := inp_string; write('Output file: '); readln(inp_string); strip_spaces(inp_string); if eof(input) then empty := true else if inp_string = nul then begin default := true; out_name := in_name; end else out_name := inp_string; end else if delim_pos = 1 then warning := badinp else begin in_name := copy(inp_string, 1, delim_pos - 1); out_name := copy(inp_string, delim_pos + 1, length(inp_string) - delim_pos); if out_name = nul then begin default := true; out_name := in_name; end; end; if (warning = clear) and (not empty) then begin make_name(in_name, nul, suffix, inp, inp_errs); if warning = clear then begin err_name := 'OUTPUT'; if default then make_name(out_name, prefix, suffix, out, out_errs) else make_name(out_name, nul, suffix, out, out_errs); end; end; if warning <> clear then begin writeln; write('ERROR IN ', err_name, ' FILE SPECIFICATION : '); case warning of badinp : writeln('No file name supplied'); badvol : writeln('Illegal character in volume name'); badfil : writeln('Illegal character in file name'); volerr : writeln('No such volume on line'); filerr : writeln('No such file on disk'); illopp : writeln('Illegal volume name'); end; { case } writeln; end; end; { if } until (empty or (warning = clear)); end; { read_fil_names } {********************************************************************** FRONT_END is RUNON's driver. It consists of a single loop that repeats until the user types EOF (^C) at the terminal. The file names are read, the system global variables are then initialized, and the input file is processed. **********************************************************************} Procedure front_end; var empty_name : boolean; begin { front end ( user interface and main loop ) } init_const; repeat writeln; read_fil_names(file_in, file_out, empty_name); writeln; if not empty_name then begin init_vars; reset(s0, file_in); rewrite(dest, file_out); writeln(file_in, ' --> ', file_out); writeln; process_file(s0, false); close(s0); close(dest, lock); end; until eof(input); end; { front end } {********************************************************************** Main program. Prints a greeting at the user's terminal, and calls FRONT_END. **********************************************************************} begin {* main program *} writeln; writeln('RUNON Text Formatter [', version_number, ']'); front_end; end { program }. ======================================================================================== DOCUMENT :usus Folder:VOL13:pdate.text ======================================================================================== (*$S+*) (*$I globals*) (* You will need the globals from volume 8 to compile this unit. *) (* If you have a small interpreter, you may need it also as the globals eat the symbol table alive. *) (* George Schreyer *) (*$L+*) (*$D+*) separate unit puts_date ; interface procedure set_prefix ( prefix_volume : vid ); procedure eeos; procedure eeol; procedure p_date ( date : daterec ) ; procedure get_date ( var date : daterec ); implementation procedure set_prefix (*prefix_volume : vid*); begin dkvid := prefix_volume; end; procedure eeos; begin clearscreen; end; procedure eeol; begin clearline; end; procedure get_date (*var date : daterec *); begin date := thedate; end; procedure p_date (*date : daterec *); begin thedate := date; end; end; begin end. ======================================================================================== DOCUMENT :usus Folder:VOL13:readln.text ======================================================================================== {********************************************************************** READLINE clears the input and internal buffers, and then reads a line of up to MAXLINEWIDTH characters from the input file. If the line is too long, it is truncated. . ST and .EN are set to the beginning and end of text, respectively. If the line is empty, or begins with a dot (period) or a space, an appropriate Boolean flag is set. **********************************************************************} Procedure readline; var all_blanks : boolean; pos : integer; begin input_buf := blank_string; internal_buf := blank_buf; all_blanks := true; blankline := false; dot_command := false; lead_blank := false; pos := 0; while not(eoln(source)) and (pos < maxlinewidth) do begin pos := pos + 1; input_buf.str[pos] := source^; if source^ <> blank_char then all_blanks := false; get(source); end; ln_number := ln_number + 1; if pos = maxlinewidth then while not(eoln(source)) do get(source); if eoln(source) then get(source); input_buf.en := pos; if (pos = 0) or all_blanks then blankline := true else if input_buf.str[1] = dot then dot_command := true else if input_buf.str[1] = blank_char then lead_blank := true; end; { readline } {********************************************************************** PROCESS_FILE is the true top level for RUNON. It begins by outputting a blank page heading of BLANK_HEADING lines. While the file is not empty or the internal buffer contains unprocessed text, the following sequence is repeated: a) If the internal buffer is empty, then read a line from the source file. If the line is empty, and we are in filling mode, ignore it, get a new line. If the line read in was a dot command, then call the dot- command processor. Otherwise, line is normal so scan and process it. b) If the internal buffer is not empty, then process it. Once the file and input buffer are both empty, force the output buffer and close the output file. The variable INC_FIL indicates if the file being processed is an INCLUDE file. It it is, the blank heading is not put out, and the output buffer is not forced out after the file has been processed. **********************************************************************} {****************************************************} { } { Procedure declaration in SYSGEN file. } {----------------------------------------------------} { } { Procedure process_file(var source : text; } { inc_fil : boolean); } { } {****************************************************} begin { process file } if not(inc_fil) then begin n := blank_heading; out_proc(skp); pageinfo.currline := 0; end; While not(eof(source)) or more_input do begin If not(more_input) then begin Readline; If not(blankline and (sysvars[new].fill_mode <> nofilling)) then begin if dot_command then d_c_p else begin scanner(input_buf.st, input_buf.en, input_buf.str, internal_buf); out_proc(norm); end; end; end else { more_input } out_proc(norm); end; { while } if not(inc_fil) then if sysvars[new].fill_mode <> nofilling then out_proc(brk); end; { process_file } {********************************************************************* INCLUDE_FILE opens a new source file and then passes it recursively to the procedure PROCESS_FILE. Up to MAX_FILES nested levels of include files may be opened simultaneously. The procedure heading is declared FORWARD before OUT_PROC, and the actual code occurs after PROCESS_FILE. If an error occurs, all open files are closed by ERROR. Three different error conditions are tested for. 1. Too many include files have been opened. Stack overflow. 2. General file I/O error. Possibly specific at a future date. 3. Include file already included. This is done to prevent infinite recursion. Possibly unnecessary. **********************************************************************} {*******************************************************} { } { Forward declaration in SYSGEN file. } {-------------------------------------------------------} { } { Procedure include_file(f_name : string); Forward } { } {*******************************************************} Procedure include_file; var i, err_pos : posint; Function file_status(f_name : string) : posint; begin {$I-} reset(f, f_name); file_status := ioresult; close(f); {$I+} end; { file_status } begin { include_file } err_pos := input_buf.st - 2; if file_stack.ptr >= max_files then error(nesdep, err_pos, input_buf.str) else if file_status(f_name) <> 0 then error(filerr, err_pos, input_buf.str) else if f_name = file_in then error(incerr, err_pos, input_buf.str) else for i := 1 to file_stack.ptr do if f_name = file_stack.stack[i].name then error(incerr, err_pos, input_buf.str); writeln('Including ', f_name); with file_stack do begin ptr := ptr + 1; stack[ptr].name := f_name; stack[ptr].line := ln_number; stack[ptr].in_buf := input_buf; ln_number := 0; end; case file_stack.ptr of 1 : begin reset(s1, f_name); process_file(s1, true); close(s1); end; 2 : begin reset(s2, f_name); process_file(s2, true); close(s2); end; 3 : begin reset(s3, f_name); process_file(s3, true); close(s3); end; 4 : begin reset(s4, f_name); process_file(s4, true); close(s4); end; 5 : begin reset(s5, f_name); process_file(s5, true); close(s5); end; end; { case } with file_stack do begin stack[ptr].name := nul; ln_number := stack[ptr].line; input_buf := stack[ptr].in_buf; ptr := ptr - 1; end; end; { include_file } ======================================================================================== DOCUMENT :usus Folder:VOL13:readnu.text ======================================================================================== {********************************************************************** READNUM reads a number from the input buffer. If there isn't a valid number, or no number exists, the error routine is called. The number must be delimited by a space, a dot, or the end of line. **********************************************************************} Procedure readnum(var number : posint); var firstchar, lastchar, pos, i : posint; ablank, anumber : boolean; Function power_of_ten(x : posint) : posint; var i, j : posint; begin j := 1; for i := 1 to x do j := j * 10; power_of_ten := j; end; { power_of_ten } begin { readnum } number := 0; ablank := true; anumber := true; pos := input_buf.st; while ablank and (pos <= input_buf.en) do if input_buf.str[pos] = blank_char then pos := pos + 1 else ablank := false; if pos > input_buf.en then error(argmsng, input_buf.st, input_buf.str) else begin if not(input_buf.str[pos] in numbers) then error(nonnum, pos, input_buf.str); firstchar := pos; while anumber and (pos <= input_buf.en) do if input_buf.str[pos] in numbers then pos := pos + 1 else anumber := false; lastchar := pos - 1; end; { else } for i := 0 to (lastchar - firstchar) do number := number + (ord(input_buf.str[lastchar - i]) - ord(zero)) * power_of_ten(i); input_buf.st := pos; end; { readnum } {********************************************************************** FIND_TEXT finds a string in the buffer TXT starting from the .STth position. The string is delimited by the first non-blank character found. The permissible delimiters are all printing, non-alphanumeric characters. The routine first searches for the two delimiters. The two pointers, ST_TXT and EN_TXT, are then set to the first and last non-blank characters within the delimiters. The .ST pointer of TXT is set to the second delimiter position plus one. **********************************************************************} Procedure find_text(var st_txt, en_txt : posint; var txt : strng); var searching : boolean; txt_pos, err_pos : posint; delim : char; begin txt_pos := txt.st; searching := true; while searching and (txt_pos <= txt.en) do if txt.str[txt_pos] = blank_char then txt_pos := txt_pos + 1 else searching := false; if searching then error(argmsng, txt.st, txt.str); delim := txt.str[txt_pos]; err_pos := txt_pos; if not(delim in text_delims) then error(baddelm, txt_pos, txt.str); txt_pos := txt_pos + 1; st_txt := txt_pos; searching := true; while searching and (txt_pos <= txt.en) do if txt.str[txt_pos] <> delim then txt_pos := txt_pos + 1 else searching := false; if searching then error(dlmmsng, err_pos, txt.str); en_txt := txt_pos - 1; txt.st := txt_pos + 1; searching := true; while searching and (st_txt <= en_txt) do if txt.str[st_txt] = blank_char then st_txt := st_txt + 1 else searching := false; searching := true; while searching and (en_txt > st_txt) do if txt.str[en_txt] = blank_char then en_txt := en_txt - 1 else searching := false; end; { find_text } {********************************************************************** GET_COMMAND reads a command from INPUT_BUF, beginning with the .ST pointer. The command must be delimited by a space, a dot, or the end of line. If the command is not identifiable, or it matches more than one command string, the error routine is called. Otherwise, CMD is set to an enumerated type corresponding to the command, and INPUT_BUF.ST is set to point at the delimiter. **********************************************************************} Function get_command : commandtype; var command : cmd_name; cmd : commandtype; match_count, cmd_length, buf_pos, fill : posint; done, searching : boolean; Function sub_string(part, whole : cmd_name; cmd_len : posint ) : boolean; var same_char : boolean; i : posint; begin same_char := true; i := 1; while (i <= cmd_len) and same_char do if part[i] = whole[i] then i := i + 1 else same_char := false; sub_string := same_char; end; { sub_string } begin { get_command } buf_pos := input_buf.st; cmd_length := 1; searching := true; cmd := brk; done := false; match_count := 0; { read string from input buffer } while (buf_pos <= input_buf.en) and (cmd_length <= maxcmdlength) and searching do if input_buf.str[buf_pos] in [blank_char, dot] then searching := false else begin if input_buf.str[buf_pos] in lc_letters then command[cmd_length] := chr(ord(input_buf.str[buf_pos]) - lcoffset) else command[cmd_length] := input_buf.str[buf_pos]; buf_pos := buf_pos + 1; cmd_length := cmd_length + 1; end; if input_buf.st = buf_pos then error(cmderr, input_buf.st, input_buf.str) else input_buf.st := buf_pos; { match string to command } while not done do begin if sub_string(command, cmd_strings[cmd], cmd_length - 1) then begin match_count := match_count + 1; get_command := cmd; end; if (match_count > 1) or (cmd = cmnt) then done := true else cmd := succ(cmd); end; { while } if match_count = 0 then error(badcmd, buf_pos - 1, input_buf.str) else if match_count > 1 then error(dblnam, buf_pos - 1, input_buf.str); end; { get_command } {********************************************************************** ACTION_CMNDS reads and checks parameters for action commands that require them. It then calls the output processor. **********************************************************************} Procedure action_cmnds(cmd : commandtype); begin case cmd of fig : begin if pageinfo.figure_set or pageinfo.figure_pending then error(figbad, input_buf.st - 1, input_buf.str); readnum(n); if n < 2 then error(toolow, input_buf.st - 1, input_buf.str) else if n > sysvars[new].printable_lines then error(toohgh, input_buf.st - 1, input_buf.str); end; indt : begin readnum(n); if n < 1 then error(toolow, input_buf.st - 1, input_buf.str) else if (sysvars[sysvars[new].version].lm + n) > sysvars[sysvars[new].version].rm then error(toohgh, input_buf.st - 1, input_buf.str); end; skp : begin readnum(n); if n < 1 then error(toolow, input_buf.st - 1, input_buf.str) else if n > sysvars[new].printable_lines then error(toohgh, input_buf.st - 1, input_buf.str); end; nofil : begin sysvars[new].fill_mode := nofilling; cmd := brk; end; tstpag : begin readnum(n); if n > sysvars[new].printable_lines then error(toohgh, input_buf.st - 1, input_buf.str) else if n < 1 then error(toolow, input_buf.st - 1, input_buf.str); end; pag, brk : { do nothing } end; { case } out_proc(cmd); end; { action_commands } {********************************************************************* TEXT_CMNDS reads text parameters from the INPUT_BUF for those commands that require them. The two pointers START_POS and END_POS point to the text in the buffer. Please note that the .CENTER command resets the INTERNAL_BUF to empty so that multiple center commands will find it that way, and that the global variable LOCK_STATUS is suspended before the text is scanned so that the normal text attributes will not be used. READ_STRING reads a filename from INPUT_BUF for INCLUDE_FILE. Notice that this uses a UCSD Pascal string. **********************************************************************} Procedure text_cmnds(cmd : commandtype); var start_pos, end_pos : posint; f_name : string; save_status : attrib_set; Procedure read_string(var str : string); var char_buf : string[1]; char_pos : posint; begin str := nul; for char_pos := start_pos to end_pos do begin char_buf := blank_char; char_buf[1] := input_buf.str[char_pos]; str := concat(str, char_buf); end; end; { read_string } begin { text_cmnds } find_text(start_pos, end_pos, input_buf); case cmd of cntr : begin if end_pos < start_pos then error(badcnt, start_pos, input_buf.str); out_proc(brk); internal_buf := blank_buf; save_status := lock_status; lock_status := []; scanner(start_pos, end_pos, input_buf.str, internal_buf); lock_status := save_status; center_buffer(internal_buf, sysvars[new].lm, sysvars[new].rm, end_pos, cntwide); output_buf := internal_buf; out_proc(brk); end; inclu : begin read_string(f_name); include_file(f_name); end; til : begin pageinfo.title.str := input_buf.str; pageinfo.title.st := start_pos; pageinfo.title.en := end_pos; end; end; { case } end; { text_cmnds } {********************************************************************** GLOBAL_CMNDS is the counterpart of ACTION_CMNDS for commands that do not require immediate output and effect system variables. N.B. For an explanation of FLIP_VERSION and why it is important, please see the documentation on the Time-warp effect. **********************************************************************} Procedure global_cmnds(cmd : commandtype); var i : posint; procedure flip_version; begin if (output_buf.en <> 0) and (sysvars[new].version = new) then begin sysvars[old] := sysvars[new]; sysvars[new].version := old; end; end; { flip_version } begin { global_cmnds } case cmd of fil : sysvars[new].fill_mode := filling; justfy : sysvars[new].fill_mode := justification; lmar : begin readnum(n); if n > sysvars[new].rm then error(toohgh, input_buf.st - 1, input_buf.str) else if n < 1 then error(toolow, input_buf.st - 1, input_buf.str); flip_version; sysvars[new].lm := n; sysvars[new].chars_in_line := sysvars[new].rm - sysvars[new].lm + 1; end; rmar : begin readnum(n); if n > sysvars[new].paper_width then error(toohgh, input_buf.st - 1, input_buf.str) else if n < sysvars[new].lm then error(toolow, input_buf.st - 1, input_buf.str); flip_version; sysvars[new].rm := n; sysvars[new].chars_in_line := sysvars[new].rm - sysvars[new].lm + 1; end; onnum : sysvars[new].numbering := true; offnum : sysvars[new].numbering := false; num : begin readnum(n); if n < 1 then error(toolow, input_buf.st - 1, input_buf.str); pageinfo.currpage := n; end; onpag : begin sysvars[new].paging := true; pageinfo.currline := 1 end; offpag : sysvars[new].paging := false; papsiz : begin readnum(m); if m < minpaplen then error(tooshrt, input_buf.st - 1, input_buf.str); readnum(n); if n > maxlinewidth then error(toowide, input_buf.st - 1, input_buf.str) else if n < minlinewidth then error(toonrrw, input_buf.st - 1, input_buf.str); flip_version; sysvars[new].printable_lines := m - bordersize; sysvars[new].paper_length := m; sysvars[new].paper_width := n; sysvars[new].lm := 10; sysvars[new].rm := n - 10; end; spc : begin readnum(n); if n < minspacing then error(toolow, input_buf.st - 1, input_buf.str) else if n > maxspacing then error(toohgh, input_buf.st - 1, input_buf.str); sysvars[new].spacing := n; end; std : begin flip_version; sysvars[new] := std_vals; end; autop : sysvars[new].ap_mode := true; noauto : sysvars[new].ap_mode := false; autset : begin readnum(m); if m > maxspacing then error(toohgh, input_buf.st - 1, input_buf.str); readnum(n); if n < 1 then error(aplow, input_buf.st - 1, input_buf.str); sysvars[new].ap_skip := m; sysvars[new].ap_indent := n; end; upper : global_case := [u_case]; lower : global_case := [l_case]; same : global_case := []; end; { case } end; { global commands } {********************************************************************** The dot command processor reads commands from the input buffer, until the line is empty or a .COMMENT command is encountered, and dispatches them to either the action-, text-, or global-command processor. The header is declared before READNUM. **********************************************************************} {**************************************} { } { header is located in SYSGEN file } {--------------------------------------} { } { Procedure d_c_p; } { } { var } { searching, } { eo_line : boolean; } { cmd : commandtype; } { pos : posint; } { } {**************************************} begin { dot command processor } eo_line := false; repeat searching := true; pos := input_buf.st; while searching and (pos <= input_buf.en) do if input_buf.str[pos] = blank_char then pos := pos + 1 else searching := false; if searching then eo_line := true else begin if input_buf.str[pos] <> dot then error(cmderr, pos, input_buf.str); input_buf.st := pos + 1; cmd := get_command; if cmd = cmnt then eo_line := true else begin if cmd in act_cmds then action_cmnds(cmd) else if cmd in text_cmds then text_cmnds(cmd) else global_cmnds(cmd); end; end; until eo_line; end; { dot command processor } ======================================================================================== DOCUMENT :usus Folder:VOL13:runon_doc.text ======================================================================================== .comment !--------------------------------------! .comment ! ! .comment ! RUNON V.2 program documentation ! .comment ! by Wynn Newhouse and Herb Jellinek ! .comment ! ! .comment ! August 9, 1980 ! .comment ! ! .comment !--------------------------------------! .title '_User _Manual' .skip 3 .indent 40 August 9, 1980 .skip 5 .center "<^<&runon" .skip 1 .center "A Text Formatting Program" .skip 30 .center / Copyright (C) 1980 Herb Jellinek and Wynn Newhouse / .center / All rights reserved. / .comment *** end of cover page .incl /intro_doc.text/ .incl /howto_doc.text/ .incl /dot_doc.text/ .incl /defalt_doc.text/ .incl /spec_doc.text/ .incl /err_doc.text/ .incl /tech_doc.text/ ======================================================================================== DOCUMENT :usus Folder:VOL13:scredit.text ======================================================================================== (* $LPrinter:*) {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} { } { Pascal Screen Generator - Edit Screen} { by Lee Meador -- Copyright (c) 1981 } { World Bible Translation Center } { 1401 Hillcrest Dr. } { Arlington, TX 76010 (817) 469-6019 } { } { This program will create or modify a } { data file that is used by SCRGEN } { to write a Pascal Procedure in a } { text file. This procedure will set } { up a form on the screen and allow } { you to input and output information} { for the blanks in the form. } { } { When creating a new screen use the } { option available to clear (zero) } { the screen. Then enter information } { for each field on the screen. You } { have a label and a series of '_'s } { for each field. You must specify } { the maximum length allowed, the } { type (integer, real, string, etc. } { that is being entered along with } { the name of the variable to put the} { data into once someone enters it. } { Display type of Normal is the only } { one supported. } { } { Note: The new field entry code was } { written using a version of these } { programs. } { } { Good Luck... } { let me know about enhancements } { } {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} PROGRAM PScrn_1; CONST MaxNumOfItems = 60; TYPE Actcode = (inscr,outscr,setscr); stat = (good,backup,default); s = String[80]; (*$I:TYPES.TEXT *) VAR Scrfile : FILE OF Scrn; Txt : TEXT; ScreenName, ScreenRes: STRING; YesNo,Yes: SET OF CHAR; ThatsAll, SaveIt : BOOLEAN; ItemNum : INTEGER; Status : Stat; procedure clear_screen; begin gotoxy ( 0, 0 ); write ( chr ( 27 ) , 'J' ); {H-19 specific} end; {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} { } { Get Functions } { by Lee Meador - Copyright (c) 1981 } { } {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} { } { The following TYPE must be defined } { } { TYPE Stat = (Good,Backup,Default); } { } { The functions here are: } { VAL - returns a Real given a string } { GetBoolean - returns a Boolean from } { whatever is input in the field } { GetInteger - returns an Integer } { from what is input in the field } { GetReal - returns a Real from what } { is input in the field } { GetString - returns a String as the } { third parameter from what is } { input in the field. } { } {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} FUNCTION VAL(STRNG:STRING):REAL; (* BY David Stringham *) (* 2102 Overbrook *) (* Arlington, Tex. 71014 *) (* 7-MAR-81 *) { Mods by Lee Meador } { 1 Apr 81 } VAR S:STRING; PTEN,ZERO,I:INTEGER; NUMBER:REAL; BEGIN (* VAL *) ZERO:=ORD('0'); (* BEGIN CULLING NON VALID CHRS *) (* INDIVIDUAL NUMBERS IN SAME *) (* STRING MUST BE SEPARATED BY *) (* A NON VALID CHARACTER; SUCH *) (* AS A BLANK. THUS $100.00$15 *) (* WILL RETURN 100.0015 *) (* AND $100.00 $15 RETURNS 100.0*) IF LENGTH(STRNG)<1 THEN BEGIN VAL:=0.0; EXIT(VAL) END; I:=0; REPEAT I:=I+1 UNTIL (NOT (STRNG[I] IN ['+', '$', ',', '.', '-', '0'..'9']) OR (I=LENGTH(STRNG))); S:=COPY(STRNG,1,I); (* GET THE REAL NUMBER *) NUMBER:=0.0; PTEN:=0; FOR I:=LENGTH(S) DOWNTO 1 DO CASE S[I] OF '0','1','2','3','4','5','6','7', '8','9' :BEGIN NUMBER:=NUMBER+ (ORD(S[I])-ZERO)*PWROFTEN(PTEN); PTEN:=PTEN+1; END; '.' :BEGIN NUMBER:=NUMBER/PWROFTEN(PTEN); PTEN:=0 END; '-' :NUMBER:=-NUMBER END; (* CASE *) (* IF NON NUMBER THEN *) (* IGNORE IT *) VAL:=NUMBER; (* ASSIGN VAL*) (* ITS VALUE *) END; (* VAL *) PROCEDURE GetString(Len:INTEGER;VAR Status:STAT;VAR RET:S); VAR CH: CHAR; C : STRING; Str : STRING; Chars : INTEGER; BEGIN Chars := 0; { The length } Str := '';{ The String } REPEAT READ(ch); IF (ch = ' ') and (EOLN) THEN ch := chr(13); { make cr back to cr } CASE ord(ch) OF 13 : BEGIN {return} IF Chars = 0 THEN BEGIN Ret := ''; Status := Default; EXIT(GetString); END; Ret := Str; Status := Good; EXIT(GetString); END; 8 : BEGIN {backspace} IF Chars = 0 THEN BEGIN Ret := ''; Status := Backup; EXIT(GetString); END; WRITE(chr(8),'_',chr(8)); Chars := Chars-1; Str := COPY(Str,1,LENGTH(Str)-1); END END; IF ORD(ch) IN [0..7,9..31,127] THEN CH := ' '; IF ORD(ch) IN [32..126] THEN BEGIN Chars := Chars+1; (*$R-*) C[1] := CH; C[0]:=CHR(1); (*$R+*) Str := CONCAT(Str,C); END; UNTIL Chars >= Len; Ret := Str; Status := Good; END; { Get String } FUNCTION GetBoolean(Len:INTEGER;VAR Status:STAT):BOOLEAN; VAR S: String; I: Integer; BEGIN GetString(Len,Status,S); { change all to upper case } FOR I := 0 TO LENGTH(S) DO IF I > 0 THEN IF S[I] IN ['a'..'z'] THEN S[I] := CHR(ORD(S[I])-32); IF (S = 'TRUE') OR (S[1] = 'Y') THEN GetBoolean := TRUE ELSE GetBoolean := FALSE; END; { Get Boolean } FUNCTION GetReal(Len:INTEGER;VAR Status:STAT):REAL; VAR S: String; BEGIN GetString(Len,Status,S); GetReal := VAL(S); END; FUNCTION GetInteger(Len:INTEGER;VAR Status:STAT):INTEGER; VAR S: String; BEGIN GetString(Len,Status,S); GetInteger := ROUND(VAL(S)); END; {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} { } { END OF Get Functions } { by Lee Meador - Copyright (c) 1981 } { } {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} PROCEDURE SCREENOUT(Action:ACTCODE); {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} { } { SCREENOUT is the result of using this} { program to enhance itself. This } { code was written by SCRGEN on info } { stored by an earlier version of } { this program. Some changes were } { made to that code to add some new } { features and support my defined } { data types. The calls to this will } { help you understand what is being } { done. } { } {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} VAR TempBoolean: BOOLEAN; TempString : STRING; TempInteger: INTEGER; TempReal : REAL; TempLongInteger: INTEGER[36]; Return : Stat; PROCEDURE INPROC; LABEL 1, 2, 3, 4, 5, 6, 7, 8, 9; BEGIN WITH Scrfile^[ItemNum] DO BEGIN { Lee's Line added } (*$G+*) (* Input ItemLabel *) 1: GOTOXY(8,8); GetSTRING(33,Return,TempSTRING); IF Return = Backup THEN GOTO 1; IF Return = Default THEN TempSTRING:=ItemLabel; GOTOXY(8,8); WRITE(TempSTRING); ItemLabel:=TempSTRING; (* Input ItemName *) 2: GOTOXY(11,9); GetSTRING(30,Return,TempSTRING); IF Return = Backup THEN GOTO 1; IF Return = Default THEN TempSTRING:=ItemName; GOTOXY(11,9); WRITE(TempSTRING); ItemName:=TempSTRING; (* Input ItemType *) 3: GOTOXY(11,10); GetSTRING(15,Return,TempSTRING); IF Return = Backup THEN GOTO 2; IF Return = Default THEN TempSTRING:='STRING'; GOTOXY(11,10); WRITE(TempSTRING); ItemType:=TempSTRING; (* Input ItemLength *) 4: GOTOXY(9,11); TempINTEGER:=GetINTEGER(3,Return); IF Return = Backup THEN GOTO 3; IF Return = Default THEN TempINTEGER:=0; GOTOXY(9,11); WRITE(TempINTEGER); ItemLength:=TempINTEGER; (* Input ItemY *) 5: GOTOXY(21,11); TempINTEGER:=GetINTEGER(3,Return); IF Return = Backup THEN GOTO 4; IF Return = Default THEN TempINTEGER:=12; GOTOXY(21,11); WRITE(TempINTEGER); ItemY:=TempINTEGER; (* Input ItemX *) 6: GOTOXY(34,11); TempINTEGER:=GetINTEGER(3,Return); IF Return = Backup THEN GOTO 5; IF Return = Default THEN TempINTEGER:=0; GOTOXY(34,11); WRITE(TempINTEGER); ItemX:=TempINTEGER; (* Input ItemDisplayType *) 7: GOTOXY(16,13); GetSTRING(8,Return,TempSTRING); IF Return = Backup THEN GOTO 6; IF Return = Default THEN TempSTRING:='NORMAL'; GOTOXY(16,13); WRITE(TempSTRING); CASE TempSTRING[1] OF 'N','n': ItemDisplayType:=NORMAL; 'I','i': ItemDisplayType:=INVERSE; 'F' ,'f' : ItemDisplayType:=FLASH END; {Case} (* Input ItemEdit *) 8: GOTOXY(7,15); TempBOOLEAN:=GetBOOLEAN(6,Return); IF Return = Backup THEN GOTO 7; IF Return = Default THEN TempBOOLEAN:=TRUE; GOTOXY(7,15); IF TempBOOLEAN THEN WRITE('Yes') ELSE WRITE('No'); ItemEdit:=TempBOOLEAN; (* Input ItemDefault *) 9: GOTOXY(10,16); GetSTRING(60,Return,TempSTRING); IF Return = Backup THEN GOTO 8; IF Return = Default THEN TempSTRING:=ItemDefault; GOTOXY(10,16); WRITE(TempSTRING); ItemDefault:=TempSTRING; (*$G-*) END; END; {INPROC} BEGIN WITH Scrfile^[ItemNum] DO BEGIN { Lee's Line added } CASE action OF SETSCR : BEGIN clear_screen; GOTOXY(1,8); WRITE ('Label: _________________________________'); GOTOXY(1,9); WRITE ('Var Name: ______________________________'); GOTOXY(1,10); WRITE ('VAR Type: _______________'); GOTOXY(1,11); WRITE ('Length: ___'); GOTOXY(15,11); WRITE ('Line: ___'); GOTOXY(26,11); WRITE ('Column: ___'); GOTOXY(1,13); WRITE ('Display Style: ________'); GOTOXY(1,15); WRITE ('Edit? ______'); GOTOXY(1,16); WRITE ('Default: ____________________________________________________________'); END; (* Setup *) INSCR: BEGIN INPROC; END; (* Input *) OUTSCR : BEGIN (* Print ItemLabel *) GOTOXY(8,8); WRITE(ItemLabel); (* Print ItemName *) GOTOXY(11,9); WRITE(ItemName); (* Print ItemType *) GOTOXY(11,10); WRITE(ItemType); (* Print ItemLength *) GOTOXY(9,11); WRITE(ItemLength); (* Print ItemY *) GOTOXY(21,11); WRITE(ItemY); (* Print ItemX *) GOTOXY(34,11); WRITE(ItemX); (* Print ItemDisplayType *) GOTOXY(16,13); CASE ItemDisplayType OF Normal : WRITE('Normal'); Inverse: WRITE('Inverse'); Flash : WRITE('Flash') END; (* CASE *) (* Print ItemEdit *) GOTOXY(7,15); IF ItemEdit THEN WRITE('Yes') ELSE WRITE('No '); (* Print ItemDefault *) GOTOXY(10,16); WRITE(ItemDefault); END (* Output *) END; (* CASE *) END; { WITH ... Lee's Line added } END; (* ScreenOut *) PROCEDURE OPEN_FILE; BEGIN { Open Screen Definition } GOTOXY(5,5); WRITELN('What Screen shall I process?'); WRITE (' (dev:fname) '); READLN(ScreenName); IF POS('.SCRN',ScreenName) = 0 THEN ScreenName := CONCAT(ScreenName,'.SCRN'); (*$I-*) RESET(Scrfile,ScreenName); (*$I+*) IF IORESULT <> 0 THEN { Create file } REWRITE(Scrfile,ScreenName); SEEK(Scrfile,0); END; { OPEN_FILE } FUNCTION Menu:INTEGER; { Show Menu and Return 1..5 } VAR CH : CHAR; BEGIN CLEAR_SCREEN; GOTOXY(10,1); WRITELN('Pascal Screen Editor'); GOTOXY(5,5); WRITELN('1. Clear Screen'); GOTOXY(5,7); WRITELN('2. Clear Item'); GOTOXY(5,9); WRITELN('3. Edit Item'); GOTOXY(5,11); WRITELN('4. Exit and Save Changes'); GOTOXY(5,13); WRITELN('5. Exit w/o Saving'); GOTOXY(5,15); WRITELN('6. Show Screen'); GOTOXY(5,17); WRITELN('7. Enter Item'); GOTOXY(1,22); WRITE('Enter Command Number: '); REPEAT READ(CH); IF NOT (CH IN ['1'..'7']) THEN WRITE (CHR(7),CHR(8)); { Beep - BS } UNTIL CH IN ['1'..'7']; Menu := ORD(CH) - ORD('0'); END; { Menu } PROCEDURE ZeroScreen; VAR CH: CHAR; I : INTEGER; BEGIN CLEAR_SCREEN; GOTOXY(5,5); WRITE('Clearing Screen Definition. OK? '); READ(CH); IF CH in Yes THEN FOR I := 1 TO MaxNumOfItems DO WITH Scrfile^[I] DO BEGIN ItemLabel := ''; ItemLength:= 0; ItemX := 0; ItemY := 0; ItemEdit := False; ItemDefault:=''; ItemType := 'String'; ItemDisplayType := Normal; ItemValid := FALSE; END; {LOOP} END; { Clear All Items } FUNCTION WhichItem(Action:String):INTEGER; { Returns Item Number } VAR I : Integer; BEGIN CLEAR_SCREEN; GOTOXY(5,5); WRITELN('Which Item do you want to ',Action,'? '); WRITE (' (1-60) '); READLN(I); WhichItem := I; END; { WhichItem } PROCEDURE ZeroItem; VAR CH: CHAR; I : INTEGER; BEGIN I := WhichItem('Remove'); GOTOXY(5,7); WRITE('Removing Item ',I,'. OK? '); READ(CH); IF CH in Yes THEN Scrfile^[I].ItemValid := False; END; { Clear an Items } PROCEDURE EnterItem; VAR CH: CHAR; BEGIN ItemNum := WhichItem('Enter'); IF Scrfile^[ITEMNUM].ItemValid THEN BEGIN GOTOXY(5,7); WRITELN('Item ',ItemNum,' Exists'); WRITE (' Shall I ReEnter it? '); READ(CH); IF NOT (CH in Yes) THEN EXIT(EnterItem); END; REPEAT ScreenOut(Setscr); ScreenOut(Inscr); ScreenOut(Setscr); ScreenOut(outscr); GOTOXY(0,23); WRITE(' Is This Correct '); UNTIL GetBoolean(1,Status); Scrfile^[ITEMNUM].ItemValid := TRUE; END; PROCEDURE EditItem; VAR I: INTEGER; PROCEDURE ChangeS(VAR Value:String;Name:String); VAR CH: CHAR; BEGIN WRITELN(Name:15,' ',Value); REPEAT WRITE('Make Changes (y/n)? '); READ(CH); WRITELN; UNTIL CH IN YesNo; IF CH IN Yes THEN BEGIN WRITELN('Enter New Value '); READLN(Value); END; END; { ChangeS } PROCEDURE ChangeI(VAR Value:INTEGER;Name:STRING); VAR CH: CHAR; BEGIN WRITELN(Name:15,' ',Value); REPEAT WRITE('Make Changes (y/n)? '); READ(CH); WRITELN; UNTIL CH IN YesNo; IF CH IN Yes THEN BEGIN WRITELN('Enter New Value '); READLN(Value); END; END; { ChangeI } BEGIN { Body of EditItem } I := WhichItem('Edit'); WITH Scrfile^[I] DO BEGIN IF NOT ItemValid THEN BEGIN ItemName := ''; ItemLabel:= ''; ItemType := ''; ItemDefault := ''; ItemEdit := FALSE; ItemLength := 0; ItemX := 0; ItemY := 0; ItemDisplayType := Normal; END; ChangeS(ItemName,'Name'); ChangeS(ItemLabel,'Label'); ChangeS(ItemType,'VAR type'); ChangeS(ItemDefault,'Default Value'); ChangeI(ItemLength,'Length'); ChangeI(ItemX,'Column'); ChangeI(ItemY,'Line Number'); ItemValid := True; END; END; { Edit an Item } PROCEDURE ShowScreen; VAR ItemNum, x,y,I : INTEGER; CH : CHAR; First : BOOLEAN; BEGIN CLEAR_SCREEN; First := True; FOR ItemNum := 1 to MaxNumOfItems DO WITH Scrfile^[ITEMNUM] DO IF ItemValid THEN BEGIN IF First THEN BEGIN x := ItemX+1+Length(ItemLabel); y := ItemY; First := FALSE; END; GOTOXY(ItemX,ItemY); WRITE (ItemLabel,' '); FOR I := 0 to ItemLength DO IF I > 0 THEN WRITE('_'); END; GOTOXY(x,y); READ(CH); END; { ShowScreen } BEGIN { Main } YesNo := ['Y','y','N','n']; Yes := ['Y','y']; CLEAR_SCREEN; GOTOXY(10,0); WRITELN('Edit or Create Screen'); OPEN_FILE; ThatsAll := FALSE; REPEAT CASE Menu OF 1 : ZeroScreen; 2 : ZeroItem; 3 : EditItem; 4 : BEGIN { Exit and Save } SaveIt := True; ThatsAll := TRUE; SEEK(Scrfile,0); PUT (Scrfile); END; 5 : BEGIN { Exit w/o Save } SaveIt := False; ThatsAll := TRUE; END; 6 : ShowScreen; 7 : EnterItem END; (* Case Statement *) UNTIL ThatsAll = TRUE; IF SaveIt THEN CLOSE(Scrfile,LOCK) ELSE CLOSE(Scrfile); END. ======================================================================================== DOCUMENT :usus Folder:VOL13:scrgen.text ======================================================================================== (*dont use the $LPrinter:*) SCREDIT - edit the screen definition SCRGEN - write the Pascal program TYPES - file definitions for SCREDIT and SCRGEN These two programs allow you to define a form to be filled in on the screen and then write a Pascal procedure that you can incorporate in your own programs to set up the screen form, allow the user to enter data for all the fields and show the contents of all the fields. This is version 1 of the programs but they work. These should shorten the time needed to set up programs that enter several values from the screen. The programs that this program writes make calls to the functions in GETFUNCS above. by Lee Meador - FWAUG, DAC {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} { } { Screen Code Generator - by Lee Meador} { Version 1.0 Box 3261 } { Copyright (c) 1981 Arlington, TX } { 76010 } { } { Uses information written in a data } { file to generate Pascal code (in } { a text file) that will let you } { set up a form on the screen, and } { then input or output the info for } { the screen. } { } { The program SCREDIT allows you to } { create and modify the data file } { so as to have the right number of } { variables of the right types, etc. } { } { The Pascal Procedure written by this } { program requires the procedures in } { GETFUNCS to work correctly. } { } { This program could use some work to } { keep from writing procedures that } { are too big. If this happens, you } { can use the E)ditor to move part } { of the code into a second procedure} { } {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} PROGRAM PScrn_2; CONST MaxNumOfItems = 60; TYPE (*$I:TYPES.TEXT *) VAR Scrfile : FILE OF Scrn; Txt : TEXT; First : BOOLEAN; Indent, ScreenName, ScreenOut: STRING; ItemNum : INTEGER; procedure clear_screen; begin gotoxy ( 0, 0 ); write ( chr ( 27 ), 'J' ); {H-19 specific} end; PROCEDURE OPEN_INPUT; BEGIN REPEAT { Open Screen Definition } GOTOXY(5,5); WRITELN('What Screen shall I process?'); WRITE (' (dev:fname) '); READLN(ScreenName); IF POS('.SCRN',ScreenName) = 0 THEN ScreenName := CONCAT(ScreenName,'.SCRN'); (*$I-*) RESET(Scrfile,CONCAT(ScreenName,'[30]')); (*$I+*) UNTIL IORESULT = 0; END; { OPEN_INPUT } PROCEDURE OPEN_OUTPUT; VAR Strng: String; Flag : Boolean; CH : Char; BEGIN REPEAT { Open Text Output file } ScreenOut := CONCAT(COPY(ScreenName,1,Length(ScreenName)-5),'.TEXT'); GOTOXY(5,8); WRITELN('What Name for Text Output? '); WRITE (' (',ScreenOut,') '); READLN(Strng); IF Length(Strng) <> 0 THEN ScreenOut := Strng; (*$I-*) RESET(Txt,ScreenOut); (*$I+*) Flag := (IORESULT<>0); { Non-existent } IF NOT Flag THEN REPEAT CLOSE(Txt); { Close it for now } GOTOXY(0,23); WRITE('Already Exists. Replace? (Y/N) '); READ(CH); Flag := CH IN ['Y','y']; { OR ok to replace } UNTIL CH IN ['Y','y','N','n']; UNTIL Flag; REWRITE(Txt,ScreenOut); END; (* OPEN_OUTPUT *) PROCEDURE DO_SETUP; VAR I,ItemNum : Integer; BEGIN GOTOXY(1,23); WRITE (' Generating SETUP ',chr(7)); WRITELN(Txt, ' SETUP : BEGIN '); {WRITELN(Txt, ' PAGE(OUTPUT);');} WRITELN ( TXT, ' WRITE ( CHR ( 27 ), CHR ( 69 ));' ); {H-19 SPECIFIC} FOR ItemNum := 1 TO MAXNUMOFITEMS DO WITH Scrfile^[ItemNum] DO IF ItemValid THEN BEGIN WRITELN(Txt,Indent, 'GOTOXY(',ItemX,',',ItemY,');'); WRITE (Txt,Indent, 'WRITE (''',ItemLabel); { Put WRITE & Label } IF ItemLength > 0 THEN WRITE(Txt, ' '); { Put if more } FOR I := 1 to ItemLength DO WRITE(Txt, '_'); { Put Underlines } WRITELN(Txt, ''');'); { Put End of WRITE } END; {LOOP} WRITELN(Txt, ' END; (* Setup *)'); END; (* WRITING SETUP *) PROCEDURE DO_INPUT; VAR Last, I, ItemNum : INTEGER; PROCEDURE DO_Default; { within DO_INPUT } BEGIN WITH Scrfile^[ItemNum] DO BEGIN WRITE (Txt,Indent, 'IF Return = Default THEN '); IF ItemDefault = '' THEN WRITE(Txt,'Temp',ItemType,':=',ItemName) ELSE BEGIN WRITE(Txt,'Temp',ItemType,':='); IF ItemType = 'STRING' THEN WRITE(Txt,''''); WRITE(Txt,ItemDefault); IF ItemType = 'STRING' THEN WRITE(Txt,''''); END; {ELSE} WRITELN(Txt,';'); END; { WITH } END; { Do Default } BEGIN { DO_INPUT } GOTOXY(0,23); WRITE ('Generating INPUT',chr(7)); WRITELN(Txt, ' INPUT: BEGIN'); WRITELN(Txt, '(*$G+*)'); Last := -1; FOR ItemNum := 1 TO MaxNumOfItems DO WITH Scrfile^[ItemNum] DO IF ItemValid THEN BEGIN FOR I := 1 to LENGTH(ItemType) DO IF ItemType[I] IN ['a'..'z'] THEN ItemType[I] := CHR(ORD(ItemType[I])-32); IF Last < 0 THEN Last := ItemNum; { For first item } WRITELN(Txt); WRITELN(Txt,Indent, '(* Input ',ItemName,' *)'); WRITELN(Txt,Indent, ItemNum,': ','GOTOXY(',ItemX+1+Length(ItemLabel), ',',ItemY,');'); WRITE (Txt,Indent); IF ItemType <> 'STRING' THEN WRITE(Txt,'Temp',ItemType,':='); WRITE (Txt,'Get',ItemType, '(',ItemLength,',Return'); IF ItemType = 'STRING' THEN WRITE(Txt,',Temp',ItemType); WRITELN(Txt,');'); WRITELN(Txt,Indent, 'IF Return = Backup THEN GOTO ',Last,';'); DO_Default; WRITELN(Txt,Indent, 'GOTOXY(',ItemX+1+Length(ItemLabel),',',Itemy,');'); IF ItemType = 'BOOLEAN' THEN WRITELN(Txt,Indent, 'IF TempBOOLEAN THEN WRITE(''Yes'')', ' ELSE WRITE(''No'');') ELSE WRITELN(Txt,Indent, 'WRITE(Temp',ItemType,');'); WRITELN(Txt,Indent, ItemName,':=Temp',ItemType,';'); Last := ItemNum; { For Labels } END; {LOOP} WRITELN(Txt, '(*$G-*)'); WRITELN(Txt, ' END; (* Input *)'); END; (* WRITING INPUT *) PROCEDURE DO_OUTPUT; VAR ItemNum: INTEGER; BEGIN GOTOXY(0,23); WRITE ('Generating OUTPUT',chr(7)); WRITELN(Txt, ' OUTPUT : BEGIN'); FOR ITEMNUM := 1 TO MAXNUMOFITEMS DO WITH Scrfile^[ItemNum] DO IF ItemValid AND (ItemLength > 0) THEN BEGIN { No Screen Labels } WRITELN(Txt,Indent, '(* Print ',ItemName,' *)'); WRITELN(Txt,Indent, 'GOTOXY(',ItemX+1+LENGTH(ItemLabel),',', ItemY,');'); WRITELN(Txt,Indent, 'WRITE(',ItemName,');'); END; {LOOP} WRITELN(Txt, ' END; (* Output *)'); END; (* WRITING OUTPUT *) BEGIN { Main } clear_screen; GOTOXY(10,0); WRITELN('Generate Screen Code'); OPEN_INPUT; OPEN_OUTPUT; clear_screen; GOTOXY(10,0); WRITELN('Pascal Screen Generator'); WRITELN; WRITELN('Generating Pascal Source to'); WRITELN(' ',ScreenOut); GOTOXY(1,23); WRITE (' Generating DEFINES '); Indent := ' '; WRITELN(Txt, 'PROCEDURE SCREENOUT(Action:ACTCODE);'); WRITE (Txt, 'LABEL '); First := True; For ItemNum := 1 to MaxNumOfItems DO If Scrfile^[ItemNum].ItemValid THEN BEGIN IF NOT First THEN BEGIN WRITELN(Txt,','); WRITE (Txt,' '); END; WRITE(Txt,ItemNum); First := FALSE; END; WRITELN(Txt, ';'); WRITELN(Txt, 'TYPE Stat: (Good,Backup,Default);'); WRITELN(Txt, 'VAR TempBoolean: BOOLEAN;'); WRITELN(Txt, ' TempString : STRING;'); WRITELN(Txt, ' TempInteger: INTEGER;'); WRITELN(Txt, ' TempReal : REAL;'); WRITELN(Txt, ' TempLongInteger: INTEGER[36];'); WRITELN(Txt, ' Return : Stat'); WRITELN(Txt, 'BEGIN'); WRITELN(Txt, 'CASE action OF'); DO_SETUP; DO_INPUT; DO_OUTPUT; WRITELN(Txt, 'END; (* ScreenOut *)'); CLOSE(Txt,LOCK); END. ======================================================================================== DOCUMENT :usus Folder:VOL13:spec_doc.text ======================================================================================== .comment !---------------------------------! .comment ! ! .comment ! RUNON documentation ! .comment ! Special characters ! .comment ! ! .comment ! August 3, 1980 ! .comment ! ! .comment !---------------------------------! .page .center "^&SPECIAL CHARACTERS\&" The eight following commands are used to control various functions. These functions are underlining, spacing, case, and the printing out of the special characters themselves. The commands that set upper case override the case-changing dot-commands. .nofill The functions are each represented by a specific character: & Underline, _^ Uppercase. Notice that the following "lead-in characters" have specific effects on the functions: _< turns the function on for a word, _^ locks the function on until a '_\' is encountered, _\ unlocks the function. .center " ^&Command sequences\& " .fill .skip 1 _<_&##Underline word###### .leftmargin 35 When prefixed to a word, this sequence causes the word to be underlined. If this sequence is not prefixed to a word, it will be ignored. .skip 1 .leftmargin 10 _^_&##Underline lock###### .leftmargin 35 causes the underline lock to be set: all subsequent words will be underlined until the underline unlock sequence is encountered. Spaces between words will not be underlined. .skip 1 .leftmargin 10 _\_&##Underline unlock#### .leftmargin 35 This sequence will only have effect if the underline lock sequence has previously been encountered. .skip 1 .leftmargin 10 _<_^##Uppercase word###### .leftmargin 35 When prefixed to a word, this sequence causes the word to be output in uppercase. If this sequence is not prefixed to a word, it will be ignored. .skip 1 .leftmargin 10 _^_^##Uppercase lock###### .leftmargin 35 causes all subsequent words to be in uppercase until the uppercase unlock sequence is encountered. Does not effect title or centered text. .page .leftmargin 10 _\_^##Uppercase unlock#### .leftmargin 35 This sequence will only have effect if the uppercase lock sequence has been encountered. .skip 1 .leftmargin 10 _####Hard space########## .leftmargin 35 This character is used while in filling or justification mode to force a space where needed. When one or more of these characters are placed between two words, the spacing will be preserved in the output file with no extra spacing inserted or removed due to justification or filling. .skip 1 .leftmargin 10 __###Quote############### .leftmargin 35 The character following the quote character is taken literally, and is not affected by any attributes in effect, except underlining. It can be used to print one of the lead-in characters or _# if it is to appear in the output file. For example, if it is desired to print a period in column one of the output file, the period must be prefixed with an underline. This character must be prefixed by itself if it is to be printed out. .justify .leftmargin 10 ======================================================================================== DOCUMENT :usus Folder:VOL13:startup.text ======================================================================================== (* PutDate is a simple routine which will allow you to enter the system date and pre-set the prefix at boot time. This version works only on UCSD version II.0 or III.0 as it requires the system globals (found on volume 8). There is also another file called PDATE.TEXT which must be compiled and linked with PUTDATE. There is a salutations message which is kind of silly, but I like it. However it uses H-19 "graphics" characters so you will have to change of delete it if you don't have an H-19. George Schreyer *) (*$S+*) (*$C Copyright (c) 1982 Great Western Software all rights reserved*) program put_date; const prompt_line = 21; type date_string = string [ 10 ]; {this record discribes the structure of a UCSD directory} daterec = packed record month: 0..12; day: 0..31; year: 0..100 end; dirrange = 0..78; {this is set to 78 instead of 77 to make the record larger than 4 blocks. this allows the directory to be read with a blockread without memory allocation problems. the final part of a record cannot be accessed because dloadtime will never exceed 77.} vid = string[7]; tid = string[15]; filekind = (untyped,xdisk,code,text, info,data,graf,foto,securedir); direntry = record dfirstblk: integer; {first block on disk} dlastblk: integer; {top of system area blk 6 or 10} case dfkind:filekind of securedir,untyped: (dvid:vid; {volumeid} deovblk, { ? } dloadtime, {# of files} dblocks:integer; {size of volume} dlastboot:daterec); {system date} xdisk,code,text,info,data, graf,foto: (dtid:tid; {filename} dlastbyte:1..512; {last byte in last block} daccess:daterec) {date} end; directory = array[dirrange] of direntry; var datex : daterec; x,y : integer; day_string, month_string, year_string : string; temp_date,date : string; iday, imonth, iyear : integer; k : integer; file_length: integer; dirx : directory; disk : file; quit : boolean; prefix_volume : vid; procedure set_prefix ( prefix_volume : vid ); external; procedure eeos; external; procedure eeol; external; procedure p_date ( date : daterec ); external; procedure get_date ( date : daterec ); external; procedure int_to_str ( number : integer; var strg : string ); var ch : char; neg : boolean; i : integer; begin strg := '00000'; neg := false; if number < 0 then begin neg := true; number := number * ( -1 ); end; for i := 1 to 5 do begin ch := chr ( ( number mod 10 ) + ( ord ( '0' ) ) ); number := number div 10; strg [ 6 - i ] := ch; end; while pos( '0', strg ) = 1 do delete ( strg, 1, 1 ); if strg = '' then strg := '0' else if neg then strg := concat ( '-',strg ); end; procedure decode_date(day,month,year:integer); begin case month of 1: month_string:='Jan'; 2: month_string:='Feb'; 3: month_string:='Mar'; 4: month_string:='Apr'; 5: month_string:='May'; 6: month_string:='Jun'; 7: month_string:='Jul'; 8: month_string:='Aug'; 9: month_string:='Sep'; 10:month_string:='Oct'; 11:month_string:='Nov'; 12:month_string:='Dec' end; daystring := ''; yearstring := ''; int_to_str(day,daystring); int_to_str(year,yearstring); end; procedure str_to_int( var data : string; var number : integer; var was_integer: boolean); {converts input string to a positive integer} var i : integer; begin was_integer := true; number := 0; i := 0; if data <> '' then repeat i := i + 1; if data [i] in ['0'..'9'] then number := 10 * number + (ord(data[i]) - ord('0')) else was_integer := false; until ( not was_integer ) or ( i = length(data)) else was_integer := false; end; procedure check_month ( month_string : string; var month : integer ); var i : integer; begin month := 0; if length ( month_string ) > 0 then begin for i := 1 to length ( month_string ) do if month_string [ i ] in [ 'a'..'z' ] then month_string [ i ] := chr ( ord ( month_string [ i ] ) - 32 ); if month_string = 'JAN' then month := 1; if month_string = 'FEB' then month := 2; if month_string = 'MAR' then month := 3; if month_string = 'APR' then month := 4; if month_string = 'MAY' then month := 5; if month_string = 'JUN' then month := 6; if month_string = 'JUL' then month := 7; if month_string = 'AUG' then month := 8; if month_string = 'SEP' then month := 9; if month_string = 'OCT' then month := 10; if month_string = 'NOV' then month := 11; if month_string = 'DEC' then month := 12; end; end; procedure space_wait; var ch : char; begin write ( ' to continue ' ); repeat read ( keyboard, ch ); until ( ch = ' ' ) and ( not eoln ( keyboard ) ); gotoxy ( 0, prompt_line + 1 ); eeol; end; function take_apart_date ( var date : date_string; var day : integer; var month : integer; var year : integer ): boolean; var i : integer; day_ok, month_ok, year_ok : boolean; temp : string [ 1 ]; begin day_ok := true; month_ok := true; year_ok := true; take_apart_date := true; day_string := ''; month_string := ''; year_string := ''; temp := ' '; i := 1; repeat temp [ 1 ] := date [ i ]; if i in [ 1, 2 ] then begin if ( i = 2 ) and ( not ( ord ( temp [ 1 ] ) in [ ord ( '0' )..ord ( '9' ) ] ) ) then begin day_string := concat ( '0', day_string ); date := concat ( '0', date ); end else day_string := concat ( day_string, temp ); end; if i in [ 4, 5, 6 ] then month_string := concat ( month_string , temp ); if i in [ 8, 9, 10 ] then year_string := concat ( year_string, temp ); i := succ ( i ); until i > length ( date ); if length ( day_string ) > 0 then str_to_int ( day_string, day, day_ok ); if ( day_ok ) and ( day in [ 1..31 ] ) then begin if length ( month_string ) > 0 then check_month ( month_string, month ); if month in [ 1..12 ] then begin if length ( year_string ) > 0 then str_to_int ( year_string, year, year_ok ); if ( not ( year in [ 0..99 ] ) ) or ( not year_ok ) then begin write ( 'year invalid ' ); space_wait; take_apart_date := false; date := ''; year := 100; end; end else begin write ( ' month invalid ' ); space_wait; take_apart_date := false; date := ''; month := 0; end; end else begin write ( 'day invalid ' ); space_wait; take_apart_date := false; date := ''; day := 0; end; end; procedure banner; {just a silly message using H-19 graphics, delete this whole procedure or write your own if you don't have an H-19} PROCEDURE FINISH; BEGIN GOTOXY( x + 16, y + 3 ); WRITE('W e l c o m e'); GOTOXY( x + 21, y + 5 ); WRITE('t o'); GOTOXY( x + 10, y + 7 ); WRITE('George''s Computer Center'); GOTOXY( x + 4, y + 12 ); WRITE('UCSD Pascal p-system v2.0 presiding'); gotoxy ( x + 15, y + 14 ); prefix_volume := '#5'; write ( 'Prefix is ', prefix_volume, ':' ); set_prefix ( prefix_volume ); END; procedure write_a ( x, y, n : integer ); var j : integer; begin gotoxy ( x, y ); for j := 1 to n do write ( 'a' ); end; procedure write_bar ( x, y, n : integer ); var j : integer; begin gotoxy ( x, y ); for j := 1 to n do begin write ( chr ( 96 ), chr ( 10 ), chr ( 8 ) ); end; end; BEGIN WRITELN(CHR(27),'t'); {sets keypad shifted mode} WRITELN(CHR(27),'x5'); WRITELN(CHR(27),'F'); x := 17; y := 4; gotoxy ( x, y ); write ( 'f' ); write_a ( x + 1, y, 42 ); write ( 'c' ); gotoxy ( x + 2, y + 1 ); write ( 'f' ); write_a ( x + 3, y + 1, 38 ); write ( 'c' ); write_a ( x + 1, y + 10, 42 ); write ( 'd' ); write_a ( x + 3, y + 9, 38 ); write ( 'd' ); write_bar ( x, y + 1, 9 ); write ( 'e' ); write_bar ( x + 2, y + 2, 7 ); write ( 'e' ); write_bar ( x + 43, y + 1, 9 ); write_bar ( x + 41, y + 2, 7 ); WRITE(CHR(27),'G'); FINISH; WRITE(CHR(27),'y5'); END; procedure write_date_to_disk; begin reset ( disk, '*' ); k := blockread ( disk, dirx, 4, 2 ); dirx[0].dlastboot := datex; k := blockwrite ( disk, dirx, 4, 2 ); close ( disk, lock ); end; begin gotoxy ( 0, 0 ); eeos; banner; quit := false; file_length := 0; get_date ( datex ); with datex do begin iday := day; imonth := month; iyear := year; decode_date ( iday, imonth, iyear ); end; date := concat ( day_string, '-', month_string, '-', year_string ); if pos ( '-', date ) = 2 then date := concat ( '0', date ); with datex do begin if not take_apart_date ( date, iday, imonth, iyear ) then begin write ( 'date in memory invalid' ); exit ( program ); end; gotoxy ( 0,prompt_line -1 ); writeln ( 'Today is ', date ); repeat gotoxy ( 0, prompt_line ); eeol; write ( 'New date ? ' ); readln ( temp_date ); if length ( temp_date ) = 0 then exit ( program ); if take_apart_date ( temp_date, iday, imonth, iyear ) then begin day := iday; month := imonth; year := iyear; p_date ( datex ); quit := true; write_date_to_disk; end; until quit; end; end. ======================================================================================== DOCUMENT :usus Folder:VOL13:sysgen.text ======================================================================================== {$S+} {$C Copyright (C) 1980 Wynn Newhouse and Herb Jellinek. } {$C All rights reserved. Unauthorized reproduction is a } {$C violation of applicable laws. } Program Runon; (*$I DECLARE.TEXT*) (*$I INITC.TEXT*) Procedure include_file(f_name : string); Forward; Procedure out_proc(cmd : commandtype); var i, j : posint; v : old_new; eo_input, eo_output : boolean; Procedure putline(n : posint); Forward; (*$I DOPAGE.TEXT*) Procedure d_c_p; var searching, eo_line : boolean; cmd : commandtype; pos : posint; (*$I READNU.TEXT*) Procedure process_file(var source : text; inc_fil : boolean); (*$I READLN.TEXT*) (*$I MAIN.TEXT*) ======================================================================================== DOCUMENT :usus Folder:VOL13:taxcalc.text ======================================================================================== {From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman appearing in the Feburary 1982 issue of Byte magazine. Copyright 1982 Byte Publications, Inc. Used with permission of Byte Publications, Inc.} {This program is not EXACTLY the original, it has been patched is several places. Specifically, some of the data in TAXTABLE.TEXT has been changed} segment procedure calculate; var ln : tline_num; procedure ad ( first, second, sum : tline_num ); {add two lines} var ln : tline_num; begin tlines [ sum ].hus := tlines [ first ].hus + tlines [ second ].hus; tlines [ sum ].wif := tlines [ first ].wif + tlines [ second ].wif; tlines [ sum ].tot := tlines [ first ].tot + tlines [ second ].tot; end; procedure add ( start, finish, sum : tline_num ); var ln : tline_num; begin for ln := start to finish do begin tlines [ sum ].hus := tlines [ sum ].hus + tlines [ ln ].hus; tlines [ sum ].wif := tlines [ sum ].wif + tlines [ ln ].wif; tlines [ sum ].tot := tlines [ sum ].tot + tlines [ ln ].tot; end; end; procedure sub ( first, second, dif : tline_num ); {subtract two lines} var ln : tline_num; begin tlines [ dif ].hus := tlines [ first ].hus - tlines [ second ].hus; tlines [ dif ].wif := tlines [ first ].wif - tlines [ second ].wif; tlines [ dif ].tot := tlines [ first ].tot - tlines [ second ].tot; end; procedure taxcalc; {the thx calculation is done here} var ch : char; htaxable, wtaxable, ttaxable: longint; xfs : filing_status; i : 1..16; which : longint; procedure gettax ( tt : tax_table; tax_able : longint; var tax : longint; w : owner ); {get factors from the taxtable ad do calculate the tax} begin for i := 1 to 16 do {search the array for the correct tax bracket} if ( tax_able > taxray [ tt, i, lower ] ) and ( tax_able <= taxray [ tt, i, upper ] ) then begin {bracked found, now calculate tax} tax := taxray [ tt, i, base ] + ( taxray [ tt, i, percent ] ) * (( tax_able - taxray [ tt, i, lower ] ) div 100 ); max_tax [ w ] := taxray [ tt, i, percent ]; exit ( gettax ); end; end; begin {taxcalc} fstat := tlines [ 7 ].fs; {get filing status} if fstat in [ 2, 3 ] then {get exemptions for married} begin htaxable := tlines [ 34 ].hus - 100000; wtaxable := tlines [ 34 ].wif - 100000; ttaxable := tlines [ 34 ].tot - 100000 * ( tlines [ 7 ].exem ); {calculate total as joint return use tax table Y} gettax ( y, ttaxable, tlines [ 35 ].tot, t_own ); repeat clear; writeln ( 'should the individual taxes be calculated ' ); write (' as M(arried filing separatelu U(nmarried ' ); read ( keyboard, ch ); until ch in [ 'M','m','U','u' ]; if ch in [ 'U','u' ] then begin {calculate taxes for husband and wife as if they could file as individuals} gettax ( x, htaxable, tlines [ 35 ].hus, h_own ); gettax ( x, wtaxable, tlines [ 35 ].wif, w_own ); end else begin {calculate taxes for husband and wife as filing separate} gettax ( ys, htaxable, tlines [ 35 ].hus, h_own ); gettax ( ys, wtaxable, tlines [ 35 ].wif, w_own ); end; end else begin {get exemptions for unmarried} ttaxable := tlines [ 34 ].tot - 100000 * ( tlines [ 7 ].exem ); case fstat of 1 : gettax ( x, ttaxable, tlines [ 35 ].tot, t_own ); 2 : gettax ( z, ttaxable, tlines [ 35 ].tot, t_own ); 3 : gettax ( y, ttaxable, tlines [ 35 ].tot, t_own ); end; end; end; procedure linea40; {compensate for zero base} begin if tlines [ 7 ].fs in [ 2, 3 ] then begin tlines [ 106 ].hus := 170000; tlines [ 106 ].wif := 170000; tlines [ 106 ].tot := 340000; end else case tlines [ 7 ].fs of 1,4 : tlines [ 106 ].tot := 230000; 5 : tlines [ 106 ].tot := 340000; end; end; procedure calsch_a; {do calculations required by schedule A} begin tlines [ 69 ].hus := tlines [ 31 ].hus div 100; {line A 3} tlines [ 69 ].wif := tlines [ 31 ].wif div 100; {line A 3} tlines [ 69 ].tot := tlines [ 31 ].tot div 100; {line A 3} sub ( 68, 69, 70 ); {line A 4} with tlines [ 70 ] do begin if hus < 0 then hus := 0; {line A 4} if wif < 0 then wif := 0; {line A 4} if tot < 0 then tot := 0; {line A 4} end; add ( 70, 72, 73 ); tlines [ 74 ].hus := 3 * tlines [ 69 ].hus; {line A 7} tlines [ 74 ].wif := 3 * tlines [ 69 ].wif; {line A 8} tlines [ 74 ].tot := 3 * tlines [ 69 ].tot; {line A 8} sub ( 73, 74, 75 ); with tlines [ 75 ] do begin if hus < 0 then hus := 0; {line A 9} if wif < 0 then wif := 0; {line A 9} if tot < 0 then tot := 0; {line A 9} end; ad ( 67, 75, 76 ); {line A 10} tlines [ 99 ] := tlines [ 76 ]; {line A 33} add ( 77, 81, 82 ); {line A 16} tlines [ 100 ] := tlines [ 82 ]; {line A 34} add ( 83, 85, 86 ); {line A 20} tlines [ 101 ] := tlines [ 86 ]; {line A 35} add ( 87, 89, 90 ); {line A 24} tlines [ 102 ] := tlines [ 90 ]; {line A 36} sub ( 91, 92, 93 ); {line A 27} if tlines [ 93 ].hus < 10000 then tlines [ 94 ].hus := tlines [ 93 ].hus else tlines [ 94 ].hus := 10000; if tlines [ 93 ].wif < 10000 then tlines [ 94 ].wif := tlines [ 93 ].wif else tlines [ 94 ].wif := 10000; if tlines [ 93 ].tot < 10000 then tlines [ 94 ].tot := tlines [ 93 ].tot else tlines [ 94 ].tot := 10000; sub ( 93, 94, 95 ); {line A 29} tlines [ 103 ] := tlines [ 95 ]; {line A 37} add ( 96, 97, 98 ); {line A 32} tlines [ 104 ] := tlines [ 98 ]; {line A 38} add ( 99, 104, 105 ); {line A 39} linea40; sub ( 105, 106, 107 ); {line A 41} tlines [ 33 ] := tlines [ 107 ]; end; procedure calsch_b; begin tlines [ minbline + 1 ] := tlines [ minbline ]; {line B 1} tlines [ 9 ] := tlines [ minbline + 1 ]; tlines [ minbline + 3 ] := tlines [ minbline + 2 ]; {line B 3} add ( minbline + 3, minbline + 5, minbline + 6 ); {line B 6} sub ( minbline + 3, minbline + 6, minbline + 7 ); {line B 7} tlines [ 10 ] := tlines [ minbline + 7 ]; end; begin {calcuate} gotoxy ( 0, 0 ); eeol; write ( 'calculating ... ' ); for ln := 8 to maxline do if ln in calcset then begin tlines [ ln ].hus := 0; tlines [ ln ].wif := 0; tlines [ ln ].tot := 0; end; calsch_b; with tlines [ 10 ] do begin {dividend exclusion} hus := hus - 10000; if hus < 0 then hus := 0; wif := wif - 10000; if wif < 0 then wif := 0; tot := hus + wif; end; add ( 8, 21, 22 ); {total income} add ( 23, 29, 30 ); {total adjustments} sub ( 22, 30, 31 ); {adjusted gross} tlines [ 32 ] := tlines [ 31 ]; {transfer 31 to 32} calsch_a; sub ( 32, 33, 34 ); {income for start of tax calculation} taxcalc; add ( 35, 36, 37 ); {total taxes} add ( 38, 45, 46 ); {total credits} sub ( 37, 46, 47 ); {balance} add ( 47, 53, 54 ); {balance} add ( 55, 61, 62 ); {total tax payments} sub ( 54, 62, 63 ); {taxes-tax payments} if tlines [ 63 ].hus < 0 then tlines [ 63 ].hus := -1 * tlines [ 63 ].hus {overpayment} else begin tlines [ 66 ].hus := tlines [ 63 ].hus; {balance due} tlines [ 63 ].hus := 0; end; if tlines [ 63 ].wif < 0 then tlines [ 63 ].wif := -1 * tlines [ 63 ].wif else begin tlines [ 66 ].wif := tlines [ 63 ].wif; tlines [ 63 ].wif := 0; end; if tlines [ 63 ].tot < 0 then tlines [ 63 ].tot := -1 * tlines [ 63 ].tot else begin tlines [ 66 ].tot := tlines [ 63 ].tot; tlines [ 63 ].tot :=0; end; for ln := 8 to maxline do if ( ln in calcset ) then tlines [ ln ].iptr := nil; end; {calculate} ======================================================================================== DOCUMENT :usus Folder:VOL13:taxedit.text ======================================================================================== {From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman appearing in the Feburary 1982 issue of Byte magazine. Copyright 1982 Byte Publications, Inc. Used with permission of Byte Publications, Inc.} {This program is not EXACTLY the original, it has been patched is several places. Specifically, some of the data in TAXTABLE.TEXT has been changed} segment procedure edit; var ln : tline_num; {index to array tlines} int : integer; edit_char, ch : char; procedure edit_spec; {enter taxpayers name, the tax year, filing status, and the number of d dependents} var h, w : integer; int, exemps : integer; ln : tline_num; procedure filingstat; begin with tlines [ 7 ] do begin gotoxy ( 0, 4 ); eeos; writeln ( ' 1) Single' ); writeln; writeln ( ' 2) Married filing Jointly' ); writeln; writeln ( ' 3) Married filing Separately' ); writeln; writeln ( ' 4) Head of Household' ); writeln; writeln ( ' 5) Widow(er)' ); writeln; repeat int := readint ( 1 ); until int in [ 1..5 ]; fs := int; if fs in [ 2, 3 ] then single := false; end; end; begin {edit_spec} ln := 7; clear; gotoxy ( 0, 2 ); with tlines [ 7 ] do begin center ( titles [ 5 ], screen ); writeln; namer ( 'name', tlines [ 6 ].name, 26 ); namer ( 'tax year', taxyear, 4 ); filingstat; exem := 0; clear; gotoxy ( 0, 2 ); write ( 'enter correct letter' ); gotoxy ( 0, 4 ); center ( titles [ 7 ], screen ); writeln; writeln ( ' Y(ourself' ); writeln; writeln ( ' O(ver sixtyfive' ); writeln; writeln ( ' B(lind' ); writeln; writeln ( ' T( over 65 and blind' ); repeat read ( keyboard , ch ); until ch in [ 'y','Y','o','O','b','B','t','T' ]; case ch of 'Y','y' : h := 1; 'O','o' : h := 2; 'B','b' : h := 2; 'T','t' : h := 3; end; if not single then begin center ( titles [ ln ], screen ); writeln; gotoxy ( 0, 6 ); eeos; writeln ( ' S(pouse' ); writeln; writeln ( ' O(ver sixtyfive' ); writeln; writeln ( ' B(lind' ); writeln; writeln ( ' T( over 65 and blind' ); repeat read ( keyboard, ch ); until ch in [ 's','S','o','O','b','B','t','T' ]; case ch of 'S','s' : w := 1; 'O','o' : w := 2; 'B','b' : w := 2; 'T','t' : w := 3; end; end else w := 0; clear; gotoxy ( 0, 6 ); write ( 'enter number of dependents ' ); exemps := readint ( 2 ); exem := w + h + exemps; end; end; procedure edit_tline ( ln : tline_num ); {main data input routine} var hsum, wsum, dol : integer [ 9 ]; nextptr, ptr, lastptr : pointer; tl : boolean; ch : char; procedure view; {displays contents of tlines[ln]} var screen : boolean; obj : intstr; begin obj := ''; screen := true; gotoxy ( 0, 3 ); eeos; if not single then begin gotoxy ( 0, 8 ); pdol ( tlines [ ln ].hus, obj ); write ( 'husband':20, obj:20 ); gotoxy ( 0, 10 ); pdol ( tlines [ ln ].wif, obj ); write ( 'wife':20, obj:20 ); end; gotoxy ( 0, 12 ); pdol ( tlines [ ln ].tot, obj ); write ( 'total':20, obj:20 ); end; procedure sums; {adds all items and place values in tlines [ ln ] } begin with tlines [ ln ] do begin hus := 0; wif := 0; tot := 0; if iptr <> nil then begin nextptr := iptr; repeat if nextptr^.whose = h_own then hus := hus + nextptr^.amt else wif := wif + nextptr^.amt; nextptr := nextptr^.nptr; until nextptr = nil; tot := hus + wif; end; end; end; procedure who ( ptr : pointer ); {assign item to husband or wife} begin with ptr^ do begin gotoxy ( 0, 12 ); write ( 'assign to H(usband or W(ife ' ); repeat read ( keyboard, ch ); until ch in [ 'H','h','W','w' ]; if ch in [ 'H','h' ] then whose := h_own else whose := w_own; gotoxy ( 0, 12 ); eeol; {clean-up gws} end; end; function viewitem ( ptr : pointer ) : pointer; {display and edit an item then return pointer to next item} var st : string; ch : char; obj : intstr; begin obj := ''; {got to initialize those strings! gws} clear; write ( 'Command --> to continue, ^D(elete,' ); write ( ' Change --> N(ame, A(mount' ); if not single then write ( ', W(hose' ); with ptr^ do begin viewitem := nptr; gotoxy ( 0, 4 ); write ( 'line number ' ); if ln <= maxtline then write ( ln:2 ) else if ln <= maxaline then write ( ln - minaline + 1:2 ) else if ln <= maxbline then write ( ln - minbline + 1:2 ); writeln ( ' ', titles [ ln ]:40 ); gotoxy ( 0, 6 ); write ( name ); eeos; gotoxy ( 0, 8 ); case whose of h_own : write ( 'husband' ); w_own : write ( 'wife' ); t_own : write ( 'total' ); end; gotoxy ( 0, 10 ); pdol ( amt, obj ); write ( 'amount ', obj:12 ); repeat repeat gotoxy ( 77, 0 ); read ( keyboard, ch ); if ch = chr ( 4 ) then begin if tl then {if pointer was from tlines [ ln ]} tlines [ ln ].iptr := nptr else lastptr^.nptr := nptr; exit ( viewitem ); end; until ( ch in [ 'N','n','W','w','A','a',' ' ] ) and ( not eoln ( keyboard ) ); if ch in [ 'N','n','W','w','A','a' ] then begin {change a value in item} with ptr^ do begin case ch of 'N','n' : namer ( 'name', ptr^.name, 10 ); 'A','a' : begin gotoxy ( 0, 10 ); readdol ( 9, amt ); writeln; end; 'W','w' : who ( ptr ); end; gotoxy ( 77, 0 ); end; end; until ch = ' '; end; tl := false; { parent of pointer is no longer tlines [ ln ]} lastptr := ptr; end; begin {edit_tline} hsum := 0; wsum := 0; with tlines [ ln ] do begin if iptr <> nil then {if any items exist} begin tl := true; {parent of pointer is tlines [ ln ]} nextptr := viewitem ( iptr ); {get first item} while ( nextptr <> nil ) do nextptr := viewitem ( nextptr ); end; repeat {add itmes or leave} clear; gotoxy ( 0, 2 ); write ( 'line number ' ); if ln <= maxtline then write ( ln:2 ) else if ln <= maxaline then write ( ln - minaline + 1:2 ) else if ln <= maxbline then write ( ln - minbline + 1:2 ); writeln ( ' ',titles [ ln ]:40 ); write ( 'do you want to add an item y/n' ); repeat read ( keyboard, ch ); until ch in [ 'Y','y','N','n' ]; eline; if ch in [ 'N','n' ] then begin sums; {add the items and put in tlines [ ln ]} view; {display the contents of tlines [ ln ]} exit ( edit_tline ); end; new ( ptr ); if iptr = nil then iptr := ptr {if its the first item of tlines [ln]} else lastptr^.nptr := ptr; lastptr := ptr; with ptr^ do {begin actual data entry} begin nptr := nil; tlnum := ln; namer ( 'name', ptr^.name, 10 ); gotoxy (0, 8 ); write ( 'enter amount ' ); readdol ( 9, amt ); if single then whose := h_own else who ( ptr ); end; until ch = 'Q'; end; end; function edit_what : char; {select a schedule to edit} var ch : char; begin clear; write ( 'Edit Command --> A(schedlue A, B(schedule B, Z(form 1040,' ); write ( ' F(iling status, Q(uit '); repeat read ( keyboard, ch ); until ch in [ 'A','a','B','b','Z','z','F','f','Q','q' ]; if ch in [ 'q','Q' ] then exit ( edit ); writeln; edit_what := ch; end; procedure ed_sequent ( first, last : tline_num ); {edit elines [ first ] to tlines [ last ] unless the line is a calculated line} var ln : tline_num; begin for ln := first to last do if not ( ln in calcset ) then begin edit_tline ( ln ); gotoxy ( 10, 23 ); write ( 'enter to continue to quit' ); repeat read ( keyboard, ch ); until ( ch in [ 'Q','q',chr ( 32 ) ] ) and ( not eoln ( keyboard ) ); if ch in [ 'Q','q' ] then exit ( ed_sequent ); end; end; procedure ed_individual; {select a single line to edit} var ok : boolean; begin repeat clear; write ( 'enter line number to be changed 0) for help ' ); repeat ok := false; int := readint ( 2 ); if int = 0 then begin clear; case edit_char of 'A','a' : for ln := minaline to maxaline do if not ( ln in calcset ) then write (( ln - minaline + 1):8, titles [ ln ]:32); 'B','b' : for ln := minbline to maxbline do if not ( ln in calcset ) then write (( ln - minbline + 1):8, titles [ ln ]:32 ); 'Z','z' : for ln := 8 to maxtline do if not ( ln in calcset ) then write ( ln:8, titles [ ln ]:32 ); end; writeln; end; case edit_char of 'A','a' : begin if ( int > 0 ) and ( int <= 41 ) then ok := true; ln := int + minaline - 1; end; 'B','b' : begin if ( int > 0 ) and ( int <= 8 ) then ok := true; ln := int + minbline - 1; end; 'Z','z' : begin if ( int > 7 ) and ( int <= maxtline ) then begin ok := true; ln := int; end; end; end; until ok; {a valid line number has been requested} if ( ln in calcset ) then begin clear; writeln ( 'line ', int, ' is a calculated value and may not', ' be edited ' ); wait; end else edit_tline ( ln ); gotoxy ( 0, 0 ); eeol; write ( ' do you want to --> C(ontinue Q(uit' ); repeat read ( keyboard, ch ); until ch in [ 'C','c','Q','q' ]; until ch in [ 'Q','q' ]; end; begin {edit} repeat clear; edit_char := edit_what; {what form should be edited} if edit_char in [ 'F','f' ] then edit_spec else begin clear; write ( ' Edit Command-->' ); write ( ' S(equentially, I(ndividual, Q(uit'); repeat read ( keyboard, ch ); until ch in [ 'S','s','I','i','Q','q' ]; case ch of 'S','s' : begin case edit_char of 'A','a' : ed_sequent ( minaline, maxaline ); 'B','b' : ed_sequent ( minbline, maxbline ); 'Z','z' : ed_sequent ( 8, maxtline ); end; end; 'I','i' : ed_individual; end; end; until ch in [ 'Q','q' ]; end; {edit} ======================================================================================== DOCUMENT :usus Folder:VOL13:taxnames.text ======================================================================================== (*$S+*) {From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman appearing in the Feburary 1982 issue of Byte magazine. Copyright 1982 Byte Publications, Inc. Used with permission of Byte Publications, Inc.} {This program is not EXACTLY the original, it has been patched is several places. Specifically, some of the data in TAXTABLE.TEXT has been changed} program taxnames; {creates file of name of tax lines} const maxtline = 115; type t = array [ 1.. maxtline ] of string [ 30 ]; var titles : t; tfile : file of t; procedure wait; var ch : char; begin gotoxy ( 10, 23 ); write ( 'Enter to continue' ); repeat read ( keyboard, ch ); until ch = chr ( 27 ); end; procedure writefile; begin rewrite ( tfile, 'linenams.ftax' ); tfile^ := titles; put ( tfile ); close ( tfile, lock ); end; procedure readfile; var i : 1..maxtline; begin reset ( tfile, 'linenams.ftax' ); titles := tfile^; for i := 1 to maxtline do begin writeln ( titles [ i ] ); if i mod 16 = 0 then begin wait; gotoxy ( 0,0 ); write ( chr ( 27 ), chr ( 69 ) ); {clear screen for H-19} end; end; end; procedure init1; begin titles [ 1 ] := 'Filing Status '; titles [ 2 ] := 'Filing Status '; titles [ 3 ] := 'Filing Status '; titles [ 4 ] := 'Filing Status '; titles [ 5 ] := 'Filing Status '; titles [ 6 ] := 'Exemptions '; titles [ 7 ] := 'Exemptions '; titles [ 8 ] := 'Wages, Salaries, etc '; titles [ 9 ] := 'Interest income '; titles [ 10 ] := 'Dividends '; titles [ 11 ] := 'Income Tax Refunds '; titles [ 12 ] := 'Alimony Received '; titles [ 13 ] := 'Business Income '; titles [ 14 ] := 'Capital Gain '; titles [ 15 ] := 'Capital Gain Dist '; titles [ 16 ] := 'Supplemental Gains '; titles [ 17 ] := 'Taxable Pensions & Annuities '; titles [ 18 ] := 'Pensions, Rents, Roys, Partner'; titles [ 19 ] := 'Farm Income '; titles [ 20 ] := 'Unemployment '; titles [ 21 ] := 'Other Income '; titles [ 22 ] := 'Total Income '; titles [ 23 ] := 'Moving Expense '; titles [ 24 ] := 'Emp Business Expense '; titles [ 25 ] := 'Payments to IRA '; titles [ 26 ] := 'Payments to Keogh '; end; procedure init2; begin titles [ 27 ] := 'Interest Penalty '; titles [ 28 ] := 'Alimony Paid '; titles [ 29 ] := 'Disability Income '; titles [ 30 ] := 'Total Adjustments '; titles [ 31 ] := 'Adjusted Gross Income '; titles [ 32 ] := 'Adjusted Gross Income '; titles [ 33 ] := 'Deductions '; titles [ 34 ] := '32 - 33 '; titles [ 35 ] := 'Tax '; titles [ 36 ] := 'Additional Taxes '; titles [ 37 ] := 'Total Taxes '; titles [ 38 ] := 'Political Contributions '; titles [ 39 ] := 'Credit for Elderly '; titles [ 40 ] := 'Child and Dependant '; titles [ 41 ] := 'Investment Credit '; titles [ 42 ] := 'Foreign Tax Credit '; titles [ 43 ] := 'Work Incentive '; titles [ 44 ] := 'Jobs Credit '; titles [ 45 ] := 'Energy Credits '; titles [ 46 ] := 'Total Credits (lines 38 to 45)'; titles [ 47 ] := 'Balance (line 37 - line 46) '; titles [ 48 ] := 'Self Employment Tax '; titles [ 49 ] := 'Minimum Tax '; end; procedure init3; begin titles [ 50 ] := 'Tax from Prior Year Inv-Credit'; titles [ 51 ] := 'FICA and RRTA Taxes '; titles [ 52 ] := 'Tax on IRA '; titles [ 53 ] := 'Advance EIC Paymts Received '; titles [ 54 ] := 'Balance (lines 47 to 53) '; titles [ 55 ] := 'Total FICA Withheld '; titles [ 56 ] := '1980 Estimated Tax Payments '; titles [ 57 ] := 'Earned Income Credit '; titles [ 58 ] := 'Amount Paid with Form 4868 '; titles [ 59 ] := 'Excess FICA and RRTA Tax Paid '; titles [ 60 ] := 'Credit for Fed Tax on SP Fuel '; titles [ 61 ] := 'Regulated Investment Co Credit'; titles [ 62 ] := 'Total (line 55 to 61) '; titles [ 63 ] := 'Overpaid '; titles [ 64 ] := 'To be Refunded to You '; titles [ 65 ] := 'Applied to Est 1981 Tax '; titles [ 66 ] := 'Balance Due '; end; procedure init4; begin titles [ 67 ] := '50 % of Medical Ins Prems '; titles [ 68 ] := 'Medicine and Drugs '; titles [ 69 ] := '1% of line 31 Form 1040 '; titles [ 70 ] := 'Sub Total line 3 - line 2 '; titles [ 71 ] := 'Balance of Ins Prems '; titles [ 72 ] := 'Other Medical and Dental '; titles [ 73 ] := 'Total (lines 4 to 6) '; titles [ 74 ] := '3% of line 31 Form 1040 '; titles [ 75 ] := 'Line 7 - Line 8 '; titles [ 76 ] := 'Total Medical and Dental '; titles [ 77 ] := 'State & Local Income Tax '; titles [ 78 ] := 'Real Estate Taxes '; titles [ 79 ] := 'General Sales Taxes '; titles [ 80 ] := 'Personal Property Taxes '; titles [ 81 ] := 'Other Taxes '; titles [ 82 ] := 'Total Taxes lines 11 to 15 '; titles [ 83 ] := 'Home Mortgage Interest '; titles [ 84 ] := 'Credit & Charge Cards '; titles [ 85 ] := 'Other Interest '; titles [ 86 ] := 'Total Int (lines 16 to 19) '; end; procedure init5; begin titles [ 87 ] := 'Cash Contributions '; titles [ 88 ] := 'Other Cash Contributions '; titles [ 89 ] := 'Carryover '; titles [ 90 ] := 'Total Contributions '; titles [ 91 ] := 'Loss Before Insurance '; titles [ 92 ] := 'Insurance Reinbursement '; titles [ 93 ] := 'Line 25 - Line 26 '; titles [ 94 ] := '$100 or Line 27 '; titles [ 95 ] := 'Total Casualty or Theft '; titles [ 96 ] := 'Union Dues '; titles [ 97 ] := 'Other Misc Deductions '; titles [ 98 ] := 'Total Miscellaneous '; titles [ 99 ] := 'Total Medical & Dental '; titles [100 ] := 'Total Taxes '; titles [101 ] := 'Total Interest '; titles [102 ] := 'Total Contributions '; titles [103 ] := 'Total Casualty or Theft '; titles [104 ] := 'Total Miscellaneous '; titles [105 ] := 'Sum (lines 33 to 38) '; titles [106 ] := 'Adjustment '; end; procedure init6; begin titles [107 ] := 'Line 39 - Line 40 '; titles [108 ] := 'Interest Income '; titles [109 ] := 'Total Interest Income '; titles [110 ] := 'Dividend Income '; titles [111 ] := 'Total Dividend Income '; titles [112 ] := 'Capital Gain Distribution '; titles [113 ] := 'Nontaxable Distributions '; titles [114 ] := 'Total (lines 5 & 6) '; titles [115 ] := 'Dividends Berore Exclusions '; end; begin init1; init2; init3; init4; init5; init6; writefile; wait; readfile; end. ======================================================================================== DOCUMENT :usus Folder:VOL13:taxprint.text ======================================================================================== {From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman appearing in the Feburary 1982 issue of Byte magazine. Copyright 1982 Byte Publications, Inc. Used with permission of Byte Publications, Inc.} {This program is not EXACTLY the original, it has been patched is several places. Specifically, some of the data in TAXTABLE.TEXT has been changed} segment procedure printer; var detail : boolean; lines : integer; print_what, ch1 : char; procedure print_date; var cmonth : string [ 3 ]; begin case month of 1 : cmonth := 'Jan'; 2 : cmonth := 'Feb'; 3 : cmonth := 'Mar'; 4 : cmonth := 'Apr'; 5 : cmonth := 'May'; 6 : cmonth := 'Jun'; 7 : cmonth := 'Jul'; 8 : cmonth := 'Aug'; 9 : cmonth := 'Sep'; 10 : cmonth := 'Oct'; 11 : cmonth := 'Nov'; 12 : cmonth := 'Dec'; end; writeln ( p, day:2, ' ', cmonth, ' ', '19', year:2 ); end; procedure heading ( title : filename ); begin line ( '*', 79 ); writeln ( p ); write ( p, tlines [ 6 ].name ); write ( p, 'Tax year ':( 44 - length ( tlines [ 6 ].name ))); writeln ( p, tlines [ 7 ].taxyear:4, title:29 ); write ( p, 'Filing status ' ); case tlines [ 7 ].fs of 1 : write ( p, '1' ); 2 : write ( p, '2' ); 3 : write ( p, '3' ); 4 : write ( p, '4' ); 5 : write ( p, '5' ); end; write ( p, ' exemptions ' ); write ( p, tlines [ 7 ].exem, ' ':27 ); print_date; line ( '*', 79 ); writeln ( p ); if fstat in [ 2, 3 ] then writeln ( p, ' ':40, ' Husband ':12, ' Wife ':12, ' Total ':12 ) else writeln ( p ); lines := 4; end; procedure detail_print ( first, last : tline_num; title : filename ); {prints an item by tax line} var ln : tline_num; obj, hdol, wdol, tdol : string [ 10 ]; nextptr : pointer; begin obj := ''; if screen then clear; heading ( title ); for ln := first to last do if tlines [ ln ].iptr <> nil then begin {do not bother unless line has an item} case print_what of 'A','a' : write ( p, ( ln - minaline + 1 ):2 ); 'B','b' : write ( p, ( ln - minbline + 1 ):2 ); 'Z','z' : write ( p, ( ln ):2 ); end; writeln ( p, ' ', titles [ ln ] ); {print name of line} lines := succ ( lines ); {increment the line counter} nextptr := tlines [ ln ].iptr; {first pointer} while nextptr <> nil do {until the last item} begin with nextptr^ do begin write ( p, name ); pdol ( amt, obj ); {convert long int to string} case whose of h_own : begin write ( p, 'Hus':( 25 - length ( name ))); writeln ( p, obj:25 ); end; w_own : begin write ( p, 'Wif':( 25 - length ( name ))); writeln ( p, obj:38 ); end; t_own : begin write ( p, 'Tot':( 25 - length ( name ))); writeln ( p, obj:51 ); end; end; lines := succ ( lines ); nextptr := nptr; end; end; with tlines [ ln ] do begin pdol ( hus, hdol ); pdol ( wif, wdol ); pdol ( tot, tdol ); if fstat in [ 2, 3 ] then writeln ( p, 'Total', hdol:45, wdol:13, tdol:13 ) else writeln ( p, 'Total', ' ':58, tdol:13 ); writeln ( p ); lines := succ ( lines ); end; if screen then if ( 16 - lines ) < 0 then begin wait; clear; lines := 0; end else if ( 54 - lines ) < 0 then begin write ( p, chr ( 12 ) ); heading ( title ); end; end; if screen then wait; write ( p, chr ( 12 )); end; procedure print ( first, last : tline_num; title : filename ); const s1 = ' ---------- ---------- ----------'; var ln : tline_num; hdol, wdol, tdol : string [ 10 ]; begin hdol := ''; wdol := ''; tdol := ''; if screen then clear; heading ( title ); for ln := first to last do with tlines [ln ] do begin pdol ( hus, hdol ); pdol ( wif, wdol ); pdol ( tot, tdol ); case print_what of 'A','a' : write ( p, ( ln - minaline + 1 ):2 ); 'B','b' : write ( p, ( ln - minbline + 1 ):2 ); 'Z','z' : write ( p, ( ln ):2 ); end; writeln ( p, ' ', titles [ ln ], ' ':5, hdol:12, wdol:12, tdol:12); if ln in dlineset then writeln ( p, s1:79 ); if ln in slineset then begin line ( '=', 79 ); writeln ( p ); end; if screen and ( ln in spageset ) then begin wait; clear; end; if ( not screen ) and ( ln = 37 ) then begin write ( p, chr ( 12 ) ); heading ( title ); end; end; if print_what in [ 'Z', 'z' ] then begin write ( p, ' Maximum Tax Bracket', ' ':18 ); writeln ( p, max_tax [ h_own ]:12, max_tax [ w_own ]:12, max_tax [ t_own ]:12 ); end; if screen then wait; write ( p, chr ( 12 ) ); end; begin {printer} {a separate line is printed after a line in slineset} slineset := [ 22, 30, 37, 47, 54, 62, 66, 76, 82, 86, 90, 95, 98, 107, 109, 111 ]; {a dashed line is printed after a line slineset} dlineset := [ 21, 29, 33, 36, 45, 46, 53, 61, 69, 72, 81, 85, 89, 92, 94, 97, 106, 113 ]; {last lines in a screen page are in spageset} spageset := [ 22, 37, 54, 76, 90, 98 ]; clear; mem; repeat detail := false; {contro to print deatil} clear; write ( 'Printer Command --> A(sched A B(sched B Z(form 1040 ' ); write ( ' #(for detail Q(uit ' ); repeat read ( keyboard, print_what ); if print_what = '#' then detail := true; until print_what in [ 'A','a','B','b','Z','z','Q','q' ]; if not ( print_what in [ 'Q','q' ] ) then begin writeln; write ( 'Do you want to output to --> P(rinter S(creen ' ); repeat read ( keyboard, ch1 ); until ch1 in [ 'P','p','S','s' ]; close ( p ); if ch1 in [ 'S','s' ] then begin screen := true; rewrite ( p, 'console:' ); end else begin screen := false; rewrite ( p , 'printer:' ); end; if detail then case print_what of 'A','a' : detail_print ( 67, 107, 'Schedule A' ); 'B','b' : detail_print ( 108, 115, 'Schedule B' ); 'Z','z' : detail_print ( 8, 66, 'Form 1040' ); end else case print_what of 'A','a' : print ( 67, 107, 'Schedule A' ); 'B','b' : print ( 108, 115, 'Schedule B' ); 'Z','z' : print ( 8, 66, 'Form 1040' ); end; end; close ( p ); until print_what in [ 'Q','q' ]; end; {printer} ======================================================================================== DOCUMENT :usus Folder:VOL13:taxrw.text ======================================================================================== {From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman appearing in the Feburary 1982 issue of Byte magazine. Copyright 1982 Byte Publications, Inc. Used with permission of Byte Publications, Inc.} {This program is not EXACTLY the original, it has been patched is several places. Specifically, some of the data in TAXTABLE.TEXT has been changed} segment procedure rw ( ch : char ); {reads or writes Files of tlines and items} var fl : file of tls; fi : file of item; function lookup ( fn : string ) : boolean; {checks to see if file is on disk} var ior : 0..15; begin {$I-} reset ( p, fn ); ior := ioresult; close ( p ); {$I+} if ior = 0 then lookup := true else begin lookup := false; if ior <> 10 then writeln ( 'ioresult for file ', fn, ' is ', ior ); end; end; procedure reader; {reads files of tlines and items} const fn1 = '.line'; fn2 = '.item'; var st : string; fn : filename; procedure read_tlines ( fn : filename ); var i : tline_num; begin if not lookup ( fn ) then begin clear; gotoxy ( 12, 20 ); writeln ( 'File ', fn, ' not found' ); wait; exit ( read_tlines ); end; reset ( fl, fn ); tlines := fl^; close ( fl ); for i := 8 to maxline do tlines [ i ].iptr := nil; writeln ( 'File ', fn, ' read. '); end; procedure read_items ( fn : filename ); var ch : char; pt, newpt : pointer; begin if not lookup ( fn ) then begin clear; gotoxy ( 10, 10 ); write ( 'File ', fn, ' not found.' ); wait; exit ( read_items ); end; reset ( fi, fn ); write ( 'Reading file ', fn ); while not eof ( fi ) do begin new ( newpt ); newpt^ := fi^; newpt^.nptr := nil; if ( tlines [ newpt^.tlnum ].iptr = nil ) then tlines [ newpt^.tlnum ].iptr := newpt else begin pt := tlines [ newpt^.tlnum ].iptr; while ( pt^.nptr <> nil ) do pt := pt^.nptr; pt^.nptr := newpt; end; get ( fi ); write ( '.' ); end; close ( fi ); end; begin {reader} namer ( 'File to be read ', st, 8 ); fn := concat ( st, fn1 ); read_tline ( fn ); fn := concat ( st, fn2 ); read_items ( fn ); wait; end; { reader } procedure writer; {writes file of tlines and items} const fn1 = '.line'; fn2 = '.item'; var st : string; fn : filename; procedure write_tlines ( fn : filename ); var ch : char; ln : tline_num; begin if lookup ( fn ) then begin clear; gotoxy ( 0 , 20 ); writeln ( 'Do you wand to remove the old file y/n ' ); repeat read ( keyboard, ch ); until ch in [ 'Y','y','N','n' ]; if ch in [ 'N','n' ] then exit ( writer ); end; rewrite ( fl, fn ); fl^ := tlines; put ( fl ); close ( fl, lock ); end; procedure write_items ( fn : filename ); var ch : char; pt : pointer; ln : tline_num; begin rewrite ( fi, fn ); for ln := 8 to maxline do if not ( ln in calcset ) then begin if tlines [ ln ].iptr <> nil then begin pt := tlines [ ln ].iptr; while ( pt <> nil ) do begin fi^ := pt^; put ( fi ); pt := pt^.nptr end; end; end; close ( fi, lock ); end; begin {writer} namer ( 'File to be written ', st, 8 ); fn := concat ( st, fn1 ); write_tline ( fn ); fn := concat ( st, fn2 ); write_items ( fn ); end; {writer} begin {rw} case ch of 'R' : reader; 'W' : writer; end; end; {rw} ======================================================================================== DOCUMENT :usus Folder:VOL13:taxstart.text ======================================================================================== {From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman appearing in the Feburary 1982 issue of Byte magazine. Copyright 1982 Byte Publications, Inc. Used with permission of Byte Publications, Inc.} {This program is not EXACTLY the original, it has been patched is several places. Specifically, some of the data in TAXTABLE.TEXT has been changed} segment procedure start; {sets up the variables} procedure initialize; {inserts nul values in tlines} var i : 1..maxline; empty : tline; begin max_tax [ h_own ] := 0; max_tax [ w_own ] := 0; max_tax [ t_own ] := 0; with empty do begin iptr := nil; hus := 0; wif := 0; tot := 0; end; for i := 8 to maxline do begin tlines [ i ] := empty; tlines [ i ].tag := 1; end; with tlines [ 7 ] do begin d1 := 1; d2 := 1; d3 := 80; taxyear := ' '; fs := 0; exem := 0; end; with tlines [ 6 ] do name := ' '; end; procedure readfactors; {reads the tax factor file into the array taxray} var tfile : file of factorarray; ttlable : tax_table; begin reset ( tfile, 'factors.ftax' ); for ttable := x to z do begin taxray [ ttable ] := tfile^; write ( '.' ); get ( tfile ); end; close ( tfile ); end; procedure readnames; {reads the line names into the array titles} type t = array [ 1..maxline ] of string [ 30 ]; var tnames : file of t; begin reset ( tnames, 'linenams.ftax' ); titles := tnames^; end; procedure getdate; {gets the system date from drive 4} var dummy : packed array [ 1..22 ] of char; high, low : integer; begin unitread ( 4, dummy, 24 ,2 ); high := ord ( dummy [ 22 ] ); low := ord ( dummy [ 21 ] ); day := ( high mod 2 ) * 16 + ( low div 16 ); month := low mod 16; year := high div 2; end; begin getdate; {the following set contains line numbers of lines requiring calculation} calcset := [ 9,10,22,20,31,32,33,34,35,37,46,47,54,62..66,69,70, 73..76,82,86,88,90,93..95,98..107,109,111,114,115]; single := true; {needs a value to start} screen := true; {most times it is} initialize; readfactors; readnames; end; ======================================================================================== DOCUMENT :usus Folder:VOL13:taxtable.text ======================================================================================== (*$S+*) {From "FIT - A Federal Income Tax Program in UCSD Pascal" by Edward Heyman appearing in the Feburary 1982 issue of Byte magazine. Copyright 1982 Byte Publications, Inc. Used with permission of Byte Publications, Inc.} {This program is not EXACTLY the original, it has been patched is several places. Specifically, some of the data in TAXTABLE.TEXT has been changed} program taxtable; type tfactors = ( lower, upper, base, per ); factorray = array [ 1..16, tfactors ] of integer [ 9 ]; t = array [ 1..4 ] of factorray; var ty : t; tfile : file of t; procedure writefile; begin rewrite ( tfile, 'factors.ftax' ); tfile^ := ty; put ( tfile ); close ( tfile, lock ); end; procedure init1a; {schedule X single tax payers lower bracket limit} begin ty [ 1, 1, lower ] := 230000; ty [ 1, 2, lower ] := 340000; ty [ 1, 3, lower ] := 440000; ty [ 1, 4, lower ] := 650000; ty [ 1, 5, lower ] := 850000; ty [ 1, 6, lower ] := 1080000; ty [ 1, 7, lower ] := 1290000; ty [ 1, 8, lower ] := 1500000; ty [ 1, 9, lower ] := 1820000; ty [ 1, 10, lower ] := 2350000; ty [ 1, 11, lower ] := 2880000; ty [ 1, 12, lower ] := 3410000; ty [ 1, 13, lower ] := 4150000; ty [ 1, 14, lower ] := 5530000; ty [ 1, 15, lower ] := 8180000; ty [ 1, 16, lower ] := 10830000; end; procedure init1b; {schedule X single taxpayers upper limit bracket} begin ty [ 1, 1, upper ] := 340000; ty [ 1, 2, upper ] := 440000; ty [ 1, 3, upper ] := 650000; ty [ 1, 4, upper ] := 850000; ty [ 1, 5, upper ] := 1080000; ty [ 1, 6, upper ] := 1290000; ty [ 1, 7, upper ] := 1500000; ty [ 1, 8, upper ] := 1820000; ty [ 1, 9, upper ] := 2350000; ty [ 1, 10, upper ] := 2880000; ty [ 1, 11, upper ] := 3410000; ty [ 1, 12, upper ] := 4150000; ty [ 1, 13, upper ] := 5530000; ty [ 1, 14, upper ] := 8180000; ty [ 1, 15, upper ] := 10830000; ty [ 1, 16, upper ] := 999999999; end; procedure init1c; {schedule X single taxpayers base tax} begin ty [ 1, 1, base ] := 00; ty [ 1, 2, base ] := 15400; ty [ 1, 3, base ] := 31400; ty [ 1, 4, base ] := 62900; ty [ 1, 5, base ] := 107200; ty [ 1, 6, base ] := 155500; ty [ 1, 7, base ] := 205900; ty [ 1, 8, base ] := 260500; ty [ 1, 9, base ] := 356500; ty [ 1, 10, base ] := 536700; ty [ 1, 11, base ] := 743400; ty [ 1, 12, base ] := 976600; ty [ 1, 13, base ] := 1339200; ty [ 1, 14, base ] := 2098200; ty [ 1, 15, base ] := 3767700; ty [ 1, 16, base ] := 5569700; end; procedure init1d; {schedule X single taxpayers tax rate} begin ty [ 1, 1, per ] := 14; ty [ 1, 2, per ] := 16; ty [ 1, 3, per ] := 18; ty [ 1, 4, per ] := 19; ty [ 1, 5, per ] := 21; ty [ 1, 6, per ] := 24; ty [ 1, 7, per ] := 26; ty [ 1, 8, per ] := 30; ty [ 1, 9, per ] := 34; ty [ 1, 10, per ] := 39; ty [ 1, 11, per ] := 44; ty [ 1, 12, per ] := 49; ty [ 1, 13, per ] := 55; ty [ 1, 14, per ] := 63; ty [ 1, 15, per ] := 68; ty [ 1, 16, per ] := 70; end; procedure init2a; {schedule Y married taxpayers lower bracket limit} begin ty [ 2, 1, lower ] := 340000; ty [ 2, 2, lower ] := 550000; ty [ 2, 3, lower ] := 760000; ty [ 2, 4, lower ] := 1190000; ty [ 2, 5, lower ] := 1600000; ty [ 2, 6, lower ] := 2020000; ty [ 2, 7, lower ] := 2460000; ty [ 2, 8, lower ] := 2990000; ty [ 2, 9, lower ] := 3520000; ty [ 2, 10, lower ] := 4580000; ty [ 2, 11, lower ] := 6000000; ty [ 2, 12, lower ] := 8560000; ty [ 2, 13, lower ] := 10940000; ty [ 2, 14, lower ] := 16240000; ty [ 2, 15, lower ] := 21540000; ty [ 2, 16, lower ] := 99999999; end; procedure init2b; begin ty [ 2, 1, upper ] := 550000; ty [ 2, 2, upper ] := 760000; ty [ 2, 3, upper ] := 1190000; ty [ 2, 4, upper ] := 1600000; ty [ 2, 5, upper ] := 2020000; ty [ 2, 6, upper ] := 2460000; ty [ 2, 7, upper ] := 2990000; ty [ 2, 8, upper ] := 3520000; ty [ 2, 9, upper ] := 4580000; ty [ 2, 10, upper ] := 6000000; ty [ 2, 11, upper ] := 8560000; ty [ 2, 12, upper ] := 10940000; ty [ 2, 13, upper ] := 16240000; ty [ 2, 14, upper ] := 21540000; ty [ 2, 15, upper ] := 999999999; ty [ 2, 16, upper ] := 999999999; end; procedure init2c; begin ty [ 2, 1, base ] := 00; ty [ 2, 2, base ] := 29400; ty [ 2, 3, base ] := 63000; ty [ 2, 4, base ] := 140040; ty [ 2, 5, base ] := 226500; ty [ 2, 6, base ] := 327300; ty [ 2, 7, base ] := 450500; ty [ 2, 8, base ] := 620100; ty [ 2, 9, base ] := 816200; ty [ 2, 10, base ] := 1272000; ty [ 2, 11, base ] := 1967800; ty [ 2, 12, base ] := 3350200; ty [ 2, 13, base ] := 4754400; ty [ 2, 14, base ] := 8146400; ty [ 2, 15, base ] := 11750400; ty [ 2, 16, base ] := 11750400; end; procedure init2d; begin ty [ 2, 1, per ] := 14; ty [ 2, 2, per ] := 16; ty [ 2, 3, per ] := 18; ty [ 2, 4, per ] := 21; ty [ 2, 5, per ] := 24; ty [ 2, 6, per ] := 28; ty [ 2, 7, per ] := 32; ty [ 2, 8, per ] := 37; ty [ 2, 9, per ] := 43; ty [ 2, 10, per ] := 49; ty [ 2, 11, per ] := 54; ty [ 2, 12, per ] := 59; ty [ 2, 13, per ] := 64; ty [ 2, 14, per ] := 68; ty [ 2, 15, per ] := 70; ty [ 2, 16, per ] := 70; end; procedure init3a; {schedule YS married taxpayers filing separately} begin ty [ 3, 1, lower ] := 170000; ty [ 3, 2, lower ] := 275000; ty [ 3, 3, lower ] := 380000; ty [ 3, 4, lower ] := 595000; ty [ 3, 5, lower ] := 800000; ty [ 3, 6, lower ] := 1010000; ty [ 3, 7, lower ] := 1230000; ty [ 3, 8, lower ] := 1495000; ty [ 3, 9, lower ] := 1760000; ty [ 3, 10, lower ] := 2290000; ty [ 3, 11, lower ] := 3000000; ty [ 3, 12, lower ] := 4280000; ty [ 3, 13, lower ] := 5470000; ty [ 3, 14, lower ] := 8120000; ty [ 3, 15, lower ] := 10770000; ty [ 3, 16, lower ] := 99999999; end; procedure init3b; begin ty [ 3, 1, upper ] := 275000; ty [ 3, 2, upper ] := 380000; ty [ 3, 3, upper ] := 595000; ty [ 3, 4, upper ] := 800000; ty [ 3, 5, upper ] := 1010000; ty [ 3, 6, upper ] := 1230000; ty [ 3, 7, upper ] := 1490000; ty [ 3, 8, upper ] := 1760000; ty [ 3, 9, upper ] := 2290000; ty [ 3, 10, upper ] := 3000000; ty [ 3, 11, upper ] := 4280000; ty [ 3, 12, upper ] := 5470000; ty [ 3, 13, upper ] := 8120000; ty [ 3, 14, upper ] := 10770000; ty [ 3, 15, upper ] := 99999999; ty [ 3, 16, upper ] := 99999999; end; procedure init3c; begin ty [ 3, 1, base ] := 00; ty [ 3, 2, base ] := 14700; ty [ 3, 3, base ] := 31500; ty [ 3, 4, base ] := 70200; ty [ 3, 5, base ] := 113250; ty [ 3, 6, base ] := 163650; ty [ 3, 7, base ] := 225250; ty [ 3, 8, base ] := 310050; ty [ 3, 9, base ] := 408100; ty [ 3, 10, base ] := 636000; ty [ 3, 11, base ] := 983900; ty [ 3, 12, base ] := 1675100; ty [ 3, 13, base ] := 2377200; ty [ 3, 14, base ] := 4073200; ty [ 3, 15, base ] := 5875200; ty [ 3, 16, base ] := 5875200; end; procedure init3d; begin ty [ 3, 1, per ] := 14; ty [ 3, 2, per ] := 16; ty [ 3, 3, per ] := 18; ty [ 3, 4, per ] := 21; ty [ 3, 5, per ] := 24; ty [ 3, 6, per ] := 28; ty [ 3, 7, per ] := 32; ty [ 3, 8, per ] := 37; ty [ 3, 9, per ] := 43; ty [ 3, 10, per ] := 49; ty [ 3, 11, per ] := 54; ty [ 3, 12, per ] := 59; ty [ 3, 13, per ] := 64; ty [ 3, 14, per ] := 68; ty [ 3, 15, per ] := 70; ty [ 3, 16, per ] := 70; end; procedure init4a; {schedule Z head of household} begin ty [ 4, 1, lower ] := 230000; ty [ 4, 2, lower ] := 440000; ty [ 4, 3, lower ] := 650000; ty [ 4, 4, lower ] := 870000; ty [ 4, 5, lower ] := 1180000; ty [ 4, 6, lower ] := 1500000; ty [ 4, 7, lower ] := 1820000; ty [ 4, 8, lower ] := 2350000; ty [ 4, 9, lower ] := 2880000; ty [ 4, 10, lower ] := 3410000; ty [ 4, 11, lower ] := 4470000; ty [ 4, 12, lower ] := 6060000; ty [ 4, 13, lower ] := 8180000; ty [ 4, 14, lower ] := 10800000; ty [ 4, 15, lower ] := 16130000; ty [ 4, 16, lower ] := 99999999; end; procedure init4b; begin ty [ 4, 1, upper ] := 440000; ty [ 4, 2, upper ] := 650000; ty [ 4, 3, upper ] := 870000; ty [ 4, 4, upper ] := 1180000; ty [ 4, 5, upper ] := 1500000; ty [ 4, 6, upper ] := 1820000; ty [ 4, 7, upper ] := 2350000; ty [ 4, 8, upper ] := 2880000; ty [ 4, 9, upper ] := 3410000; ty [ 4, 10, upper ] := 4470000; ty [ 4, 11, upper ] := 6060000; ty [ 4, 12, upper ] := 8180000; ty [ 4, 13, upper ] := 10830000; ty [ 4, 14, upper ] := 16130000; ty [ 4, 15, upper ] := 99999999; ty [ 4, 16, upper ] := 99999999; end; procedure init4c; begin ty [ 4, 1, base ] := 00; ty [ 4, 2, base ] := 29400; ty [ 4, 3, base ] := 63000; ty [ 4, 4, base ] := 102600; ty [ 4, 5, base ] := 170800; ty [ 4, 6, base ] := 247600; ty [ 4, 7, base ] := 330800; ty [ 4, 8, base ] := 495100; ty [ 4, 9, base ] := 685900; ty [ 4, 10, base ] := 908500; ty [ 4, 11, base ] := 1396100; ty [ 4, 12, base ] := 2254700; ty [ 4, 13, base ] := 3505500; ty [ 4, 14, base ] := 5175000; ty [ 4, 15, base ] := 8779000; ty [ 4, 16, base ] := 9999999; end; procedure init4d; begin ty [ 4, 1, per ] := 14; ty [ 4, 2, per ] := 16; ty [ 4, 3, per ] := 18; ty [ 4, 4, per ] := 22; ty [ 4, 5, per ] := 24; ty [ 4, 6, per ] := 26; ty [ 4, 7, per ] := 31; ty [ 4, 8, per ] := 36; ty [ 4, 9, per ] := 43; ty [ 4, 10, per ] := 46; ty [ 4, 11, per ] := 54; ty [ 4, 12, per ] := 59; ty [ 4, 13, per ] := 63; ty [ 4, 14, per ] := 68; ty [ 4, 15, per ] := 70; ty [ 4, 16, per ] := 70; end; begin init1a; init1b; init1c; init1d; init2a; init2b; init2c; init2d; init3a; init3b; init3c; init3d; init4a; init4b; init4c; init4d; writefile; end. ======================================================================================== DOCUMENT :usus Folder:VOL13:tech_doc.text ======================================================================================== .comment !---------------------------------! .comment ! ! .comment ! RUNON documentation ! .comment ! Technical description ! .comment ! ! .comment !---------------------------------! .title " Technical Description " .page .center " ^&Data Structures\& " .noautopara .skip 1 The following are the main data structures of the program: .skip 1 There are three main storage areas for text. These are known as the <&input, <&internal, and <&output buffers: .skip 2 .center " ^^input buffer\^ " This is used to store a line of up to 132 characters from the input file. The .ST index points at the first character of scannable text. The .EN index points at the last character. .skip 2 .center " ^^internal buffer\^ " This contains the scanned version of the input buffer. All of the special commands have been processed, and are no longer present in the text. The text is represented as an array of records, each of which contains: a character; the 'visible length' of the character, in spaces; a set of attributes (characteristics) the character possesses; and a 'malleability' value that says whether or not the character, if it is a space, can be expanded during justification. Thus, malleability really has meaning only for space characters. When in filling mode, the .ST index always points at one past the end of the word just placed into the output buffer. The .EN index points at the last record of the buffer. <^runon uses the condition (.ST > .EN) to signify the emptiness of the buffer. This is also true of the output buffer. .skip 2 .center " ^^output buffer\^ " This buffer is of the same type as the internal buffer. When <^runon is in non- filling mode, they are identical. In filling and justification modes, however, the output buffer contains a justifiable copy of the internal buffer, with all extra blanks removed. <^runon places as many words as it can into the output buffer, and then, if we are in justification mode rather than filling mode, justifies it. .skip 2 The other data structures are: .skip 3 .center " <^sysvars " This record contains all of the global values that affect filling. These are the values that need to be protected by the Time-warp effect. The fields are: .skip 1 .testpage 3 <^version: .break 'Points to' current set of values (see Time-warp section). .skip 1 <^fill__mode: .break States whether in justify, fill, or nofill mode. .skip 1 <^paging: .break States whether or not the output file is to be broken into pages. .skip 1 <^numbering: .break Pages numbered / unnumbered. .skip 1 <^lm, <^rm: .break These are the values of the left and right margins, respectively. They represent columns on the page. .skip 1 <^ap__skip: .break Contains the number of lines to drop down when executing an automatic paragraph. .skip 1 <^ap__indent: .break Contains the number of spaces to skip as the indent for an auto-paragraph. .skip 1 <^paper__width: .break Width in columns of the paper. .skip 1 <^paper__length: .break Length in lines of the paper. .skip 1 <^chars__in__line: .break Number of visible characters in output buffer between left and right margins. Used solely by <^move__word. .skip 1 <^printable__lines: .break Number of usable lines on page (page length minus border size). .skip 1 <^spacing: .break Standard typewriter spacing, e.g. spacing 1 yields no blank lines on output. .skip 3 .center " <^pageinfo " This record contains miscellaneous information pertaining to the page. .skip 1 <^currline: .break Number of lines from bottom of header. .skip 1 <^currpage: .break Current page number. .skip 1 <^figure__set: .break Indicates that there is a figure to put out, and it may be put out immediately. .skip 1 <^figure__pending: .break Indicates that program is waiting to output figure at top of next page. .skip 1 <^figure__size: .break Contains size of next figure to be output. .skip 1 <^title: .break String representing current document title. .skip 3 .center " ^^File Stack\^ " The File__stack is a structure consisting of .PTR, which is the pointer to the current top-of-stack, and .STACK, which is an array of ^^stack__entry\^s. Each <^stack__entry consists of a <^.name, a <^.line, and an <^.in__buf. The <^.name contains the name of an included file, the <^.line contains the line number of the file that was being processed when <^.name was included. The <^.in__buf is a copy of the current input buffer when <^.name was included. This allows the dot-command processor to continue with any other commands on the line when the file was included. .autopara .autoset 2 5 .page .center " ^&Time-warp Effect\& " When in fill mode, it is possible for an incomplete line of text to be accumulated in the output buffer, and then to encounter a dot command, such as <^rightmargin, which would cause the output buffer to be changed and otherwise wrongly processed. The problem is caused by commands which affect the line- or paper-width after the output buffer has started to be processed. In order to get around this little snafu, <^runon keeps two versions of <^sysvars, and a 'pointer' to the one currently in effect. This 'pointer' can assume two values, <^new and <^old. If a new output line has been started, and a dot command is then received, only the values in <^sysvars[new] are changed. The version pointer is changed to point at the version containing the pre-dot command values. When the line is finished, the version pointer is changed to <^new. The pointer to the current values is kept in <^sysvars[new].version, so if we use this value as an 'indirect address', we can easily reference the correct field of <^sysvars. Using a construction of the type .nofill ^^sysvars[sysvars[new].version].\^field .justify allows you to reference field 'field' of the current values. ======================================================================================== DOCUMENT :usus Folder:VOL13:types.text ======================================================================================== {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} { } { TYPES.TEXT begins here } { } {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} { } { Pascal Screen Code Generator } { by Lee Meador -- Copyright (c) 1981 } { } { Type definitions: } { Use by putting these lines in program} { } { TYPE } { (*$I WBTC1:TYPES.TEXT *) } { } {}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{}{} DisplayType = (Normal,Inverse, Flash); Item = RECORD ItemValid :BOOLEAN; ItemLabel :STRING; ItemLength :INTEGER; ItemX, ItemY :INTEGER; ItemEdit :Boolean; ItemDefault, ItemName, ItemType :STRING; ItemDisplayType :DisplayType; END; Scrn = ARRAY [1..60] OF Item; ======================================================================================== DOCUMENT :usus Folder:VOL13:vol13.doc.text ======================================================================================== Volume 13 of the USUS library RUNON, FIT, and some small stuff DECLARE.TEXT 22 include files of RUNON INITC.TEXT 26 ditto DOPAGE.TEXT 34 ditto READNU.TEXT 30 ditto READLN.TEXT 16 ditto MAIN.TEXT 22 RUNON main program. A nice fast text formatter. SYSGEN.TEXT 4 Compile this file to make RUNON. RUNON_DOC.TEXT 4 RUNON documentation in un-formatted form. INTRO_DOC.TEXT 10 an include file of the documentation. HOWTO_DOC.TEXT 12 ditto DOT_DOC.TEXT 26 ditto DEFALT_DOC.TEXT 4 ditto SPEC_DOC.TEXT 10 ditto ERR_DOC.TEXT 12 ditto TECH_DOC.TEXT 16 ditto TAXNAMES.TEXT 18 Generates form line names for FIT. TAXTABLE.TEXT 24 Generates an out-of-date tax table for FIT. TAXCALC.TEXT 20 an include file for FIT. The Federal Income Tax Program TAXSTART.TEXT 8 ditto TAXRW.TEXT 10 ditto TAXPRINT.TEXT 16 ditto TAXEDIT.TEXT 22 ditto FIT.TEXT 20 The main program of FIT, hand typed by yours truly. STARTUP.TEXT 22 A version II.0 startup program with date and prefix set PDATE.TEXT 4 a unit for STARTUP ERRORDATA 1 This data file should have been on Volume 8. SCREDIT.TEXT 36 A screen form generator, simple but it works. SCRGEN.TEXT 18 Converts output of SCREDIT to Pascal soruce TYPES.TEXT 6 an include file for SCREDIT and SCRGEN VOL13.DOC.TEXT 6 You're reading it. 30/30 files, 491 blocks used, 3 unused, 3 in largest Please transfer the text below to a disk label if you copy this volume. USUS Volume 13 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Some notes from the editor: RUNON This is a fairly nice imbedded command type text formatter submitted by Wynn Newhouse and Herb Jellinek. It is several times faster than PROSE which was on volume 3 and RUNON does just as many things. It could use a little improvement in the user interface, it seems to reject some legal filename constructs such as *FARB but after it gets going it works fine. FIT This is my hand typed version of FIT from a past issue of BYTE. I never got my version working (I left out a critical line) until Edward Heyman sent me a disk with the original on it and I went through the thing line by line. However in the process of trying to find my one bug, I found several rough edges which got fixed, so instead of using the original, I used my version. I found some problems with the data in TAXTABLE and I have changed it. Also be aware that the tables are for a past tax year and will have to be updated with current information before you try to do your taxes on it! STARTUP I got tired of always having to go back to the F(iler to reset my prefix after hard crashing the system, so I wrote a startup program to do it for me. I also had a tendency to forget to set the date so I made the startup program force me to enter a date (or simply if it is not to be changed). It also displays a banner message to identify itself. This program uses the II.0 globals in a separate unit to access the system data and will not work in IV.0. There is IV.0 version on volume 12. SCREDIT and SCRGEN These programs, by Lee Meador, allow you to define a screen form and then convert the definition to Pascal source. The documentation is sort of lacking but after some fumbling, I got the hang of it. ERRORDATA This is a data file for the SCREENUNIT which is on Volume 8. It got replaced by an older version of the file by accident. regards - george schreyer ======================================================================================== DOCUMENT :usus Folder:VOL14:8080conv.text ======================================================================================== (************************************************************************) (* *) (* Author: David Parrish *) (* Medical College of Georgia *) (* Augusta, Georgia 30912 *) (* *) (* Date: June 14, 1980 *) (* *) (* *) (******* This program is part of the MCG Pascal utilities library *******) (* *) (* This program takes an assembly language program written *) (* with Intel 8080 opcodes and translates them to Zilog *) (* Z-80 opcodes. *) (* *) (* Limitations to the program: *) (* *) (* 1. Opcodes and operands must be in upper-case letters. *) (* 2. Labels must be within columns 1 to 16. *) (* 3. Opcodes and pseudo-ops must start in column 17 *) (* ( The second 8 column tab stop ). *) (* 4. The pseudo-ops are those of the UCSD assembler. *) (* 5. Comments must start in column 1 or 33 (4th tab). *) (* 6. Everything past column 32 is ignored. *) (* 7. If the Z-80 opcode and operand is longer than 16 *) (* columns, the characters past that limit are lost. *) (* 8. No multiple operations per line. *) (* 9. Labels that contain 'SP' or 'PSW' will cause the line to *) (* not be translated. This can be solved by changing the *) (* label's name, or by using lower-case letters. (i.e. 'sp') *) (* *) (* *) (* The characters '#' and '$' in the translation table represent *) (* respectivily no operand with the opcode and a literally translated *) (* operand. The lines in the program that start with '{*}' are for *) (* program tracing and debugging and may be removed to speed up *) (* execution. As far as I know, there are no other limitations or *) (* bugs in the program. This program was a quick-fix for a problem *) (* and may be helpful for others. Hopefully, it will serve as a *) (* spring-board for better translation programs. (i.e. a free format *) (* parser, TDL to UCSD assembler translation, etc.) *) (* *) (* *) (************************************************************************) Program conv; const tablesize = 237; type tblrectype = record Intlops : string[12]; Zopc : string[4]; Zopr : string[8] end; var infile, outfile : text; error, hitend : boolean; tableloc,k,j : integer; len, errnum : integer; orgstr,substr : string; table : array [1..tablesize] of tblrectype; registers : set of char; Zoperand : string; opcode, operand : string; asc1, asc2 : string; Procedure tableload; type rectype = record a8opc : string[4]; a8opr : string[8]; aZopc : string[4]; aZopr : string[8] end; var recfile : file of rectype; temprec : rectype; i : integer; begin {*} writeln('begin tableload'); reset(recfile,'look.up.table'); for i := 1 to tablesize do begin temprec := recfile^; get(recfile); table[i].Intlops := concat(temprec.a8opc,temprec.a8opr); table[i].Zopc := temprec.aZopc; table[i].Zopr := temprec.aZopr end; {*} writeln('end tableload'); close(recfile) end; (* tableload *) Procedure setfiles; var tempstr : string; begin write('Input file name > '); readln(tempstr); reset(infile,tempstr); write('Output file name > '); readln(tempstr); {*} writeln('end setfiles'); rewrite(outfile,tempstr) end; (* setfiles *) Procedure splitcode; (* takes orginal string and extracts opcode and operand *) var i, j : integer; begin {*} writeln('begin splitcodes'); substr := ''; if length(orgstr) > 32 then substr := copy(orgstr,17,16) else substr := copy(orgstr,17,(length(orgstr)-16)); {*} writeln(' orgstr *',orgstr,'*'); {*} writeln(' substr *',substr,'*'); substr := concat(substr,' '); j := length(substr); i := pos(' ',substr); if i = 0 then begin opcode := substr; operand := '#' end (* I know, I just haven't *) else begin (* removed it yet.... *) opcode := copy(substr,1,(i-1)); while substr[j] = ' ' do j := j-1; while (substr[i] = ' ') and ( i <= j ) do i := i+1; if i > j then operand := '#' else operand := copy(substr,i,(j-i+1)) end; {*} writeln('opcode *',opcode,'*'); {*} writeln('operand *',operand,'*'); {*} writeln('end splitcodes') end; (* splitcode *) Function search : integer; (* Binary table search *) var found : boolean; sertbl, seropc: string; i, j, k : integer; procedure normalize; (* takes opcode and operand from splitcodes *) var i, k : integer; (* and converts to form of table elements. *) begin {*} writeln('begin normalize'); seropc := ' '; insert(opcode, seropc,1); k := length(operand); i := 0; while i < k do begin i := i+1; if operand[i] = ' ' then begin k := k-1; delete(operand,i,1) end end; if length(operand) = 1 then begin if (operand[1] in registers) or ( operand[1] = '#' ) then seropc[5] := operand[1] else seropc[5] := '$'; {*} writeln('>A<>',seropc,'<') end else begin if (pos('SP',operand)<>0) then begin if length(operand)=2 then insert('SP',seropc,5) else if operand[3] = ',' then insert('SP,$',seropc,5) else insert('$',seropc,5); {*} writeln('>D<>',seropc,'<') end else if pos('PSW',operand) <> 0 then begin if length(operand)=3 then insert('PSW',seropc,5); {*} writeln('>E<>',seropc,'<') end else seropc[5] := '$'; if (operand[1] in registers) and (operand[2] = ',') then begin if (operand[3] in registers) and (length(operand) = 3) then begin insert(operand,seropc,5); delete(seropc,(pos('$',seropc)),1); {*} writeln('>B<>',seropc,'<') end else begin asc1 := copy(operand,1,2); {*} writeln('asc1 *',asc1,'*'); insert(asc1,seropc,5); {*} writeln('>C<>',seropc,'<') end end; end; (* if length = 1 else *) seropc := copy(seropc,1,12); {*} writeln('seropc *',seropc,'*'); {*} writeln('end normalize ') end; (* normalize *) begin {*} writeln('begin search '); normalize; i := 1; j:=tablesize; found := false; repeat k:=(i+j) div 2; sertbl := table[k].Intlops; {*} writeln('sertbl > ',sertbl); if sertbl = seropc then found := true else if sertbl < seropc then i:=k+1 else j:=k-1 until (found or (i>j)); if i>j then k:= 0; search := k; {*} writeln('end search ') end; (* search *) Procedure insertcode; (* Puts Z-80 codes into original string. *) begin {*} writeln('begin insertcode '); substr := concat(table[tableloc].Zopc,' ',Zoperand,' '); substr := copy(substr,1,16); if length(orgstr) > 32 then delete(orgstr,17,16) else delete(orgstr,17,(length(orgstr)-16)); insert(substr,orgstr,17); writeln(outfile,orgstr); {*} writeln('end insertcode') end; (* insertcode *) Begin (* main line *) registers := ['A','B','C','D','E','H','L','M']; hitend := false; errnum := 0; error := false; tableload; setfiles; readln(infile,orgstr); repeat {*}writeln(' Begin loop '); len := length(orgstr); if len = 0 then insert(' ',orgstr,1); if (orgstr[1] = ';') or (len < 17) or (orgstr[17] = '.') then begin writeln(outfile,orgstr); if (pos('.END',orgstr)=17) (* check for end of source *) and (pos('.ENDC',orgstr)=0) and (pos('.ENDM',orgstr)=0) then hitend := true end else begin splitcode; tableloc := search; if tableloc = 0 then begin writeln(outfile,'**** ',orgstr); errnum := errnum +1; error := true; write(chr(7)) end else begin (* Decoding section *) {*} writeln(' Decoding section '); Zoperand := table[tableloc].Zopr; j := pos('$',Zoperand); if Zoperand[1] = '#' then Zoperand[1] := ' '; if pos(',',operand) = 0 then begin (* zero and one operands *) if pos('$',table[tableloc].Intlops) = 0 then insertcode else begin (* replace literal from operand *) delete(Zoperand,j,1); insert(operand,Zoperand,j); insertcode end end (* 0 & 1 operands *) else begin (* 2 operands *) if j = 0 then insertcode else begin delete(Zoperand,j,1); k := pos(',',operand); delete(operand,1,k); insert(operand,Zoperand,j); insertcode end end end (* Decoding section *) end; readln(infile,orgstr); {*}writeln(' After readln ') until hitend; {*}writeln('hit eof '); if error then writeln('There were ',errnum,' error(s).') else writeln('No errors encountered'); close(infile); close(outfile, lock) End. (* main line *) ======================================================================================== DOCUMENT :usus Folder:VOL14:banner.text ======================================================================================== (* By David Mundie for Culinary Software Systems. *) (* Types four lines of 32 characters on a hard-copy device. *) {as modified by george schreyer} PROGRAM banner; CONST AbsMaxLine = 5; {Maximum lines of text -1} MaxChPerLn = 31; {Max chars per line - 1} ColPerCh = 5; {Columns of dots per character} ColPChM1 = 4; {above -1} RowPerCh = 8; {Rows of dots per character} RowPChM1 = 7; {above -1} MaxPixels = 39; {Dots per character (RowPerCh X ColPerCh -1)} HasDiablo = false; {if so, uses 1/2 linefeeds to fill in char's} TYPE pixel = 0..MaxPixels; {MOD ColPerCh = Column; DIV RowPerCh = Row} {SO a character grid (upright) looks like: 0 1 2 3 4 5 6 7 8 9 ...and on its side: 10 11 12 13 14 35 30 25 20 15 10 5 0 15 16 17 18 19 36 31 26 21 16 11 6 1 20 21 22 23 24 37 32 27 22 17 12 7 2 (top) 25 26 27 28 29 38 33 28 23 18 13 8 3 30 31 32 33 34 39 34 29 24 19 14 9 4 35 36 37 38 39 } pixset = set of pixel; VAR c: char; MaxLine, LinesTyped, n, m: integer; SizeFactor: 1..10; filename: string; message: ARRAY [0..AbsMaxLine,0..MaxChPerLn] OF pixset; textin: ARRAY [0..AbsMaxLine] OF string; table : ARRAY [' '..'z'] OF pixset; list: text; procedure cr; begin write ( list, chr ( 128 + 13 ) ); {sends cr with parity bit set so OS won't add a lf gws} end; PROCEDURE initialize; BEGIN table['!'] := [2,7,12,17,32]; table['A'] := [1..3,5,10,9,14,15..19,20,25,30,24,29,34]; table['B'] := [0..3,5,10,9,14,15..18,20,25,30,24,29,30..33]; table['C'] := [1..3,5,10,15,20,25,31..33,29,9]; table['D'] := [0..2,5,10,15,20,25,30..32,28,24,19,14,8]; table['E'] := [0..4,5,10,15..19,20,25,30..34]; table['F'] := [0..4,5,10,15..18,20,25,30]; table['G'] := [1..4,5,10,15,20,25,31..34,29,24,18..19]; table['H'] := [0,5,10,15,20,25,30,4,9,14,19,24,34,29,16..18]; table['I'] := [1..3,7,12,22,17,12,27,31..33]; table['J'] := [0..4,8,13,18,23,28,31..32,25]; table['K'] := [0,5,10,15,20,25,30,16,12,8,4,22,28,34]; table['L'] := [0,5,10,15,20,25,30..34]; table['M'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,6,8,12,17]; table['N'] := [0,5,10,15,20,25,30,4,9,14,19,24,29,34,11,17,23]; table['O'] := [1..3,31..33,5,10,15,20,25,9,14,19,24,29]; table['P'] := [0..3,5,10,15,20,25,30,16..18,14,9]; table['Q'] := [1..3,5,10,15,20,25,31,32,34,28,22,24,19,14,9,4]; table['R'] := [0..3,5,9,10,14,19,15..18,20,25,30,22,28,34]; table['S'] := [1..4,30..33,16..18,5,10,24,29]; table['T'] := [0..4,7,12,17,22,27,32]; table['U'] := [0,5,10,15,20,25,31..33,29,24,19,14,9,4]; table['V'] := [0,5,10,15,20,26,32,28,24,19,14,9,4]; table['W'] := [0,5,10,15,20,25,31,33,27,22,17,29,24,19,14,9,4]; table['X'] := [0,5,25,30,4,9,29,34,21,17,13,11,17,23]; table['Y'] := [0,5,10,16,22,27,32,18,14,9,4]; table['Z'] := [0..4,30..34,25,21,17,13,9]; table[' '] :=[]; table['a'] := [11..14,19,21..24,25,29,31..34]; table['b'] := [0,5,10,20,25,15..18,30..33,24,29]; table['c'] := [11..13,15,20,25,31..33]; table['d'] := [4,9,14,15,16..19,31..34,20,25,24,29]; table['e'] := [11,12,15,18,20..23,25,31,32]; table['f'] := [2,6,8,11,15..17,21,26,31]; table['g'] := [11,12,15,18,20,23,26..28,33,36,37]; table['h'] := [0,5,10,15,20,25,30,16,17,23,28,33]; table['i'] := [7,16,17,22,27,31..33]; table['j'] := [8,18,23,28,33,31,37]; table['k'] := [0,5,10,15,20,25,30,21,17,27,33]; table['l'] := [1,2,7,12,17,22,27,31..33]; table['m'] := [11,13,15,17,19,20,22,24,25,29,30,34]; table['n'] := [11,12,15,18,20,23,25,28,30,33]; table['o'] := [11,12,15,18,20,23,25,28,31,32]; table['p'] := [10..12,15,18,20,23,25..27,30,35]; table['q'] := [11..13,15,18,20,23,26..28,33,38,39]; table['r'] := [10,12,13,15,16,20,25,30]; table['s'] := [11..13,15,21..23,29,31..33]; table['t'] := [6,10..12,16,21,26,32]; table['u'] := [10,13,15,18,20,23,25,28,31..34]; table['v'] := [10,14,15,19,20,24,26,28,32]; END; PROCEDURE Init2; BEGIN table['w'] := [10,14,15,17,19,20,22,24,25,27,29,31,33]; table['x'] := [10,14,16,18,22,26,28,30,34]; table['y'] := [10,13,15,18,20,23,26..28,33,36,37]; table['z'] := [10..14,18,22,26,30..34]; table['-'] := [16,17,18]; table['*'] := [7,12,17,22,27,16,18,10,14,20,24]; table['?'] := [1..3,5,9,13,17,22,32]; table['.'] := [29,34]; table[','] := [28,33,37]; table[':'] := [12,17,27,32]; table[';'] := table[':'] + [36]; table['1'] := [36..38,2,7,12,17,22,27,32,6]; table['2'] := [35..39,30,31,27,23,19,14,9,1..3,5]; table['3'] := [36..38,30,17..19,1..3,5,9,14,24,29,34]; table['4'] := [20..24,15,11,7,3,8,13,18,28,33,38]; table['5'] := [0..4,9,5,10,15,21..23,29,34,36..38,30]; table['6'] := [36..38,21..23,1..3,9,5,10,15,20,25,30,29,34]; table['7'] := [5,0..4,9,14,19,23,27,31,35]; table['8'] := [1..3,21..23,36..38,9,14,19,29,34,5,10,15,25,30]; table['9'] := [1..3,16..18,36..38,30,9,14,19,24,29,34,5,10]; table['0'] := [1..3,36..38,5,10,15,20,25,30,9,14,19,24,29,34,24,26,22,18]; END; PROCEDURE Show; VAR i,CCount,Col,Lines,Row, Size:integer; maxlen:integer; DotNum : integer; DotOn : Packed Array [0..223] of Boolean; PROCEDURE WriteDot; VAR x, y: integer; BEGIN FOR y := 1 TO SizeFactor DO BEGIN DotOn [ DotNum ] := true; DotNum := Dotnum + 1; END END; PROCEDURE WriteBlank; VAR i: integer; BEGIN FOR i := 1 TO SizeFactor DO begin DotOn [ DotNum ] := false; DotNum := DotNum + 1; end; END; FUNCTION FillLeft: boolean; VAR x, {current pixel} y: integer; {1 pixel to left} TCh: pixset; BEGIN IF Row >= RowPChM1 THEN FillLeft := false ELSE BEGIN TCh := message[Lines,CCount]; x := Row*ColPerCh + Col; y := x + ColPerCh; IF NOT(y IN TCh) THEN FillLeft := false ELSE IF Col <= 0 THEN FillLeft := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh) ELSE IF Col >= ColPChM1 THEN FillLeft := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh) ELSE FillLeft := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)) OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)) END END; FUNCTION FillRight: boolean; VAR x, {current pixel} y: integer; {1 pixel to right} TCh: pixset; BEGIN IF Row <= 0 THEN FillRight := false ELSE BEGIN TCh := message[Lines,CCount]; x := Row*ColPerCh + Col; y := x - ColPerCh; IF NOT(y IN TCh) THEN FillRight := false ELSE IF Col <= 0 THEN FillRight := ((x + 1) IN TCh) AND NOT ((y + 1) IN TCh) ELSE IF Col >= ColPChM1 THEN FillRight := ((x - 1) IN TCh) AND NOT ((y - 1) IN TCh) ELSE FillRight := (((x + 1) IN TCh) AND NOT ((y + 1) IN TCh)) OR (((x - 1) IN TCh) AND NOT ((y - 1) IN TCh)) END END; Procedure Strike( ch : char ); var j : integer; SPACE : PACKED ARRAY [0..1] OF CHAR; CHARX : PACKED ARRAY [0..1] OF CHAR; BEGIN SPACE[1]:=CHR(32); CHARX[1]:=CH; FOR j :=1 TO DotNum-1 DO IF DotOn[j] THEN UNITWRITE(6,CHARX[1],1,0,1) ELSE UNITWRITE(6,SPACE[1],1,0,1); CR; END; BEGIN DotNum := 1; maxlen := 0; FOR i := 0 TO LinesTyped-1 DO IF length(textin[i]) > maxlen THEN maxlen := length(textin[i]); FOR CCount := 1 TO maxlen DO BEGIN FOR Col := 0 TO 4 DO FOR Size := 1 TO SizeFactor DO BEGIN FOR Lines := LinesTyped-1 DOWNTO 0 DO BEGIN FOR Row := 7 DOWNTO 0 DO BEGIN IF Row * ColPerCh + Col IN message[Lines,CCount] THEN FOR i := 1 TO 2 DO WriteDot ELSE IF FillLeft THEN BEGIN WriteDot; WriteBlank END ELSE IF FillRight THEN BEGIN WriteBlank; WriteDot END ELSE FOR i := 1 TO 2 DO WriteBlank END; FOR i := 1 TO 2 DO WriteBlank {space between lines} END; Strike('8'); Strike('#'); DotNum := 1; Writeln(list) END; Writeln(list) END; END; BEGIN FOR n := 0 TO AbsMaxLine DO BEGIN FOR m := 0 TO 31 DO message[n,m] := []; textin[n] := '' END; Initialize; Init2; SizeFactor := 1; Write( 'By what factor (1 to 8) do you wish to multiply the size of the letters? '); Readln(SizeFactor); IF SizeFactor > 1 then MaxLine := AbsMaxLine DIV SizeFactor + 1 ELSE MaxLine := AbsMaxLine; Writeln( 'Enter your message (up to ',MaxLine,' lines of up to 32 characters): '); n := 0; REPEAT Readln(textin[n]); m := Length(textin[n]); IF m > MaxChPerLn THEN DELETE(Textin[n],MaxChPerLn, m - MaxChPerLn + 1); n := n + 1 UNTIL (n > MaxLine-1) OR (textin[n-1] = ' ') OR (textin[n-1] = ''); IF (textin[n-1] = ' ') OR (textin[n-1] = '') THEN LinesTyped := n-1 ELSE LinesTyped := n; REWRITE(LIST,'PRINTER:'); page(list); (*write(list,CHR(27),'PH',CHR(27),'\'); {set 8 lpi} WRITE(LIST,CHR(27),'PD\'); {set 16.5 cpi}*) {for TI-820} FOR n := 0 TO LinesTyped-1 DO FOR m := 1 TO length(textin[n]) DO message[n,m] := table[textin[n,m]]; Show; page(list); (*WRITE(LIST,CHR(27),'PC\'); {set 10 cpi} WRITE(LIST,CHR(27),'PA\'); {set 6 lpi}*) {for TI-820} CLOSE(list,lock); END. ======================================================================================== DOCUMENT :usus Folder:VOL14:bondystuff.text ======================================================================================== This is a note from Jon bondy which describes his submissions. -gws The COPVOL and COPFILE programs should be easy to understand: they ask for source and destination volumes/files and perform a copy by reading the source into one buffer, writing that buffer to the destination, reading the destination into a second buffer, and then comparing the buffers. In COPVER, if the file *SYSTEM.PDP11 does not exist, it is assumed that the program is running on an 8080 or a Z-80 and the COPVER.ASM 8080 assembly routines are executed to copy the booter tracks using CP/M BIOS routines: I know this will not work for everyone, but it is better than nothing at all, and there is no sector read mode in I.5. The COMPFILE program reads the two files and compares them bit for bit: if there are discrepancies, the block and byte number is calculated and displayed. The other compare program in the library is probably much better for TEXT files, but to compare binary/data files, this program is useful. The disk SCANNER program allows you to scan an entire volume rapidly searching for the occurance of one of a number of character strings. If the strings are found anywhere, the directory is searched to see in what file the string was located. Then the file name and the string found, along with the context in which it was found, is displayed on the screen. This program is useful if you have a number of disks with similar data and you want to find a particular file but don't know the name: I use it to locate TeleMail files on my archive disks. The program looks for SCAN.DATA.TEXT for the list of search strings. The GAME program is a simple game with demons and a maze. The screen is used as a playing field, with "-", "|", and "+" used as maze obstacles: the player is a 'P' and the "demons" which try to kill him/her are 'D's. A player can kill a demon by landing on top of him; demons do the same for the player. This results in a 50/50 chance of success if a player makes a head-long rush towards a demon: more subtle approaches are required to insure winning (like sneaking up on him from behind). One feature of the game is the board edit mode, in which the player can create his/her own maze. At the top level, one has the choice of changing the demon M(ode, starting to P(lay a game, changing the L(evel of difficulty of play, and entering S(etup (the game board editor). All commands are single key strokes, with both upper and lower case characters accepted. The Demons operate in one of two "modes": Inertial mode or Heat-Seeking mode. In Inertial mode, they chose a random direction and go in that direction until they hit an obstacle (or kill a Player!): they then make a random decision and continue in a new direction until they hit something else. In Heat-Seeking mode, they know the direction of the Player, and they try to get to him/her, although they do not know enough to go around walls. Typing "M" at the top level or during game play toggles the mode. In Heat-Seeking mode, the Player hasn't got a chance to win on a 2 MHz Z-80, so I added the playing difficulty levels, from 0 to 9: at level 0, the game runs so fast you can't keep up, while at level 9 it is fairly easy to win once you have some experience. During game play you can move the player up, down, left, or right (they keys for these actions are defined in the program), entering Hyper-Space by typing an "H" (puts you in a random position on the board), toggling the Demon Mode by typing an "M", changing the levels by typing the numeric digits from "0" to "9", or quiting. Setup mode allows the player to G(et or P(ut a game board (maze), alter the N(umber of demons at the start of the game from 1 to 9, or E(dit the game board. G(etting a non-existant game board will have the side-effect of clearing the game board, allowing easy generation of a new one in E(dit mode. The Edit mode allows the creation or deletion of all walls/corridors in the maze. The default direction is specified by pressing any of the up, down, t left, or right keys: thereafter the other keys ("+", "-", "|") will be inserted in the game board in the same direction. This allows easy creation of vertical walls. A few things must be set up by the user before the Game program will work. The first is to create a "key_hit" routine which returns "true" when there is a character ready from the keyboard. I have done this in my program by using a "port_read" routine which reads the keyboard status register and detects the ready bit (I include this routine for the 8080/Z-80 as GAME.ASSEM.TEXT). The user must also modify the "eeoln" routine to provide the correct erase-to-end- of-line sequence for his/her terminal. (Reviewer' note : I did these modifications for the H-89 and they are included also. - gws) Finally, if the user wants to use different cursor control keys than I have (I use the "star" shaped cluster of "f", "g", "v", and "t"), s/he must modify the CONST part of the program where indicated. Jon Bondy ======================================================================================== DOCUMENT :usus Folder:VOL14:calendar.text ======================================================================================== {Program Author: Walter I. Hess 1460 Seven Pines Rd. Schaumberg, IL 60193 Assumes Heath H19 or VT-52 CRT} PROGRAM CALENDAR; {Version "O" W.I.H. 1/7/80} {Program will provide a calendar month in any year from 1753 on.} CONST {The Gregorian Calendar was adopted in the U.S. in 1752} STARTYR = 1753; STARTDAY = 1; TYPE SHINT = 0..255; VAR CH,ESCH : CHAR; MONTH : SHINT; DAY,YEAR,J : INTEGER; PROCEDURE CALCDAY; {Procedure calculates the day of the week for the first day of the desired month. "0" is Sunday and "6" is Saturday. STARTDAY is the day of the week (Monday) of January 1, 1753.} BEGIN DAY := STARTDAY; FOR J := STARTYR TO YEAR - 1 DO IF ((J MOD 4 = 0) AND (J MOD 100 <> 0)) OR (J MOD 400 = 0) THEN DAY := DAY + 2 ELSE DAY := DAY + 1; CASE MONTH OF 2: DAY := DAY + 31; 3: DAY := DAY + 59; 4: DAY := DAY + 90; 5: DAY := DAY + 120; 6: DAY := DAY + 151; 7: DAY := DAY + 181; 8: DAY := DAY + 212; 9: DAY := DAY + 243; 10: DAY := DAY + 273; 11: DAY := DAY + 304; 12: DAY := DAY + 334; END; {Case} IF (MONTH > 2) AND (((YEAR MOD 4 = 0) AND (YEAR MOD 100 <> 0)) OR (YEAR MOD 400 = 0)) THEN DAY := DAY + 1; DAY := DAY MOD 7; END; {Calcday} PROCEDURE CLEARPRM; {Procedure clears the "prompt" line.} BEGIN WRITE(ESCH,'Y8 '); WRITE(ESCH,'l'); END; {Clearprm} PROCEDURE PREPSCR; {Procedure draws the calendar outline on the screen} VAR J,K : SHINT; PROCEDURE HLINE (LINE : SHINT); BEGIN GOTOXY(5,LINE); FOR K := 5 TO 73 DO WRITE('a'); END; {Hline} BEGIN WRITE(ESCH,'E',ESCH,'F'); HLINE(3); FOR J := 0 TO 6 DO HLINE(5 + 3 * J); FOR J := 0 TO 7 DO FOR K := 4 TO 22 DO BEGIN GOTOXY(4 + 10 * J, K); WRITE('`'); END; GOTOXY(4,3);WRITE('f'); GOTOXY(4,23);WRITE('e'); GOTOXY(74,3);WRITE('c'); GOTOXY(74,23);WRITE('d'); FOR J := 0 TO 5 DO BEGIN GOTOXY(4, 5 + J * 3);WRITE('v'); GOTOXY(74, 5 + J * 3);WRITE('t'); END; FOR J := 0 TO 5 DO BEGIN GOTOXY(14 + 10 * J, 3); WRITE('s'); GOTOXY(14 + 10 * J, 23); WRITE('u'); FOR K := 0 TO 5 DO BEGIN GOTOXY(14 + 10 * J, 5 + 3 * K); WRITE('b'); END; END; WRITE(ESCH,'G'); GOTOXY(7,4);WRITE('SUNDAY'); GOTOXY(17,4);WRITE('MONDAY'); GOTOXY(26,4);WRITE('TUESDAY'); GOTOXY(35,4);WRITE('WEDNESDAY'); GOTOXY(46,4);WRITE('THURSDAY'); GOTOXY(57,4);WRITE('FRIDAY'); GOTOXY(66,4);WRITE('SATURDAY'); END; {Prepscr} PROCEDURE CLEARMON; {Procedure clears the dates in preparation for a new month.} VAR J,K,L : SHINT; BEGIN GOTOXY(0,1);WRITE(ESCH,'l'); FOR J := 0 TO 6 DO FOR K := 0 TO 5 DO FOR L := 0 TO 1 DO BEGIN GOTOXY(5 + J * 10, 6 + K * 3 + L); WRITE(' '); END; END; {Clearmon} PROCEDURE DISPMONT; {Procedure displays the new month.} VAR DAYS,J,K : SHINT; BEGIN CASE MONTH OF 1: BEGIN GOTOXY(33,1);WRITE('JANUARY '); DAYS := 31; END; 2: BEGIN GOTOXY(32,1);WRITE('FEBRUARY '); IF ((YEAR MOD 4 = 0) AND (YEAR MOD 100 <> 0)) OR (YEAR MOD 400 = 0) THEN DAYS := 29 ELSE DAYS := 28; END; 3: BEGIN GOTOXY(34,1);WRITE('MARCH '); DAYS := 31; END; 4: BEGIN GOTOXY(34,1);WRITE('APRIL '); DAYS := 30; END; 5: BEGIN GOTOXY(35,1);WRITE('MAY '); DAYS := 31; END; 6: BEGIN GOTOXY(34,1);WRITE('JUNE '); DAYS := 30; END; 7: BEGIN GOTOXY(34,1);WRITE('JULY '); DAYS := 31; END; 8: BEGIN GOTOXY(35,1);WRITE('AUGUST '); DAYS := 31; END; 9: BEGIN GOTOXY(32,1);WRITE('SEPTEMBER '); DAYS := 30; END; 10: BEGIN GOTOXY(33,1);WRITE('OCTOBER '); DAYS := 31; END; 11: BEGIN GOTOXY(33,1);WRITE('NOVEMBER '); DAYS := 30; END; 12: BEGIN GOTOXY(33,1);WRITE('DECEMBER '); DAYS := 31; END; END; {Case} WRITE(YEAR); K := 6; FOR J := 1 TO DAYS DO BEGIN GOTOXY(5 + DAY * 10, K); WRITE(J:2); DAY := DAY + 1; IF DAY = 7 THEN BEGIN DAY := 0; K := K + 3; END; END; END; {Dispmont} BEGIN {Calendar} ESCH := CHR(27); WRITE(ESCH,'E',ESCH,'x1',ESCH,'x5',ESCH,'y6'); PREPSCR; REPEAT CLEARPRM; WRITE('ENTER YEAR OR "0" TO TERMINATE PROGRAM '); READLN(YEAR); IF YEAR >= STARTYR THEN BEGIN REPEAT CLEARPRM; WRITE('ENTER MONTH (1 TO 12 FOR JANUARY TO DECEMBER) '); READLN(MONTH); UNTIL (MONTH > 0 ) AND (MONTH < 13); CLEARMON; CALCDAY; DISPMONT; END; UNTIL YEAR = 0; WRITE(ESCH,'z'); END. {Calendar} ======================================================================================== DOCUMENT :usus Folder:VOL14:compfile.text ======================================================================================== program compfile; { compare file utility program. written by Jon Bondy Feb 1982 } const { number of retries for reading and writing } readretries = 1; writeretries = 3; buffsize = 32; { blocks } bs = 8; type block = packed array [1..512] of char; var buff1, buff2 : array[1..buffsize] of block; retrycount : integer; file_1, file_2 : file; fname : string; ch : char; procedure do_compare; var startblock : integer; size : integer; retrycount : integer; i : integer; error : boolean; procedure read_1(var size : integer; startblock : integer); var retrycount : integer; begin retrycount := 0; repeat if (ioresult <> 0) then writeln('Attempting to re-try reading file 1 after block ', startblock,'.'); { obtain actual amount of data read here for use later on } {$I-} size := blockread(file_1,buff1,buffsize,startblock); {$I+} retrycount := retrycount + 1; until (ioresult = 0) or (retrycount > readretries); if (ioresult <> 0) then begin writeln('Unrecoverable error reading file 1 after block ', startblock,'.'); exit(do_compare); end; end; { read_1 } procedure read_2(size, startblock : integer); var retrycount, size_read : integer; begin retrycount := 0; repeat if (ioresult <> 0) then writeln('Attempting to re-try reading file 2 after block ', startblock,'.'); {$I-} size_read := blockread(file_2,buff2,size,startblock); {$I+} retrycount := retrycount + 1; until ((ioresult = 0) and (size_read = size)) or (retrycount > readretries); if (ioresult <> 0) or (size_read <> size) then begin writeln('Unrecoverable error reading file 2 after block ',startblock,'.'); exit(do_compare); end; end; { read_2 } procedure compare_buffers(size, startblock : integer); var i, j : integer; begin for i := 1 to size do if (buff1[i] <> buff2[i]) then begin writeln('Compare error in block ', (startblock + i - 1), '.'); for j := 1 to 512 do if (buff1[i][j] <> buff2[i][j]) then begin writeln('Compare error in byte ', j, '.'); exit(do_compare); end; { if } end; { if } end; { compare_buffers } begin { do_compare } startblock := 0; repeat size := buffsize; { try to fill buffer each time } write('Comparing block ',startblock:4,' '); for i := 1 to 24 do write(chr(bs)); read_1(size,startblock); read_2(size,startblock); compare_buffers(size,startblock); startblock := startblock + buffsize; until (size < buffsize); writeln; writeln('Comparison completed successfully.'); end; { do_compare } begin { main } repeat writeln('Compare File Utility. Written by Jon Bondy, 2/82.'); repeat write('Enter first file name : '); readln(fname); close(file_1); {$I-} reset(file_1,fname); {$I+} until (ioresult = 0); repeat write('Enter second file name : '); readln(fname); close(file_2); {$I-} reset(file_2,fname); {$I+} until (ioresult = 0); do_compare; write('Do you wish to make another comparison? '); read(ch); writeln; until (ch = 'n') or (ch = 'N'); write('Press when system disk is in Unit 4 again.'); readln(ch); end. ======================================================================================== DOCUMENT :usus Folder:VOL14:copfile.text ======================================================================================== program copfile; { copy verify file utility program. written by Jon Bondy Feb 1982 } const { number of retries for reading and writing } readretries = 1; writeretries = 3; buffsize = 32; { blocks } bs = 8; type block = packed array [0..255] of integer; var buff1, buff2 : array[1..buffsize] of block; retrycount : integer; source, dest : file; fname : string; ch : char; proceed : boolean; procedure docopy; var startblock : integer; size : integer; error : boolean; i : integer; procedure doread(var size : integer; startblock : integer); var retrycount : integer; begin retrycount := 0; repeat if (ioresult <> 0) then writeln('Attempting to re-try source read after block ', startblock,'.'); { obtain actual amount of data read here for use later on } {$I-} size := blockread(source,buff1,buffsize,startblock); {$I+} retrycount := retrycount + 1; until (ioresult = 0) or (retrycount > readretries); if (ioresult <> 0) then begin writeln('Unrecoverable error reading source file after block ', startblock,'.'); exit(docopy); end; end; { doread } procedure dowrite(size, startblock : integer); var retrycount, size_read : integer; begin retrycount := 0; repeat if (ioresult <> 0) then writeln('Attempting to re-try write after block ',startblock,'.'); {$I-} size_read := blockwrite(dest,buff1,size,startblock); {$I+} retrycount := retrycount + 1; until ((ioresult = 0) and (size_read = size)) or (retrycount > writeretries); if (ioresult <> 0) or (size_read <> size) then begin writeln('Unrecoverable error writing destination file after block ', startblock,'.'); exit(docopy); end; end; { dowrite } function docompare(size, startblock : integer) : boolean; { return true if compare error } var retrycount, size_read : integer; i : integer; error : boolean; begin retrycount := 0; repeat if (ioresult <> 0) then writeln('Attempting to re-try destination read after block ', startblock,'.'); {$I-} size_read := blockread(dest,buff2,size,startblock); {$I+} retrycount := retrycount + 1; until ((ioresult = 0) and (size_read = size)) or (retrycount > readretries); if (ioresult <> 0) or (size_read <> size) then begin writeln('Error re-reading destination file after block ', startblock,'.'); docompare := true; { signal error } exit(docompare); end; error := false; for i := 1 to size do error := error or (buff1[i] <> buff2[i]); if error then writeln('Compare error after block ',startblock,'.'); docompare := error; end; { docompare } begin { docopy } startblock := 0; repeat size := buffsize; { try to fill buffer each time } retrycount := 0; repeat write('Copying block ',startblock:4,' '); for i := 1 to 22 do write(chr(bs)); doread(size,startblock); dowrite(size,startblock); error := docompare(size,startblock); { true if error on compare } if error then writeln('Retrying copy starting at block ',startblock); retrycount := retrycount + 1; until not error or (retrycount > readretries); if error then begin writeln; writeln('Unable to copy due to unrecoverable errors.'); exit(docopy); end; startblock := startblock + buffsize; until (size < buffsize); writeln; close(dest,lock); writeln('Copy completed successfully.'); end; { docopy } begin { main } repeat writeln('Copy/Verify File Utility. Written by Jon Bondy, 2/82.'); repeat write('Enter source file name : '); readln(fname); close(source); {$I-} reset(source,fname); {$I+} until (ioresult = 0); repeat write('Enter destination file name : '); readln(fname); close(dest); { try to open for read } {$I-} reset(dest,fname); {$I+} if (ioresult = 0) then begin { file found } write('File exists: destroy it ? '); read(ch); writeln; if (ch = 'y') or (ch = 'Y') then begin close(dest,purge); proceed := true; end else proceed := false; { prevent copy } end else proceed := true; { file not found } close(dest); if proceed then {$I-} rewrite(dest,fname); {$I+} until (ioresult = 0); if proceed then docopy; write('Do you wish to make another copy? '); read(ch); writeln; until (ch = 'n') or (ch = 'N'); write('Press when system disk is in Unit 4 again.'); readln(ch); end. ======================================================================================== DOCUMENT :usus Folder:VOL14:copver.asm.text ======================================================================================== SELDSK .EQU 1BH SETTRK .EQU 1EH SETSEC .EQU 21H SETDMA .EQU 24H READ .EQU 27H WRITE .EQU 2AH .FUNC READSECTOR,4 POP IX ;return address POP IY ;POP TWO WORDS OF ZEROS POP IY ;POP TWO WORDS OF ZEROS POP BC ;memory write address LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,SETDMA LD DE,TAG1 PUSH DE JP (HL) ;CALL SETDMA TAG1 POP BC ;disk number LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,SELDSK LD DE,TAG2 PUSH DE JP (HL) ;CALL SELDSK TAG2 POP BC ;track number LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,SETTRK LD DE,TAG3 PUSH DE JP (HL) ;CALL SETTRK TAG3 POP BC ;sector number LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,SETSEC LD DE,TAG4 PUSH DE JP (HL) ;CALL SETSEC TAG4 LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,READ LD DE,TAG5 PUSH DE JP (HL) ;CALL READ TAG5 LD BC,0FFFFH JP NZ,TAG6 LD BC,00000H TAG6 PUSH BC ;FUNCTION RETURN VALUE JP (IX) ;restore return address .FUNC WRITESECTOR,4 POP IX ;return address POP IY ;POP TWO WORDS OF ZEROS POP IY ;POP TWO WORDS OF ZEROS POP BC ;memory write address LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,SETDMA LD DE,TAG1 PUSH DE JP (HL) ;CALL SETDMA TAG1 POP BC ;disk number LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,SELDSK LD DE,TAG2 PUSH DE JP (HL) ;CALL SELDSK TAG2 POP BC ;track number LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,SETTRK LD DE,TAG3 PUSH DE JP (HL) ;CALL SETTRK TAG3 POP BC ;sector number LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,SETSEC LD DE,TAG4 PUSH DE JP (HL) ;CALL SETSEC TAG4 LD HL,(0001H) ;PICK UP MS-BYTE OF BIOS ADDRESS LD L,WRITE LD DE,TAG5 PUSH DE JP (HL) ;CALL WRITE TAG5 LD BC,0FFFFH JP NZ,TAG6 LD BC,00000H TAG6 PUSH BC ;FUNCTION RETURN VALUE JP (IX) ;restore return address .END ; FILE IS COPVER.ASM.TEXT ======================================================================================== DOCUMENT :usus Folder:VOL14:copvol.text ======================================================================================== program copver; { copy verify utility program. written by Jon Bondy 1981 } const { number of retries for reading and writing } readretries = 1; writeretries = 3; { unit numbers } source = 4; dest = 5; buffsize = 32; { blocks } bs = 8; type block = packed array [0..255] of integer; var buff1, buff2 : array[1..buffsize] of block; totalblocks : integer; retrycount : integer; { to allow one to read the directory to find the volume id } dir : record trash1, trash2, trash3 : integer; volid : string[7]; eovblk : integer; end; ch : char; function readsector(sect, track, disk : integer; var mem_addr : integer) : integer; external; function writesector(sect, track, disk : integer; var mem_addr : integer) : integer; external; procedure docopy; var startblock : integer; size : integer; error : boolean; i : integer; procedure copy_booter; var interleave : array[1..26] of integer; procedure read_booter; var track, sector, addr, buffer, i : integer; error : boolean; begin write('Reading boot tracks.'); for i := 1 to 20 do write(chr(bs)); addr := 0; buffer := 1; error := false; for track := 0 to 1 do for sector := 1 to 26 do begin error := error or (readsector(interleave[sector],track,0,buff1[buffer,addr]) <> 0); addr := addr + 64; if (addr = 256) then begin addr := 0; buffer := buffer + 1; end end; if error then begin writeln('Unable to read boot tracks.'); exit(docopy); end; end; { read_booter } procedure write_booter; var track, sector, addr, buffer, i : integer; error : boolean; begin write('Writing boot tracks.'); for i := 1 to 20 do write(chr(bs)); addr := 0; buffer := 1; error := false; for track := 0 to 1 do for sector := 1 to 26 do begin error := error or (writesector(interleave[sector],track,1,buff1[buffer,addr]) <> 0); addr := addr + 64; if (addr = 256) then begin addr := 0; buffer := buffer + 1; end end; if error then begin writeln('Unable to write boot tracks.'); exit(docopy); end; end; { write_booter } procedure compare_booter; var track, sector, addr, buffer, i : integer; error : boolean; begin write('Comparing boot tracks.'); for i := 1 to 22 do write(chr(bs)); addr := 0; buffer := 1; error := false; for track := 0 to 1 do for sector := 1 to 26 do begin error := error or (readsector(interleave[sector],track,1,buff2[buffer,addr]) <> 0); addr := addr + 64; if (addr = 256) then begin addr := 0; buffer := buffer + 1; end end; if error then begin writeln('Unable to re-read boot tracks.'); exit(docopy); end; error := false; for i := 1 to 13 do error := error or (buff1[i] <> buff2[i]); if error then begin writeln('Boot tracks compare error.'); exit(docopy); end end; { compare_booter } begin { copy_booter } interleave[1] := 1; interleave[2] := 3; interleave[3] := 5; interleave[4] := 7; interleave[5] := 9; interleave[6] := 11; interleave[7] := 13; interleave[8] := 15; interleave[9] := 17; interleave[10] := 19; interleave[11] := 21; interleave[12] := 23; interleave[13] := 25; interleave[14] := 2; interleave[15] := 4; interleave[16] := 6; interleave[17] := 8; interleave[18] := 10; interleave[19] := 12; interleave[20] := 14; interleave[21] := 16; interleave[22] := 18; interleave[23] := 20; interleave[24] := 22; interleave[25] := 24; interleave[26] := 26; read_booter; write_booter; compare_booter; end; { copy_booter } procedure doread(size, startblock : integer); var retrycount : integer; begin retrycount := 0; repeat if (ioresult <> 0) then writeln('Attempting to re-try read after block ',startblock,'.'); {$I-} unitread(source,buff1,size,startblock); {$I+} retrycount := retrycount + 1; until (ioresult = 0) or (retrycount > readretries); if (ioresult <> 0) then begin writeln('Unrecoverable error reading Unit 4 after block ',startblock,'.'); exit(docopy); end; end; { doread } procedure dowrite(size, startblock : integer); var retrycount : integer; begin retrycount := 0; repeat if (ioresult <> 0) then writeln('Attempting to re-try write after block ',startblock,'.'); {$I-} unitwrite(dest,buff1,size,startblock); {$I+} retrycount := retrycount + 1; until (ioresult = 0) or (retrycount > writeretries); if (ioresult <> 0) then begin writeln('Unrecoverable error writing Unit 5 after block ',startblock,'.'); exit(docopy); end; end; { dowrite } function docompare(size, startblock : integer) : boolean; { return true if compare error } var retrycount : integer; i : integer; error : boolean; begin retrycount := 0; repeat if (ioresult <> 0) then writeln('Attempting to re-try re-read after block ',startblock,'.'); {$I-} unitread(dest,buff2,size,startblock); {$I+} retrycount := retrycount + 1; until (ioresult = 0) or (retrycount > readretries); if (ioresult <> 0) then begin writeln('Error re-reading Unit 5 after block ',startblock,'.'); docompare := true; { signal error } exit(docompare); end; error := false; for i := 1 to (size div 512) do error := error or (buff1[i] <> buff2[i]); if error then writeln('Compare error after block ',startblock,'.'); docompare := error; end; { docompare } begin { docopy } copy_booter; startblock := 0; repeat size := totalblocks - startblock; if (size > buffsize) then size := sizeof(buff1) else size := size * 512; retrycount := 0; repeat write('Copying block ',startblock:4,' '); for i := 1 to 22 do write(chr(bs)); doread(size,startblock); dowrite(size,startblock); error := docompare(size,startblock); { true if error on compare } if error then writeln('Retrying copy starting at block ',startblock); retrycount := retrycount + 1; until not error or (retrycount > readretries); if error then begin writeln; writeln('Unable to copy due to unrecoverable errors.'); exit(docopy); end; startblock := startblock + buffsize; until (startblock > totalblocks); writeln; writeln('Copy completed successfully.'); end; { docopy } begin repeat writeln('Copy/Verify Utility. Written by Jon Bondy, 1/81.'); writeln('Place disk to be copied in Unit 4; new copy disk in Unit 5.'); write('Press to start copying'); readln(ch); unitread(source,dir,sizeof(dir),2); { read in directory } if (length(dir.volid) <= 7) then writeln('Copying Volume ',dir.volid) else writeln('Source diskette is not a UCSD Volume.'); totalblocks := dir.eovblk; write('Copy ',totalblocks,' blocks? '); read(ch); writeln; if (ch <> 'y') and (ch <> 'Y') then begin repeat write('How many blocks do you want to copy? '); {$I-} readln(totalblocks); {$I+} until (ioresult = 0); end; unitread(dest,dir,sizeof(dir),2); { read directory } if (length(dir.volid) <= 7) then begin write('Is it OK to destroy volume ',dir.volid,': ? '); read(ch); writeln; if (ch = 'y') or (ch = 'Y') then docopy; end else { not valid UCSD Volume } docopy; write('Do you wish to make another copy? '); read(ch); writeln; until (ch = 'n') or (ch = 'N'); write('Press when system disk is in Unit 4 again.'); readln(ch); end. ======================================================================================== DOCUMENT :usus Folder:VOL14:crosses.gpat ======================================================================================== +-----------------------------------------------------------------------------+|| ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + + + + ||| + + + + + + + + + + + ||| + + + + + + + + + + + + ||| + + + + + + + + + + + + ||| + + + + + + + + + + + + + ||| + + + + + + + + + + + + + ||| + + + + + + + + + + + + + + ||| + + + + + + + + + + + + + + ||| + + + + + + + + + + + + + + + ||| + + + + + + + + + + + + + + + ||| + + + + + + + + + + + + + + + + ||| ||+-----------------------------------------------------------------------------+|+-----------------------------------------------------------------------------+|| ||| -------- ---------------- ------- ||| | | ======================================================================================== DOCUMENT :usus Folder:VOL14:dayofwk.text ======================================================================================== {Program Author: Walter Hess 1460 Seven Pines Rd. Schaumberg, IL 60193 Assumes H19 CRT} PROGRAM DAYOFWK; {Version "A" W.I.H. 1/30/80} CONST {The Gregorian Calendar was adopted in the U.S. in 1752} STARTYR = 1753; STARTDAY = 1; TYPE SHINT = 0..255; VAR MONTH,DATE : SHINT; DAY,YEAR,J : INTEGER; PROCEDURE CALCDAY; BEGIN DAY := STARTDAY; FOR J := STARTYR TO YEAR - 1 DO IF ((J MOD 4 = 0) AND (J MOD 100 <> 0)) OR (J MOD 400 = 0) THEN DAY := DAY + 2 ELSE DAY := DAY + 1; CASE MONTH OF 1: ; 2: DAY := DAY + 31; 3: DAY := DAY + 59; 4: DAY := DAY + 90; 5: DAY := DAY + 120; 6: DAY := DAY + 151; 7: DAY := DAY + 181; 8: DAY := DAY + 212; 9: DAY := DAY + 243; 10: DAY := DAY + 273; 11: DAY := DAY + 304; 12: DAY := DAY + 334; END; {Case} IF (MONTH > 2) AND (((YEAR MOD 4 = 0) AND (YEAR MOD 100 <> 0)) OR (YEAR MOD 400 = 0)) THEN DAY := DAY + 1; DAY := DAY + DATE - 1; DAY := DAY MOD 7; END; {Calcday} BEGIN {Dayofwk} WRITELN('PROGRAM WILL CALCULATE THE DAY OF THE WEEK ANY DATE FALLS ON'); WRITELN('FROM JANUARY 1, 1800 ON. ENTER "0" FOR YEAR TO TERMINATE.'); WRITELN('ENTER MONTH AS 1 TO 12 FOR JANUARY TO DECEMBER'); WRITELN; WRITE(CHR(27),'u'); REPEAT WRITE('ENTER YEAR '); READLN(YEAR); IF YEAR >= STARTYR THEN BEGIN REPEAT WRITE('ENTER MONTH '); READLN(MONTH); UNTIL (MONTH > 0 ) AND (MONTH < 13); REPEAT WRITE('ENTER DATE '); READLN(DATE); UNTIL (DATE > 0) AND (DATE < 32); CALCDAY; WRITELN; WRITE(' IN ',YEAR); CASE MONTH OF 1: WRITE(' JANUARY '); 2: WRITE(' FEBRUARY '); 3: WRITE(' MARCH '); 4: WRITE(' APRIL '); 5: WRITE(' MAY '); 6: WRITE(' JUNE '); 7: WRITE(' JULY '); 8: WRITE(' AUGUST '); 9: WRITE(' SEPTEMBER '); 10: WRITE(' OCTOBER '); 11: WRITE(' NOVEMBER '); 12: WRITE(' DECEMBER '); END; {Case} WRITE(DATE,' IS A '); CASE DAY OF 0: WRITELN('SUNDAY'); 1: WRITELN('MONDAY'); 2: WRITELN('TUESDAY'); 3: WRITELN('WEDNESDAY'); 4: WRITELN('THURSDAY'); 5: WRITELN('FRIDAY'); 6: WRITELN('SATURDAY'); END; {Case} WRITELN; END; UNTIL YEAR = 0; WRITE(CHR(27),'z'); END. {Dayofwk} ======================================================================================== DOCUMENT :usus Folder:VOL14:default.gpat ======================================================================================== +---------------+------------------------------+------------------------------+|| | | ||| ------------- | ----------- | -------------- | ---------------------------- ||| | | ||+----------- | -------------- | ------------ -+- -------------------------- ||| | | ||| ---------- | ----- | --------------- | ----- | -----------------------------+|| | | ||+------------------- | ------ | ------ | ------------- | ---------------------+|| | | ||+------------ ------------- | --------+------------- | -------------------- ||| | | ||| +---+ --+---+---+---+-- +---+-+-----+ | --+-----+-----+-----+-----+-----+-- ||| | | | | | | | | | | | | | | | | ||| | | | | | | | | | | | | | | | + + | + + + + + | ||| | | | | | | | | | | | | | | | + + + + + + + ||| | | | | | | | | | | | | | | | + + + + + + + + + -+|| | | | | | | | | | | | | | | | + + + + + + + + ||| | | | | | | | | | | | | | | +- + + + + + + + + ||| | | | | | | | | + + + + + + + + ||| --+---+-- | --+---+---+---+ | + + + | + + + + + ||| | | | | | | | | | | ||+-------------------------------+-----+-----+-----+-----+-----+-----+-----+---+|+-----------------------------------------------------------------------------+|| ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + + + ||| + + + + + + + + ======================================================================================== DOCUMENT :usus Folder:VOL14:fastread.text ======================================================================================== { FASTREAD - fast text file string read for UCSD pascal. } { dhd - PCD Systems, Inc. } unit fastread; interface { file control block } const bufsiz = 1024; linemax = 255; type lineindex = 0..linemax; longstring = string[linemax]; ffile = file; fcb = record inlfn: string[30]; { input file name } line: longstring; { current text line } bpos: integer; { buffer position } endfile: boolean; { true when end of file } buf: packed array[0..bufsiz] of char; blknr: integer; end; procedure getstring(var phyle: fcb; var infile: ffile; var s: longstring); procedure openfile(var phyle: fcb; var infile: ffile; var lfn: string); implementation const cr = 13; procedure openfile{var phyle: fcb; var infile: ffile; var lfn: string}; begin { openfile } with phyle do begin reset(infile, lfn); inlfn := lfn; line := ''; bpos := bufsiz + 1; endfile := false; blknr := 2; end; end; { openfile } procedure getstring{var phyle: fcb; var infile: ffile; var s: longstring}; const dle = 16; var bcnt, chg: integer; begin { getstring } {$R- disable string range checks } with phyle do repeat if bpos >= bufsiz then { time for next buffer } begin bcnt := blockread(infile, buf[0], 2, blknr); bpos := 0; blknr := blknr + bcnt; if bcnt < 2 then { eof } begin endfile := true; EXIT(getstring) end; end; chg := scan(bufsiz-bpos, =chr(cr), buf[bpos]); if (bpos + chg) < bufsiz then { found a carriage return } begin moveleft(buf[bpos], S[1], chg); { copy string except CR } S[0] := chr(chg); bpos := bpos + chg + 1; end else begin chg := scan(bufsiz-bpos, =chr(0), buf[bpos]); { look for null } if (bpos + chg) < bufsiz then begin moveleft(buf[bpos], S[1], chg-1); S[0] := chr(chg); bpos := bufsiz; end; end; until chg > 0; if length(s) > 2 then if s[1] = chr(dle) then { insert leading blanks } begin chg := ord(s[2])-32; if chg > 2 then moveright(s[3], s[chg+1], length(s)-2) else moveleft (s[3], s[chg+1], length(s)-2); fillchar(s[1], chg, ' '); s[0] := chr(length(s)+chg-2); end; end; { getstring } {$R+} end. { of unit } ======================================================================================== DOCUMENT :usus Folder:VOL14:game.assem.text ======================================================================================== .FUNC PORTREAD,1 ;PARAM IS PORT NUMBER POP IX ;RETURN ADDRESS POP IY ;POP TWO WORDS OF ZEROS POP IY ;POP TWO WORDS OF ZEROS POP BC ;PORT NUMBER IN E,(C) ;READ PORT LD D,0 PUSH DE JP (IX) .END ======================================================================================== DOCUMENT :usus Folder:VOL14:game.text ======================================================================================== (*$S+*) program game; (* This is a game by Jon Bondy. I think it needs some work. I got it to run on my H-89, but it seemed to ignore many of the movement commands and I lost every time, oh well. You will have to install your own keyboard status routine, Jon provides one of his own and I provide one for the H-89. gws*) const { lengths } l_line = 78; l_screen = 23; home_x = 0; home_y = 1; { cursor direction keys as ORDs } ord_up = 116; { t } ord_down = 118; { v } ord_right = 103; { g } ord_left = 102; { f } { obstacles as ORDs } ord_horiz = 45; { - } ord_vert = 124; { | } ord_intersect = 43; { + } { misc chars in ORD form } ord_uc_i = 73; { I } ord_lc_i = 105; { i } ord_uc_q = 81; { Q } ord_lc_q = 113; { q } ord_uc_h = 72; { H } ord_lc_h = 104; { h } ord_uc_m = 77; { M } ord_lc_m = 109; { m } ord_0 = 48; { 0 } ord_1 = 49; { 1 } ord_2 = 50; { 2 } ord_3 = 51; { 3 } ord_4 = 52; { 4 } ord_5 = 53; { 5 } ord_6 = 54; { 6 } ord_7 = 55; { 7 } ord_8 = 56; { 8 } ord_9 = 57; { 9 } ord_space = 32; max_demons = 9; { obstacles as CHARs } empty = ' '; v_wall = '|'; h_wall = '-'; intersect = '+'; { demons/players as CHARs } demon = 'D'; player = 'P'; type t_obstacle = char; t_line = packed array [home_x..l_line] of t_obstacle; var pattern : file of t_line; board : array[home_y..l_screen] of t_line; old_random : integer; ch : char; i : integer; { location of player } player_x, player_y : integer; { used in delay loop to slow down game } speed_control : integer; num_demons, num_live_demons : integer; { starts at 1: game over when decreased to 0 } num_players : integer; { demon mode } demon_motion : (inertial_demon, heat_seeking_demon); demon_data : array[1..max_demons] of record { current position } x, y : integer; { current direction (inertial mode only): a cursor character } direction : char; alive : boolean; end; procedure eeoln; begin write(chr(27), 'K'); {H-19 specific gws} end; { eeoln } function random : integer; { procedure } begin random := old_random; old_random := ((old_random * 32761) + 13) mod 32717; end; { random } procedure clear_board; var x, y : integer; begin { board is empty... } fillchar(board, sizeof(board), ord(empty)); { ...with boarders established as walls } for x := home_x to l_line do begin board[home_y,x] := h_wall; board[l_screen,x] := h_wall; end; for y := home_y to l_screen do begin board[y,home_x] := v_wall; board[y,l_line] := v_wall; end; board[home_y,home_x] := intersect; board[home_y,l_line] := intersect; board[l_screen,home_x] := intersect; board[l_screen,l_line] := intersect; end; procedure show_board; var y, length : integer; begin gotoxy(home_x, home_y); length := l_line - home_x + 1; for y := home_y to l_screen do begin unitwrite(1,board[y],length); if (y <> l_screen) then writeln; end; { for y } gotoxy(home_x, home_y); end; { show_board } procedure go_prev_dir(prev_dir : char; var x, y : integer); { modify x,y so that motion continues in direction used last } begin case ord(prev_dir) of ord_up : if (y > home_y) then y := y - 1; ord_down : if (y < l_screen) then y := y + 1; ord_left : if (x > home_x) then x := x - 1; ord_right : if (x < l_line) then x := x + 1; end; { case } end; { go_prev_dir } procedure edit; var x, y : integer; ch, prev_dir : char; begin gotoxy(0,0); eeoln; write('Edit: up, down, left, right, "-", "|", "+", " ", I(nit, Q(uit'); x := home_x; y := home_y; prev_dir := chr(ord_right); repeat gotoxy(x,y); read(keyboard,ch); case ord(ch) of ord_up : begin if (y > home_y) then y := y - 1; prev_dir := ch; end; ord_down : begin if (y < l_screen) then y := y + 1; prev_dir := ch; end; ord_left : begin if (x > home_x) then x := x - 1; prev_dir := ch; end; ord_right : begin if (x < l_line) then x := x + 1; prev_dir := ch; end; ord_horiz : begin board[y,x] := h_wall; write('-'); go_prev_dir(prev_dir,x,y); end; ord_vert : begin board[y,x] := v_wall; write('|'); go_prev_dir(prev_dir,x,y); end; ord_intersect : begin board[y,x] := intersect; write('+'); go_prev_dir(prev_dir,x,y); end; ord_space : begin board[y,x] := empty; write(' '); go_prev_dir(prev_dir,x,y); end; ord_lc_i, ord_uc_i : begin clear_board; show_board; end; end; { case } until (ch = 'q') or (ch = 'Q'); end; { edit } procedure put_pattern; var fname : string; y : integer; begin gotoxy(0,0); eeoln; write('Write pattern to what file name (".GPAT" assumed) ? '); readln(fname); if (length(fname) > 0) then begin {$I-} rewrite(pattern,concat(fname,'.gpat')); {$I+} if (ioresult = 0) then begin for y := home_y to l_screen do begin pattern^ := board[y]; put(pattern); end; close(pattern,lock); gotoxy(0,0); eeoln; write('File written successfully.'); { delay to allow message to be read } for y := 1 to 800 do begin end; end; end; end; { put_pattern } procedure get_pattern; var fname : string; y : integer; begin gotoxy(0,0); eeoln; write('Read pattern from what file name (".GPAT" assumed) ? '); readln(fname); if (length(fname) > 0) then begin {$I-} reset(pattern,concat(fname,'.gpat')); {$I+} if (ioresult = 0) then for y := home_y to l_screen do begin board[y] := pattern^; get(pattern); end else clear_board; show_board; close(pattern); end; end; { get_pattern } procedure setup; var ch : char; begin repeat gotoxy(0,0); eeoln; write('Setup: E(dit, G(et, P(ut, S(how, N(umdemons, Q(uit : '); read(keyboard,ch); case ch of 'e','E' : edit; 'g','G' : get_pattern; 'p','P' : put_pattern; 's','S' : show_board; 'n','N' : begin gotoxy(0,0); eeoln; write('Enter number of demons: '); read(ch); if (ch in ['1'..'9']) then num_demons := ord(ch) - ord('0'); ch := ' '; end; 'q','Q' : begin end; end; { case } until (ch = 'q') or (ch = 'Q'); end; { setup } (*function portread(port : integer) : integer; external; { procedure }*) function kbstat : boolean; external; {my own keyboard status routine for an H-89} function key_hit : boolean; { procedure } begin {key_hit := odd(portread(0) div 2);} key_hit := kbstat; end; { key_hit } procedure update_board(x,y : integer; token : t_obstacle); begin gotoxy(x,y); write(token); gotoxy(0,0); board[y,x] := token; end; { update_board } procedure kill_demon(x_input,y_input : integer); var i : integer; begin for i := 1 to max_demons do with demon_data[i] do begin if alive and (x = x_input) and (y = y_input) then begin alive := false; num_live_demons := num_live_demons - 1; update_board(x,y,empty); gotoxy(70,0); write('Demons: ', num_live_demons); end; end; end; { kill_demon } procedure hyperspace(var x, y : integer; token : t_obstacle); { put "token" in random board position and return position in x/y } var done : boolean; begin done := false; update_board(x,y,empty); repeat x := random mod l_line; y := (random mod (l_screen - 1)) + 1; if (board[y,x] = empty) then begin update_board(x,y,token); done := true; end; until done; end; { hyperspace } procedure move_player(var quit : boolean); var ch : char; board_element : t_obstacle; begin read(keyboard,ch); update_board(player_x, player_y, empty); case ord(ch) of ord_right : begin board_element := board[player_y,player_x+1]; if (board_element = empty) then player_x := player_x + 1 else if (board_element = demon) then begin player_x := player_x + 1; kill_demon(player_x,player_y); end; end; ord_left : begin board_element := board[player_y,player_x-1]; if (board_element = empty) then player_x := player_x - 1 else if (board_element = demon) then begin player_x := player_x - 1; kill_demon(player_x,player_y); end; end; ord_up : begin board_element := board[player_y-1,player_x]; if (board_element = empty) then player_y := player_y - 1 else if (board_element = demon) then begin player_y := player_y - 1; kill_demon(player_x,player_y); end; end; ord_down : begin board_element := board[player_y+1,player_x]; if (board_element = empty) then player_y := player_y + 1 else if (board_element = demon) then begin player_y := player_y + 1; kill_demon(player_x,player_y); end; end; ord_lc_q, ord_uc_q : quit := true; ord_lc_h, ord_uc_h : hyperspace(player_x, player_y, player); ord_lc_m, ord_uc_m : if (demon_motion = inertial_demon) then demon_motion := heat_seeking_demon else demon_motion := inertial_demon; ord_0 : speed_control := 0; ord_1 : speed_control := 10; ord_2 : speed_control := 20; ord_3 : speed_control := 30; ord_4 : speed_control := 40; ord_5 : speed_control := 50; ord_6 : speed_control := 60; ord_7 : speed_control := 70; ord_8 : speed_control := 80; ord_9 : speed_control := 90; end; { case } update_board(player_x,player_y,player); end; { move_player } procedure change_direction(x,y : integer; var direction : char); { when an inertial demon hits something, this routine figurs out what direction to send him in next } var new_direction : char; num_free_directions : integer; empty_player : set of t_obstacle; begin num_free_directions := 0; empty_player := [empty,player]; { determine what directions are possible -- establish "new_direction" in case there is only one such } if (board[y-1,x] in empty_player) then begin num_free_directions := num_free_directions + 1; new_direction := chr(ord_up); end; if (board[y+1,x] in empty_player) then begin num_free_directions := num_free_directions + 1; new_direction := chr(ord_down); end; if (board[y,x+1] in empty_player) then begin num_free_directions := num_free_directions + 1; new_direction := chr(ord_right); end; if (board[y,x-1] in empty_player) then begin num_free_directions := num_free_directions + 1; new_direction := chr(ord_left); end; if (num_free_directions > 1) then begin { there is more than one possible new direction: select randomly } new_direction := empty; repeat case (random mod 4) of 0 : if (board[y-1,x] in empty_player) then if (direction <> chr(ord_down)) then new_direction := chr(ord_up); 1 : if (board[y+1,x] in empty_player) then if (direction <> chr(ord_up)) then new_direction := chr(ord_down); 2 : if (board[y,x-1] in empty_player) then if (direction <> chr(ord_right)) then new_direction := chr(ord_left); 3 : if (board[y,x+1] in empty_player) then if (direction <> chr(ord_left)) then new_direction := chr(ord_right); end; { case } until (new_direction <> empty); end; { if } direction := new_direction; end; { change_direction } (*$I game1.text*) ======================================================================================== DOCUMENT :usus Folder:VOL14:game1.text ======================================================================================== (* included from game.text*) procedure init_play; var i : integer; begin num_players := 1; player_x := home_x + 1; player_y := home_y + 1; hyperspace(player_x, player_y, player); { position randomly } num_live_demons := num_demons; for i := 1 to num_live_demons do with demon_data[i] do begin { position randomly } x := home_x + 1; y := home_y + 1; hyperspace(x,y,demon); { establish initial inertial direction randomly } direction := empty; change_direction(x,y,direction); alive := true; end; { "kill" the other demons } for i := (num_live_demons + 1) to max_demons do demon_data[i].alive := false; gotoxy(70,0); write('Demons: ', num_live_demons); end; { init_play } procedure kill_player; begin num_players := num_players - 1; end; { kill_player } function demon_right(var x,y : integer) : boolean; { try to move demon right: return true if successful } var board_element : t_obstacle; begin demon_right := true; board_element := board[y,x+1]; if (board_element = empty) then x := x + 1 else if (board_element = player) then begin x := x + 1; kill_player; end else if (board_element = demon) then hyperspace(x,y,demon) else demon_right := false; end; { demon_right } function demon_left(var x,y : integer) : boolean; { try to move demon left: return true if successful } var board_element : t_obstacle; begin demon_left := true; board_element := board[y,x-1]; if (board_element = empty) then x := x - 1 else if (board_element = player) then begin x := x - 1; kill_player; end else if (board_element = demon) then hyperspace(x,y,demon) else demon_left := false; end; { demon_left } function demon_up(var x,y : integer) : boolean; { try to move demon up: return true if successful } var board_element : t_obstacle; begin demon_up := true; board_element := board[y-1,x]; if (board_element = empty) then y := y - 1 else if (board_element = player) then begin y := y - 1; kill_player; end else if (board_element = demon) then hyperspace(x,y,demon) else demon_up := false; end; { demon_up } function demon_down(var x,y : integer) : boolean; { try to move demon down: return true if successful } var board_element : t_obstacle; begin demon_down := true; board_element := board[y+1,x]; if (board_element = empty) then y := y + 1 else if (board_element = player) then begin y := y + 1; kill_player; end else if (board_element = demon) then hyperspace(x,y,demon) else demon_down := false; end; { demon_down } procedure move_same_direction(demon_num : integer); { move demon inertially } begin with demon_data[demon_num] do begin update_board(x,y,empty); case ord(direction) of ord_right : if not demon_right(x,y) then begin change_direction(x,y,direction); move_same_direction(demon_num); end; ord_left : if not demon_left(x,y) then begin change_direction(x,y,direction); move_same_direction(demon_num); end; ord_up : if not demon_up(x,y) then begin change_direction(x,y,direction); move_same_direction(demon_num); end; ord_down : if not demon_down(x,y) then begin change_direction(x,y,direction); move_same_direction(demon_num); end; end; { case } update_board(x,y,demon); end; { with } end; { move_same_direction } procedure move_towards_player(demon_num : integer); { move demon towards player } var index : integer; trash : boolean; begin with demon_data[demon_num] do begin update_board(x,y,empty); index := 0; { right two quadrants } if (player_x > x) then index := index + 1 { vertically adjacent } else if (player_x = x) then index := index + 2; { upper two quadrants } if (player_y > y) then index := index + 4 { horizontally adjacent } else if (player_y = y) then index := index + 8; { angle is between +/- 45 degrees or between 135 and 225 degrees } if (abs(player_x - x) > abs(player_y - y)) then index := index + 16; case index of 0 : if not demon_up(x,y) then trash := demon_left(x,y); 1 : if not demon_up(x,y) then trash := demon_right(x,y); 2 : if not demon_up(x,y) then if not demon_right(x,y) then trash := demon_left(x,y); 4 : if not demon_down(x,y) then trash := demon_left(x,y); 5 : if not demon_down(x,y) then trash := demon_right(x,y); 6 : if not demon_down(x,y) then if not demon_left(x,y) then trash := demon_right(x,y); 16 : if not demon_left(x,y) then trash := demon_up(x,y); 17 : if not demon_right(x,y) then trash := demon_up(x,y); 20 : if not demon_left(x,y) then trash := demon_down(x,y); 21 : if not demon_right(x,y) then trash := demon_down(x,y); 24 : if not demon_left(x,y) then if not demon_down(x,y) then trash := demon_up(x,y); 25 : if not demon_right(x,y) then if not demon_down(x,y) then trash := demon_up(x,y); 3, 7, 8, 9, 10, 11, 12, 13, 14, 15, 18, 19, 22, 23, 26 : writeln('case selector error ', index); end; { case } update_board(x,y,demon); end; { with } end; { move_towards_player } procedure move_demon(demon_num : integer); begin case demon_motion of inertial_demon : move_same_direction(demon_num); heat_seeking_demon : move_towards_player(demon_num); end; { case } end; { move_demon } procedure play_game; var quit : boolean; i, demon_num : integer; ch : char; begin gotoxy(0,0); eeoln; write('Play: up, down, right, left, H(yper, M(ode, 0..9=Level, Q(uit'); quit := false; init_play; demon_num := 0; repeat { delay if necessary for slow player } for i := 1 to speed_control do begin end; if key_hit then move_player(quit); repeat demon_num := demon_num + 1; if (demon_num > max_demons) then demon_num := 1; if demon_data[demon_num].alive then move_demon(demon_num); until demon_data[demon_num].alive or (num_live_demons = 0); until (num_live_demons = 0) or (num_players = 0) or quit; if key_hit then read(keyboard,ch); gotoxy(0,0); eeoln; if (num_live_demons = 0) then write('Congratulations: you win!') else if (num_players = 0) then write('Too bad: the Demons gotcha!'); update_board(player_x,player_y,empty); for i := 1 to max_demons do with demon_data[i] do if alive then update_board(x,y,empty); if not quit then for i := 1 to 4500 do begin end; { delay } end; { play_game } procedure initialize; var y : integer; begin writeln('Video Game Program. Jon Bondy. 11/81.'); for y := 1 to 800 do begin end; old_random := 13157; {$I-} reset(pattern,'default.gpat'); {$I+} if (ioresult <> 0) then clear_board else for y := home_y to l_screen do begin board[y] := pattern^; get(pattern); end; show_board; close(pattern); num_demons := 5; demon_motion := inertial_demon; speed_control := 50; end; { initialize } begin { game } initialize; repeat gotoxy(0,0); eeoln; write('GAME: S(etup, demon M(ode'); if (demon_motion = inertial_demon) then write('(I)') else if (demon_motion = heat_seeking_demon) then write('(H)'); write(', L(evel(', speed_control div 10,'), P(lay, Q(uit : '); repeat i := random; { more randomness! } until key_hit; read(ch); case ch of 's','S' : setup; 'm','M' : if (demon_motion = inertial_demon) then demon_motion := heat_seeking_demon else demon_motion := inertial_demon; 'l','L' : begin gotoxy(0,0); eeoln; write('Enter level (0..9) [9 is slowest] : '); repeat read(ch) until (ch in ['0'..'9']); speed_control := (ord(ch) - ord('0')) * 10; end; '0' : speed_control := 0; '1' : speed_control := 10; '2' : speed_control := 20; '3' : speed_control := 30; '4' : speed_control := 40; '5' : speed_control := 50; '6' : speed_control := 60; '7' : speed_control := 70; '8' : speed_control := 80; '9' : speed_control := 90; 'p','P' : play_game; 'q','Q' : begin end; end; { case } until (ch = 'q') or (ch = 'Q'); end. { game } ======================================================================================== DOCUMENT :usus Folder:VOL14:hexdump.text ======================================================================================== PROGRAM dump; LABEL 0,1,2,3; VAR disk: FILE OF RECORD buffer : PACKED ARRAY[1..512] OF CHAR; END; disk2: FILE OF RECORD buffer2 : PACKED ARRAY[1..2] OF CHAR; END; sblock,linumber,nblocks,chrnumber,recnumber,temp,rec: INTEGER; chrs : PACKED ARRAY[1..65] OF CHAR; ch : CHAR; infilename,outfilename : STRING[20]; tinput,scrfilname : STRING[20]; tchrs,fchrs : STRING; (*$G+*) FUNCTION val (instr : STRING) : INTEGER; VAR temp,chrat,fin : INTEGER; nchrs : PACKED ARRAY[1..10] OF CHAR; BEGIN val := 0;fin := 0;chrat := 0;nchrs := '0123456789'; REPEAT chrat := chrat + 1;temp := SCAN(10,=instr[chrat],nchrs); IF temp < 10 THEN BEGIN fin := fin * 10;fin := fin + temp; END; UNTIL (chrat = LENGTH(instr)) OR (chrat=6); val := fin; END; PROCEDURE blank; BEGIN WITH disk2^ DO BEGIN buffer2 := ' '; PUT(disk2); END; END; PROCEDURE return; BEGIN WITH disk2^ DO BEGIN buffer2[1] := CHR(00); buffer2[2] := CHR(13); PUT(disk2); END; END; PROCEDURE header; BEGIN chrs := '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ. abcdefghijklmnopqrstuvwxyz:'; fchrs := '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ. abcdefghijklmnopqrstuvwxyz:'; scrfilname := '#2: '; WITH disk2^ DO BEGIN {WITH} FOR temp := 1 to 12 DO blank; FOR temp := 1 to 10 DO BEGIN buffer2 := ' '; tchrs := ' '; tchrs := COPY(infilename,(temp*2-1),1); IF POS(tchrs,fchrs)<>0 THEN buffer2[1] := chrs[POS(tchrs,fchrs)]; tchrs := COPY(infilename,(temp*2),1); IF POS(tchrs,fchrs)<>0 THEN buffer2[2] := chrs[POS(tchrs,fchrs)]; PUT(disk2); END; return; FOR temp := 1 to 13 DO blank; temp := recnumber + 1;buffer2 := 'Bl';PUT(disk2); buffer2 := 'oc';PUT(disk2);buffer2 := 'k:';PUT(disk2); blank; buffer2[1] := chrs[((recnumber+1) DIV 10)+1]; buffer2[2] := chrs[((recnumber+1) MOD 10)+1]; PUT(disk2);return;return;blank;blank;chrnumber := 0; REPEAT BEGIN chrnumber := chrnumber + 1;buffer2[1] := chrs[chrnumber]; buffer2[2] := ':';PUT(disk2);blank; END; UNTIL chrnumber=16; return;chrnumber := 0;buffer2 := '--'; REPEAT BEGIN chrnumber := chrnumber + 1;PUT(disk2); END; UNTIL chrnumber=34; return;buffer2 := '0:';PUT(disk2);blank; END {WITH}; END {header}; BEGIN {dump} 3:WRITE('Output filename -----> '); READLN (outfilename); IF LENGTH(outfilename)=0 THEN outfilename := '#2:'; REWRITE(disk2,outfilename); SEEK(disk2,0); 1:WRITE ('Input filename -----> '); READLN (infilename); IF LENGTH(infilename)=0 THEN infilename := 'SYSTEM.WRK.CODE'; RESET(disk,infilename); 2:WRITE ('Starting Block -----> '); READLN (tinput); IF LENGTH(tinput)=0 THEN sblock:=0 ELSE sblock:=Val(tinput); WRITE ('Ending Block -----> '); READLN (tinput); IF LENGTH(tinput)=0 THEN nblocks:=0 ELSE nblocks:=Val(tinput); recnumber := sblock - 1; REPEAT {block} BEGIN {block} header; linumber := 0; recnumber := recnumber + 1; SEEK(disk,recnumber); GET(disk); chrnumber := 0; WITH disk^ DO REPEAT {chr} BEGIN {chr} chrnumber := chrnumber + 1; WITH disk2^ DO BEGIN {WITH} buffer2 := ' '; temp := ORD(buffer[chrnumber]); IF (temp > 255) THEN GOTO 0; buffer2[1] := chrs[(temp DIV 16)+1]; buffer2[2] := chrs[(temp MOD 16)+1]; PUT(disk2);blank; 0:IF (chrnumber MOD 16 = 0) THEN BEGIN {THEN} linumber := linumber + 1;return; buffer2[1] := chrs[(linumber MOD 16)+1]; buffer2[2] := ':'; IF chrnumber <> 512 THEN BEGIN IF outfilename = scrfilname THEN READ(KEYBOARD,ch); PUT(disk2); END; blank; END {THEN}; END {WITH}; END {chr}; UNTIL chrnumber = 512; WITH disk2^ DO BEGIN {WITH} chrnumber := 0; REPEAT IF outfilename <> '#2:' THEN return; chrnumber := chrnumber + 1; UNTIL chrnumber = 29; END {WITH}; END {block}; UNTIL recnumber = (nblocks); WRITE ('Anymore Blocks ? '); READ (ch);WRITELN; IF ch IN ['y','Y'] THEN GOTO 2; CLOSE(disk); WRITE ('Anymore Input ? '); READ (ch);WRITELN;IF ch IN ['y','Y'] THEN GOTO 1; CLOSE(disk2,LOCK); WRITE('Anymore Output? ');READ(ch); WRITELN;IF ch IN ['y','Y'] THEN GOTO 3; END {dump}. ======================================================================================== DOCUMENT :usus Folder:VOL14:home_loan.text ======================================================================================== PROGRAM HOME_LOAN; VAR A,R,Y,RATE,P,R12,R1,NP,FR,CM,CM1: REAL; procedure clear_screen; begin write ( chr ( 27 ) , chr ( 69 ) ); {H-19 specific} end; FUNCTION INPUT_VALUE:REAL; { function by: EDWARD J GRUNDLER } VAR I:INTEGER; INP:STRING; DEC,NEX,EX,NEG,OK:BOOLEAN; EXPO,J,X:REAL; BEGIN REPEAT DEC:=FALSE; EX:=FALSE; READLN(INP); IF LENGTH(INP)=0 THEN INP:='0'; OK:=NOT(INP[1]='E'); IF LENGTH(INP)>1 THEN OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E')); FOR I:=1 TO LENGTH(INP) DO BEGIN OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']); IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']); OK:=OK AND NOT(DEC AND(INP[I]='.')); IF NOT DEC THEN DEC:=(INP[I]='.'); OK:=OK AND NOT(EX AND (INP[I]='E')); IF NOT EX THEN EX:=(INP[I]='E'); IF I>1 THEN OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E')); OK:=OK AND NOT(EX AND (INP[I]='.')) END; OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']); OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9'])); IF NOT OK THEN WRITE(CHR(31),'READ ERROR, TRY AGAIN ',CHR(29)) UNTIL OK; X:=0; DEC:=FALSE; EXPO:=0; NEG:=FALSE; EX:=FALSE; J:=1; FOR I:=1 TO LENGTH(INP) DO BEGIN IF NOT DEC THEN DEC:=(INP[I]='.'); IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-'); IF NOT NEX THEN NEX:=EX AND (INP[I]='-'); IF NOT EX THEN EX:=(INP[I]='E'); IF EX AND NOT(INP[I] IN ['+','-','E']) THEN EXPO:=EXPO*10+ORD(INP[I])-ORD('0'); IF NOT EX THEN BEGIN IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN BEGIN J:=J/10; X:=X+(ORD(INP[I])-ORD('0'))*J END ELSE IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0') END END; IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO); IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X END; PROCEDURE GET_DATA; VAR CH: CHAR; BEGIN clear_screen; WRITE(' enter Q to quit or SPACE-BAR to continue'); READ(KEYBOARD,CH); IF CH='Q' THEN EXIT(HOME_LOAN); WRITELN; WRITE('Amt. of loan = '); A:=INPUT_VALUE; WRITE('annual percent interest rate = '); RATE:=INPUT_VALLUE; WRITE('Length of loan (years) = '); Y:=INPUT_VALUE; END; { procedure GET_DATA } PROCEDURE PAYMENT; FUNCTION POWER(A,B:REAL):REAL; BEGIN POWER:=EXP(B*LN(A)) END; BEGIN R:=RATE/100; R12:=R/12; P:=A*R12/(1-POWER(1+R12,-12*Y)) END; PROCEDURE DISPLAY; VAR YR,MO,NEXTYR: INTEGER; BEGBAL,PAYINT,PAYPRIN,ENDBAL,TOTINT,TOTPRIN: REAL; CH: CHAR; BEGIN clear_screen; WRITELN(' AMT OF LOAN = ',A:12:2); WRITELN(' INTEREST RATE = ',RATE:6:2,' PERCENT'); WRITELN(' LENGHT OF LOAN = ',Y:6:2,' YEARS'); WRITELN(' MONTHLY PAYMENT = ',P:8:2); R1:=RATE/1200+1; NP:=12*Y; FR:=0.5; CM:=NP+LN(1-FR*(1-EXP(-NP*LN(R1))))/LN(R1); WRITELN('THE LOAN IS ',(1-FR)*100:5:2,' PERCENT PAID OFF AT ',TRUNC(CM/12)+1, ' YEARS ',CM-12*TRUNC(CM/12):5:2,' MONTHS'); CM1:=NP+LN(0.5)/LN(R1)+1; WRITELN('CROSS-OVER PAYMENT : ',TRUNC(CM1/12)+1,' YEARS ', CM1-12*TRUNC(CM1/12):5:2,' MONTHS'); WRITELN(' BEGINNIG PAYMENT APPLIED TO ENDING'); WRITELN(' YEAR MONTH BALANCE INTEREST PRINCIPLE BALANCE'); YR:=1; MO:=1; BEGBAL:=A; TOTINT:=0; TOTPRIN:=0; GOTOXY(0,8); WHILE BEGBAL>0 DO BEGIN PAYINT:=BEGBAL*R12; PAYPRIN:=P-PAYINT; ENDBAL:=BEGBAL-PAYPRIN; IF (YR=1) OR (YR=Y) OR (YR=NEXTYR) THEN begin WRITELN(YR:6,MO:6,BEGBAL:10:2,PAYINT:8:2,PAYPRIN:8:2, ' ',ENDBAL:8:2); TOTINT:=TOTINT+PAYINT; TOTPRIN:=TOTPRIN+PAYPRIN; IF MO=12 THEN begin WRITELN; WRITELN(' TOTAL FOR YEAR ',TOTINT:8:2,TOTPRIN:8:2); WRITE('enter next year you want printed '); NEXTYR:=TRUNC(INPUT_VALUE); TOTINT:=0; TOTPRIN:=0; GOTOXY(0,8) end; end; BEGBAL:=ENDBAL; IF MO<12 THEN MO:=MO+1 ELSE begin MO:=1; YR:=YR+1 END; END; END; BEGIN { main program HOME_LOAN } REPEAT GET_DATA; PAYMENT; DISPLAY UNTIL FALSE; END. ======================================================================================== DOCUMENT :usus Folder:VOL14:kbstat.text ======================================================================================== .FUNC KBSTAT,0 ; H-89 dependant keyboard status routine .PRIVATE RETADDR ; reserve space for return address RECRDY .EQU 1 ; set up ready bit mask POP HL ; pop return address LD (RETADDR),HL ; and save it POP HL ; pop two words of trash off stack POP HL ; second word LD HL,1 ; set condition to ready (true) IN A,(237) ; read keyboard line status register (355 octal) AND RECRDY ; and compare with bit mask (looking for bit 0) JP NZ,DONE ; branch if ready LD HL,0 ; set condition to false if not ready DONE PUSH HL ; push condition on stack LD HL,(RETADDR) ; retrieve return address JP (HL) ; jump to return address .END ======================================================================================== DOCUMENT :usus Folder:VOL14:listinfo.text ======================================================================================== { $L-remout:} (**************************************************************) (* *) (* author: David Parrish *) (* Medical College of Georgia *) (* Augusta, Georgia 30912 *) (* *) (* date: April 30, 1980 *) (* *) (** This program is part of the MCG Pascal utilities library **) (* *) (* system.miscinfo parameter record definition *) (* by Ronald A. Parsons *) (* *) (* defines terminal and screen parameters from the file *) (* produced by setup for ucsd pascal version i.5. *) (* also works for II.0 - gws *) (* the following variables are associated with *) (* the setup defined parameter. *) (* the full name of these variables is minfobuffer.xxxxx *) (* e.g., *) (* minfobuffer.screenheight *) (* or *) (* with minfobuffer do ... screenheight ... end; *) (* *) (* ----- the following variables are type boolean. *) (* hasclock has clock *) (* has8510a has 8510a *) (* haslowercase has lower case *) (* hasrandom has random cursor addressing *) (* hasslow has slow terminal *) (* student student *) (* premcup prefix [move cursor up] *) (* premcright prefix [move cursor right] *) (* preereol prefix [erase to end of line] *) (* preereos prefix [erase to end of screen] *) (* premchome prefix [move cursor home] *) (* predcharacter prefix [delete character] *) (* preerscreen prefix [erase screen] *) (* preerline prefix [erase line] *) (* prekmcright prefix [key for moving right] *) (* prekmcleft prefix [key for moving left] *) (* prekmcup prefix [key for moving up] *) (* prekmcdown prefix [key for moving down] *) (* prenonprintchar prefix [non-printing character] *) (* prekeystop prefix [key for stop] *) (* prekeybreak prefix [key for break] *) (* prekeyflush prefix [key for flush] *) (* prekeyendfile prefix [key to end file] *) (* preedescapekey prefix [editor 'escape' key] *) (* prekeydline prefix [key to delete line] *) (* prekeydcharacter prefix [key to delete character] *) (* preedacceptkey prefix [editor 'accept' key] *) (* *) (* ----- the following variables are type integer. *) (* screenheight screen height *) (* screenwidth screen width *) (* *) (**************************************************************) {$P} (**************************************************************) (* *) (* ----- the follwing variables are type char. *) (* leadintoscreen lead-in to screen *) (* movecursorhome move cursor home *) (* eraseeos erase to end of screen *) (* eraseeol erase to end of line *) (* movecright move cursor right *) (* movecup move cursor up *) (* backspace backspace *) (* verticalmdelay vertical move delay *) (* eraseline erase line *) (* erasescreen erase screen *) (* keytomcup key to move cursor up *) (* keytomcdown key to move cursor down *) (* keytomcleft key to move cursor left *) (* keytomcright key to move cursor right *) (* keytoendfile key to end file *) (* keyforflush key for flush *) (* keyforbreak key for break *) (* keyforstop key for stop *) (* keytodcharacter key to delete character *) (* nonprintchar non-printing character *) (* keytodline key to delete line *) (* editorescapekey editor 'escape' key *) (* leadincharacter lead-in character from keyboard *) (* editoracceptkey editor 'accept' key *) (* *) (**************************************************************) {$P} {$S+} Program listinfo; Const vmd = 'vertical move delay '; lns = 'lead-in to screen '; lnk = 'lead-in from keyboard '; mch = 'move cursor home '; eos = 'erase to end of screen '; eol = 'erase to end of line '; mcr = 'move cursor right '; mcu = 'move cursor up '; bs = 'backspace '; el = 'erase line '; es = 'erase screen '; npc = 'non-printing character '; kmcu = 'key to move cursor up '; kmcd = 'key to move cursor down '; kmcl = 'key to move cursor left '; kmcr = 'key to move cursor right '; keof = 'key to end file '; kf = 'key for flush '; kb = 'key for break '; ks = 'key for stop '; kdc = 'key to delete a character '; kdl = 'key to delete a line '; eak = 'editor accept key '; eek = 'editor escape key '; Type amiscinfo = packed record dummy1 : packed array [0..28] of integer; dummy2,dummy3,student,hasslow,hasrandom,haslowercase, has8510a,hasclock : boolean; dummy4 : integer; erasescreen,eraseline,verticalmdelay,backspace, movecup,movecright,eraseeol,eraseeos,movecursorhome, leadintoscreen : char; preerline,preerscreen,predcharacter,premchome, preereos,preereol,premcright,premcup : boolean; screenwidth,screenheight : integer; editoracceptkey,leadincharacter,editorescapekey, keytodline,nonprintchar,keytodcharacter, keyforstop,keyforbreak,keyforflush,keytoendfile, keytomcright,keytomcleft,keytomcdown,keytomcup : char; dummy5 : integer; dummy6,dummy7,predacceptkey,prekeydcharacter, prekeydline,preedescapekey,prekeyendfile, prekeyflush,prekeybreak,prekeystop,prenonprintchar, prekmcdown,prekmcup,prekmcleft,prekmcright : boolean; dummy8 : packed array [48..95] of integer; end; string8 = string[8]; string5 = string[5]; string6 = string[6]; {$P} Var minfobuffer : amiscinforec; out : text; mode : integer; charfield : string6; tffield : string5; decfield : integer; hexfield : string8; asc : char; Procedure clearfrom(y:integer); begin gotoxy(0,y); with minfobuffer do begin if preereos then write(leadintoscreen); write(eraseeos) end end; Procedure minfoinit; { initialize } var minfofile : file of amiscinforec; begin reset (minfofile,'*system.miscinfo'); get (minfofile); minfobuffer := minfofile^ ; close (minfofile); end; { minfoinit } Procedure tf(tfval : boolean; var tfstring : string5); begin if tfval = true then tfstring := 'True ' else tfstring := 'False' end; { true-false } Procedure conv(charval : char; var astring : string6; var ahex : string8; var adec : integer); var charord : integer; procedure hexconv; VAR UD,LD : INTEGER; BEGIN ahex := ' '; UD := charord DIV 16; LD := charord MOD 16; IF UD > 9 THEN ahex[7] := CHR(UD+55) ELSE ahex[7] := CHR(UD+48); IF LD > 9 THEN ahex[8] := CHR(LD+55) ELSE ahex[8] := CHR(LD+48) END; { hexconv } {$P} begin { conv } astring := ' '; charord := ord(charval); hexconv; adec := charord; if (charord > 32) and (charord < 127) then astring[3] := charval else if charord = 127 then astring := 'DEL ' else case charord of 0: astring := 'NUL ^@'; 1: astring := 'SOH ^A'; 2: astring := 'STX ^B'; 3: astring := 'ETX ^C'; 4: astring := 'EOT ^D'; 5: astring := 'ENQ ^E'; 6: astring := 'ACK ^F'; 7: astring := 'BEL ^G'; 8: astring := 'BS ^H'; 9: astring := 'HT ^I'; 10: astring := 'LF ^J'; 11: astring := 'VT ^K'; 12: astring := 'FF ^L'; 13: astring := 'CR ^M'; 14: astring := 'SO ^N'; 15: astring := 'SI ^O'; 16: astring := 'DLE ^P'; 17: astring := 'DC1 ^Q'; 18: astring := 'DC2 ^R'; 19: astring := 'DC3 ^S'; 20: astring := 'DC4 ^T'; 21: astring := 'NAK ^U'; 22: astring := 'SYN ^V'; 23: astring := 'ETB ^W'; 24: astring := 'CAN ^X'; 25: astring := 'EM ^Y'; 26: astring := 'SUB ^Z'; 27: astring := 'ESC ^['; 28: astring := 'FS ^\'; 29: astring := 'GS ^]'; 30: astring := 'RS ^^'; 31: astring := 'US ^_'; 32: astring := 'SP ' end { case and if's } end; { conv } {$P} Procedure seg1print; begin with minfobuffer do begin conv(verticalmdelay,charfield,hexfield,decfield); writeln(out,' ',vmd ,' ',charfield,' ','-----',decfield:12,hexfield,'H'); conv(leadintoscreen,charfield,hexfield,decfield); writeln(out,' ',lns ,' ',charfield,' ','-----',decfield:12,hexfield,'H'); conv(leadincharacter,charfield,hexfield,decfield); writeln(out,' ',lnk ,' ',charfield,' ','-----',decfield:12,hexfield,'H'); tf(premchome ,tffield); conv(movecursorhome ,charfield,hexfield,decfield); writeln(out,' ',mch ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(preereos ,tffield); conv(eraseeos ,charfield,hexfield,decfield); writeln(out,' ',eos ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(preereol ,tffield); conv(eraseeol ,charfield,hexfield,decfield); writeln(out,' ',eol ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); end { with } end; { seg1print } Procedure seg2print; begin with minfobuffer do begin tf(premcright ,tffield); conv(movecright ,charfield,hexfield,decfield); writeln(out,' ',mcr ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(premcup ,tffield); conv(movecup ,charfield,hexfield,decfield); writeln(out,' ',mcu ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(predcharacter ,tffield); conv(backspace ,charfield,hexfield,decfield); writeln(out,' ',bs ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(preerline ,tffield); conv(eraseline ,charfield,hexfield,decfield); writeln(out,' ',el ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(preerscreen ,tffield); conv(erasescreen ,charfield,hexfield,decfield); writeln(out,' ',es ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(prenonprintchar ,tffield); conv(nonprintchar ,charfield,hexfield,decfield); writeln(out,' ',npc ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); end { with } end; { seg2print } {$P} Procedure seg3print; begin with minfobuffer do begin tf(prekmcup ,tffield); conv(keytomcup ,charfield,hexfield,decfield); writeln(out,' ',kmcu,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(prekmcdown ,tffield); conv(keytomcdown ,charfield,hexfield,decfield); writeln(out,' ',kmcd,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(prekmcleft ,tffield); conv(keytomcleft ,charfield,hexfield,decfield); writeln(out,' ',kmcl,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(prekmcright ,tffield); conv(keytomcright ,charfield,hexfield,decfield); writeln(out,' ',kmcr,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(prekeyendfile ,tffield); conv(keytoendfile ,charfield,hexfield,decfield); writeln(out,' ',keof,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(prekeyflush ,tffield); conv(keyforflush ,charfield,hexfield,decfield); writeln(out,' ',kf ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); end { with } end; { seg3print } Procedure seg4print; begin with minfobuffer do begin tf(prekeybreak ,tffield); conv(keyforbreak ,charfield,hexfield,decfield); writeln(out,' ',kb ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(prekeystop ,tffield); conv(keyforstop ,charfield,hexfield,decfield); writeln(out,' ',ks ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(prekeydcharacter,tffield); conv(keytodcharacter,charfield,hexfield,decfield); writeln(out,' ',kdc ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(prekeydline ,tffield); conv(keytodline ,charfield,hexfield,decfield); writeln(out,' ',kdl ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(predacceptkey ,tffield); conv(editoracceptkey,charfield,hexfield,decfield); writeln(out,' ',eak ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); tf(preedescapekey ,tffield); conv(editorescapekey,charfield,hexfield,decfield); writeln(out,' ',eek ,' ',charfield,' ',tffield,decfield:12,hexfield,'H'); end { with } end; { seg4print } {$P} Procedure seg5print; begin with minfobuffer do begin writeln(out); tf(hasclock,tffield); writeln(out,' has clock ',tffield); tf(has8510a,tffield); writeln(out,' has 8510A ',tffield); tf(haslowercase,tffield); writeln(out,' has lower case ',tffield); tf(hasrandom,tffield); writeln(out,' has random cursor ',tffield); tf(hasslow,tffield); writeln(out,' has slow terminal ',tffield); tf(student,tffield); writeln(out,' student setup ',tffield); writeln(out); writeln(out,' The screen size is ',screenheight:3,' high by ', screenwidth:3,' wide.') end { with } end; { seg5print } Procedure printbanner(pass : integer); begin if (mode =1) and (pass > 1) then begin gotoxy(0,23); write('Press any key to continue. '); read(asc) end; if mode = 1 then clearfrom(0); if (mode = 1) or (pass = 1) then begin writeln(out); write(out,' Discription Value Prefixed? '); writeln(out,'Dec value Hex value') end end; { print banner } {$P} Procedure setoutput; var itsdone : boolean; filname : string; begin repeat case mode of 1: filname := 'console:'; 2: filname := 'remout:'; 3: begin gotoxy(0,7); write('File name (include .text) > '); readln(filname) end end; { case } {$I-} rewrite (out,filname); itsdone := (ioresult = 0) {$I+} until itsdone end; { setoutput } Begin { MAIN LINE } minfoinit; repeat clearfrom(0); gotoxy(0,3); writeln('List SYSTEM.MISCINFO'); repeat gotoxy(0,5); write('Miscinfo listing to [1] screen, [2] printer, '); write('[3] file [4] quit > [ ]'); gotoxy(66,5); read(asc); mode := ord(asc)-48 until (mode > 0) and (mode < 5); if mode < 4 then begin setoutput; printbanner(1); seg1print; seg2print; seg3print; printbanner(2); seg4print; seg5print; close(out, lock); if (mode =1) then begin gotoxy(0,23); write('Press any key to continue. '); read(asc) end end { if mode < 4 } until mode = 4 End. { MAIN LINE } ======================================================================================== DOCUMENT :usus Folder:VOL14:look.up.table ======================================================================================== ACI $ ADC a$ ADC A ADC aA ADC B ADC aB ADC C ADC aC ADC D ADC aD ADC E ADC aE ADC H ADC aH ADC L ADC aL ADC M ADC a(HL) ADD A ADD aA ADD B ADD aB ADD C ADD aC ADD D ADD aD ADD E ADD aE ADD H ADD aH ADD L ADD aL ADD M ADD a(HL) ADI $ ADD a$ ANA A AND aA ANA B AND aB ANA C AND aC ANA D AND aD ANA E AND aE ANA H AND aH ANA L AND aL ANA M AND a(HL) ANI $ AND a$ CALL$ CALLa$ CC $ CALLaC,$ CM $ CALLaM,$ CMA # CPL a# CMC # CCF a# CMP A CP aA CMP B CP aB CMP C CP aC CMP D CP aD CMP E CP aE CMP H CP aH CMP L CP aL CMP M CP a(HL) CNC $ CALLaNC,$ CNZ $ CALLaNZ,$ CP $ CALLaP,$ CPE $ CALLaPE,$ CPI $ CP a$ CPO $ CALLaPO,$ CZ $ CALLaZ,$ DAA # DAA a# DAD B ADD aHL,BC DAD D ADD aHL,DE DAD H ADD aHL,HL DAD SP ADD aHL,SP DCR A DEC aA DCR B DEC aB DCR C DEC aC DCR D DEC aD DCR E DEC aE DCR H DEC aH DCR L DEC aL DCR M DEC a(HL) DCX B DEC aBC DCX D DEC aDE DCX H DEC aHL DCX SP DEC aSP DI # DI a# EI # EI a# HLT # HALTa# IN $ IN aA,$ INR A INC aA INR B INC aB INR C INC aC INR D INC aD INR E INC aE INR H INC aH INR L INC aL INR M INC a(HL) INX B INC aBC INX D INC aDE INX H INC aHL INX SP INC aSP JC $ JP aC,$ JM $ JP aM,$ JMP $ JP a$ JNC $ JP aNC,$ JNZ $ JP aNZ,$ JP $ JP aP,$ JPE $ JP aPE,$ JPO $ JP aPO,$ JZ $ JP aZ,$ LDA $ LD aA,($) LDAXB LD aA,(BC) LDAXD LD aA,(DE) LHLD$ LD aHL,($) LXI B,$ LD aBC,$ LXI D,$ LD aDE,$ LXI H,$ LD aHL,$ LXI SP,$ LD aSP,$ MOV A,A LD aA,A MOV A,B LD aA,B MOV A,C LD aA,C MOV A,D LD aA,D MOV A,E LD aA,E MOV A,H LD aA,H MOV A,L LD aA,L MOV A,M LD aA,(HL) MOV B,A LD aB,A MOV B,B LD aB,B MOV B,C LD aB,C MOV B,D LD aB,D MOV B,E LD aB,E MOV B,H LD aB,H MOV B,L LD aB,L MOV B,M LD aB,(HL) MOV C,A LD aC,A MOV C,B LD aC,B MOV C,C LD aC,C MOV C,D LD aC,D MOV C,E LD aC,E MOV C,H LD aC,H MOV C,L LD aC,L MOV C,M LD aC,(HL) MOV D,A LD aD,A MOV D,B LD aD,B MOV D,C LD aD,C MOV D,D LD aD,D MOV D,E LD aD,E MOV D,H LD aD,H MOV D,L LD aD,L MOV D,M LD aD,(HL) MOV E,A LD aE,A MOV E,B LD aE,B MOV E,C LD aE,C MOV E,D LD aE,D MOV E,E LD aE,E MOV E,H LD aE,H MOV E,L LD aE,L MOV E,M LD aE,(HL) MOV H,A LD aH,A MOV H,B LD aH,B MOV H,C LD aH,C MOV H,D LD aH,D MOV H,E LD aH,E MOV H,H LD aH,H MOV H,L LD aH,L MOV H,M LD aH,(HL) MOV L,A LD aL,A MOV L,B LD aL,B MOV L,C LD aL,C MOV L,D LD aL,D MOV L,E LD aL,E MOV L,H LD aL,H MOV L,L LD aL,L MOV L,M LD aL,(HL) MOV M,A LD a(HL),A MOV M,B LD a(HL),B MOV M,C LD a(HL),C MOV M,D LD a(HL),D MOV M,E LD a(HL),E MOV M,H LD a(HL),H MOV M,L LD a(HL),L MVI A,$ LD aA,$ MVI B,$ LD aB,$ MVI C,$ LD aC,$ MVI D,$ LD aD,$ MVI E,$ LD aE,$ MVI H,$ LD aH,$ MVI L,$ LD aL,$ MVI M,$ LD a(HL),$ NOP # NOP a# ORA A OR aA ORA B OR aB ORA C OR aC ORA D OR aD ORA E OR aE ORA H OR aH ORA L OR aL ORA M OR a(HL) ORI $ OR a$ OUT $ OUT a$,A PCHL# JP a(HL) POP B POP aBC POP D POP aDE POP H POP aHL POP PSW POP aPSW PUSHB PUSHaBC PUSHD PUSHaDE PUSHH PUSHaHL PUSHPSW PUSHaPSW RAL # RLA a# RAR # RRA a# RC # RET aC RET # RET a# RLC # RLCAa# RM # RET aM RNC # RET aNC RNZ # RET aNZ RP # RET aP RPE # RET aPE RPO # RET aPO RRC # RRCAa# RST $ RST a$ RZ # RET aZ SBB A SBC aA SBB B SBC aB SBB C SBC aC SBB D SBC aD SBB E SBC aE SBB H SBC aH SBB L SBC aL SBB M SBC a(HL) SBI $ SBC a$ SHLD$ LD a($),HL SPHL# LD aSP,HL STA $ LD a($),A STAXB LD a(BC),A STAXD LD a(DE),A STC # SCF a# SUB A SUB aA SUB B SUB aB SUB C SUB aC SUB D SUB aD SUB E SUB aE SUB H SUB aH SUB L SUB aL SUB M SUB a(HL) SUI $ SUB a$ XCHG# EX aDE,HL XRA A XOR aA XRA B XOR aB XRA C XOR aC XRA D XOR aD XRA E XOR aE XRA H XOR aH XRA L XOR aL XRA M XOR a(HL) XRI $ XOR a$ XTHL# EX a(SP),HL O^™ ™  ======================================================================================== DOCUMENT :usus Folder:VOL14:refer.inc.text ======================================================================================== (* included from REFERENCE *) procedure printtree(root: ptrtoentry); var thiscell: listofusages; count: natural; procedure conditionalwrite(n: natural; substitute: sixchars); begin { conditionalwrite } if n = 0 then write(outfile, substitute) else write(outfile, n:6); end; { conditionalwrite } procedure namewrite(p: ptrtoentry); var len: integer; s: setrange; begin { namewrite } with p^ do begin len := length(procname); for s := 0 to len-1 do if s in caseset then write(outfile, chr(ord(procname[s+1])-uclcdisplacement)) else write(outfile, procname[s+1]); end; if len < sigcharlimit then write(outfile, ' ':sigcharlimit-len); end; { namewrite } begin { printtree } if root <> nil then with root^ do begin printtree(before); writeln(outfile); write(outfile, linenumber: 5); conditionalwrite(startofbody, ' '); case status of fwdhalf,notproc: write(outfile, ' eh?'); formal: write(outfile, ' fml'); outside: write(outfile, ' ext'); shortform: write(outfile, ' '); allfwd: write(outfile, forwardblock:6); end; write(outfile, ' '); namewrite(root); write(outfile, ' :'); thiscell := calls; count := 0; while thiscell <> nil do begin if ((count mod namesperline) = 0) and (count <> 0) then begin writeln(outfile); write(outfile, ' ':sigcharlimit+19, ' :'); end; write(outfile, ' '); namewrite(thiscell^.what); thiscell := thiscell^.next; count := count + 1; end; writeln(outfile); printtree(after); end; end; { printtree } procedure nexttoken; procedure ignorecomment(tail: string); procedure getdirective; var i: integer; found: boolean; inclfn: string[30]; begin { getdirective } {$R- disable range checks } nextch; if ch = 'I' then { include } begin nextch; if ch = ' ' then begin nextch; i := 0; while ch <> '}' do begin i := i + 1; inclfn[i] := ch; nextch; end; inclfn[0] := chr(i); { set string length } {$I- disable IO checks } including := including + 1; with fcb[including] do begin close(infile); reset(infile, inclfn); found := ioresult = 0; if not found then { found the file } begin inclfn := concat(inclfn, '.text'); reset(infile, inclfn); found := ioresult = 0; end; {$I+} if found then begin writeln('---opening: ', inclfn); inlfn := inclfn; chno := 0; line := ''; bpos := bufsiz; endfile := false; blknr := 2; end else begin writeln('---cannot find: ', inclfn); close(infile); including := including - 1; with fcb[including] do reset(infile, inlfn); end; end; end; end; {$R+} end; { getdirective } begin { ignorecomment } nextch; if ch = '$' then getdirective; repeat while (ch <> tail[1]) do nextch; if ch = '*' then nextch; until (ch = tail[length(tail)]); nextch; end; { ignorecomment } procedure ignorenumbers; begin { ignorenumbers } while ch in digits do nextch; with fcb[including] do if ch = '.' then begin if (line[chno+1] in digits) then begin nextch; while ch in digits do nextch; end; end; if (ch = 'E') or (ch = 'e') then begin nextch; if (ch = '+') or (ch = '-') then nextch; while ch in digits do nextch; end; end; { ignorenumbers } procedure readident; var j: integer; begin { readident } {$R- disable range check to store string length } token := namesy; symbol := spaces; symbolcase := []; j := 0; while (j < sigcharlimit) and (ch in alphanums) do begin j := j + 1; if ch in uppercase then begin symbol[j] := chr(ord(ch)+uclcdisplacement); symbolcase := symbolcase + [j-1]; end else symbol[j] := ch; nextch; end; symbol[0] := chr(j); {$R+} while ch in alphanums do nextch; end; { readident } begin { nexttoken } token := othersy; repeat if ch in usefulchars then begin case ch of ')': begin nextch; token := rparensy; end; '(': begin nextch; if ch = '*' then ignorecomment('*)') else token := lparensy; end; '{': ignorecomment('}'); '''': begin nextch; while ch <> '''' do nextch; nextch; end; '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': ignorenumbers; ':': begin nextch; if ch = '=' then begin token := assignsy; nextch; end else token := colonsy; end; '.': begin nextch; if ch <> '.' then token := periodsy else begin token := subrangesy; nextch; end; end; ';': begin nextch; token := semicolsy; end; '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': readident; end end else nextch until token <> othersy; end; { nexttoken } procedure processunit(programid: boolean); var at: ptrtoentry; function nameisinscope: boolean; var llevel: ptrtostackcell; discovered: boolean; where: ptrtoentry; begin { nameisinscope } llevel := stack; discovered := false; savesymbol := symbol; while (llevel <> nil) and not discovered do begin findnode(discovered, where, llevel^.scopetree); if not discovered then llevel := llevel^.substack; end; if discovered then nameisinscope := (where^.status <> notproc) else nameisinscope := false; end; { nameisinscope } procedure processblock; var address: ptrtoentry; procedure crossreferencer; var newcell: listofusages; ptr: listofusages; home: ptrtoentry; slevel: ptrtostackcell; found: boolean; procedure findcell; var nextptr: listofusages; begin { findcell } found := false; nextptr := stack^.current^.calls; if nextptr <> nil then repeat ptr := nextptr; found := (ptr^.what^.procname = savesymbol); nextptr := ptr^.next; until found or (nextptr = nil) else ptr := nil; end; { findcell } begin { crossreferencer } slevel := stack; found := false; while (slevel <> nil) and not found do begin findnode(found, home, slevel^.scopetree); if not found then slevel := slevel^.substack end; if found then begin if home^.status <> notproc then begin findcell; if not found then begin new(newcell); if ptr <> nil then ptr^.next := newcell else stack^.current^.calls := newcell; newcell^.what := home; newcell^.next := nil; end; end; end; end; { crossreferencer } procedure scanforname; begin { scanforname } nexttoken; while token <> namesy do nexttoken; end; { scanforname } begin { processblock } while (symbol <> sbegin) do begin while (symbol <> sbegin) and (symbol <> sprocedure) and (symbol <> sfunction) and (symbol <> ssegment) do begin scanforname; if nameisinscope then begin address := makeentry(false, false); end; end; if symbol <> sbegin then begin if symbol = ssegment then nexttoken; processunit(false); scanforname; end; end; depth := 1; stack^.current^.startofbody := lineno; nexttoken; while depth <> 0 do begin if token <> namesy then nexttoken else if (symbol = sbegin) or (symbol = scase) then begin depth := depth + 1; nexttoken end else if (symbol = send) then begin depth := depth - 1; nexttoken; end else begin savesymbol := symbol; nexttoken; if token <> assignsy then crossreferencer else nexttoken end; end; end; { processblock } procedure scanparameters; var which: ptrtoentry; procedure scantillclose; begin { scantillclose } nexttoken; while token <> rparensy do begin if token = lparensy then scantillclose; nexttoken; end; end; { scantillclose } begin { scanparameters } nexttoken; while token <> rparensy do begin if (token = namesy) then begin if (symbol = sprocedure) or (symbol = sfunction) then begin nexttoken; if token = namesy then begin which := makeentry(false, true); which^.status := formal; pop; nexttoken; if token = lparensy then scantillclose; end else begin error(2); nexttoken; end; end else begin if nameisinscope then which := makeentry(false, false); nexttoken; end; end else nexttoken; end; nexttoken; end; { scanparameters } begin { processunit } printflag := true; adjustment := first; nexttoken; if token <> namesy then error(2) else begin at := makeentry(programid, true); while not (token in [lparensy,semicolsy,colonsy]) do nexttoken; if token = lparensy then scanparameters; while token <> semicolsy do nexttoken; printline; printflag := false; writeln(outfile); nexttoken; if token <> namesy then error(3) else begin if (symbol <> slabel) and (symbol <> sconst) and (symbol <> stype) and (symbol <> sprocedure) and (symbol <> sfunction) and (symbol <> svar) and (symbol <> sbegin) and (symbol <> suses) and (symbol <> ssegment) then begin if symbol = sforward then at^.status := fwdhalf else at^.status := outside; pop end else begin processblock; pop end end end; end; { processunit } procedure printheading; begin { printheading } writeln(outfile, 'procedural cross-refrencer - version s-02.01'); writeln(outfile, '============================================'); writeln(outfile); end; { printheading } ======================================================================================== DOCUMENT :usus Folder:VOL14:reference.text ======================================================================================== { program referencer Copyright (C) 1979 A.H. Sale Southhamptom, England See Pascal News #17 Permission is granted to copy this program, store it in a computer system, and distribute it provided that this header comment is retained in all copies } {$S+ allow compiler to swap } program refrencer; const sigcharlimit = 10; setlimit = 09; uclcdisplacement = 32; linelimit = 200; linewidth = 80; indentation = 4; bufsiz = 1024; cr = 13; { carriage return } sprogram = 'program'; sprocedure = 'procedure'; sfunction = 'function'; slabel = 'label'; sconst = 'const'; stype = 'type'; svar = 'var'; sbegin = 'begin'; scase = 'case'; send = 'end'; sforward = 'forward'; suses = 'uses'; ssegment = 'segment'; spaces = ''; type natural = 0..maxint; positive = 1..maxint; sixchars = packed array[1..6] of char; sigcharrange = 1..sigcharlimit; setrange = 0..setlimit; pseudostring = string[sigcharlimit]; stringcases = set of setrange; linesize = 1..linelimit; lineindex = 0..linelimit; setofchar = set of char; prockind = (fwdhalf,allfwd,shortform,formal,outside,notproc); ptrtoentry = ^entry; listofusages = ^usagecell; ptrtostackcell = ^stackcell; tokentype = (othersy,namesy,lparensy,rparensy,colonsy, semicolsy,periodsy,assignsy,subrangesy); entry = record procname: pseudostring; caseset: stringcases; linenumber: natural; startofbody: natural; left,right: ptrtoentry; before,after: ptrtoentry; calls: listofusages; localtree: ptrtoentry; case status: prockind of fwdhalf,shortform,formal,outside,notproc: (); allfwd: (forwardblock: natural); end; usagecell = record what: ptrtoentry; next: listofusages end; stackcell = record current: ptrtoentry; scopetree: ptrtoentry; substack: ptrtostackcell; end; longstring = STRING[255]; var lineno: natural; depth: natural; level: -1..maxint; pretty: natural; onscreen: boolean; adjustment: (first,other); movement: integer; printflag: boolean; errorflag: boolean; ch: char; token: tokentype; symbol: pseudostring; symbolcase: stringcase; savesymbol: pseudostring; superroot: ptrtoentry; stack: ptrtostackcell; alphabet: set of char; alphanums: setofchar; uppercase: setofchar; digits: setofchar; usefulchars: setofchar; namesperline: positive; outlfn: string[30]; outfile: text; { include file stuff } including: integer; { include file nest level } { file control block } infile: file; { input file } fcb: array[0..1] of record chno: lineindex; { current char index } inlfn: string[30]; { input file name } line: longstring; { current text line } bpos: integer; { buffer position } endfile: boolean; { true when end of file } buf: packed array[0..bufsiz] of char; blknr: integer; end; procedure getstring(VAR S: longstring); const dle = 16; var bcnt, chg: integer; begin { getstring } {$R- disable string range checks } with fcb[including] do repeat if bpos >= bufsiz then { time for next buffer } begin bcnt := blockread(infile, buf[0], 2, blknr); bpos := 0; blknr := blknr + bcnt; if bcnt < 2 then { eof } begin endfile := true; EXIT(getstring) end; end; chg := scan(bufsiz-bpos, =chr(CR), buf[bpos]); if (bpos + chg) < bufsiz then { found a carriage return } begin moveleft(buf[bpos], S[1], chg); { copy string except CR } S[0] := chr(chg); bpos := bpos + chg + 1; end else begin chg := scan(1024-bpos, =chr(0), buf[bpos]); { look for null } if (bpos + chg) < bufsiz then begin moveleft(buf[bpos], S[1], chg-1); S[0] := chr(chg); bpos := 1024; end; end; until chg > 0; if s[1] = chr(dle) then begin s[1] := ' '; s[2] := ' ' end; end; { getstring } {$R+} procedure printline; var i: linesize; begin { printline } write(outfile, lineno:5, ' '); i := 1; with fcb[including] do if adjustment = first then begin while (i < length(line)) and (line[i] = ' ') do i := succ(i); movement := (level * indentation) - (i - 1); adjustment := other; if level > 0 then write(outfile, ' ':(level*indentation)); end else begin if movement > 0 then write(outfile, ' ': movement) else if movement < 0 then while (i < length(line)) and (line[i] = ' ') and (i <= -movement) do i := succ(i); end; with fcb[including] do while i < length(line) do begin write(outfile, line[i]); i := succ(i); end; writeln(outfile); end; { printline } procedure error(e: positive ); begin { error } errorflag := true; write(outfile, 'FATAL ERROR - '); case e of 1: write(outfile, 'no "program" word'); 2: write(outfile, 'no identifier after prog/proc/func'); 3: write(outfile, 'token after heading unexpected'); 4: write(outfile, 'lost "." check begin/case/ends'); 5: write(outfile, 'same name, but not forward declared'); 6: write(outfile, 'cannot nest include files'); 7: write(outfile, 'file not found'); end; writeln(outfile, ' - at following line'); adjustment := first; printline; writeln(outfile, 'Last symbol: "', symbol, '"'); end; { error } procedure nextch; begin { nextch } with fcb[including] do if (including > 0) and endfile then begin close(infile); including := including -1; with fcb[including] do begin reset(infile, inlfn); writeln('--- re-opening ', inlfn) end; end; with fcb[including] do if chno = length(line) then begin if printflag then printline; getstring(line); line := concat(line, ' '); lineno := lineno + 1; chno := 1; ch := line[1]; if not onscreen then write('.'); end else begin chno := succ(chno); ch := line[chno]; end; end; { nextch } procedure push(newscope: ptrtoentry); var newlevel: ptrtostackcell; begin { push } new(newlevel); newlevel^.current := newscope; newlevel^.scopetree := nil; newlevel^.substack := stack; stack := newlevel; level := level + 1; end; { push } procedure pop; var oldcell: ptrtostackcell; begin { pop } stack^.current^.localtree := stack^.scopetree; oldcell := stack; stack := oldcell^.substack; level := level - 1; end; { pop } procedure findnode(var match: boolean; var follow: ptrtoentry; thisnode: ptrtoentry); begin { findnode } match := false; while (thisnode <> nil) and not match do begin follow := thisnode; if savesymbol < thisnode^.procname then thisnode := thisnode^.left else if savesymbol > thisnode^.procname then thisnode := thisnode^.right else match := true; end; end; function makeentry(mainprog: boolean; proc: boolean): ptrtoentry; var newentry, node: ptrtoentry; located: boolean; procedure puttosupertree(newnode: ptrtoentry); var place: ptrtoentry; procedure findleaf; var subroot: ptrtoentry; begin { findleaf } subroot := superroot; while subroot <> nil do begin place := subroot; if savesymbol < subroot^.procname then subroot := subroot^.before else subroot := subroot^.after end; end; { findleaf } begin { puttosupertree } if superroot = nil then superroot := newnode else begin findleaf; with place^ do begin if savesymbol < procname then before := newnode else after := newnode end end end; { puttosupertree } begin { makeentry } located := false; savesymbol := symbol; if mainprog then new(newentry) else if stack^.scopetree = nil then begin new(newentry); stack^.scopetree := newentry; end else begin findnode(located, node, stack^.scopetree); if not located then begin new(newentry); with node^ do if symbol < procname then left := newentry else right := newentry end end; if not located then begin with newentry^ do begin procname := symbol; caseset := symbolcase; linenumber := lineno; startofbody := 0; if proc then status := shortform else status := notproc; left := nil; right := nil; before := nil; after := nil; calls := nil; localtree := nil; end; makeentry := newentry; if proc then begin puttosupertree(newentry); push(newentry); end; end else begin makeentry := node; push(node); if node^.status = fwdhalf then begin stack^.scopetree := node^.localtree; node^.status := allfwd; node^.forwardblock := lineno; end else error(5) end end; { makeentry } (*$I refer.inc.text*) begin { refrencer } including := 0; with fcb[including] do begin chno := 0; bpos := bufsiz; blknr := 2; line := ''; endfile := false; write('Input file name: '); readln(inlfn); if inlfn = '' then exit(refrencer); {$I- disable system IO checks } reset(infile, inlfn); if ioresult <> 0 then begin inlfn := concat(inlfn, '.text'); reset(infile, inlfn); if ioresult <> 0 then begin error(7); exit(refrencer); end; end; {$I+} onscreen := (inlfn = '#1:') or (inlfn = 'CONSOLE:') or (inlfn = 'console:'); end; write('Output file name: '); readln(outlfn); if outlfn = '' then outlfn := 'CONSOLE:'; rewrite(outfile, outlfn); superroot := nil; new(stack); with stack^ do begin current := nil; scopetree := nil; substack := nil; end; printflag := false; uppercase := ['A'..'Z']; alphabet := uppercase + ['a'..'z']; digits := ['0'..'9']; alphanums := alphabet + digits + ['_']; usefulchars := alphabet + digits + ['(', ')', '{', '.', ':', ';', '''']; namesperline := (linewidth - (sigcharlimit + 21)) div (sigcharlimit + 1); lineno := 0; level := -1; errorflag := false; page(outfile); printheading; writeln(outfile, ' line program/procedure/function heading'); for pretty := 1 to 43 do write(outfile, '-'); writeln(outfile); writeln(outfile); nexttoken; if token <> namesy then error(1) else if symbol <> sprogram then error(1) else begin processunit(true); if not errorflag then begin if (token <> periodsy) and (token <> subrangesy) then error(4) else begin adjustment := first; printline; end end end; if not errorflag then begin page(outfile); printheading; writeln(outfile, ' head body notes ', ' ':sigcharlimit, ' call made to'); for pretty := 1 to (sigcharlimit+37) do write(outfile, '-'); writeln(outfile); printtree(superroot); writeln(outfile); end; close(outfile, lock); end. { refrencer } ======================================================================================== DOCUMENT :usus Folder:VOL14:reform.text ======================================================================================== (************************************************************************) (* *) (* This program is used to reformat the conversion table *) (* text file to a data file that can be read swiftly and *) (* in the proper format for the 8080 to Z-80 opcode *) (* conversion program. *) (* *) (* Author: David Parrish *) (* Medical College of Georgia *) (* Augusta, Georgia 30912 *) (* *) (* Date: June 14, 1980 *) (* *) (******* This program is part of the MCG Pascal utilities library *******) (* *) (* *) (************************************************************************) Program reform; type rectype = record a8opc : string[4]; a8opr : string[8]; aZopc : string[4]; aZopr : string[8] end; var infile : text; outfile : file of rectype; outrec : rectype; orgstr, temp : string; i : integer; begin reset(infile,'table.text'); rewrite(outfile,'look.up.table'); for i := 1 to 237 do (* 237 opcodes in the table *) begin readln(infile,orgstr); outrec.a8opc := copy(orgstr,1,4); outrec.a8opr := copy(orgstr,9,8); outrec.aZopc := copy(orgstr,17,4); temp := copy(orgstr,25,(length(orgstr)-24)); temp := concat(temp,' '); outrec.aZopr := copy(temp,1,8); outfile^ := outrec; put(outfile); writeln(orgstr) end; close(infile); close(outfile, lock) end. ======================================================================================== DOCUMENT :usus Folder:VOL14:roman.text ======================================================================================== program roman; { Enter year and get the roman numeral equivalent back. CEF Exobiology Labs. Univ. HI Feb 1982 } { For an interesting historical discussion of Roman Numerals } { as well as a rational for the algorithm behind this program } { see "The World of Mathematics", Volume One, edited by } { James R. Newman, published by Simon and Schuster, New York } type digit = 0..9; var n : integer; procedure write_digit( d: digit; units, fives, tens : char); { write digit d in roman numerals using the characters units, fives, and tens} var i : integer; begin if d = 9 then write(units, tens) else if d = 4 then write(units, fives) else begin if d >= 5 then write(fives); for i := 1 to d mod 5 do write(units); end; end; { write digit } procedure write_date( date : integer ); {write date in roman numerals - dates not in the range 1..3999 are printed as *** } { NOTE-won't happen now due to changes by} {Gene Gingerich--see main program write statements } begin if ( date <= 0 ) or ( date >= 4000 ) then write('***') else begin write_digit(date div 1000,'M','*','*'); write_digit((date div 100) mod 10,'C','D','M'); write_digit((date div 10) mod 10,'X','L','C'); write_digit(date mod 10,'I','V','X'); end; end; {write_date} procedure do_it; { do_it repeatedly asks for input and produces } { output until the user terminates the program } begin repeat writeln;writeln;writeln; writeln('Enter a year between 1 and 3999 Any other'); write('year will cause the the program to terminate --> '); (*$I-*) repeat readln(n); until ioresult = 0; (*$I+*) if ((n > 0) and (n < 4000)) then begin writeln; write('In Rome it would be --> '); write_date(n); end; until((n <= 0) or (n > 3999)); end; {do_it} begin {main} writeln;writeln; writeln('This program is generated from an example in the book:'); writeln(' '); writeln('"The UCSD Pascal Handbook" by Randy Clark and Stephen Koehler'); writeln('from Softech Microsystems, San Diego, Calif. The book is'); writeln('directed toward the Implementation of UCSD Pascal provided'); writeln('by Softech Microsystems and is an excellent reference for'); writeln('users of that system. The book is published by Prentice-'); writeln('Hall. This display has been added to the program by '); writeln('Gene Gingerich of GINGER BRED SOFTWARE, a happy user of'); writeln('the Softech UCSD Pascal System, Version II.0. Some minor'); writeln('changes have been made to warn the user about limits,'); writeln('valid year entries and how to terminate the program during'); writeln('execution. Comments have also been added by Professor'); writeln('C. E. Folsome, of the Univ. Hawaii, who generated the program'); writeln('for me. No criticsm of this fine book is meant'); do_it; { go do it until termination } end. ======================================================================================== DOCUMENT :usus Folder:VOL14:scanner.text ======================================================================================== (*$L-printer:*) program scanner; {Scanner is by Jon Bondy and slightly modified by George Schreyer. Scanner read a whole disk and looks for a list of strings contained in a data file called SCAN.DATA.TEXT. Make this file with the editor and put all of the strings you wish to find in it on separate lines. The original was sensitive to null lines, I fixed it. Also the original always started at block 10 (it assumes that you keep duplicate directories). I changed it so that it will know where to start (block 6 or 10). This is a good program. It is ESPECIALLY useful when you have deleted a copy of an important file and you want to find where it is still on the disk. gws} CONST { disk directory stuff } MAXDIR = 77; (*MAX NUMBER OF ENTRIES IN A DIRECTORY*) MAXUNIT = 12; (*MAX NUMBER OF UNITS *) VIDLENG = 7; (*NUMBER OF CHARS IN A VOLUME ID*) TIDLENG = 15; (*NUMBER OF CHARS IN TITLE ID*) FBLKSIZE = 512; (*STANDARD DISK BLOCK LENGTH*) DIRBLK = 2; (*DISK ADDR OF DIRECTORY*) max_entries = 10; read_unit = 5; { unit where disk is read } buffer_length = 16383; { starts at zero } TYPE { disk directory stuff from UCSD GLOBALS.TEXT } DATEREC = PACKED RECORD MONTH: 0..12; (*0 IMPLIES DATE NOT MEANINGFUL*) DAY: 0..31; (*DAY OF MONTH*) YEAR: 0..100 (*100 IS TEMP DISK FLAG*) END (*DATEREC*) ; UNITNUM = 0..MAXUNIT; VID = STRING[VIDLENG]; { volume name (I.D.) } DIRRANGE = 0..MAXDIR; { number of entries (files) in a directory } TID = STRING[TIDLENG]; { title (file name) I.D. } FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE, INFOFILE,DATAFILE,GRAFFILE,FOTOFILE,SECUREDIR); DIRENTRY = RECORD DFIRSTBLK: INTEGER; (*FIRST PHYSICAL DISK ADDR*) DLASTBLK: INTEGER; (*POINTS AT BLOCK FOLLOWING*) CASE DFKIND: FILEKIND OF SECUREDIR, UNTYPEDFILE: (*ONLY IN DIR[0]...VOLUME INFO*) (DVID: VID; (*NAME OF DISK VOLUME*) DEOVBLK: INTEGER; (*LASTBLK OF VOLUME*) DNUMFILES: DIRRANGE; (*NUM FILES IN DIR*) DLOADTIME: INTEGER; (*TIME OF LAST ACCESS*) DLASTBOOT: DATEREC); (*MOST RECENT DATE SETTING*) XDSKFILE,CODEFILE,TEXTFILE,INFOFILE, DATAFILE,GRAFFILE,FOTOFILE: (DTID: TID; (*TITLE OF FILE*) DLASTBYTE: 1..FBLKSIZE; (*NUM BYTES IN LAST BLOCK*) DACCESS: DATEREC) (*LAST MODIFICATION DATE*) END (*DIRENTRY*) ; var DIRECTORY : ARRAY [DIRRANGE] OF DIRENTRY; infile : text; { file from which search strings are read } dict : array[1..max_entries] of string; { list of search strings } num_entries : integer; { number of search strings } buffer : packed array [0..buffer_length] of char; i, j, k, l : integer; start_char, start_block, num_blocks, chars_read, len : integer; found, done : boolean; procedure tell_found; var i, block : integer; found : boolean; begin block := start_block + (start_char div 512); write('Block: ', block:3, ' '); found := false; for i := 1 to directory[0].dnumfiles do with directory[i] do if (block >= dfirstblk) and (block < dlastblk) then begin write('File: ', dtid, ' ':(16-length(dtid))); found := true; end; if not found then write('Not found in a file. '); writeln(' v'); { display context of text found } for i := -35 to 35 do if (start_char+i-2 >= 0) and (start_char+i-1 < chars_read) then if (buffer[start_char+i-2] in [' '..'~']) then write(buffer[start_char+i-2]) else write('*') else write('*'); writeln; writeln; end; { tell_found } begin writeln('Disk Scanner Program. Jon Bondy. Jan 1982.'); {$I-} reset(infile,'scan.data.text'); {$I+} if (ioresult <> 0) then begin writeln('Unable to locate SCAN.DATA.TEXT'); exit(scanner); end; num_entries := 1; while not eof(infile) and (num_entries <= max_entries) do begin readln(infile,dict[num_entries]); if dict[num_entries] <> '' then begin writeln(num_entries:2, ': "', dict[num_entries], '"'); num_entries := num_entries + 1; {we don't want to search for null strings. This blew up the original. gws } end; end; num_entries := num_entries - 1; write('Enter when disk is in Unit 5.'); readln; unitread(read_unit,directory,sizeof(directory),dirblk,0); with directory[0] do writeln('Volume ', dvid, ': scanning ', deovblk - directory[0].dlastblk, ' blocks.'); start_block := directory[0].dlastblk {was 10 gws}; while (start_block <= directory[0].deovblk) do begin num_blocks := directory[0].deovblk - start_block; if (num_blocks > 32) then num_blocks := 32; chars_read := num_blocks * 512; unitread(read_unit, buffer, chars_read, start_block); for j := 1 to num_entries do begin { scan for each entry } start_char := 0; len := chars_read - 1; done := false; repeat { until not found in buffer } k := scan(len,=dict[j,1],buffer[start_char]); start_char := start_char + k + 1; if (k < len) then begin { found initial char } l := 2; found := true; while (l <= length(dict[j])) and found do begin{ finish compare } if (dict[j][l] <> buffer[start_char+l-2]) then found := false; l := l + 1; end; { while } if found then tell_found; end { if } else done := true; len := len - k - 1; until done; end; { for j } { re-scan last block in case key word ran across block boundary } start_block := start_block + 31; end; { for i } end. ======================================================================================== DOCUMENT :usus Folder:VOL14:sorts1.text ======================================================================================== PROGRAM RANDOM1;{Bubblesort as the sort method} CONST MAXSIZE=500; VAR SEED:REAL; DIDSWAP:BOOLEAN; TIMEDIFF,HITIME,LO1TIME,LO2TIME,X,Y:INTEGER; SCALAR:ARRAY[1..MAXSIZE] OF INTEGER; PROCEDURE SWAP (VAR I,J:INTEGER); VAR TEMP:INTEGER; BEGIN TEMP:=I; I:=J; J:=TEMP; END; PROCEDURE SORT; VAR COUNTER:INTEGER; BEGIN DIDSWAP:=FALSE; FOR COUNTER:=1 TO MAXSIZE-1 DO BEGIN IF SCALAR[COUNTER]>SCALAR[COUNTER+1] THEN BEGIN SWAP(SCALAR[COUNTER],SCALAR[COUNTER+1]); DIDSWAP:=TRUE; END; END; END; FUNCTION RANDOM:INTEGER; BEGIN SEED:=SEED*27.182813+31.415917; SEED:=SEED-TRUNC(SEED); IF SEED<0 THEN SEED:=-SEED; RANDOM:=TRUNC(SEED*50+1); END; BEGIN TIME(HITIME,LO1TIME); SEED:=1.23456789; FOR X:=1 TO MAXSIZE DO SCALAR[X]:=RANDOM; FOR Y:=1 TO MAXSIZE DO WRITE(SCALAR[Y]:4); X:=1; REPEAT BEGIN SORT; WRITELN('IN ITERATION ',X,' OF SWAP-REPEAT LOOP'); X:=X+1; END; UNTIL DIDSWAP=FALSE; FOR Y:=1 TO MAXSIZE DO WRITE(SCALAR[Y]:4); TIME(HITIME,LO2TIME); TIMEDIFF:=LO2TIME-LO1TIME; IF TIMEDIFF<0 THEN TIMEDIFF:=TIMEDIFF+32767; WRITELN(TIMEDIFF DIV 60,'.',(100*(TIMEDIFF MOD 60) DIV 60),' seconds'); END. ======================================================================================== DOCUMENT :usus Folder:VOL14:sorts2.text ======================================================================================== PROGRAM RANDOM2;{Straight Selection sort as the sort method} CONST MAXSIZE=500; TYPE INDEX=0..MAXSIZE; VAR SEED:REAL; DIDSWAP:BOOLEAN; TIMEDIFF,HITIME,LO1TIME,LO2TIME,X,Y:INTEGER; SCALAR:ARRAY[1..MAXSIZE] OF INTEGER; PROCEDURE SELECTSORT; VAR I,J,K:INDEX; X:INTEGER; BEGIN FOR I:=1 TO MAXSIZE-1 DO BEGIN K:=I; X:=SCALAR[I]; FOR J:=I+1 TO MAXSIZE DO IF SCALAR[J]J; IF LJ; IF I=R; UNTIL S=0; END;{quicksort} FUNCTION RANDOM:INTEGER; BEGIN SEED:=SEED*27.182813+31.415917; SEED:=SEED-TRUNC(SEED); IF SEED<0 THEN SEED:=-SEED; RANDOM:=TRUNC(SEED*50+1); END; BEGIN TIME(HITIME,LO1TIME); SEED:=1.23456789; FOR X:=1 TO MAXSIZE DO SCALAR[X]:=RANDOM; FOR Y:=1 TO MAXSIZE DO WRITE(SCALAR[Y]:4); QUICKSORT; FOR Y:=1 TO MAXSIZE DO WRITE(SCALAR[Y]:4); TIME(HITIME,LO2TIME); TIMEDIFF:=LO2TIME-LO1TIME; IF TIMEDIFF<0 THEN TIMEDIFF:=TIMEDIFF+32767; WRITELN(TIMEDIFF DIV 60,'.',(100*(TIMEDIFF MOD 60) DIV 60),' seconds'); END. ======================================================================================== DOCUMENT :usus Folder:VOL14:sparse.gpat ======================================================================================== +-----------------------------------------------------------------------------+|| ||| -------- ---------------- ------- ||| | | ||| | | ||| --------- | | ------------------ ||| | | ||+- +-------- ---------+ -+||| | | | | ||| | | | | ||| --------- | | ------------------ ||| | | | | ||| | | ||+- | +-------- ---------+ | -+|| | | ||| --------- | | ----------------- ||| | | ||| | | ||| ||| -------- ------------------ ----- ||| ||| | ||+-------------------------------+---------------------------------------------+|1 2 $EQUAL $CURSOR  ======================================================================================== DOCUMENT :usus Folder:VOL14:srccom.text ======================================================================================== { SRCCOM - source file comparison program. adapted from program COMPARE, Pascal News #12. Copyright (C) 1977,1978 James F. Miner Social Science Research Facilities Center 25 Blegan Hall 269 19th Ave. So University of Minnesota Minneapolis, Minnesota 55455 General permission to make fair use in non-profit activites of all or part of this material is granted provided that this is given. } PROGRAM SRCCOM; USES (*$U FASTREAD.CODE*) FASTREAD; { Reference: Pascal News, Issue 13 } CONST VERSION = '1.3'; LINELENGTH = 120; MINLINESFORMATCH = 6; TYPE LINEPOINTER = ^LINE; LSTRING = LONGSTRING; LINE = PACKED RECORD NEXTLINE: LINEPOINTER; IMAGE: LSTRING END; STREAM = RECORD CURSOR, HEAD, TAIL: LINEPOINTER; CURSORLINENO, HEADLINENO, TAILLINENO: INTEGER; ENDFILE: BOOLEAN END; VAR OUTFILE: TEXT; FILEA, FILEB: FFILE; FCBA, FCBB: FCB; A, B: STREAM; MATCH: BOOLEAN; ENDFILE: BOOLEAN; OUTLFN, NAME1, NAME2: STRING[30]; TEMPLINE: LSTRING; FREELINES: LINEPOINTER; SAME: BOOLEAN; PROCEDURE COMPAREFILES; FUNCTION ENDSTREAM(VAR X: STREAM): BOOLEAN; BEGIN { ENDSTREAM } ENDSTREAM := (X.CURSOR = NIL) AND X.ENDFILE END; { ENDSTREAM } PROCEDURE MARK(VAR X: STREAM); VAR P: LINEPOINTER; BEGIN { MARK } WITH X DO IF HEAD <> NIL THEN BEGIN WHILE HEAD <> CURSOR DO BEGIN WITH HEAD^ DO BEGIN P := NEXTLINE; NEXTLINE := FREELINES; FREELINES := HEAD END; HEAD := P; END; HEADLINENO := CURSORLINENO; IF CURSOR = NIL THEN BEGIN TAIL := NIL; TAILLINENO := CURSORLINENO END; END END; { MARK } PROCEDURE MOVECURSOR(VAR X: STREAM; VAR FCBX: FCB; VAR INFILE: FFILE); PROCEDURE READLINE; VAR NEWLINE: LINEPOINTER; J: INTEGER; BEGIN { READLINE } IF NOT X.ENDFILE THEN BEGIN GETSTRING(FCBX, INFILE, TEMPLINE); NEWLINE := FREELINES; IF NEWLINE = NIL THEN NEW(NEWLINE) ELSE FREELINES := FREELINE^.NEXTLINE; NEWLINE^.IMAGE := TEMPLINE; 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 := FCBX.ENDFILE; 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 BEGIN READLINE; X.CURSOR := X.HEAD; X.CURSORLINENO := X.HEADLINENO; END ELSE ENDFILE := TRUE; END; { MOVECURSOR } PROCEDURE BACKTRACK(VAR X: STREAM; VAR XLINES: INTEGER); 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); 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 } REPEAT { COMPARENEXTLINES } MOVECURSOR(A, FCBA, FILEA); MOVECURSOR(B, FCBB, FILEB); MARK(A); MARK(B); COMPARELINES(MATCH); UNTIL ENDFILE OR NOT MATCH; END; { FINDMISMATCH } PROCEDURE FINDMATCH; VAR ADVANCEB: BOOLEAN; PROCEDURE SEARCH(VAR X: STREAM; VAR FCBX: FCB; VAR FILEX: FFILE; VAR Y: STREAM; VAR FCBY: FCB; VAR FILEY: FFILE); VAR COUNT: INTEGER; PROCEDURE CHECKFULLMATCH; 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, FCBX, FILEX); MOVECURSOR(Y, FCBY, 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, FCBY, FILEY); BACKTRACK(X, COUNT); CHECKFULLMATCH; COUNT := COUNT - 1; WHILE (COUNT <> 0) AND NOT MATCH DO BEGIN MOVECURSOR(X, FCBX, FILEY); COUNT := COUNT - 1; CHECKFULLMATCH; END END; { SEARCH } PROCEDURE PRINTMISMATCH; VAR EMPTYA, EMPTYB: BOOLEAN; PROCEDURE WRITETEXT(P, Q: LINEPOINTER); BEGIN { WRITETEXT } WRITELN(OUTFILE); WHILE (P <> NIL) AND (P <> Q) DO BEGIN WRITE(OUTFILE, ' * '); WITH P^ DO WRITELN(OUTFILE, IMAGE); P := P^.NEXTLINE END; IF P = NIL THEN WRITELN(OUTFILE, ' *** EOF ***'); WRITELN(OUTFILE); END; { WRITETEXT } PROCEDURE WRITELINENO(VAR X: STREAM); VAR F, L: INTEGER; BEGIN { WRITELINENO } F := X.HEADLINENO; L := X.CURSORLINENO - 1; WRITE(OUTFILE, 'LINE'); IF F = 1 THEN WRITE(OUTFILE, ' ', F:1) ELSE WRITE(OUTFILE, 'S ', F:1, ' TO ', L:1); IF X.CURSOR = NIL THEN WRITE(OUTFILE, ' (BEFORE EOF)'); END; { WRITELINENO } PROCEDURE PRINTEXTRATEXT(VAR X: STREAM; XNAME: STRING; VAR Y: STREAM; YNAME: STRING); BEGIN { PRINTEXTRATEXT } WRITE(OUTFILE, ' EXTRA TEXT ON "', XNAME, '", '); WRITELINENO(X); WRITELN(OUTFILE); IF Y.HEAD = NIL THEN WRITELN(OUTFILE, ' BEFORE EOF ON FILE "', YNAME, '"') ELSE WRITELN(OUTFILE, ' BETWEEN LINES ', Y.HEADLINENO-1:1, ' AND ', Y.HEADLINENO:1, ' OF "', YNAME, '"'); WRITETEXT(X.HEAD, X.CURSOR) END; { PRINTEXTRATEXT } BEGIN { PRINTMISMATCH } WRITELN(OUTFILE, '***************************************'); EMPTYA := (A.HEAD = A.CURSOR); EMPTYB := (B.HEAD = B.CURSOR); IF EMPTYA OR EMPTYB THEN IF EMPTYA THEN PRINTEXTRATEXT(B, NAME2, A, NAME1) ELSE PRINTEXTRATEXT(A, NAME1, B, NAME2) ELSE BEGIN WRITELN(OUTFILE, ' MISMATCH:'); WRITELN(OUTFILE); WRITE(OUTFILE, ' "', NAME1, '", '); WRITELINENO(A); WRITELN(OUTFILE, ':'); WRITETEXT(A.HEAD, A.CURSOR); WRITE(OUTFILE, ' "', NAME2, '", '); WRITELINENO(B); WRITELN(OUTFILE, ':'); WRITETEXT(B.HEAD, B.CURSOR) END END; { PRINTMISMATCH } BEGIN { FINDMATCH } ADVANCEB := TRUE; REPEAT IF NOT ENDFILE THEN ADVANCEB := NOT ADVANCEB ELSE ADVANCEB := ENDSTREAM(A); IF ADVANCEB THEN SEARCH(A, FCBA, FILEA, B, FCBB, FILEB) ELSE SEARCH(B, FCBB, FILEB, A, FCBA, FILEA) UNTIL MATCH; PRINTMISMATCH; END; { FINDMISMATCH } BEGIN { COMPAREFILES } MATCH := TRUE; REPEAT IF MATCH THEN FINDMISMATCH ELSE BEGIN SAME := FALSE; FINDMATCH END UNTIL ENDFILE AND MATCH END; { COMPAREFILES } PROCEDURE INITIALIZE; PROCEDURE INITSTREAM(VAR X: STREAM; VAR FCBX: FCB; VAR FILEX: FFILE; VAR LFN: STRING); BEGIN { INITSTREAM } WITH X DO BEGIN CURSOR := NIL; TAIL := NIL; CURSORLINENO := 0; HEADLINENO := 0; TAILLINENO := 0 END; WRITE('File name: '); READLN(LFN); OPENFILE(FCBX, FILEX, LFN); X.ENDFILE := FCBX.ENDFILE; END; { INITSTREAM } BEGIN { INITIALIZE } INITSTREAM(A, FCBA, FILEA, NAME1); INITSTREAM(B, FCBB, FILEB, NAME2); ENDFILE := A.ENDFILE OR B.ENDFILE; FREELINES := NIL; WRITE('Output file? '); READLN(OUTLFN); IF OUTLFN = '' THEN OUTLFN := 'CONSOLE:'; REWRITE(OUTFILE, OUTLFN); END; { INITIALIZE } BEGIN { COMPARE } INITIALIZE; PAGE(OUTFILE); WRITELN(OUTFILE, 'SRCCOM - V', VERSION); WRITELN(OUTFILE); WRITELN(OUTFILE, ' Match criterion = ', MINLINESFORMATCH:1, ' lines.'); WRITELN(OUTFILE); IF A.ENDFILE THEN WRITELN(OUTFILE, '"', NAME1, ' IS EMPTY.'); IF B.ENDFILE THEN WRITELN(OUTFILE, '"', NAME2, ' IS EMPTY.'); IF NOT ENDFILE THEN BEGIN SAME := TRUE; COMPAREFILES; IF SAME THEN WRITELN(OUTFILE, ' NO DIFFERENCES.') END; CLOSE(OUTFILE, LOCK); END. { COMPARE } ======================================================================================== DOCUMENT :usus Folder:VOL14:stock.data.text ======================================================================================== Astro City Bonds 50 Bigg Corporation 1 Metro Properties 0 Pioneer Mutal 4 Oak Creek Realty 7 Standard Drilling 0 City Bus Lines 0 Tiny Auto Company 2 Uranium Mining 6 Valley Electric 3 12 7 9 7 8 6 5 -2 11 -5 -8 14 -6 10 8 6 4 7 6 11 13 -10 13 10 7 5 4 3 -1 -3 -5 -8 -10 10 -10 -5 -6 -4 3 -3 -8 -7 6 -15 10 30 -20 -40 40 -15 45 -20 30 25 -20 20 6 12 3 8 5 6 7 10 4 -20 21 -19 21 16 4 8 -10 10 -11 18 -23 25 22 18 -14 -12 -8 10 14 -18 -22 -25 8 -2 7 4 3 5 4 6 -4 -4 -7 -2 26 18 23 20 17 19 11 13 14 24 -10 16 23 28 15 21 24 18 31 -8 24 -7 25 11 -2 15 13 17 14 1 19 23 -9 8 12 11 7 -2 9 11 14 -1 20 -2 -14 46 56 -20 37 -5 67 -11 9 51 -9 21 18 19 15 23 26 15 18 25 27 -7 14 -5 30 13 23 13 22 18 -10 38 -16 -4 34 29 -10 19 -7 18 -14 13 33 -4 17 15 14 12 14 15 13 10 19 18 ======================================================================================== DOCUMENT :usus Folder:VOL14:stock.doc.text ======================================================================================== 17 September 1980 I am not aware of any portion of this program as being from another program. Stock is a computer implementation of a bookshelf game "Stocks & Bonds" owned and published by Avalon Hill. The program was developed on a Heathkit (H-11) and a Southwest Technical Products (SWTP-82) terminial using Pascal II.0. The idiosyncrasies of the program are: 1. It is scope dependent. 2. I have no random number generator and I am simulating one from the line clock. Therefore, there must be a line clock and it must be on. [changed to detect presence of clock and prompt for seed if no clock gws] 3. It uses CHR(12), form feed, to clear the screen and home the cursor. [ changed to H-19 codes gws] 4. The program data is initialized from a text file named STOCK:STOCK.DATA.TEXT [changed to #5:STOCK.DATA.TEXT gws] Questions can be directed to: Homer Baker Phoenix Union High School District 2526 W. Osborn Road Phoenix, AZ 85017 Phone:(602) 257-3086 Home :(602) 967-0064 ======================================================================================== DOCUMENT :usus Folder:VOL14:stock.text ======================================================================================== {$S+} program stockmarket; type share=record amount:0..500; value:integer[7]; end; stock=record name:string[20]; value:share; dividend:integer; end; player=record name:string[10]; value:array[1..10] of share; dividend,turn:integer; cash:integer[10]; end; table=(bear,bull); var market:array[table] of array[2..10] of array[2..12] of integer; stocks:array[1..10] of stock; players:array[1..9] of player; num:string[3]; ch:char; hi,lo1,lo2,seed,currentp,currents,year:integer; nplayer:1..9; procedure clear_screen; begin write ( chr ( 27 ), chr ( 69 ) ) ; {H-19 specific gws} end; procedure clear_line; begin write ( chr ( 27 ), chr ( 75 ) ); {H-19 specific gws} end; procedure clear; begin gotoxy(0,16); writeln(' '); writeln(' '); writeln(' '); gotoxy(0,16) end; function number:integer; var n,i:integer; begin n:=0; for i:=1 to length(num) do if ord(num[i])>47 then if ord(num[i])<58 then n:=n*10+(ord(num[i])-48) else begin clear; writeln(' Type digits please.'); n:=0 end; number:=n; end; function upper(cha:char):char; begin if ord(cha)>96 then if ord(cha)<123 then upper:=chr(ord(cha)-32) else upper:=cha else upper:=cha; end; procedure gameconst; var i,j:integer; k:table; f:interactive; begin reset(f,'#5:STOCK.DATA.TEXT'); writeln('Stocks:':20,'Dividends per year'); for i:=1 to 10 do begin readln(f,stocks[i].name); readln(f,stocks[i].dividend); writeln(stocks[i].name:20,stocks[i].dividend:4); end; for k:=bear to bull do for j:=2 to 10 do begin for i:=2 to 12 do read(f,market[k,j,i]); readln(f); end; close(f); end; procedure initialize; var i,j:integer; begin for i:= 1 to 10 do begin if i=1 then begin stocks[i].value.amount:=50; stocks[i].value.value:=1000 end else begin stocks[i].value.amount:=500; stocks[i].value.value:=100; end; if i<10 then begin for j:=1 to 10 do begin players[i].value[j].amount:=0; players[i].value[j].value:=0; players[i].dividend:=0; players[i].turn:=i; players[i].cash:=5000; end; end; end; end; procedure playersname; var i,j:integer; begin write('How many players (1..9)?'); read(ch); nplayer:=ord(ch)-48; writeln; for i:=1 to nplayer do begin write('Enter name of player ',i:1,' '); readln(players[i].name); if length(players[i].name)=0 then i:=i-1; end; end; function random:real; begin random := seed/32767; seed := ( 103 * seed + 1999 ) mod 32767; if seed < 0 then seed := seed * ( -1 ); end; {random} function irandom(low,high:integer):integer; {irandom produces integer numbers ranging from low to high} begin irandom:=trunc(random*(high-low+0.9)+low) end; function dieroll:integer; begin dieroll:=irandom(1,6) end; procedure game; var i,j,k:integer; procedure disstock(i:integer); begin gotoxy(0,i+3); writeln(stocks[i].name:20 ,stocks[i].value.value:4,stocks[i].value.amount:4); end; procedure shostock; var i:integer; begin clear_screen; writeln(' Year 198',year:1); writeln('Stock'); gotoxy(18,2); writeln('Value Avail'); for i:=1 to 10 do disstock(i); end; procedure update; var j,k:integer; i:table; procedure split(k:integer); var i,j:integer; begin {split} stocks[k].value.value:=stocks[k].value.value div 2; for i:=1 to nplayer do for j:=1 to nplayer do if i=players[j].turn then begin if players[j].value[k].amount<= stocks[k].value.amount then begin stocks[k].value.amount:=stocks[k].value.amount- players[j].value[k].amount; players[j].value[k].amount:=players[j].value[k].amount * 2 end else begin players[j].cash:=players[j].cash+ ((players[j].value[k].amount-stocks[k].value.amount) *stocks[k].value.value); players[j].value[k].amount:=players[j].value[k].amount +stocks[k].value.amount; stocks[k].value.amount:=0 end end; end; {split} procedure paydiv; var play,stoq:integer; begin for play:=1 to 9 do begin players[play].dividend:=0; for stoq:=1 to 10 do begin players[play].value[stoq].value:=players[play].value[stoq].amount *stocks[stoq].value.value; if stocks[stoq].value.value>49 then players[play].dividend:=players[play].dividend +players[play].value[stoq].amount*stocks[stoq].dividend end; players[play].cash:=players[play].cash+players[play].dividend; end; end; procedure bust(stoq:integer); var i:integer; begin stocks[stoq].value.value:=0; stocks[stoq].value.amount:=0; for i:=1 to nplayer do begin players[i].value[stoq].amount:=0; players[i].value[stoq].value:=0 end; end; begin {update} if irandom(1,2)=1 then i:=bull else i:=bear; j:=dieroll+dieroll; for k:=2 to 10 do begin if stocks[k].value.value=0 then begin stocks[k].value.amount:=500; stocks[k].value.value:=100 end; stocks[k].value.value:=stocks[k].value.value+market[i,k,j]; if stocks[k].value.value>150 then split(k); if stocks[k].value.value<1 then bust(k); end; paydiv; shostock; end; {update} procedure plystock(play,stoq:integer); begin gotoxy(30,stoq+3); writeln(players[play].value[stoq].amount:4, players[play].value[stoq].value:6); end; procedure shoplay(play:integer); var i:integer; begin gotoxy(28,1); writeln(players[play].name:10); gotoxy(30,2); writeln('Shares Value'); for i:=1 to 10 do plystock(play,i); gotoxy(24,14); writeln('Dividends ',players[play].dividend:6); gotoxy(29,15); writeln('Cash ',players[play].cash:6); clear end; procedure seturn; var i,r,x:integer; begin for i:=1 to nplayer do begin r:=irandom(1,nplayer); x:=players[i].turn; players[i].turn:=players[r].turn; players[r].turn:=x; end; end; procedure transak(play,tran,stoq:integer); var n:integer; begin gotoxy(0,16); clear_line; If tran<0 then write('Sell ') else write('Buy '); write('how many shares of ',stocks[stoq].name); readln(num); n:=number; if tran<0 then begin if players[play].value[stoq].amount0 then getstk(play,i) until ch='F'; end; begin {game} for year:=0 to 9 do begin update; seturn; for i:=1 to nplayer do for j:=1 to nplayer do if i=players[j].turn then playturn(j); end; end; {game} procedure finish; var cash:integer[10]; play,stoq:integer; begin clear_screen; for play:=1 to nplayer do begin cash:=players[play].cash; for stoq:=1 to 10 do begin cash:=cash+players[play].value[stoq].value end; writeln(players[play].name:10,' $',cash:10) end; end; begin{stockmarket} clear_screen; time ( hi, lo1 ); for hi := 1 to 1000 do ; time ( hi, lo2 ); if lo2 = lo1 then begin write ( 'no clock, please type an integer ' ); readln ( seed ); end else seed := lo2; clear_screen; gameconst; playersname; initialize; game; finish; end. {stockmarket} ======================================================================================== DOCUMENT :usus Folder:VOL14:table.text ======================================================================================== ACI $ ADC $ ADC A ADC A ADC B ADC B ADC C ADC C ADC D ADC D ADC E ADC E ADC H ADC H ADC L ADC L ADC M ADC (HL) ADD A ADD A ADD B ADD B ADD C ADD C ADD D ADD D ADD E ADD E ADD H ADD H ADD L ADD L ADD M ADD (HL) ADI $ ADD $ ANA A AND A ANA B AND B ANA C AND C ANA D AND D ANA E AND E ANA H AND H ANA L AND L ANA M AND (HL) ANI $ AND $ CALL $ CALL $ CC $ CALL C,$ CM $ CALL M,$ CMA # CPL # CMC # CCF # CMP A CP A CMP B CP B CMP C CP C CMP D CP D CMP E CP E CMP H CP H CMP L CP L CMP M CP (HL) CNC $ CALL NC,$ CNZ $ CALL NZ,$ CP $ CALL P,$ CPE $ CALL PE,$ CPI $ CP $ CPO $ CALL PO,$ CZ $ CALL Z,$ DAA # DAA # DAD B ADD HL,BC DAD D ADD HL,DE DAD H ADD HL,HL DAD SP ADD HL,SP DCR A DEC A DCR B DEC B DCR C DEC C DCR D DEC D DCR E DEC E DCR H DEC H DCR L DEC L DCR M DEC (HL) DCX B DEC BC DCX D DEC DE DCX H DEC HL DCX SP DEC SP DI # DI # EI # EI # HLT # HALT # IN $ IN A,$ INR A INC A INR B INC B INR C INC C INR D INC D INR E INC E INR H INC H INR L INC L INR M INC (HL) INX B INC BC INX D INC DE INX H INC HL INX SP INC SP JC $ JP C,$ JM $ JP M,$ JMP $ JP $ JNC $ JP NC,$ JNZ $ JP NZ,$ JP $ JP P,$ JPE $ JP PE,$ JPO $ JP PO,$ JZ $ JP Z,$ LDA $ LD A,($) LDAX B LD A,(BC) LDAX D LD A,(DE) LHLD $ LD HL,($) LXI B,$ LD BC,$ LXI D,$ LD DE,$ LXI H,$ LD HL,$ LXI SP,$ LD SP,$ MOV A,A LD A,A MOV A,B LD A,B MOV A,C LD A,C MOV A,D LD A,D MOV A,E LD A,E MOV A,H LD A,H MOV A,L LD A,L MOV A,M LD A,(HL) MOV B,A LD B,A MOV B,B LD B,B MOV B,C LD B,C MOV B,D LD B,D MOV B,E LD B,E MOV B,H LD B,H MOV B,L LD B,L MOV B,M LD B,(HL) MOV C,A LD C,A MOV C,B LD C,B MOV C,C LD C,C MOV C,D LD C,D MOV C,E LD C,E MOV C,H LD C,H MOV C,L LD C,L MOV C,M LD C,(HL) MOV D,A LD D,A MOV D,B LD D,B MOV D,C LD D,C MOV D,D LD D,D MOV D,E LD D,E MOV D,H LD D,H MOV D,L LD D,L MOV D,M LD D,(HL) MOV E,A LD E,A MOV E,B LD E,B MOV E,C LD E,C MOV E,D LD E,D MOV E,E LD E,E MOV E,H LD E,H MOV E,L LD E,L MOV E,M LD E,(HL) MOV H,A LD H,A MOV H,B LD H,B MOV H,C LD H,C MOV H,D LD H,D MOV H,E LD H,E MOV H,H LD H,H MOV H,L LD H,L MOV H,M LD H,(HL) MOV L,A LD L,A MOV L,B LD L,B MOV L,C LD L,C MOV L,D LD L,D MOV L,E LD L,E MOV L,H LD L,H MOV L,L LD L,L MOV L,M LD L,(HL) MOV M,A LD (HL),A MOV M,B LD (HL),B MOV M,C LD (HL),C MOV M,D LD (HL),D MOV M,E LD (HL),E MOV M,H LD (HL),H MOV M,L LD (HL),L MVI A,$ LD A,$ MVI B,$ LD B,$ MVI C,$ LD C,$ MVI D,$ LD D,$ MVI E,$ LD E,$ MVI H,$ LD H,$ MVI L,$ LD L,$ MVI M,$ LD (HL),$ NOP # NOP # ORA A OR A ORA B OR B ORA C OR C ORA D OR D ORA E OR E ORA H OR H ORA L OR L ORA M OR (HL) ORI $ OR $ OUT $ OUT $,A PCHL # JP (HL) POP B POP BC POP D POP DE POP H POP HL POP PSW POP PSW PUSH B PUSH BC PUSH D PUSH DE PUSH H PUSH HL PUSH PSW PUSH PSW RAL # RLA # RAR # RRA # RC # RET C RET # RET # RLC # RLCA # RM # RET M RNC # RET NC RNZ # RET NZ RP # RET P RPE # RET PE RPO # RET PO RRC # RRCA # RST $ RST $ RZ # RET Z SBB A SBC A SBB B SBC B SBB C SBC C SBB D SBC D SBB E SBC E SBB H SBC H SBB L SBC L SBB M SBC (HL) SBI $ SBC $ SHLD $ LD ($),HL SPHL # LD SP,HL STA $ LD ($),A STAX B LD (BC),A STAX D LD (DE),A STC # SCF # SUB A SUB A SUB B SUB B SUB C SUB C SUB D SUB D SUB E SUB E SUB H SUB H SUB L SUB L SUB M SUB (HL) SUI $ SUB $ XCHG # EX DE,HL XRA A XOR A XRA B XOR B XRA C XOR C XRA D XOR D XRA E XOR E XRA H XOR H XRA L XOR L XRA M XOR (HL) XRI $ XOR $ XTHL # EX (SP),HL ======================================================================================== DOCUMENT :usus Folder:VOL14:vol14.doc.text ======================================================================================== USUS Library Volume 14 Assorted programs from almost everyone COPVOL.TEXT 18 Jon Bondy's disk copier (will copy Z-80 type boot blocks) COPVER.ASM.TEXT 8 an external procedure for COPVAL COPFILE.TEXT 12 Jon Bondy's file copier COMPFILE.TEXT 10 A binary file comparison program GAME.TEXT 26 A game with a maze and demons by Jon Bondy GAME1.TEXT 18 an include file of GAME DEFAULT.GPAT 4 a data file for GAME CROSSES.GPAT 4 ditto SPARSE.GPAT 4 ditto GAME.ASSEM.TEXT 4 an external procedure for GAME ( keypress ) SCANNER.TEXT 14 A nifty program which looks through a disk for a string KBSTAT.TEXT 4 my keypress routine (for an H-89) BONDYSTUFF.TEXT 14 Jon's documemtation HOME_LOAN.TEXT 10 A simple program to calculate simple loans BANNER.TEXT 22 Prints banners in BIG letters STOCK.TEXT 22 A Stock Market game STOCK.DATA.TEXT 6 a data file for STOCK STOCK.DOC.TEXT 6 documentation for STOCK SRCCOM.TEXT 18 A nice source comparison program FASTREAD.TEXT 8 a unit for SRCCOM REFERENCE.TEXT 24 A simple but effective procedural cross referencer REFER.INC.TEXT 22 an include file of REFERENCE 8080CONV.TEXT 26 Converts 8080 instructions to Z-80 instructions LOOK.UP.TABLE 15 A data file for 8080CONV TABLE.TEXT 18 The text of the data in case you have to recreate it REFORM.TEXT 8 A utility for 8080CONV CALENDAR.TEXT 12 A perpetual calendar ( requires an H-19 ) DAYOFWK.TEXT 8 Calculates the day of the week for any date LISTINFO.TEXT 36 Generates a report of your *SYSTEM.MISCINFO SORTS1.TEXT 6 These four programs are demos of four different sorts SORTS2.TEXT 6 SORTS3.TEXT 6 SORTS4.TEXT 6 HEXDUMP.TEXT 12 Dumps blocks in hex ROMAN.TEXT 10 Converts decimal dates to Roman numerals VOL14.DOC.TEXT 14 You're reading it ------------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 14 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Some notes from the editor: COPVOL This is a general disk copier with verification. It will also copy the boot block of Z-80/8080 type systems. You may have to modify the external procedure. COPFILE A general file copier. COMPFILE A binary file comparison program. It will compare any type of file but does not provide as nice a difference report as SRCCOM will for textfiles. GAME A game with demons and a maze with some added features. Refer to BONDYSTUFF.TEXT for more detailed info. You will need a keypress function to make it work. SCANNER This program will very quickly look through a disk for a target string. It had some problems as Jon submitted it, but I fixed them (you may note my kludging here and there). This program is REALLY useful if you have deleted a file and you want to know in which areas it may still exist. HOME_LOAN This is a simple loan calculator. It could use some work on the display format, but it appears to work. BANNER This little ditty was supposed to be on Volume 8 ( it is in the catalog file, but the file is not on the copy that I have). It prints a banner in BIG letters ( up to about 10" high ) or multiple lines of smaller letters. The character font is passable but could use improvement. I have modified it here and there, changing the overstrike characters and adding the font data for digits. STOCK Stock is a stock market game, simple but interesting. SRCCOM and FASTREAD SRCCOM is a textfile comparison similar in function to the comparison routine on Volume 4. Fastread is a unit which allow MUCH faster reading of textfiles than the standard READ procedure. REFERENCE REFERENCE is a simple procedural cross-referencer. It tells you the scope of procedures and functions and reports which routine call which routine. 8080CONV and REFORM This utility converts 8080 assembly language source into Z-80 source. It assumes that the 8080 source conforms to a certain set of conventions, which can be arranged by processing the 8080 source with REFORM. LISTINFO This program generates a report of the data in *SYSTEM.MISCINFO. It was written for version I.5 but I tested it under II.0 and it works. It probably won't work right for IV.0. CALENDAR and DAYOFWK These programs do date conversions for the Gregorian calendar. CALENDAR requires an H-19 as some simple graphics work is done. SORTS1 .. SORTS4 These demo programs are four different types of sorts. They include internal timers to time themselves, so if you don't have TIME supported on your machine, you will have to use a stopwatch. TIME is also used to initialize a random number generator which is used to generate a random list on integers to sort, so you may have to include a routine to prompt for a seed also. HEXDUMP This is a simple program which dumps blocks in hex. I think that PATCH is much more useful in this regard, but this program works. ROMAN This is a simple program which converts decimal numbers to Roman numerals. ======================================================================================== DOCUMENT :usus Folder:VOL15:a.___.remu.text ======================================================================================== { USUS Remote Communication Unit for Apple /// & Hayes SmartModem - 820510 } { Note: this version is an EXPERIMENTAL version... Arley Dealey } {$setc debug := false } {$setc test := false } unit RemUnit ; { This is a separate compilation unit intended to stand between application code and a communication line. Implementation of this unit follows the specifications set out in the USUS (UCSD p-System Users Society) Remote Unit Standard of August, 1981. ******************************************************************************* *** NOTE: This Apple /// implementation is less well tested than the author *** *** would like, but it is being submitted to the library in its current *** *** state in the interest of expediency. - acd *** ******************************************************************************* This implementation is designed to interface to the following models: computer serial port modem -------- ----------- ----- Apple /// internal Hayes Smartmodem The following routines are not functional: CR_DialTone CR_SetAddress CR_SetDTR CR_SetRTS The following routines contain calls to UnitClear: CR_Answer CR_CommInit The following routines are implemented but untested: CR_Answer CR_Ringing CR_ClearToSend The authors may be contacted as follows: Robert W. Peterson Arley C. Dealey ------------------ --------------- US Mail P.O. Box 1686 Volition Systems Plano, TX 75074 1000 Texas National Bank Bldg. Dallas, TX 75225 (214) 692-6518 GTE Telemail *BVL1707 *NPN6141 Compuserve 70235,326 70130,177 ( usually via EMAIL or the MUSUS SIG ) Source TCA928 {checked infrequently} Change Log ====== === Date What change was made & who made the change --------- --------------------------------------------------------------------- 04 Jul 82 Changed RS232_StList declaration so correct allocation is made. [acd] 10 May 82 Cleaned up. UnitControl does return status in ioresult. [acd] 26 Dec 81 SOS request vars changed to constants where possible - Arley Dealey 21 Dec 81 Implemented CR_ClearToSend - Arley Dealey 20 Dec 81 Implemented CR_Break - Arley Dealey 09 Dec 81 Convert from 990 ver. IV.0 to Apple /// ver. II.x - Arley Dealey 19 Nov 81 Add compile conditional for debugging and segments - Bob Peterson 26 Oct 81 Convert from Polymorphic to 990 25 Aug 81 Bring up to adopted standard - Bob Peterson 03 Aug 81 Convert to IV.0 - Bob Peterson 28 Mar 81 Original code - Bob Peterson ==============================================================================} {$P} interface {============== Copyright Notice =============================================} {$C Copyright 1980, 1981 by Robert W. Peterson. All rights reserved. } {============== Copyright Notice =============================================} const CR_Version = '82 Jul 04 [1.1a]' ; {*** NON-STANDARD ***} CR_Host = 'Apple ///' ; {*** NON-STANDARD ***} CR_Modem = 'Smartmodem' ; {*** NON-STANDARD ***} type CR_Baud_Result = ( CR_Bad_Parameter, CR_Bad_Rate, CR_Set_OK, CR_Select_Not_Supported ) ; CR_DialResult = ( CR_Off_Hook, CR_DialError, CR_NoAutoDial ) ; CR_Rem_Port = packed record Part1 : integer ; Part2 : integer ; end { CR_Rem_Port } ; CR_State = ( CR_On, CR_Off, CR_Auto ) ; CR_WhoAmI = ( CR_Orig, CR_Ans ) ; var CR_AttenChar : char ; CR_Current_Port : CR_Rem_Port ; {$ifc debug} Remote : interactive ; {*** NON-STANDARD ***} DebugLog : interactive ; {*** NON-STANDARD ***} {$endc} { Initialization and termination routines. } procedure CR_CommInit ( Dir : CR_WhoAmI ; Attention_Char : char ; var Remote_Exists : boolean ; var Dialer_Exists : boolean ) ; procedure CR_CommQuit ; { Input status. } function CR_KbStat : boolean ; function CR_RemStat : boolean ; { Input/Output operations. } function CR_GetKb : char ; function CR_GetRem : char ; procedure CR_PutRem ( C : char ) ; { Control procedures. } procedure CR_Answer ; procedure CR_Break ; function CR_Carrier : boolean ; function CR_ClearToSend : boolean ; procedure CR_Delay ( Tenths : integer ) ; procedure CR_Dial ( Number : string ; WaitChar : char ; var Result : CR_DialResult ) ; function CR_DialTone : boolean ; procedure CR_Hook ( OnHook : boolean ) ; function CR_Ringing : boolean ; procedure CR_SetAddress( HighAddr : integer ; LowAddr : integer ; Vector : integer ) ; procedure CR_SetCommunications ( Parity : boolean ; Even : boolean ; Rate : integer ; CharBits : integer ; StopBits : integer ; Dir : CR_WhoAmI ; Model : string ; var Result : CR_Baud_Result ) ; procedure CR_Set_DTR ( New_State : CR_State ) ; procedure CR_Set_RTS ( New_State : CR_State ) ; implementation {$P} { Page here so the option is not in the interface text } const Answer_After = '3' ; { Answer after this many rings. } CR = 13 ; { Carriage Return } Esc = 27 ; Default_Rate = 300 ; Default_Mode = true ; { Default to parity enabled } Default_Parity = true ; { Default to even parity } Default_CharBits = 7 ; { Default to seven data bits } Default_StopBits = 1 ; { Default to one stop bit } Default_Kind = 'Apple ///' ; Hung_Up = true ; Crt_Unit = 1 ; Kb_Unit = 2 ; RemIn_Unit = 7 ; RemOut_Unit = 8 ; Timer = 600 ; UnknownRate = -1 ; { SmartModem return codes: } SM_OK = '0' ; SM_Connect = '1' ; SM_Ring = '2' ; SM_No_Carrier = '3' ; SM_Error = '4' ; { Default S6 =wait for dial tone in seconds 2 S7 =wait for carrier in seconds 30 S8 =pause time for comma in seconds 2 S9 =carrier detector response time in tenths of a second 6 S10=delay between loss of carrier and hangup, in seconds 7 S11=TouchTone duration and spacing in milliseconds 70 S12=escape code guard time in 50ths of a second 50 } SM_Defaults = 'EV S10=4 S12=10' ; SM_Dial_Prologue = 'DT' ; { D=dial command; T=use tone dialing } SM_Long_Wait = 32000 ; SM_Short_Wait = 500 ; type IO_Direction = ( IO_Out, IO_In ) ; ReqType = ( StatReq, CntlReq ) ; Byte = 0..255 ; Bits2 = 0..3 ; Bits3 = 0..7 ; Bits4 = 0..15 ; Bits5 = 0..31 ; Bits6 = 0..63 ; Bits7 = 0..127 ; SOS_ReqCode = packed record Channel : IO_Direction ; StatOrCntl : ReqType ; RequestNum : Byte ; Reserved : Bits6 ; end ; { NOTE: We had to kludge up a declaration for the status word. } { Logically it should look like this: } {$ifc false } RS232_Status = packed record Current : packed record ParityErr : boolean ; FramingErr : boolean ; OverRun : boolean ; RecRegFull : boolean ; XmitRegEmpty: boolean ; DCD_False : boolean ; DSR_False : boolean ; IRQ_Pending : boolean ; end ; Latched : packed record ParityErr : boolean ; FramingErr : boolean ; OverRun : boolean ; RecRegFull : boolean ; XmitRegEmpty: boolean ; DCD_False : boolean ; DSR_False : boolean ; IRQ_Pending : boolean ; end ; end ; {$endc } { but the compiler allocates two words for that, so we use the clumsy } { declaration which follows. } RS232_Status = packed record { Status at last interrupt } ParityErr : boolean ; FramingErr : boolean ; OverRun : boolean ; RecRegFull : boolean ; XmitRegEmpty: boolean ; DCD_False : boolean ; DSR_False : boolean ; IRQ_Pending : boolean ; { Latched status } L_ParityErr : boolean ; L_FramingErr : boolean ; L_OverRun : boolean ; L_RecRegFull : boolean ; L_XmitRegEmpty: boolean ; L_DCD_False : boolean ; L_DSR_False : boolean ; L_IRQ_Pending : boolean ; end ; RS232_StList = packed record BufferSize : Byte ; BaudRate : Byte ; DataFormat : Byte ; CR_Delay : Byte ; LF_Delay : Byte ; FF_Delay : Byte ; Protocol : Byte ; CtlChar1 : Byte ; CtlChar2 : Byte ; MaxBufLevel : Byte ; MinBufLevel : Byte ; BlockLength : Byte ; HdwrHandShake : Byte ; filler : Bits7 ; ImRead : BOOLEAN ; Status : RS232_Status end ; RS232_BufList = record OutBufSize : integer ; { Size of output buffer } CharsOut : integer ; { Number of chars buffered out } InBufSize : integer ; { Size of input buffer } CharsIn : integer ; { Number of chars buffered in } end ; var Baud_Settable : boolean ; Control : integer ; CurrentBaud : integer ; DTR_State : CR_State ; RTS_State : CR_State ; Off_Hook : boolean ; Unit_Carrier : boolean ; Model_ID : string ; StatusList : RS232_StList ; {$ifc debug} xxx : integer ; {*** NON-STANDARD ***} {$endc} function SM_Execute_Command ( Cmd : string ; Wait_Count: integer ) : char ; forward ; function Check_SmartModem_There : boolean ; forward ; function SM_Attention : boolean ; forward ; procedure RS232Control ( Request : ReqType ; VAR StatusList : RS232_StList ) ; forward ; {$P} { ----------------------------------------------------------- } { Initialization/Termination Procedures } { ----------------------------------------------------------- } procedure CR_SetAddress { HighAddr : integer ; LowAddr : integer ; Vector : integer } ; begin { CR_SetAddress } with CR_Current_Port do begin Part1 := HighAddr ; Part2 := LowAddr ; end ; end ; { CR_SetAddress } procedure CR_SetCommunications { Parity : boolean ; Even : boolean ; Rate : integer ; CharBits : integer ; StopBits : integer ; Dir : CR_WhoAmI ; Model : string ; var Result : CR_Baud_Result } ; var ReqCode : SOS_ReqCode ; StatusList : RS232_StList ; ReqRate : integer ; begin { CR_SetCommunications } Model_ID := 'Apple ///' ; Control := 12 ; Baud_Settable := true ; { Use a nested if-then-else structure here instead of a case statement because of the wide range of selector values involved. - acd } if Rate = 50 then ReqRate := 1 else if Rate = 75 then ReqRate := 2 else if Rate = 110 then ReqRate := 3 else if Rate = 135 then ReqRate := 4 else if Rate = 150 then ReqRate := 5 else if Rate = 300 then ReqRate := 6 else if Rate = 600 then ReqRate := 7 else if Rate = 1200 then ReqRate := 8 else if Rate = 1800 then ReqRate := 9 else if Rate = 2400 then ReqRate := 10 else if Rate = 3600 then ReqRate := 11 else if Rate = 4800 then ReqRate := 12 else if Rate = 7200 then ReqRate := 13 else if Rate = 9600 then ReqRate := 14 else if Rate = 19200 then ReqRate := 15 else ReqRate := UnknownRate ; if ReqRate = UnknownRate then Result := CR_BadRate else if Rate = CurrentBaud then Result := CR_SetOK else begin RS232Control( StatReq, StatusList ) ; if ioresult = 0 then begin StatusList.BaudRate := ReqRate ; RS232Control( CntlReq, StatusList ) ; end ; { ioresult = 0 } if ioresult = 0 then begin CurrentBaud := Rate ; Result := CR_SetOK end else begin Result := CR_BadRate ; end ; end { rate <> currentbaud } end ; { CR_SetCommunications } procedure CR_CommInit { Dir : CR_WhoAmI ; Attention_Char : Char ; var Remote_Exists : boolean ; var Dialer_Exists : boolean } ; var C : char ; Result : CR_Baud_Result ; procedure Not_There ( Which : integer ) ; begin { Not_There } GoToXY( 0, 10 ) ; writeln( ' ':20, 'Required unit #', Which, ' failed UnitClear!' ) ; Remote_Exists := false ; end ; { Not_There } begin { CR_CommInit } { Save RS232 control parameters } RS232Control( StatReq, StatusList ) ; { Check that required units exist. } Remote_Exists := true ; UnitClear( RemIn_Unit ) ; if IOResult <> 0 then Not_There ( RemIn_Unit ) ; UnitClear( RemOut_Unit ) ; if IOResult <> 0 then Not_There ( RemOut_Unit ) ; { The following call to CR_SetCommunications had to be moved here so that } { the proper baud was set BEFORE the call to SM_Attention tries to talk } { to the SmartModem. - acd 3 Jul 82 } CR_SetCommunications ( Default_Mode, Default_Parity, Default_Rate, Default_CharBits, Default_StopBits, CR_Orig, Default_Kind, Result ) ; if Result = CR_SelectNotSupported then BaudSettable := false else BaudSettable := true ; if not SM_Attention then if not SM_Attention then CR_Hook( Hung_Up ) ; Dialer_exists := Check_SmartModem_There ; Model_ID := '' ; DTR_State := CR_Auto ; RTS_State := CR_Auto ; CR_Hook( Hung_Up ) ; CR_AttenChar := Attention_Char ; end ; { CR_CommInit } procedure CR_CommQuit ; var C : char ; Result : CR_Baud_Result ; begin { CR_CommQuit } {$ifc debug} xxx := succ(xxx) ; writeln( DebugLog, '':xxx, 'entering CR_CommQuit' ) ; {$endc} if Unit_Carrier { If we think we are communicating, } then if not SM_Attention { ...get the SmartModem's attention } then if not SM_Attention then { do nothing } ; if SM_Attention then CR_Hook( Hung_Up ) ; { Now hang up the phone. } if Baud_Settable { If we were able to change the baud rate, } then CR_SetCommunications { ...reset to the default } ( Default_Mode, Default_Parity, Default_Rate, Default_CharBits, Default_StopBits, CR_Orig, Default_Kind, Result ) ; if SM_Attention then { 'Z' is software reset of the SmartModem. } C := SM_Execute_Command( 'Z', SM_Short_Wait ) ; {$ifc debug} writeln( DebugLog, '':xxx, 'exiting CR_CommQuit' ) ; xxx := pred(xxx) ; {$endc} { Restore RS232 control parameters } RS232Control( CntlReq, StatusList ) ; end ; { CR_CommQuit } {$P} { ------------------------------------------------------------------- } { Internal Subroutines } { ------------------------------------------------------------------- } procedure RS232Control { Request : ReqType ; VAR StatusList : RS232_StList } ; var ReqCode : SOS_ReqCode ; begin { RS232Control } with ReqCode do begin Channel := IO_Out ; StatOrCntl := Request ; RequestNum := 1 ; { Set/Retrieve control parameters } Reserved := 0 ; end ; if Request = StatReq then StatusList.BufferSize := sizeof( StatusList )-1 ; unitstatus( RemOut_Unit, StatusList, ReqCode ) ; end ; { RS232Control } function SM_Execute_Command { Cmd : string ; Wait_Count: integer ) : char } ; var Ch : char ; I : integer ; begin { SM_Execute_Command } {$ifc debug} xxx := succ(xxx) ; writeln( DebugLog, '':xxx, 'entering SM_Execute_Command ' ) ; {$endc} CR_Delay( 2 ) ; while CR_RemStat do { Flush trash } begin Ch := CR_GetRem ; end ; { "AT" is what the SmartModem requires at the start of each command line } CR_PutRem( 'A' ) ; CR_PutRem( 'T' ) ; CR_PutRem( ' ' ) ; for I := 1 to length( Cmd ) do { Output each command character } CR_PutRem( Cmd[I] ) ; CR_PutRem( chr(13) ) ; { Terminate command with } I := Wait_Count ; repeat if CR_KbStat { This allows a manual exit, using } then { from the keyboard } begin if CR_GetKb = CR_AttenChar then I := 0 ; end else I := pred( I ) until (I <= 0) or CR_RemStat ; { Loop until the counter goes } { to zero or something comes in } { on the Remote line. } if CR_RemStat { If something came from Remote line, } then begin Ch := CR_GetRem ; { fetch character from remote } Ch := chr( ord( Ch ) mod 128 ) ; { mask bit7 (shame, shame Hayes) } CR_Delay( 2 ) ; {$ifc debug} writeln( DebugLog, '':xxx, 'CR_GetRem = ', Ch ) ; {$endc} end else begin Ch := SM_Error ; { If we timed out, return an error. } CR_Delay( 2 ) ; {$ifc debug} writeln( DebugLog, '':xxx, 'CR_GetRem FAILED' ) ; {$endc} end ; SM_Execute_Command := Ch ; while CR_RemStat do begin Ch := CR_GetRem ; { Flush trash } end ; {$ifc debug} writeln( DebugLog, '':xxx, 'exiting SM_Execute_Command ' ) ; xxx := pred(xxx) ; {$endc} end ; { SM_Execute_Command } function Check_SmartModem_There { : boolean } ; { This function returns TRUE if the SmartModem responds to a simple command. It returns FALSE if the SmartModem does not understand the command or if no response is generated (such as when the SmartModem is not connected or the unit is being used with some other type of modem). } var B : boolean ; C : char ; begin { Check_SmartModem_There } {$ifc debug} xxx := succ(xxx) ; writeln( DebugLog, '':xxx, 'entering Check_Smartmodem_There ' ) ; {$endc} { The command sent has the following effects: "E" causes the SmartModem to suppress echoing command characters "V" causes the SmartModem to use abbreviated command responses } if SM_Execute_Command( SM_Defaults, SM_Short_Wait ) = SM_OK then Check_SmartModem_There := true else Check_SmartModem_There := false ; CR_Delay( 2 ) ; {$ifc debug} writeln( DebugLog, '':xxx, 'exiting Check_Smartmodem_There ' ) ; xxx := pred(xxx) ; {$endc} end ; { Check_SmartModem_There } function SM_Attention { : boolean } ; { This function will get the SmartModem's attention, regardless of the modems state. } var B : boolean ; begin { SM_Attention } {$ifc debug} xxx := succ(xxx) ; writeln( DebugLog, '':xxx, 'entering SM_Attention ' ) ; {$endc} if Check_SmartModem_There then SM_Attention := true else begin CR_Delay( 2 ) ; CR_Delay( 12 ) ; { Delay just over 1 second } CR_PutRem( '+' ) ; { "+++" is default attention getter. } CR_PutRem( '+' ) ; CR_PutRem( '+' ) ; CR_Delay( 12 ) ; { Delay just over 1 second } CR_PutRem( chr( CR ) ) ; SM_Attention := Check_SmartModem_There ; end ; CR_Delay( 2 ) ; {$ifc debug} writeln( DebugLog, '':xxx, 'exiting SM_Attention ' ) ; xxx := pred(xxx) ; {$endc} end ; { SM_Attention } {$P} { ------------------------------------------------------------------- } { Control Procedures } { ------------------------------------------------------------------- } procedure CR_Answer ; { *** UNTESTED *** } var C : char ; Connected : boolean ; Count : integer ; Ring : boolean ; Waiting : boolean ; begin { CR_Answer } if not SM_Attention then { null } ; C := SM_Execute_Command( concat('S0=', Answer_After), SM_Short_Wait ) ; Waiting := true ; while Waiting do begin Ring := CR_Ringing ; Waiting := not Ring ; if Waiting then if CR_KbStat then begin Waiting := (CR_GetKB <> CR_AttenChar) ; end ; end ; if Ring then begin UnitClear( RemIn_Unit ) ; UnitClear( RemOut_Unit ) ; Waiting := true ; Connected := false ; Count := 32000 ; repeat Count := succ( Count ) ; if CR_KbStat then Waiting := not (CR_GetKb = CR_AttenChar) else if CR_RemStat then begin Waiting := not (CR_GetRem = SM_Connect) ; Connected := not Waiting ; end else Waiting := (Count > 0) ; until not Waiting ; if not Connected then CR_Hook( Hung_Up ) ; end ; end ; { CR_Answer } procedure CR_Break ; const ReqCode = 14 ; { 0000000000001110 = $0E = 14 \____/\______/^^ | | |+-> I/O channel : 0 = Output | | +--> Request Type: 1 = Control | +-------> Request code: 3 = Transmit break signal +--------------> Reserved : (must be zero) } var BreakLength : PACKED ARRAY[ 0..0 ] OF Byte ; begin { CR_Break } BreakLength[0] := 1 ; UnitStatus( RemOut_Unit, BreakLength, ReqCode ) ; end ; { CR_Break } function CR_Carrier { : boolean } ; const ReqCode = 5 ; { 0000000000000101 = $05 = 5 \____/\______/^^ | | |+-> I/O channel : 1 = Input | | +--> Request Type: 0 = Status | +-------> Request code: 1 = Retrieve control parameters +--------------> Reserved : (must be zero) } var StatusList : RS232_StList ; begin { CR_Carrier } {$ifc false } StatusList.BufferSize := sizeof( RS232_StList )-1 ; UnitStatus( RemIn_Unit, StatusList, ReqCode ) ; CR_Carrier := not StatusList.Status.DCD_False ; Off_Hook := not StatusList.Status.DCD_False ; {$elsec } { Simulate carrier detect by following the hook status } CR_Carrier := UnitCarrier ; Off_Hook := UnitCarrier ; {$endc } end ; { CR_Carrier } function CR_ClearToSend { : boolean } ; { *** UNTESTED *** } const ReqCode = 12 ; { 0000000000001100 = $0C = 12 \____/\______/^^ | | |+-> I/O channel : 0 = Output | | +--> Request Type: 0 = Status | +-------> Request code: 3 = Retrieve driver buffer info +--------------> Reserved : (must be zero) } var ControlBlock : RS232_BufList ; begin { CR_ClearToSend } unitstatus( RemIn_Unit, ControlBlock, ReqCode ) ; with ControlBlock do if (CharsOut < OutBufSize) then CR_ClearToSend := true else CR_ClearToSend := false ; end ; { CR_ClearToSend } procedure CR_Delay { Tenths : integer } ; { Purpose: Delay 0.1 seconds for each tenth requested } { This implementation uses the non-obvious technique of issuing a SOS Console 'synchronize' request. This requests a delay until the next vertical retrace cycle of the video generator. Since these occur sixty times per second the iterated call will produce the requested delay +/- slightly less than 1/60 second. - acd } const SC_Synchronize = 22 ; { Apple /// screen control function # } var Count : integer ; Index : integer ; FnCode : integer ; begin { CR_Delay } FnCode := SC_Synchronize ; for Index := 1 to Tenths do for Count := 1 to 6 do UnitWrite( Crt_Unit, FnCode, 2,, 12 ) ; end ; { CR_Delay } procedure CR_Dial { Number : string ; WaitChar : char ; var Result : CR_Dial_Result } ; { This routine will cause the SmartModem to dial the number passed } var I : integer ; Cmd : string ; Valid_Set : set of char ; begin { CR_Dial } { Initialize valid character set } Valid_Set := [ 'p','P','t','T','*','#',';',WaitChar,'0'..'9' ] ; Result := CR_DialError ; { Assume an error } { Get SmartModem's attention } if not SM_Attention then exit( CR_Dial ) ; CR_Hook( Hung_Up ) ; { Be sure we know where we are } { Start the dial command with the dial prologue. (See the implementation constant list) } Cmd := SM_Dial_Prologue ; for I := 1 to length( Number ) do if Number[I] in Valid_Set { Include only valid characters } then { in the passed number } Cmd := concat( Cmd, copy( Number, I, 1 ) ) ; { Execute the dial command and be patient about the response } if SM_Execute_Command( Cmd, SM_Long_Wait ) = SM_Connect then begin { We got an answer & carrier } Result := CR_Off_Hook ; Unit_Carrier:= true ; end { No carrier. We may have } else Unit_Carrier := false ; { answer. We'll never know. } end ; { CR_Dial } function CR_DialTone ; begin { CR_DialTone } CR_DialTone := true ; end ; { CR_DialTone } procedure CR_Hook { On_Hook : boolean } ; begin { CR_Hook } if On_Hook { If we want to go on hook... } then begin if not SM_Attention { ...get the modem's attention } then if not SM_Attention then { null } ; { Send the "hang up" command } Off_Hook := not (SM_Execute_Command( 'H0', SM_Short_Wait) = SM_OK) ; end else Off_Hook := true ; Unit_Carrier := Off_Hook ; { The simulated carrier follows the } { status of the receiver. } end ; { CR_Hook } function CR_Ringing { : boolean } ; { *** UNTESTED *** } begin { CR_Ringing } if CR_RemStat then CR_Ringing := (SM_Ring = CR_GetRem) else CR_Ringing := false ; end ; { CR_Ringing } procedure CR_SetDTR ; begin { CR_SetDTR } { This should be 'do-able' with SOS calls (I think). - acd } end ; { CR_SetDTR } procedure CR_SetRTS ; begin { CR_SetRTS } { This should be 'do-able' with SOS calls (I think). - acd } end ; { CR_SetRTS } {$P} { ------------------------------------------------------------------- } { Status Procedures } { ------------------------------------------------------------------- } function CR_KbStat { : boolean } ; const ReqCode = 21 ; { 0000000000010101 = $15 = 21 \____/\______/^^ | | |+-> I/O channel : 1 = Input | | +--> Request Type: 0 = Status | +-------> Request code: 5 = Buffered keystroke count +--------------> Reserved : (must be zero) } var ReqList : packed record Enqueued : byte ; Unused : byte ; end ; begin { CR_KbStat } UnitStatus( Kb_Unit, ReqList, ReqCode ) ; if ReqList.Enqueued > 0 then CR_KbStat := true else CR_KbStat := false ; end ; { CR_KbStat } function CR_RemStat { : boolean } ; const ReqCode = 13 ; { 0000000000001101 = $0D = 13 \____/\______/^^ | | |+-> I/O channel : 1 = Input | | +--> Request Type: 0 = Status | +-------> Request code: 3 = Retrieve driver buffer info +--------------> Reserved : (must be zero) } var RemBufStat : RS232_BufList ; begin { CR_RemStat } UnitStatus( RemIn_Unit, RemBufStat, ReqCode ) ; if RemBufStat.CharsIn > 0 then CR_RemStat := true else CR_RemStat := false ; end ; { CR_RemStat } {$P} { ------------------------------------------------------------------- } { Input/Output Procedures } { ------------------------------------------------------------------- } function CR_GetKb { : char } ; var Ch : packed array [0..0] of char ; begin { CR_GetKb } UnitRead( KB_Unit, Ch[0], 1, 0, Control ) ; CR_GetKb := Ch[0] ; end ; { CR_GetKb } function CR_GetRem { : char } ; var Ch : packed array [0..0] of char ; begin { CR_GetRem } UnitRead( RemIn_Unit, Ch[0], 1, 0, Control ) ; {$ifc debug} { if ch in [' '..'~'] then write( DebugLog, ch ) ; } {$endc} CR_GetRem := Ch[0] ; end ; { CR_GetRem } procedure CR_PutRem { C : char } ; begin { CR_PutRem } {$ifc debug} write( DebugLog, c ) ; {$endc} UnitWrite( RemOut_Unit, C, 1, 0, Control ) ; end ; { CR_PutRem } {$P} begin { SmartUnit initialization } CR_AttenChar := chr(Esc) ; CR_Current_Port.Part1 := 0 ; CR_Current_Port.Part2 := 0 ; BaudSettable := false ; Control := 12 ; CurrentBaud := 0 ; { force initialization of baud } DTR_State := CR_Auto ; RTS_State := CR_Auto ; Off_Hook := false ; Unit_Carrier := Off_Hook ; Model_ID := Default_Kind ; unitclear( KB_Unit ) ; unitclear( RemIn_Unit ) ; unitclear( RemOut_Unit ) ; {$ifc debug} xxx := 0 ; reset( remote, '.RS232' ) ; reset( DebugLog, 'console:' ) ; {$endc} end { SmartUnit initialization }. ======================================================================================== DOCUMENT :usus Folder:VOL15:clr_break.text ======================================================================================== .PROC CLR_BREAK ; To clear break bit in CR_BREAK ; This external procedures is for use with the ; procedure CR_BREAK in REMUNIT for LSI-11s ; M. A. Ikezawa, 17 July 1981 XCSR .EQU 177524 BIC #1,@#XCSR MOV (SP)+,R0 JMP @R0 .END ======================================================================================== DOCUMENT :usus Folder:VOL15:comm.text ======================================================================================== program comm; { communicate with remote computer and upload/download text } { written by Jon Bondy. } const mdata = 129; { modem data port (both in and out) } mstat = 128; { modem status port } mcmd = 130; { modem command reg } mbaud = 128; { modem baud rate reg } mirpt = 131; { interrupt mask reg } mreset = 1; { reset device } m300b = 132; { 300 baud, 1 stop bits } mimask = 0; { enable no TUART interrupts } mmask = 64; { modem data available mask } cdata = 1; { console data port } kstat = 0; { console status port } kdata = 1; { keyboard data port } kmask = 2; { keyboard data available mask } esc = 27; command_ch = 1; { ^A prefixes commands (receive, send, quit) } lf = 10; cr = 13; cntl_s = 19; cntl_q = 17; bufmax = 30000; type byte = 0..255; var receiving : boolean; rcv_buff : packed array[0..bufmax] of byte; rcv_idx, i : 0..bufmax; next_block : integer; { next block to be written for out_file } data : byte; in_file : text; out_file : file; function pand(ch : byte; mask : integer) : integer; external; { procedure } function portread(addr : integer) : byte; external; { procedure } procedure portwrite(addr : integer; data : byte); external; function eparity(data : byte) : byte; external; { even parity in msb } { procedure } procedure initialize; begin writeln('Tele-communications program. Written by Jon Bondy 3/82.'); writeln('Enter to invoke commands.'); portwrite(mcmd,mreset); { reset TUART } portwrite(mbaud,m300b); { set to 300 baud } portwrite(mirpt,mimask); { disable all TUART interrupts } receiving := false; rcv_idx := 0; end; { initialize } function open_o_file : boolean; { procedure } var fname : string; ok : boolean; ch : char; begin repeat write('Enter Pascal file name for received data (".text" assummed) : '); readln(fname); if (length(fname) = 0) then begin open_o_file := false; exit(open_o_file); end; fname := concat(fname,'.text'); close(out_file); {$I-} reset(out_file,fname); { test if file exists } {$I+} ok := true; if (ioresult = 0) then begin write('Do you want to write over that file? '); read(ch); writeln; ok := false; if (ch = 'y') or (ch = 'Y') then ok := true; end; close(out_file); {$I-} if ok then rewrite(out_file,fname); {$I+} until (ioresult = 0) and ok; open_o_file := true; end; { open_o_file } function write_header : boolean; { procedure } var date_file : file; nblock : integer; date1, date2 : byte; begin { read in current date from system disk } {$I-} reset(date_file,'*'); nblock := blockread(date_file,rcv_buff[0],1,2); {$I+} if (nblock <> 1) or (ioresult <> 0) then begin writeln('Error during receive file initialization.'); close(date_file); write_header := false; exit(write_header); end; close(date_file); date1 := rcv_buff[20]; date2 := rcv_buff[21]; { create text file header } fillchar(rcv_buff[0],1024,chr(0)); rcv_buff[0] := 1; rcv_buff[114] := 1; { autoindent := true } rcv_buff[122] := 79; { right margin := 79 } rcv_buff[124] := 5; { paragraph margin := 5 } rcv_buff[126] := ord('^'); { command character := '^' } rcv_buff[128] := date1; rcv_buff[129] := date2; rcv_buff[130] := date1; rcv_buff[131] := date2; {$I-} nblock := blockwrite(out_file,rcv_buff[0],2,0); {$I+} if (nblock <> 2) or (ioresult <> 0) then begin writeln('Error during receive file initialization.'); close(out_file); write_header := false; end else write_header := true; end; { write_header } procedure start_receive; begin if not open_o_file then exit(start_receive); if not write_header then exit(start_receive); receiving := true; rcv_idx := 0; { just in case not cleaned up previously } next_block := 2; writeln(''); end; { start_receive } procedure close_out_file; var nc, nblock : integer; data_length, len : integer; from_index, to_index : integer; done : boolean; begin if (rcv_idx > bufmax) then nc := bufmax else nc := rcv_idx-1; { move characters to "right" of array } data_length := sizeof(rcv_buff) - 1; from_index := data_length - nc; moveright(rcv_buff[0],rcv_buff[from_index],nc+1); done := false; to_index := 0; { move 1024-byte blocks of chars to left, making sure lines are not split across block boundaries. } repeat if (from_index + 1023 < data_length - 1) then len := scan(-1024,=chr(cr),rcv_buff[from_index+1023]) + 1024 else begin len := data_length - from_index + 1; done := true; end; moveleft(rcv_buff[from_index],rcv_buff[to_index],len); from_index := from_index + len; fillchar(rcv_buff[to_index + len], 1024 - len, chr(0)); to_index := to_index + 1024; if (to_index > from_index) then begin writeln; writeln('Index overwrite error.'); end; until done; len := to_index div 512; nblock := blockwrite(out_file,rcv_buff[0],len,next_block); if (nblock <> len) or (ioresult <> 0) then begin writeln('Error during file write.'); end; close(out_file, lock); receiving := false; rcv_idx := 0; writeln(''); end; { close_out_file } procedure write_interim_buffer; var nc, nblock : integer; data_length, len : integer; from_index, to_index : integer; done : boolean; begin if (rcv_idx > bufmax) then nc := bufmax else nc := rcv_idx-1; { move characters to "right" of array } data_length := sizeof(rcv_buff) - 1; from_index := data_length - nc; moveright(rcv_buff[0],rcv_buff[from_index],nc+1); done := false; to_index := 0; { move 1024-byte blocks of chars to left, making sure lines are not split across block boundaries. } repeat if (from_index + 1023 < data_length - 1) then begin len := scan(-1024,=chr(cr),rcv_buff[from_index+1023]) + 1024; moveleft(rcv_buff[from_index],rcv_buff[to_index],len); from_index := from_index + len; fillchar(rcv_buff[to_index + len], 1024 - len, chr(0)); to_index := to_index + 1024; if (to_index > from_index) then begin writeln; writeln('Index overwrite error.'); end; end else done := true; { do not move last partial block } until done; { write data to disk } len := to_index div 512; {$I-} nblock := blockwrite(out_file,rcv_buff[0],len,next_block); {$I+} if (nblock <> len) or (ioresult <> 0) then begin writeln('Error during file write: receive aborted.'); close(out_file, lock); rcv_idx := 0; receiving := false; writeln(''); exit(write_interim_buffer); end; next_block := next_block + len; { start off with partial block in buffer after interim write } len := data_length - from_index + 1; moveleft(rcv_buff[from_index],rcv_buff[0],len); rcv_idx := len; end; { write_interim_buffer } procedure put_out_file; { buffer full, so put it on disk } var counter : integer; ch : char; begin { ask host computer to stop transmitting } portwrite(mdata,eparity(cntl_s)); { continue to receive chars while awaiting host pause } counter := 500; { counter will = 0 when host has stopped: timeout } while (counter > 0) do begin if (pand(portread(mstat),mmask) <> 0) then begin { modem receive char? } ch := chr(pand(portread(mdata),127)); { remove parity bit } portwrite(cdata,ord(ch)); { echo to crt } if (ch <> chr(lf)) then begin rcv_buff[rcv_idx] := ord(ch); rcv_idx := rcv_idx + 1; end; counter := 500; { try to time out again } end; { if } counter := counter - 1; end; { while } write_interim_buffer; portwrite(mdata,eparity(cntl_q)); { host may resume xmission } end; { put_out_file } function open_i_file : boolean; { procedure } var fname : string; begin repeat write('Enter Pascal file name for send data (".text" assummed) : '); readln(fname); if (length(fname) = 0) then begin open_i_file := false; exit(open_i_file); end; fname := concat(fname,'.text'); close(in_file); {$I-} reset(in_file,fname); {$I+} until (ioresult = 0); open_i_file := true; end; { open_i_file } procedure send_file; var abort : boolean; r_ch, s_ch : char; begin if not open_i_file then exit(send_file); abort := false; while not eof(infile) and not abort do begin if eoln(infile) then begin s_ch := chr(cr); readln(infile); end else read(infile,s_ch); { write to modem } portwrite(mdata,eparity(ord(s_ch))); r_ch := chr(128); repeat { abort send if key pressed during send } if (pand(portread(kstat),kmask) <> 0) then if (pand(portread(kdata),127) = esc) then abort := true; { see if modem received echo character yet } if (pand(portread(mstat),mmask) <> 0) then begin { read modem, remove parity bit } r_ch := chr(pand(portread(mdata),127)); { write char to CRT -- assume CRT is faster than modem } portwrite(cdata,ord(r_ch)); end; { if } until (s_ch = r_ch) or abort; end; { while } close(infile); if abort then begin writeln; r_ch := chr(pand(portread(kdata),127)); { clear keyboard ch } writeln(''); end else writeln(''); end; { send_file } procedure get_command; var ch : char; begin repeat writeln; write('Comm: R(eceive, S(end, C(lose, T(erminal, Q(uit : '); repeat until (pand(portread(kstat),kmask) <> 0); ch := chr(pand(portread(kdata),127)); until (ch in ['r','R','s','S','c','C','t','T','q','Q']); writeln; case ch of 'r','R' : start_receive; 's','S' : send_file; 'c','C' : close_out_file; 't','T' : begin end; { return to terminal mode } 'q','Q' : begin if (rcv_idx > 0) then close_out_file; exit(comm); end; end { case } end; { if } begin initialize; repeat { char ready from modem? } if (pand(portread(mstat),mmask) <> 0) then begin data := pand(portread(mdata),127); { remove parity bit } { transfer to CRT -- assume CRT is faster than modem } portwrite(cdata,data); if receiving and (data <> lf) then begin rcv_buff[rcv_idx] := data; rcv_idx := rcv_idx + 1; end; if (rcv_idx >= (bufmax - 1500)) then put_out_file; end; { read character from modem } { char ready from keyboard? } if (pand(portread(kstat),kmask) <> 0) then begin { read from keyboard } data := pand(portread(kdata),127); { clear msb } if (data = command_ch) then get_command else portwrite(mdata,eparity(data)); { assume kbd is slower than modem } end; { read character from keyboard } until false; end. { comm } ======================================================================================== DOCUMENT :usus Folder:VOL15:contents.text ======================================================================================== This file describes the files contained on this diskette. The files contain sources for two different separate compilation units, each of which was written to conform to the USUS Standard Remote Separate Compilation Unit of August 1981. One of the units makes no assumptions about the modem in use. The other requires the Hayes Microcomputer Products Smartmodem. The description of each group of files follows the directory listing of the files. HSM.TROOT.TEXT 16 5-Dec-81 6 Text HSM.TINC1.TEXT 16 5-Dec-81 22 Text HSM.TINC2.TEXT 14 5-Dec-81 38 Text These files contain TERMINAL, a terminal emulation program. This version of TERMINAL will emulate a dumb terminal as well as use the capabilities of auto-dial if the Remote Unit claims auto-dial support is available. The program is also able to: --Log received characters into a memory buffer and move the buffer to a user-named disk file. --Send a text file to the remote system. --Send logon text to the remote system. --Change log files during a session. --Purge the log file upon user request. --Optionally respond to Compuserve's VideoTex CRT control codes. See the source code for additional comments. To use the program, first compile a USUS Remote Unit. Edit HSM.TROOT.TEXT's unit reference to point to the Unit's code file. Compile using HSM.TROOT.TEXT as the compiler input file. Using LIBRARY, create a code file containing both the output of the HSM.TROOT.TEXT compile and the Remote Unit object code. HSM.UROOT.TEXT 22 5-Dec-81 52 Text HSM.UINC1.TEXT 16 5-Dec-81 74 Text HSM.UINC2.TEXT 14 22-Dec-81 158 Text These files contain an implemetation of the USUS Remote Separate Compilation Unit of August 1981 which expects to use a Hayes Smartmodem. To use the unit, compile HSM.UROOT.TEXT after editing in any changes required in the CR_SETCOMMUNICATIONS routine. See the comments in HSM.UROOT.TEXT for additional guidance. STD.UNIT.TEXT 24 16-Nov-81 90 Text STD.UNIT.CODE 11 22-May-82 114 Code This implementation of the USUS Remote Unit assumes the minimum about the communications connection. It is useful when using an acoustic coupler environment or direct connect modem which does not have auto-dial capabilities, as well as in hardwire situations. It does assume a synchronous BIOS and a standard implementation of UnitStatus, UnitRead, and UnitWrite. It has been compiled under IV.0 and used extensively. USERLIB.TEXT 4 22-May-82 139 Text This is a user library file that points to the standard unit's code file. By entering "x" followed by "TERM.MAIN L=USERLIB" one executes the most recent version of TERMINAL. TERM.EMUL.TEXT 10 29-May-82 172 Text TERM.MAIN.TEXT 20 29-May-82 182 Text TERM.INIT.TEXT 22 29-May-82 202 Text TERM.LOG.TEXT 14 29-May-82 125 Text TERM.UTIL.TEXT 22 3-Jun-82 232 Text TERM.MAIN.CODE 32 3-Jun-82 254 Code These files also contain the source and object of TERMINAL. However, this version is much improved over the other. The code file is for version IV.0 and has been used extensively. New and improved features of this version include: 1) The memory buffer is moved to disk using BLOCKWRITE, instead of the much slower WRITE/WRITELN. In addition, the file created is a legal text file. That is, each block pair ends with followed by nulls. 2) TERMINAL tells you how large the log file is in blocks. This allows you to monitor the file size in case your available space is limited. 3) The Menu has more information in it. The options selected, the name of the log file, and the logon text selected are all displayed in the menu. 4) When returning to terminal emulation from the menu, the last 10 lines of the log file are redisplayed. 5) The program has been reorganized and segmented to fit smaller machines (like my 56K 8080). 6) Logon text, previously compiled into the program, is now stored in a file, along with default option settings. The file can reside on any blocked volume in the set [4,5,9..17]. The program will search first the prefix volume, then the system volume, then #4, #5, #9, and up to #17:. The segmentation uses more segments than are available in some versions of the p-System. This may result in compile errors under I.4, I.5, and II.x if some routines are not removed from the list of segment procedures. See the documentation in TERM.MAIN.TEXT for additional information. To use the program, first compile a USUS Remote Unit. Edit TERM.MAIN.TEXT's unit reference to point to the Unit's code file. Compile using TERM.MAIN.TEXT as the compiler input file. Using LIBRARY, create a code file containing both the output of the HSM.TROOT.TEXT compile and the Remote Unit object code or use a user library. If questions come up regarding programs contained on this volume, contact the author at Bob Peterson P.O. Box 1686 Plano, Texas 75074 (214) 995-0618 Central time zone business hours 70235,326 on Compuserve via EMail or MUSUS *BVL1707 or *ZLZ1912 on GTE Telemail ======================================================================================== DOCUMENT :usus Folder:VOL15:hsm.uinc1.text ======================================================================================== PROCEDURE SETCOMMUNICATIONS( PARITY : boolean ; EVEN : boolean ; RATE : integer ; CHARBITS : integer ; STOPBITS : integer ; DIR : CR_WHOAMI ; MODEL : string ; var RESULT : CR_BAUD_RESULT ) ; begin MODEL_ID := '' ; BAUD_SETTABLE := false ; RESULT := CR_SELECT_NOT_SUPPORTED ; if length( MODEL )>2 then if (copy(MODEL,1,3) = '990') then RESULT := CR_SET_OK ; CONTROL := 12 ; end ; { SETCOMMUNICATIONS } PROCEDURE COMMINIT( DIR : CR_WHOAMI ; ATTENTION_CHAR : CHAR ; VAR REMOTE_EXISTS : BOOLEAN ; VAR DIALER_EXISTS : BOOLEAN ) ; VAR C : CHAR ; RESULT : CR_BAUD_RESULT ; PROCEDURE NOT_THERE( WHICH : INTEGER ) ; BEGIN GOTOXY( 0, 10 ) ; WRITELN(' ':20, 'Required unit #', WHICH, ' failed UNITCLEAR!') ; REMOTE_EXISTS := FALSE ; END ; BEGIN { Check that the required units exist. } REMOTE_EXISTS := TRUE ; UNITCLEAR( REMIN_UNIT ) ; IF IORESULT <> 0 THEN NOT_THERE( REMIN_UNIT ) ; UNITCLEAR( REMOUT_UNIT ) ; IF IORESULT <> 0 THEN NOT_THERE( REMOUT_UNIT ) ; IF NOT SM_ATTENTION THEN IF NOT SM_ATTENTION THEN CR_HOOK( HUNG_UP ) ; DIALER_EXISTS := CHECK_SMARTMODEM_THERE ; MODEL_ID := '' ; DTR_STATE := CR_AUTO ; RTS_STATE := CR_AUTO ; CR_HOOK( HUNG_UP ) ; CR_ATTENCHAR := ATTENTION_CHAR ; SETCOMMUNICATIONS( DEFAULT_MODE, DEFAULT_PARITY, DEFAULT_RATE, DEFAULT_CHARBITS, DEFAULT_STOPBITS, CR_ORIG, DEFAULT_KIND, RESULT ) ; BAUD_SETTABLE := RESULT = CR_SELECT_NOT_SUPPORTED ; END ; { COMMINIT } PROCEDURE COMMQUIT ; VAR C : CHAR ; RESULT : CR_BAUD_RESULT ; BEGIN IF UNIT_CARRIER { If we think we are communicating, } THEN IF NOT SM_ATTENTION { . . . get the Smartmodem's attention, } THEN IF NOT SM_ATTENTION THEN { Null } ; IF SM_ATTENTION THEN CR_HOOK( HUNG_UP ) ; { Now hang up the phone. } IF BAUD_SETTABLE { If we were able to change the baud rate, } THEN SETCOMMUNICATIONS( { . . . reset to the default. } DEFAULT_MODE, DEFAULT_PARITY, DEFAULT_RATE, DEFAULT_CHARBITS, DEFAULT_STOPBITS, CR_ORIG, DEFAULT_KIND, RESULT ) ; IF SM_ATTENTION THEN { "Z" is a software reset of the Smartmodem. } C := SM_EXECUTE_COMMAND( 'Z', SM_SHORT_WAIT ) ; END ; { COMMQUIT } { End of procedures set up for change to Segment Procedures. } PROCEDURE CR_SETADDRESS{ HIGHADDR : INTEGER ; LOWADDR : INTEGER ; VECTOR : INTEGER } ; BEGIN SETADDRESS( HIGHADDR, LOWADDR, VECTOR ) ; END ; PROCEDURE CR_SETCOMMUNICATIONS{ PARITY : boolean ; EVEN : boolean ; RATE : integer ; CHARBITS : integer ; STOPBITS : integer ; DIR : CR_WHOAMI ; MODEL : string ; var RESULT : CR_BAUD_RESULT } ; BEGIN SETCOMMUNICATIONS( PARITY, EVEN, RATE, CHARBITS, STOPBITS, DIR, MODEL, RESULT ) ; END ; PROCEDURE CR_SETDTR ; BEGIN END ; PROCEDURE CR_SETRTS ; BEGIN END ; PROCEDURE CR_COMMINIT{ DIR : CR_WHOAMI ; ATTENTION_CHAR : CHAR ; VAR REMOTE_EXISTS : BOOLEAN ; VAR DIALER_EXITST : BOOLEAN } ; BEGIN COMMINIT( DIR, ATTENTION_CHAR, REMOTE_EXISTS, DIALER_EXISTS ) ; END ; PROCEDURE CR_COMMQUIT ; BEGIN COMMQUIT ; END ; {$P+} { --------------------------------------------------------- } { Internal Subroutines } { --------------------------------------------------------- } FUNCTION SM_EXECUTE_COMMAND{ CMD : STRING ; WAIT_COUNT : INTEGER ) : CHAR } ; VAR CH : CHAR ; I : INTEGER ; BEGIN CR_DELAY( 2 ) ; WHILE CR_REMSTAT DO CH := CR_GETREM ; { Flush trash } { "AT" is what the Smartmodem requires at the start of each command line. } CR_PUTREM( 'A' ) ; CR_PUTREM( 'T' ) ; CR_PUTREM( ' ' ) ; FOR I := 1 TO LENGTH( CMD ) DO { Output each command char. } CR_PUTREM( CMD[I] ) ; CR_PUTREM( CHR(13) ) ; { Terminate command with } I := WAIT_COUNT ; REPEAT { Wait for a response. } I := I - 1 ; IF CR_KBSTAT { This allows a manual exit, using } THEN { from the } IF CR_GETKB = CR_ATTENCHAR { keyboard. } THEN I := 0 ; UNTIL (I <= 0) OR CR_REMSTAT ; { Loop until the counter goes to zero or something comes in from the Remote line. } IF CR_REMSTAT { If something came from the remote line, } THEN BEGIN CH := CR_GETREM ; { fetch character from Remote. } IF ORD( CH ) > 127 THEN CH := CHR( ORD( CH ) - 128 ) ; CR_DELAY( 2 ) ; END ELSE BEGIN CH := SM_ERROR ; { If we timed out, return an error. } CR_DELAY( 2 ) ; END ; SM_EXECUTE_COMMAND := CH ; WHILE CR_REMSTAT DO CH := CR_GETREM ; { Flush trash } END ; FUNCTION CHECK_SMARTMODEM_THERE { : BOOLEAN } ; { This function returns TRUE if the Smartmodem responds to a simple command. It returns FALSE if the Smartmodem does not understand the command or if no response is generated (such as when the Smartmodem is not connected or the unit is being used with some other type of modem.) } VAR B : BOOLEAN ; C : CHAR ; BEGIN { The command sent has the following effects: "E" causes the Smartmodem to suppress echoing command characters "V" causes the Smartmodem to use abbreviated command responses } C := SM_EXECUTE_COMMAND( SM_DEFAULTS, SM_SHORT_WAIT ) ; IF ORD( C ) > 127 THEN C := CHR( ORD( C ) - 128 ) ; B := SM_OK = C ; CR_DELAY( 2 ) ; CHECK_SMARTMODEM_THERE := B ; END ; FUNCTION SM_ATTENTION { : BOOLEAN } ; { This function will get the Smartmodem's attention, irregardless of the modem's state. } VAR B : BOOLEAN ; BEGIN CR_SETDTR( CR_OFF ) ; { If the user has implemented this routine, setting DTR low will get the Smartmodem's attention. } CR_SETDTR( CR_AUTO ) ; B := CHECK_SMARTMODEM_THERE ; IF NOT B THEN BEGIN CR_DELAY( 2 ) ; CR_DELAY( 12 ) ; { Delay just over 1 second } CR_PUTREM( '+' ) ; { "+++" is the default attention getter. } CR_PUTREM( '+' ) ; CR_PUTREM( '+' ) ; CR_DELAY( 12 ) ; { Delay just over 1 second } CR_PUTREM( CHR( CR ) ) ; B := CHECK_SMARTMODEM_THERE ; END ; CR_DELAY( 2 ) ; SM_ATTENTION := B ; END ; ======================================================================================== DOCUMENT :usus Folder:VOL15:hsm.uinc2.text ======================================================================================== {$P+} { --------------------------------------------------------- } { Control Procedures } { --------------------------------------------------------- } PROCEDURE CR_ANSWER ; { ** UNTESTED ** } VAR C : CHAR ; CONNECTED : BOOLEAN ; COUNT : INTEGER ; RING : BOOLEAN ; WAITING : BOOLEAN ; BEGIN IF NOT SM_ATTENTION THEN ; { null } C := SM_EXECUTE_COMMAND( CONCAT( 'S0=', ANSWER_AFTER ), SM_SHORT_WAIT ) ; WAITING := TRUE ; WHILE WAITING DO BEGIN RING := CR_RINGING ; WAITING := NOT RING ; IF WAITING THEN IF CR_KBSTAT THEN WAITING := CR_GETKB <> CR_ATTENCHAR ; END ; IF RING THEN BEGIN UNITCLEAR( REMIN_UNIT ) ; UNITCLEAR( REMOUT_UNIT ) ; WAITING := TRUE ; CONNECTED := FALSE ; COUNT := 32000 ; REPEAT COUNT := COUNT - 1 ; IF CR_KBSTAT THEN WAITING := NOT (CR_GETKB = CR_ATTENCHAR) ELSE IF CR_REMSTAT THEN BEGIN WAITING := NOT (CR_GETREM = SM_CONNECT) ; CONNECTED := NOT WAITING ; END ELSE WAITING := COUNT > 0 ; UNTIL NOT WAITING ; IF NOT CONNECTED THEN CR_HOOK( HUNG_UP ) ; END ; END ; { CR_ANSWER } PROCEDURE CR_BREAK ; BEGIN END ; function CR_CARRIER{: boolean}; begin CR_CARRIER := UNIT_CARRIER ; OFF_HOOK := UNIT_CARRIER ; end ; { CR_CARRIER } FUNCTION CR_CLEARTOSEND{ : BOOLEAN } ; BEGIN CR_CLEARTOSEND := TRUE ; END ; { CR_CLEARTOSEND } procedure CR_DELAY{ TENTHS : integer } ; { Purpose: delay 0.1 seconds for each tenth requested. } var clock : T_CLOCK ; I : integer ; J : integer ; begin I := TENTHS ; while i > 0 do begin I := I - 1 ; J := TIMER ; while j > 0 do j := j - 1 ; end ; end ; { CR_DELAY } PROCEDURE CR_DIAL{ NUMBER : STRING ; WAITCHAR : CHAR ; VAR RESULT : CR_DIAL_RESULT } ; { This routine will cause the Smartmodem to dial the number passed. } VAR I : INTEGER ; CMD : STRING ; VALID_SET : SET OF CHAR ; BEGIN { Initialize valid character set } VALID_SET := [ 'P', 'T', '*', '#', ';', WAITCHAR, '0', '1', '2', '3', '4', '5','6', '7', '8', '9' ] ; RESULT := CR_DIALERROR ; { Assume an error } { Get Smartmodem's attention. } IF NOT SM_ATTENTION THEN EXIT( CR_DIAL ) ; CR_HOOK( HUNG_UP ) ; { Be sure we know where we are. } { Start the dial command with the dial prologue. (See the Implementation Constant list.) } CMD := SM_DIAL_PROLOGUE ; FOR I := 1 TO LENGTH( NUMBER ) DO IF NUMBER[I] IN VALID_SET { Include only valid characters } THEN { in the passed number. } CMD := CONCAT( CMD, COPY( NUMBER, I, 1 ) ) ; { Execute the dial command and be patient about the response.} IF SM_EXECUTE_COMMAND( CMD, SM_LONG_WAIT ) = SM_CONNECT THEN BEGIN { We got an answer & carrier. } RESULT := CR_OFF_HOOK ; UNIT_CARRIER := TRUE ; END ELSE { No carrier. We may have an } UNIT_CARRIER := FALSE ; { answer. We'll never know. } END ; { CR_DIAL } FUNCTION CR_DIALTONE ; BEGIN CR_DIALTONE := TRUE ; END ; PROCEDURE CR_HOOK{ ON_HOOK : BOOLEAN } ; BEGIN IF ON_HOOK { If we want to go on-hook, } THEN BEGIN IF NOT SM_ATTENTION { . . . get the modem's attention. } THEN IF NOT SM_ATTENTION THEN ; { Send the "hang up" command. } OFF_HOOK := NOT (SM_EXECUTE_COMMAND( 'H0', SM_SHORT_WAIT ) = SM_OK) END ELSE OFF_HOOK := TRUE ; UNIT_CARRIER := OFF_HOOK ; { The simulated carrier follows the status of the reciever. } END ; { CR_HOOK } FUNCTION CR_RINGING { : BOOLEAN } ; { ** UNTESTED ** } BEGIN IF CR_REMSTAT THEN CR_RINGING := SM_RING = CR_GETREM ELSE CR_RINGING := FALSE ; END ; {$P+} { --------------------------------------------------------- } { Status Procedures } { --------------------------------------------------------- } FUNCTION CR_KBSTAT{ : BOOLEAN } ; VAR A : TRICK ; BEGIN UNITSTATUS( KB_UNIT, A, 1 ) ; CR_KBSTAT := A.I > 0 ; END ; { CR_KBSTAT } FUNCTION CR_REMSTAT{ : BOOLEAN } ; VAR A : TRICK ; BEGIN UNITSTATUS( REMIN_UNIT, A, 1 ) ; CR_REMSTAT := A.I > 0 ; END ; { CR_REMSTAT } {$P+} { --------------------------------------------------------- } { Input/Output Procdures } { --------------------------------------------------------- } FUNCTION CR_GETKB{ : CHAR } ; VAR ARAY : TRICK ; BEGIN UNITREAD( KB_UNIT, ARAY.A, 1,, 12 ) ; CR_GETKB := ARAY.A[0] ; END ; { CR_GETKB } FUNCTION CR_GETREM{ : CHAR } ; VAR ARAY : TRICK ; BEGIN UNITREAD( REMIN_UNIT, ARAY.A, 1,, CONTROL ) ; CR_GETREM := ARAY.A[0] ; END ; { CR_GETREM } PROCEDURE CR_PUTREM{ C : CHAR } ; VAR P : TRICK ; BEGIN P.A[0] := C ; UNITWRITE( REMOUT_UNIT, P.A, 1, 0, CONTROL ) ; END ; { CR_PUTREM } ======================================================================================== DOCUMENT :usus Folder:VOL15:hsm.uroot.text ======================================================================================== UNIT REMUNIT ;{ IV.0 w/ SMARTMODEM}{xL Printer: }{xL+} INTERFACE {============== Copyright Notice =============================================} {$c Copyright 1980, 1981 by Robert W. Peterson. All Rights Reserved. } {============== Copyright Notice =============================================} { This is a separate compilation unit intended to stand between application code and a communication line. Implementation of this unit follows the specifications and suggestions set out in the USUS (UCSD p-System User Society) Remote Unit Standard of August, 1981. This unit is specifically intended for the following communications environment: 1) A p-System which implements Unitstatus, Unitread and Unitwrite in the standard manner. 2) The modem in use is a Hayes Microcomputer Products, Inc., Smartmodem with the factory option switch settings. This unit is designed to interface to the model codes defined in the include file "SMART.TINC.TEXT". The following routines are not functional: CR_BREAK CR_CLEARTOSEND CR_DIALTONE CR_SETADDRESS CR_SETDTR CR_SETRTS The following routines contain calls to UnitClear: CR_ANSWER CR_COMMINIT There is code near the end of this unit which is IV.0 dependent. For versions of the p-System(tm) other than IV.0, this code must be moved to CR_COMMINIT. The author may be contacted as follows: USMail: Robert W. Peterson P.O. Box 1686 Plano, Texas 75074 GTE Telemail: *BVL1707 Compuserve: 70235,326 (usually via EMAIL or the MUSUS SIG) Change Log ====== === Date What change was made & Who made the change --------- ---------------------------------------------------------------- 5 Dec 81 Remove 990 specific code. Remove Segment procedures-Bob Peterson 5 Dec 81 Partition the source to fit memory-bound editor - Bob Peterson 2 Dec 81 Remove compile conditionals and debug stuff - Bob Peterson 19 Nov 81 Add compile conditionals for debugging and Segments-Bob Peterson 26 Oct 81 Convert from Polymorphic to 990 25 Aug 81 Bring up to actually adopted standard - Bob Peterson 25 Aug 81 Add Hayes Smartmodem support - Bob Peterson 3 Aug 81 Convert to IV.0 - Bob Peterson 28 Mar 81 Original code - Bob Peterson =============================================================================} {$P+} TYPE CR_BAUD_RESULT = ( CR_BAD_PARAMETER, CR_BAD_RATE, CR_SET_OK, CR_SELECT_NOT_SUPPORTED ) ; CR_DIALRESULT = ( CR_OFF_HOOK, CR_DIALERROR, CR_NOAUTODIAL ) ; CR_REM_PORT = PACKED RECORD PART1 : INTEGER ; PART2 : INTEGER ; END ; { CR_REM_PORT } CR_STATE = ( CR_ON, CR_OFF, CR_AUTO ) ; CR_WHOAMI = ( CR_ORIG, CR_ANS ) ; VAR CR_ATTENCHAR : CHAR ; CR_CURRENT_PORT : CR_REM_PORT ; { Initialization and termination routines. } PROCEDURE CR_COMMINIT( DIR : CR_WHOAMI ; ATTENTION_CHAR : CHAR ; VAR REMOTE_EXISTS : BOOLEAN ; VAR DIALER_EXISTS : BOOLEAN ) ; PROCEDURE CR_COMMQUIT ; { Input status. } FUNCTION CR_KBSTAT : BOOLEAN ; FUNCTION CR_REMSTAT : BOOLEAN ; { Input/Output operations. } FUNCTION CR_GETKB : CHAR ; FUNCTION CR_GETREM : CHAR ; PROCEDURE CR_PUTREM( C : CHAR ) ; { Control procedures. } PROCEDURE CR_ANSWER ; PROCEDURE CR_BREAK ; FUNCTION CR_CARRIER : BOOLEAN ; FUNCTION CR_CLEARTOSEND : BOOLEAN ; PROCEDURE CR_DELAY( TENTHS : INTEGER ) ; PROCEDURE CR_DIAL( NUMBER : STRING ; WAITCHAR : CHAR VAR RESULT : CR_DIALRESULT ) ; FUNCTION CR_DIALTONE : BOOLEAN ; PROCEDURE CR_HOOK( ON_HOOK : BOOLEAN ) ; FUNCTION CR_RINGING : BOOLEAN ; PROCEDURE CR_SETADDRESS(HIGHADDR : INTEGER ; LOWADDR : INTEGER ; VECTOR : INTEGER ) ; PROCEDURE CR_SETCOMMUNICATIONS( PARITY : BOOLEAN ; EVEN : BOOLEAN ; RATE : INTEGER ; CHARBITS : INTEGER ; STOPBITS : INTEGER ; DIR : CR_WHOAMI ; MODEL : STRING ; VAR RESULT : CR_BAUD_RESULT ) ; PROCEDURE CR_SET_DTR( NEW_STATE : CR_STATE ) ; PROCEDURE CR_SET_RTS( NEW_STATE : CR_STATE ) ; IMPLEMENTATION {$P+}{ Page here so the option is not in the interface text. } CONST ANSWER_AFTER = '3' ; { Answer after this many rings} CR = 13 ; { Carriage Return } DEFAULT_RATE = 300 ; DEFAULT_MODE = TRUE ; { Default to parity enabled. } DEFAULT_PARITY = TRUE ; { Default to even parity. } DEFAULT_CHARBITS = 7 ; { Default to seven data bits.} DEFAULT_KIND = '990/5'; { Default model code. } DEFAULT_STOPBITS = 1 ; { Default to one stop bits. } HUNG_UP = TRUE ; KB_UNIT = 2 ; REMIN_UNIT = 7 ; REMOUT_UNIT = 8 ; TIMER = 600 ; { Smartmodem return codes: } SM_OK = '0' ; SM_CONNECT = '1' ; SM_RING = '2' ; SM_NO_CARRIER = '3' ; SM_ERROR = '4' ; { Default S6 =wait for dial tone in seconds 2 S7 =wait for carrier in seconds 30 S8 =pause time for comma in seconds 2 S9 =carrier detector response time in tenths of a second 6 S10=delay between loss of carrier and hangup, in seconds 7 S11=TouchTone duration and spacing in milliseconds 70 S12=escape code guard time in 50ths of a second 50 } SM_DEFAULTS = 'EV S10=4 S12=10' ; SM_DIAL_PROLOGUE = 'DT' ; { D=dial command; T=use tone dialing } SM_LONG_WAIT = 32000 ; SM_SHORT_WAIT = 500 ; TYPE T_CLOCK = record case boolean of { NOTE: TI uses binary representation for long integers. } true : ( ticks : integer[ 4 ] ) ; false : ( hitime : integer ; lotime : integer ) ; end ; { case } TRICK = PACKED RECORD CASE INTEGER OF 1:(A : PACKED ARRAY[0..80] OF CHAR); 2:(S : STRING[80]); 3:(I : INTEGER; J : INTEGER); 4:(L : ARRAY[0..39] OF INTEGER); 5:(B : ARRAY[0..39] OF BOOLEAN); 6:(C : PACKED RECORD CHARL : CHAR ; CHARR : CHAR END ) ; END ; { TRICK } VAR BAUD_SETTABLE : BOOLEAN ; CONTROL : INTEGER ; CURRENT_BAUD : INTEGER ; DTR_STATE : CR_STATE ; MODEL_ID : STRING ; OFF_HOOK : BOOLEAN ; RTS_STATE : CR_STATE ; UNIT_CARRIER : BOOLEAN ; FUNCTION SM_EXECUTE_COMMAND( CMD : STRING ; WAIT_COUNT : INTEGER ) : CHAR ; FORWARD ; FUNCTION CHECK_SMARTMODEM_THERE : BOOLEAN ; FORWARD ; FUNCTION SM_ATTENTION : BOOLEAN ; FORWARD ; {$P+} { --------------------------------------------------------- } { Initialization/Termination Procedures } { --------------------------------------------------------- } { The following procedures are set up this way so that in IV.0 it is a simple matter to Segment the actual code. These are not time-critical routines, so even the small delay caused by the indirect call does not matter. To make these into IV.0 Segment procedures, simply add "SEGMENT" just before the "PROCEDURE" keyword. } PROCEDURE SETADDRESS( HIGHADDR : INTEGER ; LOWADDR : INTEGER ; VECTOR : INTEGER ) ; BEGIN WITH CR_CURRENT_PORT DO BEGIN PART1 := HIGHADDR ; PART2 := LOWADDR ; END ; END ; { SETADDRESS } {$I HSM.UINC1.TEXT } {$I HSM.UINC2.TEXT } {$P+} BEGIN { ******************************************************************* } { ******************************************************************* } { This code is initialization code. Leave it here for } { IV.0 but move it to CR_COMMINIT for any other version. } { Under IV.0, this code is guaranteed to be executed before } { any other code in this unit. } { ******************************************************************* } { ******************************************************************* } CR_ATTENCHAR := CHR( 5 ) ; { E } CR_CURRENT_PORT.PART1 := 0 ; CR_CURRENT_PORT.PART2 := 0 ; BAUD_SETTABLE := FALSE ; CONTROL := 12 ; CURRENT_BAUD := 300 ; DTR_STATE := CR_AUTO ; MODEL_ID := '' ; OFF_HOOK := FALSE ; RTS_STATE := CR_AUTO ; UNIT_CARRIER := FALSE ; { ******************************************************************* } { ******************************************************************* } { End of IV.0 initialization code. } { ******************************************************************* } { ******************************************************************* } *** ; { In any version other than IV.0, remove this line. } END. ======================================================================================== DOCUMENT :usus Folder:VOL15:iounit.text ======================================================================================== UNIT IOUNIT; {This is an implememtation dependent unit for LSI-11's. It allow direct access to the hardware buffers so the i/o can be accomplished directly without the intervention of the OS. It may be necessary to disable interrupts at a port if characters are to be read from that port as the interrupt driven OS has a tendency to snatch them away before you can get your hands on them. george w. schreyer} INTERFACE TYPE CHAR_POINTER = ^CHAR; WORD = PACKED ARRAY[0..15] OF BOOLEAN; WORD_POINTER = ^WORD; VAR MODEM_RBUF : CHAR_POINTER; MODEM_RCSR : WORD_POINTER; MODEM_XBUF : CHAR_POINTER; MODEM_XCSR : WORD_POINTER; PRINT_RBUF : CHAR_POINTER; PRINT_RCSR : WORD_POINTER; PRINT_XBUF : CHAR_POINTER; PRINT_XCSR : WORD_POINTER; CRT_RBUF : CHAR_POINTER; CRT_RCSR : WORD_POINTER; CRT_XBUF : CHAR_POINTER; CRT_XCSR : WORD_POINTER; BIT : WORD; PROCEDURE VER_IOUNIT; PROCEDURE SET_UP_POINTERS; (******************) IMPLEMENTATION PROCEDURE VER_IOUNIT ; BEGIN WRITELN('uses iounit version 1 5-Aug-81'); END; PROCEDURE SET_UP_POINTERS; {sets values of pointers} TYPE REP = (POINTREP,INTREP); {this procedure adapted from SMARTREMOT in USUS library} TTT = (WORDREF,BITREP); ALIAST = RECORD CASE REP OF POINTREP: (POINTVAL : CHAR_POINTER); INTREP : (INTVAL : INTEGER); END; BUFFER = RECORD CASE TTT OF WORDREF : (WORDVAL : WORD_POINTER); BITREP : (INTVALX : INTEGER); END; VAR ALIAS : ALIAST; XBUFFER : BUFFER; {the negative numbers below are two's complement representations of the addresses (octal) of various places in the I/O page. The addresses used conform to UCSD and RT-11 standard conventions. Although not important here, the vector is 200.} BEGIN ALIAS.INTVAL := -182; {printer rbuf, 177512} PRINT_RBUF := ALIAS.POINTVAL; XBUFFER.INTVALX := -184; {printer rcsr, 177510} PRINT_RCSR := XBUFFER.WORDVAL; ALIAS.INTVAL := -178; {printer xbuf, 177516} PRINT_XBUF := ALIAS.POINTVAL; XBUFFER.INTVALX := -180; {printer xcsr, 177514} PRINT_XCSR := XBUFFER.WORDVAL; (*********) ALIAS.INTVAL := -170; {modem xbuf, 177526} MODEM_XBUF := ALIAS.POINTVAL; XBUFFER.INTVALX := -172; {modem xcsr, 177524} MODEM_XCSR := XBUFFER.WORDVAL; ALIAS.INTVAL := -174; {modem rbuf, 177522} MODEM_RBUF := ALIAS.POINTVAL; XBUFFER.INTVALX := -176; {modem rcsr, 177520} MODEM_RCSR := XBUFFER.WORDVAL; (********) ALIAS.INTVAL := -138; {console xbuf, 177566} CRT_XBUF := ALIAS.POINTVAL; XBUFFER.INTVALX := -140; {console xcsr, 177564} CRT_XCSR := XBUFFER.WORDVAL; ALIAS.INTVAL := -142; {console rbuf, 177562} CRT_RBUF := ALIAS.POINTVAL; XBUFFER.INTVALX := -144; {console rcsr, 177560} CRT_RCSR := XBUFFER.WORDVAL; END; {initpointer} END. ======================================================================================== DOCUMENT :usus Folder:VOL15:remtalk.text ======================================================================================== { Mark Allen's Box to Box Talker } {$I-,R-} program talker; const readunit=7; writeunit=8; filestringsize=40; blockmax=511; {# of bytes in a packet - 1. must be (512/(2**n))-1 n=0..7} tempmax=686; {=ceiling((blockmax+1)*4/3)+4 - 1 (4 for checksum)} type commands= (nocommand,sendblock,resendblock,getblock,regetblock, resetfile,rewritefile,gotoprompt,closefile,success, sumerror,diskerror,closerror,openerror); setofchar=set of char; bufftype=packed array[0..0,0..blockmax] of char; var commandtoch:packed array[commands] of char; chtocommand:packed array[char] of commands; ch:packed array[0..1] of char; tempbuff:packed array[0..tempmax] of 0..255; f:file; C : TEXT; ReDir : BOOLEAN; buff:^bufftype; charcnt,buffpos,bufffirst,bufflast,buffsize:integer; buffbyte:packed record case integer of 0:(int:integer); 1:(bit05:0..63; bit67:0..3; fill1:0..255); 2:(bit03:0..15; bit47:0..15; fill2:0..255); 3:(bit01:0..3; bit27:0..63; fill3:0..255); end; FUNCTION ReDirect : BOOLEAN; BEGIN ReDir := ReDir AND NOT EOF (C); ReDirect := ReDir END; FUNCTION ReadChar : CHAR; VAR Ch : CHAR; BEGIN IF ReDirect THEN READ (C, Ch) ELSE READ (KeyBoard, Ch); ReadChar := Ch END; PROCEDURE ReadLine (VAR Str : STRING); BEGIN IF ReDirect THEN BEGIN READLN (C, Str); WRITELN (Str) END ELSE READLN (Str) END; function prompt(message:string; okset:setofchar):char; var ch:char; begin write(message); repeat Ch := ReadChar; if ch in ['a'..'z'] then ch:=chr(ord(ch)-ord('a')+ord('A')); IF NOT (Ch IN OkSet) THEN ReDir := FALSE until ch in okset; writeln(ch); prompt:=ch; end; procedure error(message:string); begin writeln; writeln('ERROR: ',message); end; procedure outchar(ch:char); begin if charcnt>=40 then begin writeln; charcnt:=0; end; write(ch); charcnt:=charcnt+1; end; procedure initialize; type block=packed array[0..511] of char; var comm:commands; blockp:^block; ch:char; begin for ch:=chr(0) to chr(255) do chtocommand[ch]:=nocommand; for comm:=nocommand to openerror do begin ch:=chr(ord('1')+ord(comm)); commandtoch[comm]:=ch; chtocommand[ch]:=comm; end; ReDir := FALSE; buffsize:=0; mark(buff); while ((memavail<0) or (memavail>3600)) and (buffsize<62) do begin new(blockp); buffsize:=buffsize+1; end; buffsize:=(512 div (blockmax+1))*buffsize; end; procedure sendcommand(comm:commands); begin ch[0]:=commandtoch[comm]; unitwrite(writeunit,ch[0],1); end; function waitcommand:commands; begin unitread(readunit,ch[0],1); waitcommand:=chtocommand[ch[0]]; end; procedure initbuffer; begin buffpos:=-1; bufffirst:=0; bufflast:=-1; end; function fillbuffer:commands; var size:integer; begin size:=blockread(f,buff^[0],buffsize div (512 div (blockmax+1))); bufffirst:=bufflast+1; bufflast:=bufffirst+(512 div (blockmax+1))*size-1; if ioresult=0 then if size=0 then fillbuffer:=closefile else fillbuffer:=success else begin fillbuffer:=diskerror; error('reading from file'); end; end; function dumpbuffer:boolean; var size:integer; ok:boolean; begin size:=(buffpos-bufffirst+1) div (512 div (blockmax+1)); ok:=(blockwrite(f,buff^[0],size)=size) and (ioresult=0); if not ok then error('writing to file'); dumpbuffer:=ok; bufffirst:=buffpos+1; end; procedure xferout(isretry:boolean); var tempcnt,state,bytecnt,checksum:integer; begin state:=0; tempcnt:=0; checksum:=0; for bytecnt:=0 to blockmax do begin buffbyte.int:=ord(buff^[buffpos-bufffirst,bytecnt]); checksum:=checksum+buffbyte.int; case state of 0:begin tempbuff[tempcnt]:=ord(odd(buffbyte.int) and odd(63)){.bit05}+32; tempcnt:=tempcnt+1; tempbuff[tempcnt]:=16*buffbyte.bit67+32; state:=1; end; 1:begin tempbuff[tempcnt]:=tempbuff[tempcnt]+ ord(odd(buffbyte.int) and odd(15)){.bit03}; tempcnt:=tempcnt+1; tempbuff[tempcnt]:=4*buffbyte.bit47+32; state:=2; end; 2:begin tempbuff[tempcnt]:=tempbuff[tempcnt]+ ord(odd(buffbyte.int) and odd(3)){.bit01}; tempcnt:=tempcnt+1; tempbuff[tempcnt]:=buffbyte.bit27+32; tempcnt:=tempcnt+1; state:=0; end; end; end; checksum:=abs(checksum); if isretry then outchar('?') else outchar('.'); tempbuff[tempmax-3]:=ord('0')+checksum div 4096 mod 16; tempbuff[tempmax-2]:=ord('0')+checksum div 256 mod 16; tempbuff[tempmax-1]:=ord('0')+checksum div 16 mod 16; tempbuff[tempmax ]:=ord('0')+checksum mod 16; unitwrite(writeunit,tempbuff,tempmax+1); end; function xferin:boolean; var tempbyte,i,sentcheck,checksum,tempcnt,state,bytecnt:integer; begin sendcommand(success); unitread(readunit,tempbuff,tempmax+1); state:=0; tempcnt:=0; buffbyte.int:=0; checksum:=0; for bytecnt:=0 to blockmax do begin case state of 0:begin buffbyte.int{.bit05}:=ord(odd(tempbuff[tempcnt]) and odd(127))-32; tempcnt:=tempcnt+1; tempbyte:=ord(odd(tempbuff[tempcnt]) and odd(127))-32; buffbyte.bit67:=tempbyte div 16; state:=1; end; 1:begin buffbyte.int{.bit03}:=ord(odd(tempbyte) and odd(15)); tempcnt:=tempcnt+1; tempbyte:=ord(odd(tempbuff[tempcnt]) and odd(127))-32; buffbyte.bit47:=tempbyte div 4; state:=2; end; 2:begin buffbyte.int{.bit01}:=ord(odd(tempbyte) and odd(3)); tempcnt:=tempcnt+1; buffbyte.bit27:=ord(odd(tempbuff[tempcnt]) and odd(127))-32; tempcnt:=tempcnt+1; state:=0; end; end; buff^[buffpos-bufffirst,bytecnt]:=chr(buffbyte.int); checksum:=checksum+buffbyte.int; end; checksum:=abs(checksum); sentcheck:=0; for i:=tempmax-3 to tempmax do sentcheck:=16*sentcheck+tempbuff[i]-ord('0'); if sentcheck=checksum then outchar('.') else outchar('?'); xferin:=sentcheck=checksum; end; procedure master; var filename:string; result,answer:commands; ok:boolean; i:integer; procedure send; begin repeat write(' Send what file? '); ReadLine (FileName); if length(filename)=0 then exit(send); close(f); reset(f,filename); IF IORESULT <> 0 THEN ReDir := FALSE until ioresult=0; repeat write(' To what remote file? '); ReadLine (FileName); if length(filename)=0 then exit(send); sendcommand(rewritefile); answer:=waitcommand; for i:=length(filename)+1 to filestringsize do filename[i]:=' '; unitwrite(writeunit,filename[1],filestringsize); answer:=waitcommand; IF Answer <> Success THEN ReDir := FALSE until answer=success; initbuffer; repeat buffpos:=buffpos+1; if buffpos>bufflast then begin answer:=fillbuffer; if answer=diskerror then exit(send); end else answer:=success; if answer=success then begin sendcommand(sendblock); answer:=waitcommand; if answer=success then begin xferout(false); answer:=waitcommand; while answer=sumerror do begin sendcommand(resendblock); answer:=waitcommand; xferout(true); answer:=waitcommand; end; end; end; until answer<>success; writeln; if answer=closefile then begin sendcommand(closefile); if waitcommand<>success then error('closing remote file'); end else error('writing to remote file'); end; procedure receive; begin repeat write(' Receive what remote file? '); ReadLine (FileName); if length(filename)=0 then exit(receive); sendcommand(resetfile); answer:=waitcommand; for i:=length(filename)+1 to filestringsize do filename[i]:=' '; unitwrite(writeunit,filename[1],filestringsize); answer:=waitcommand; IF Answer <> Success THEN ReDir := FALSE until answer=success; repeat write(' To what file? '); ReadLine (FileName); if length(filename)=0 then exit(receive); close(f); rewrite(f,filename); IF IORESULT <> 0 THEN ReDir := FALSE until ioresult=0; initbuffer; repeat sendcommand(getblock); answer:=waitcommand; if answer=success then begin buffpos:=buffpos+1; while not xferin do begin sendcommand(regetblock); answer:=waitcommand; end; end; if (buffpos-bufffirst+1=buffsize) or (answer=closefile) then if not dumpbuffer then exit(receive); until answer in [closefile,diskerror]; writeln; if answer=closefile then begin close(f,lock); if ioresult<>0 then error('closing file'); end else error('reading from remote file'); end; PROCEDURE FromFile; VAR FN : STRING; BEGIN ReDir := FALSE; CLOSE (C, LOCK); REPEAT WRITE (' Get cmds from file : '); READLN (FN); IF LENGTH (FN) = 0 THEN EXIT (FromFile); FN := CONCAT (FN, '.TEXT'); RESET (C, FN); UNTIL IORESULT = 0; ReDir := TRUE END; begin (*Master*) repeat charcnt:=0; case prompt(' S(end R(eceive F(ile Q(uit ',['S','R','F','Q']) of 'S':send; 'R':receive; 'Q':begin sendcommand(gotoprompt); answer:=waitcommand; exit(master); end; 'F': FromFile end; until false; end; procedure slave; var filename:string; i:integer; answer,command:commands; begin answer:=nocommand; repeat if answer<>nocommand then sendcommand(answer); answer:=nocommand; command:=waitcommand; case command of getblock, regetblock: begin if command=getblock then buffpos:=buffpos+1; if buffpos>bufflast then answer:=fillbuffer else answer:=success; if answer=success then begin sendcommand(success); answer:=waitcommand; xferout(command=regetblock); answer:=nocommand; end; end; sendblock, resendblock: begin answer:=success; if command=sendblock then begin if buffpos-bufffirst+1=buffsize then if not dumpbuffer then answer:=diskerror; buffpos:=buffpos+1; end; if answer=success then if not xferin then answer:=sumerror; end; resetfile, rewritefile: begin writeln; initbuffer; charcnt:=0; sendcommand(success); unitread(readunit,filename[1],filestringsize); i:=filestringsize; while (i>0) and (filename[i]=' ') do i:=i-1; filename[0]:=chr(i); close(f); if command=resetfile then begin write('Sending '); reset(f,filename); end else begin write('Receiving '); rewrite(f,filename); end; if ioresult=0 then answer:=success else answer:=openerror; writeln(filename); end; closefile: begin answer:=diskerror; if dumpbuffer then begin close(f,lock); if ioresult=0 then answer:=success; end; end; gotoprompt: begin sendcommand(success); writeln; exit(slave); end; end; until false; end; begin initialize; unitclear(readunit); unitclear(writeunit); writeln; writeln('Remtalk [14 Feb 82]'); writeln(' 1) Let both machines reach this prompt'); writeln(' 2) Press S(lave on one machine'); writeln(' 3) Press M(aster on the other'); repeat case prompt('M(aster S(lave Q(uit ',['M','S','Q']) of 'M':master; 'S':slave; 'Q':exit(program); end; until false; end. ======================================================================================== DOCUMENT :usus Folder:VOL15:remunit.l3.text ======================================================================================== {$S+} {UNIT REMUNIT Version L3 12 August 1981} {============== Copyright Notice =======================} {$C Copyright 1980, 1981 by Robert W. Peterson } {============== Copyright Notice =======================} {Copyright 1981 by Michael A. Ikezawa} {Copyright 1981 by Walter B. Farrell} {============================================================ This is a separate compilation unit intended to stand between application code and a communication line. Implementation of this unit follows the specifications and suggestions set out in the Feburary 1981 draft of the USUS (UCSD p-System User Society) remote unit specification. This unit will interface to the following model codes: LSI-11 The following routines are not functional: CR_CLEARTOSEND CR_DIAL CR_DIALTONE CR_SETADDRESS CR_SETCOMMUNICATIONS ============================================================} {============================================================ Change Log ====== === Date What change was made & Who made the change --------- ---------------------------------------------------- 28 Mar 81 Original code - Bob Peterson 16 May 81 LSI-11 Modifications - Mike Ikezawa In the IMPLEMENTATION section: (1) Delete the following CONSTANTs entirely: POLY_KB POLY_REMOTE (2) In PROCEDURE CR_ANSWER delete: UNITCLEAR(POLY_REMOTE) (3) The single statement in FUNCTION CR_KBSTAT should read: CR_KBSTAT := NOT UNITBUSY(KB_UNIT) (4) The single statement in FUNCTION CR_REMSTAT should read: CR_REMSTAT := NOT UNITBUSY(REMIN_UNIT) (5) The UNITREAD statement in FUNCTION CR_GETKB should read: UNITREAD(KB_UNIT,ARAY.A,1,,1) (6) The UNITREAD statement in FUNCTION CR_GETREM should read: UNITREAD(REMIN_UNIT,ARAY.A,1,,1) 1 June 81 More LSI-11 Modifications by Walt Farrell (1) Following declaration of BAUD_SETTABLE: BUF_KB, BUF-REMIN : PACKED ARRAY[1..1] OF CHAR; (2) In Procedure CR_ANSWER following UNITCLEAR(REMOUT_UNIT); : UNITREAD( REMIN_UNIT, BUF_REMIN, 1,,1); (3) Replace Function CR_KBSTAT with: FUNCTION CR_KBSTAT( : BOOLEAN ) VAR STATUS_REC : ARRAY[1..30] OF INTEGER; BEGIN UNITSTATUS( KB_UNIT, STATUS_REC, 1); CR_KBSTAT := (STATUS_REC[1] > 0); END; (4) Replace Function CR_GETKB with: FUNCTION CR_GETKB ( : CHAR ); BEGIN UNITREAD( KB_UNIT, BUF_KB, 1,,5); CR_GETKB := BUF_KB[1]; END; (5) Replace Function CR_GETREM with: FUNCTION CR_GETREM ( : CHAR ); BEGIN CR_GETREM := BUF_REMIN[1]; UNITREAD( REMIN_UNIT, BUF_REMIN, 1,,1); END; (6) In CR_COMMINIT just before MODEL_ID := ''; : UNITREAD( REMIN_UNIT, BUF_REMIN, 1,,1); 12 Aug 81 More LSI-11 Modifications by Mike Ikezawa CR_BREAK has been implemented. It uses the external procedures SET_BREAK and CLR_BREAK. In this version, SET_BREAK and CLR_BREAK are written for the LSI-11. This makes this version machine-dependent. However, it is very possible that if SET_BREAK and CLR_BREAK are replaced by appropriate external functions that are written for other machines, this version may very well work on those machines also. 19 Jun 82 Changed CR_RATE_SET_OK in interface part to CR_SET_OK per std in NL#5 Changed CR_REMSTAT to use UNITSTATUS and commented out an initial UNITREAD in CR_COMMINIT. This allowed this unit to work with Bob Peterson's TERM.MAIN.TEXT and still work with TOMUSUS. George Schreyer ============================================================} UNIT REMUNIT ; INTERFACE {$P+} TYPE CR_DIALRESULT = ( CR_OFF_HOOK, CR_DIALERROR, CR_NOAUTODIAL ) ; CR_BAUD_RESULT = ( CR_BAD_PARAMETER, CR_BAD_RATE, CR_SET_OK, CR_SELECT_NOT_SUPPORTED ) ; CR_WHOAMI = ( CR_ORIG, CR_ANS ) ; CR_REM_PORT = PACKED RECORD PART1 : INTEGER ; PART2 : INTEGER ; END ; { CR_REM_PORT } VAR CR_ATTENCHAR : CHAR ; CR_CURRENT_PORT : CR_REM_PORT ; { Initialization and termination routines. } PROCEDURE CR_COMMINIT( DIR : CR_WHOAMI ; ATTENTION_CHAR : CHAR ; VAR REMOTE_EXISTS : BOOLEAN ; VAR DIALER_EXISTS : BOOLEAN ) ; PROCEDURE CR_COMMQUIT ; { Input status. } FUNCTION CR_KBSTAT : BOOLEAN ; FUNCTION CR_REMSTAT : BOOLEAN ; { Input/Output operations. } FUNCTION CR_GETKB : CHAR ; FUNCTION CR_GETREM : CHAR ; PROCEDURE CR_PUTREM( C : CHAR ) ; { Control procedures. } PROCEDURE CR_ANSWER ; PROCEDURE CR_BREAK ; FUNCTION CR_CARRIER : BOOLEAN ; FUNCTION CR_CLEARTOSEND : BOOLEAN ; PROCEDURE CR_DELAY( TENTHS : INTEGER ) ; PROCEDURE CR_DIAL( NUMBER : STRING ; WAITCHAR : CHAR VAR RESULT : CR_DIALRESULT ) ; PROCEDURE CR_HOOK( ON_HOOK : BOOLEAN ) ; PROCEDURE CR_SETADDRESS(HIGHADDR : INTEGER ; LOWADDR : INTEGER ; VECTOR : INTEGER ) ; PROCEDURE CR_SETCOMMUNICATIONS( PARITY : BOOLEAN ; EVEN : BOOLEAN ; RATE : INTEGER ; CHARBITS : INTEGER ; STOPBITS : INTEGER ; DIR : CR_WHOAMI ; MODEL : STRING ; VAR RESULT : CR_BAUD_RESULT ) ; IMPLEMENTATION {$P+}{ Page here so the option is not in the interface text. } CONST DEFAULT_RATE = 300 ; DEFAULT_MODE = TRUE ; { Default to parity enabled. } DEFAULT_PARITY = TRUE ; { Default to even parity. } DEFAULT_CHARBITS = 7 ; { Default to seven data bits.} DEFAULT_STOPBITS = 2 ; { Default to two stop bits. } KB_UNIT = 2 ; REMIN_UNIT = 7 ; REMOUT_UNIT = 8 ; TIMER = 250 ; TYPE TRICK = PACKED RECORD CASE INTEGER OF 1:(A : PACKED ARRAY[0..80] OF CHAR); 2:(S : STRING[80]); 3:(I : INTEGER; J : INTEGER); 4:(L : ARRAY[0..39] OF INTEGER); 5:(B : ARRAY[0..39] OF BOOLEAN); 6:(C : PACKED RECORD CHARL : CHAR ; CHARR : CHAR END ) ; END ; { TRICK } VAR BAUD_SETTABLE : BOOLEAN ; buf_kb, buf_remin : packed array[1..1] of char; CONTROL : INTEGER ; CURRENT_BAUD : INTEGER ; MODEL_ID : STRING ; OFF_HOOK : BOOLEAN ; {$P+} { --------------------------------------------------------- } { Control Procedures } { --------------------------------------------------------- } procedure set_break; external; procedure clr_break; external; PROCEDURE CR_ANSWER ; VAR WAITING : BOOLEAN ; BEGIN WAITING := TRUE ; WHILE WAITING DO BEGIN WAITING := NOT CR_CARRIER ; IF WAITING THEN IF CR_KBSTAT THEN WAITING := CR_GETKB <> CR_ATTENCHAR ; END ; OFF_HOOK := NOT WAITING ; IF NOT WAITING THEN BEGIN UNITCLEAR( REMIN_UNIT ) ; UNITCLEAR( REMOUT_UNIT ) ; unitread(remin_unit,buf_remin,1,,1); END ; END ; { CR_ANSWER } PROCEDURE CR_BREAK ; var i :integer; BEGIN cr_putrem(chr(0)); cr_putrem(chr(0)); set_break; for i := 1 to 100 do cr_putrem(chr(0)); clr_break; END ; FUNCTION CR_CARRIER{ : BOOLEAN } ; BEGIN CR_CARRIER := TRUE ; OFF_HOOK := TRUE ; END ; { CR_CARRIER } FUNCTION CR_CLEARTOSEND{ : BOOLEAN } ; BEGIN CR_CLEARTOSEND := TRUE ; END ; { CR_CLEARTOSEND } PROCEDURE CR_DELAY{ TENTHS : INTEGER } ; VAR I : INTEGER ; BEGIN I := TIMER ; WHILE I > 0 DO I := I - 1 ; END ; { CR_DELAY } PROCEDURE CR_DIAL{ NUMBER : STRING ; VAR RESULT : CR_DIAL_RESULT } ; BEGIN RESULT := CR_NOAUTODIAL ; END ; { CR_DIAL } PROCEDURE CR_HOOK{ ON_HOOK : BOOLEAN } ; BEGIN OFF_HOOK := NOT ON_HOOK ; END ; { CR_HOOK } {$P+} { --------------------------------------------------------- } { Status Procedures } { --------------------------------------------------------- } FUNCTION CR_KBSTAT{ : BOOLEAN } ; var status_rec :array[1..30] of integer; BEGIN unitstatus(kb_unit,status_rec,1); cr_kbstat := (status_rec[1] > 0); END ; { CR_KBSTAT } FUNCTION CR_REMSTAT{ : BOOLEAN } ; var status_rec : array[1..30] of integer; BEGIN CR_REMSTAT := not UNITBUSY( remin_unit ) ; {unitstatus ( remin_unit, status_rec, 1 );} {this sometimes works and} {cr_remstat := ( status_rec[1] > 0 );} {and sometimes doesn't gws} END ; { CR_REMSTAT } {$P+} { --------------------------------------------------------- } { Input/Output Procdures } { --------------------------------------------------------- } FUNCTION CR_GETKB{ : CHAR } ; BEGIN unitread(kb_unit,buf_kb,1,,5); cr_getkb := buf_kb[1]; END ; { CR_GETKB } FUNCTION CR_GETREM{ : CHAR } ; BEGIN cr_getrem := buf_remin[1]; unitread(remin_unit,buf_remin,1,,1); END ; { CR_GETREM } PROCEDURE CR_PUTREM{ C : CHAR } ; VAR P : TRICK ; BEGIN IF CR_CARRIER THEN BEGIN P.A[0] := C ; UNITWRITE( REMOUT_UNIT, P.A, 1, 0, CONTROL ) ; END ; END ; { CR_PUTREM } {$P+} { --------------------------------------------------------- } { Initialization/Termination Procedures } { --------------------------------------------------------- } PROCEDURE CR_SETADDRESS{ HIGHADDR : INTEGER ; LOWADDR : INTEGER ; VECTOR : INTEGER } ; BEGIN WITH CR_CURRENT_PORT DO BEGIN PART1 := HIGHADDR ; PART2 := LOWADDR ; END ; END ; { CR_SETADDRESS } PROCEDURE CR_SETCOMMUNICATIONS{ PARITY : BOOLEAN ; EVEN : BOOLEAN ; RATE : INTEGER ; CHARBITS : INTEGER ; STOPBITS : INTEGER ; DIR : CR_WHOAMI ; MODEL : STRING ; VAR RESULT : CR_BAUD_RESULT } ; BEGIN CONTROL := 12 ; BAUD_SETTABLE := FALSE ; RESULT := CR_SELECT_NOT_SUPPORTED ; END ; { CR_SETCOMMUNICATIONS } PROCEDURE CR_COMMINIT{ DIR : CR_WHOAMI ; ATTENTION_CHAR : CHAR ; VAR REMOTE_EXISTS : BOOLEAN ; VAR DIALER_EXITST : BOOLEAN } ; VAR RESULT : CR_BAUD_RESULT ; PROCEDURE NOT_THERE ; BEGIN PAGE( OUTPUT ) ; GOTOXY( 0, 10 ) ; WRITELN(' ':20, 'Required unit failed UNITCLEAR!') ; WRITELN(' ':20, 'Program will terminate.') ; EXIT( PROGRAM ) ; END ; BEGIN { Set no auto-dial. } DIALER_EXISTS := FALSE ; { Check that the required units exist. } REMOTE_EXISTS := TRUE ; UNITCLEAR( REMIN_UNIT ) ; IF IORESULT <> 0 THEN NOT_THERE ; UNITCLEAR( REMOUT_UNIT ) ; IF IORESULT <> 0 THEN NOT_THERE ; {unitread(remin_unit,buf_remin,1,,1);} {primes the pump} MODEL_ID := '' ; OFF_HOOK := FALSE ; BAUD_SETTABLE := TRUE ; CR_ATTENCHAR := ATTENTION_CHAR ; CR_SETCOMMUNICATIONS( DEFAULT_MODE, DEFAULT_PARITY, DEFAULT_RATE, DEFAULT_CHARBITS, DEFAULT_STOPBITS, CR_ORIG, 'LSI-11', RESULT ) ; BAUD_SETTABLE := RESULT = CR_SELECT_NOT_SUPPORTED ; END ; { CR_COMMINIT } PROCEDURE CR_COMMQUIT ; VAR RESULT : CR_BAUD_RESULT ; BEGIN OFF_HOOK := FALSE ; IF BAUD_SETTABLE THEN CR_SETCOMMUNICATIONS( DEFAULT_MODE, DEFAULT_PARITY, DEFAULT_RATE, DEFAULT_CHARBITS, DEFAULT_STOPBITS, CR_ORIG, 'LSI-11', RESULT ) ; END ; { CR_COMMQUIT } END. ======================================================================================== DOCUMENT :usus Folder:VOL15:set_break.text ======================================================================================== .PROC SET_BREAK ; To set break bit in CR_BREAK ; This external procedure is for use with the ; procedure CR_BREAK in REMUNIT for LSI-11s ; M. A. Ikezawa, 17 July 1981 XCSR .EQU 177524 BIS #1,@#XCSR MOV (SP)+,R0 JMP @R0 .END ======================================================================================== DOCUMENT :usus Folder:VOL15:smtremv5.text ======================================================================================== {Program SMARTREMOTE allows you to communicate with another computer or terminal via a modem and your telephone. The program is capable of operation in either half or full duplex. The program will also optionally record in a disk file or print all incoming information from the modem (although not from the console unless the remote computer echos the information) or transmit the contents of a disk file to the modem. The program works well and is freindly to use but ***BEWARE*** of machine dependency. gws} (* Program Author: Walter Hess 1460 Seven Pines Rd. Schaumberg, IL 60193*) {Modified by George W. Schreyer 1-Feb-81. - - - > ** NOTE!!! ** < - - - This program is machine specific! It will only run on a PDP-11 or LSI-11 or H-11. It is also heavily terminal dependant on a Heath H-19 or DEC VT- 52. The code makes extensive use of pointers to point at I/O status registers and buffers in the I/O page. The address have been adjusted to the same as used by the UCSD operating system for 'PRINTER:' and 'REMIN:' and 'REMOUT:'. There are also printer dependant commands for a TI-820. The funny negative numbers scattered about are two's complement repesentations of addresses (in the case of INITPOINTER) or bit patterns (as in the main program and elsewhere). All this garbage could be replaced with blockreads and blockwrites (of regular reads and writes for that matter if you don't mind slow programs) for reading and writing files and unitreads to get data from the modem and keyboard. This would make the program portable, but it works on my computer the kludgey way it is and I don't feel like modifying it again. This would be a good project for one of you super-sharp Pascal programmers out there in computerland. gws} (* SMTTERM BEWARE!!! This program has only been finished (I think) during the last week. It requires a serial card at addresses 177570 thru changed address, see below 177576 (octal). the VECTOR address is 270 but is not used as PASCAL has no provision for servicing an interrupt from this card. The resultant RS232 port is connected to a coupler for dial-up to the remote computer. The biggest problem I had was in writing to a disc file from the remote computer due to the fact that PASCAL stores data for a file in temporary storage someplace and periodically actually writes it to disc. The period while it is writing to disc is relatively long and since the remote computer keeps sending data, some information would be lost. I solved the problem by writing to an array, and when the array is nearly full, I send the remote computer an ESC changed to "H" which is the command sequence which halts the cntl S particular remote computer I use (see PROCEDURE WARRY). After a short wait while the remote computer stops during which time arriving characters are accepted, I write the array to the disc file and then tell the remote computer to changed to resume by sending an ESC which restarts the cntl Q remote computer (see PROCEDURE WFILE). The particular commands will, of course, be different for different computers. Another tricky area was the use of "BREAK". If you want to send a "BREAK" to the remote computer, do not use the "BREAK" key as this will locally interrupt PASCAL. Instead, I simulate a "BREAK" with the top row f5 which does the job nicely. The program uses certain of the ESC functions created by the top row of keys as program commands and passes all other ESC sequences to the remote computer. If the remote computer needs one of the top row sequences, the command structure will have to be modified. It seems that Heath uses sequences for the top row which are not commonly used elsewhere.*) PROGRAM SMTTERM; { VERSION "O" 10/20/79 W.I.H. } {version '5' 27-AUG-81 George W. Schreyer} USES (*$U iounit.code*) IOUNIT; CONST ARLEN = 100; VAR TCHAR : PACKED ARRAY[0..1] OF CHAR; i,ARINDEX,CFULL,PRINDEX,COLM,LNCT,LNPAGE,L : INTEGER; NFULL,HALT,LESC,FDUP,CMD,PRINTON,RCRDON,PLBKON,TERMINATE : BOOLEAN; FILENAME : STRING[30]; PRARRY : PACKED ARRAY[1..ARLEN] OF STRING[132]; SSTRING : STRING[1]; PRFILE : TEXT; R : REAL; RCH,CH,ESCH : CHAR; PROCEDURE WASTE; {wait until printer ready} VAR K : INTEGER; BEGIN REPEAT BIT := PRINT_XCSR^; UNTIL BIT[7]; END; {Waste} PROCEDURE COMM(CH : CHAR); {check for modem ready then stuff ch in xbuf} BEGIN REPEAT BIT := MODEM_XCSR^; UNTIL BIT[7]; MODEM_XBUF^ := CH END; {Comm} PROCEDURE QUIT; BEGIN WRITE(ESCH,'k'); WRITE(ESCH,'y1'); WRITE(ESCH,'y5'); bit := modem_rcsr^; bit[6] := true; {re-enable interupts at modem rcsr} modem_rcsr^:= bit; CLOSE(PRFILE,LOCK); END; {quit} PROCEDURE CARRAY; {empty buffer file} VAR J : INTEGER; BEGIN FOR J := 2 TO ARLEN DO PRARRY[J] := ''; END; {Carray} PROCEDURE WARRY; {see if necessary to stop host} BEGIN IF ORD(CH) > 127 THEN CH := CHR(ORD(CH) - 128); IF (CH = CHR(13)) THEN BEGIN PRINDEX := 1; ARINDEX := ARINDEX + 1; IF ARINDEX = ARLEN - 3 THEN BEGIN NFULL := TRUE; COMM(CHR(19)); {send cntl-s} END; END ELSE BEGIN IF CH <> CHR(127) THEN BEGIN SSTRING[1] := CH; INSERT(SSTRING,PRARRY[ARINDEX],PRINDEX); PRINDEX := PRINDEX + 1; END; END; END; {Warry} PROCEDURE DISPLAY; BEGIN WRITE(ESCH,'Y8 ',ESCH,'l',ESCH,'F^',ESCH,'G'); IF CMD THEN WRITE(ESCH,'p'); WRITE('BLUE Cmd',ESCH,'q',ESCH,'F^',ESCH,'G'); IF PLBKON THEN WRITE(ESCH,'p'); WRITE('RED Playback',ESCH,'q',ESCH,'F^',ESCH,'G'); IF RCRDON THEN WRITE(ESCH,'p'); WRITE('GREY Record',ESCH,'q',ESCH,'F^',ESCH,'G'); IF NOT FDUP THEN WRITE(ESCH,'p'); WRITE('f1 Half Duplex',ESCH,'q',ESCH,'F^',ESCH,'G'); IF PRINTON THEN WRITE(ESCH,'p'); WRITE('f2 Print',ESCH,'q',ESCH,'F^',ESCH,'G','f3 Quit', ESCH,'F^',ESCH,'Gf5 Break',ESCH,'F^',ESCH,'G'); END; {Display} PROCEDURE RCORD; VAR TRYAGAIN : BOOLEAN; BEGIN {$I-} REPEAT unitclear(1); WRITE('Enter File Name (.TEXT Assumed)'); WRITE(' Or CR to Terminate '); READLN(FILENAME); IF LENGTH(FILENAME) = 0 THEN BEGIN RCRDON := FALSE; EXIT(RCORD); END; FILENAME := CONCAT(FILENAME,'.TEXT'); RESET(PRFILE,FILENAME); IF IORESULT = 0 THEN BEGIN CLOSE(PRFILE); WRITE(ESCH,'Y8 ',ESCH,'l','File exists, do you want to '); WRITE('replace it (Y or N) '); REPEAT READ(CH); UNTIL (CH = 'Y') OR (CH = 'N') OR (CH = 'y') OR (CH = 'n'); IF (CH = 'N') OR (CH = 'n') THEN TRYAGAIN := TRUE ELSE TRYAGAIN := FALSE; END ELSE TRYAGAIN := FALSE; IF NOT TRYAGAIN THEN REWRITE(PRFILE,FILENAME); UNTIL (IORESULT = 0) AND (NOT TRYAGAIN); {$I+} END; {Rcord} PROCEDURE WFILE; {write buffer array to disk} VAR K,J : INTEGER; BEGIN K := 1; IF LENGTH(PRARRY[1]) = 0 THEN K := 2; FOR J := K TO ARINDEX - 1 DO begin (*$I-*) WRITELN(PRFILE,PRARRY[J]); (*$I+*) if ioresult <> 0 then begin close(prfile,lock); write(chr(27),'Y8 ',chr(27),'l'); write('file full '); RCORD; WRITE(CHR(27),'Y8 ',CHR(27),'K','please wait ...'); writeln(prfile,prarry[j]); end; end; IF PRINDEX > 1 THEN PRARRY[1] := PRARRY[ARINDEX] ELSE PRARRY[1] := ''; ARINDEX := 1; CARRAY; NFULL := FALSE; END; {Wfile} procedure dummy; begin write(chr(27),'j'); WRITE(CHR(27),'Y8 ',CHR(27),'K','please wait ...'); wfile; display; write(chr(27),'k'); COMM(CHR(17)); {send cntl-q} end; PROCEDURE PRINT (PRTCHR : CHAR); BEGIN WASTE;PRINT_XBUF^ := PRTCHR; END; {Print} PROCEDURE COMMAND; VAR GCHAR : BOOLEAN; PROCEDURE PLAYBACK; VAR J : INTEGER; BEGIN {$I-} REPEAT WRITE(ESCH,'Y8 ',ESCH,'l','Enter File Name (.TEXT Assumed)'); WRITE(' Or CR to Terminate '); READLN(FILENAME); IF LENGTH(FILENAME) = 0 THEN BEGIN PLBKON := FALSE; EXIT(PLAYBACK); END; FILENAME := CONCAT(FILENAME,'.TEXT'); RESET(PRFILE,FILENAME); UNTIL IORESULT = 0; {$I+} WRITE(ESCH,'k'); WHILE NOT EOF(PRFILE) DO BEGIN READ(PRFILE,RCH); COMM(RCH); WRITE(RCH); IF EOLN(PRFILE) THEN BEGIN COMM(CHR(13)); COMM(CHR(10)); WRITE(CHR(13)); READ(PRFILE,RCH); END; END; {While} PLBKON := FALSE; WRITE(ESCH,'j'); CLOSE(PRFILE); END; {Playback} BEGIN {Command} WRITE(ESCH,'x5',ESCH,'j'); DISPLAY; IF CMD THEN BEGIN REPEAT GCHAR := FALSE; REPEAT READ(CH); IF CH = ESCH THEN BEGIN GCHAR := TRUE; READ(CH); END ELSE WRITE(CHR(7)); UNTIL GCHAR AND (CH IN ['P'..'U']); CASE CH OF 'P' : CMD := FALSE; 'Q' : IF PLBKON THEN PLBKON := FALSE ELSE BEGIN PLBKON := TRUE; DISPLAY; PLAYBACK; END; 'R' : IF RCRDON THEN BEGIN RCRDON := FALSE; write(chr(27),'l'); WRITE(CHR(27),'Y8 ',chr(27),'K','please wait ...'); WFILE; CLOSE(PRFILE,LOCK); END ELSE BEGIN RCRDON := TRUE; PRINDEX := 1; ARINDEX := 1; CARRAY; NFULL := FALSE; PRARRY[1] := ''; write(chr(27),'Y8 ',chr(27),'l'); RCORD; write(chr(27),'k'); END; 'S' : IF FDUP = TRUE THEN FDUP := FALSE ELSE FDUP := TRUE; 'T' : PRINTON := NOT PRINTON; 'U' : TERMINATE := TRUE; END; {Case} DISPLAY; UNTIL (NOT CMD) OR TERMINATE; END; WRITE(ESCH,'y5',ESCH,'k'); END; {Command} BEGIN { Smtterm } WRITE(CHR(27),CHR(69)); WRITELN('smart remote version 5 3-Sep-81'); set_up_pointers; BIT := MODEM_RCSR^; BIT[6] := FALSE; {disable interupts} MODEM_RCSR^ := BIT; BIT := MODEM_XCSR^; BIT[6] := FALSE; MODEM_XCSR^ := BIT; ESCH := CHR(27); WRITE(ESCH,'x1'); SSTRING := ' '; CFULL := 0; NFULL := FALSE;TERMINATE := FALSE; HALT := FALSE; FDUP := TRUE;CMD := FALSE;PRINTON := FALSE;RCRDON := FALSE; PLBKON := FALSE; COMMAND; WHILE NOT TERMINATE DO BEGIN UNITREAD(2,TCHAR[0],1,,1); WHILE UNITBUSY(2) DO BEGIN bit := modem_rcsr^; IF NFULL THEN CFULL := CFULL + 1; IF bit[7] THEN BEGIN CFULL := 0; CH := MODEM_RBUF^; if ord(ch) > 127 then ch := chr(ord(ch)-128); IF CH <> CHR(10) THEN BEGIN WRITE(CH); IF PRINTON THEN PRINT(CH); IF RCRDON THEN WARRY; END; END; IF CFULL = 100 {wait until 100 loops without receipt of a char} THEN BEGIN DUMMY; CFULL := 0; END; END; {While} IF LESC THEN BEGIN LESC := FALSE; IF TCHAR[0] = 'P' THEN BEGIN CMD := TRUE; COMMAND END ELSE BEGIN IF TCHAR[0] = 'W' THEN BEGIN for i := 0 to 15 do bit[i] := false; bit[0] := true; MODEM_XCSR^ := bit; {set break bit, bit 0, in modem xcsr} FOR L := 1 TO 500 DO R := 6.2*164.83*9.5/17.84; bit[0] := false; MODEM_XCSR^ := bit; {reset break bit} END ELSE BEGIN COMM(ESCH);COMM(TCHAR[0]); IF TCHAR[0] = 'H' THEN HALT := TRUE; END; END; END ELSE IF (TCHAR[0] = ESCH) AND (NOT HALT) THEN LESC := TRUE ELSE BEGIN COMM(TCHAR[0]); IF TCHAR[0] = ESCH THEN HALT := FALSE ELSE IF NOT FDUP THEN WRITE(TCHAR[0]); END; END; IF TERMINATE THEN QUIT; END. {Smtterm} ======================================================================================== DOCUMENT :usus Folder:VOL15:std.unit.text ======================================================================================== UNIT REMUNIT ;{ This is REMUNIT for a Poly } {xL PRINTER: } INTERFACE {============== Copyright Notice =======================} {$C Copyright 1980, 1981 by Robert W. Peterson } {============== Copyright Notice =======================} {============================================================ This is a separate compilation unit intended to stand between application code and a communication line. Implementation of this unit follows the specifications and suggestions set out in the Feburary 1981 draft of the USUS (UCSD p-System User Society) remote unit specification. This unit will interface to the following model codes: POLYMORPHIC The following routines are not functional: CR_BREAK CR_CLEARTOSEND CR_DIAL CR_DIALTONE CR_SETADDRESS CR_SETCOMMUNICATIONS CR_SETDTR CR_SETRTS The following routines contain calls to UnitClear: CR_ANSWER ============================================================} {============================================================ Change Log ====== === Date What change was made & Who made the change --------- ---------------------------------------------------- 16 Nov 81 Bring up to actually adopted standard - Bob Peterson 03 Aug 81 Convert to IV.0 - Bob Peterson 28 Mar 81 Original code - Bob Peterson ============================================================} {$P+} TYPE CR_DIALRESULT = ( CR_OFF_HOOK, CR_DIALERROR, CR_NOAUTODIAL ) ; CR_BAUD_RESULT = ( CR_BAD_PARAMETER, CR_BAD_RATE, CR_SET_OK, CR_SELECT_NOT_SUPPORTED ) ; CR_WHOAMI = ( CR_ORIG, CR_ANS ) ; CR_REM_PORT = PACKED RECORD PART1 : INTEGER ; PART2 : INTEGER ; END ; { CR_REM_PORT } CR_STATE = ( CR_ON, CR_OFF, CR_AUTO ) ; VAR CR_ATTENCHAR : CHAR ; CR_CURRENT_PORT : CR_REM_PORT ; { Initialization and termination routines. } PROCEDURE CR_COMMINIT( DIR : CR_WHOAMI ; ATTENTION_CHAR : CHAR ; VAR REMOTE_EXISTS : BOOLEAN ; VAR DIALER_EXITST : BOOLEAN ) ; PROCEDURE CR_COMMQUIT ; { Input status. } FUNCTION CR_KBSTAT : BOOLEAN ; FUNCTION CR_REMSTAT : BOOLEAN ; { Input/Output operations. } FUNCTION CR_GETKB : CHAR ; FUNCTION CR_GETREM : CHAR ; PROCEDURE CR_PUTREM( C : CHAR ) ; { Control procedures. } PROCEDURE CR_ANSWER ; PROCEDURE CR_BREAK ; FUNCTION CR_CARRIER : BOOLEAN ; FUNCTION CR_CLEARTOSEND : BOOLEAN ; PROCEDURE CR_DELAY( TENTHS : INTEGER ) ; PROCEDURE CR_DIAL( NUMBER : STRING ; WAITCHAR : CHAR VAR RESULT : CR_DIALRESULT ) ; FUNCTION CR_DIALTONE : BOOLEAN ; PROCEDURE CR_HOOK( ON_HOOK : BOOLEAN ) ; FUNCTION CR_RINGING : BOOLEAN ; PROCEDURE CR_SETADDRESS(HIGHADDR : INTEGER ; LOWADDR : INTEGER ; VECTOR : INTEGER ) ; PROCEDURE CR_SETCOMMUNICATIONS( PARITY : BOOLEAN ; EVEN : BOOLEAN ; RATE : INTEGER ; CHARBITS : INTEGER ; STOPBITS : INTEGER ; DIR : CR_WHOAMI ; MODEL : STRING ; VAR RESULT : CR_BAUD_RESULT ) ; PROCEDURE CR_SET_DTR( NEW_STATE : CR_STATE ) ; PROCEDURE CR_SET_RTS( NEW_STATE : CR_STATE ) ; IMPLEMENTATION {$P+}{ Page here so the option is not in the interface text. } CONST DEFAULT_RATE = 300 ; DEFAULT_MODE = TRUE ; { Default to parity enabled. } DEFAULT_PARITY = TRUE ; { Default to even parity. } DEFAULT_CHARBITS = 7 ; { Default to seven data bits.} DEFAULT_STOPBITS = 1 ; { Default to one stop bits. } HUNG_UP = TRUE ; KB_UNIT = 2 ; REMIN_UNIT = 7 ; REMOUT_UNIT = 8 ; TIMER = 250 ; TYPE TRICK = PACKED RECORD CASE INTEGER OF 1:(A : PACKED ARRAY[0..80] OF CHAR); 2:(S : STRING[80]); 3:(I : INTEGER; J : INTEGER); 4:(L : ARRAY[0..39] OF INTEGER); 5:(B : ARRAY[0..39] OF BOOLEAN); 6:(C : PACKED RECORD CHARL : CHAR ; CHARR : CHAR END ) ; END ; { TRICK } VAR BAUD_SETTABLE : BOOLEAN ; CONTROL : INTEGER ; CURRENT_BAUD : INTEGER ; DTR_STATE : CR_STATE ; MODEL_ID : STRING ; OFF_HOOK : BOOLEAN ; RTS_STATE : CR_STATE ; UNIT_CARRIER : BOOLEAN ; {$P+} { --------------------------------------------------------- } { Control Procedures } { --------------------------------------------------------- } PROCEDURE CR_ANSWER ; VAR WAITING : BOOLEAN ; BEGIN WAITING := TRUE ; WHILE WAITING DO BEGIN WAITING := NOT CR_CARRIER ; IF WAITING THEN IF CR_KBSTAT THEN WAITING := CR_GETKB <> CR_ATTENCHAR ; END ; OFF_HOOK := NOT WAITING ; IF NOT WAITING THEN BEGIN UNITCLEAR( REMIN_UNIT ) ; UNITCLEAR( REMOUT_UNIT ) ; END ; END ; { CR_ANSWER } PROCEDURE CR_BREAK ; BEGIN END ; FUNCTION CR_CARRIER{ : BOOLEAN } ; BEGIN CR_CARRIER := UNIT_CARRIER ; OFF_HOOK := UNIT_CARRIER ; END ; { CR_CARRIER } FUNCTION CR_CLEARTOSEND{ : BOOLEAN } ; BEGIN CR_CLEARTOSEND := TRUE ; END ; { CR_CLEARTOSEND } PROCEDURE CR_DELAY{ TENTHS : INTEGER } ; VAR I : INTEGER ; BEGIN I := TIMER ; WHILE I > 0 DO I := I - 1 ; END ; { CR_DELAY } PROCEDURE CR_DIAL{ NUMBER : STRING ; VAR RESULT : CR_DIAL_RESULT } ; BEGIN RESULT := CR_NOAUTODIAL ; END ; { CR_DIAL } FUNCTION CR_DIALTONE ; BEGIN CR_DIALTONE := TRUE ; END ; PROCEDURE CR_HOOK{ ON_HOOK : BOOLEAN } ; BEGIN OFF_HOOK := NOT ON_HOOK ; UNIT_CARRIER := OFF_HOOK ; END ; { CR_HOOK } FUNCTION CR_RINGING { : BOOLEAN } ; BEGIN CR_RINGING := TRUE ; END ; {$P+} { --------------------------------------------------------- } { Status Procedures } { --------------------------------------------------------- } FUNCTION CR_KBSTAT{ : BOOLEAN } ; VAR A : TRICK ; BEGIN UNITSTATUS( KB_UNIT, A, 1 ) ; CR_KBSTAT := A.I > 0 ; END ; { CR_KBSTAT } FUNCTION CR_REMSTAT{ : BOOLEAN } ; VAR A : TRICK ; BEGIN UNITSTATUS( REMIN_UNIT, A, 1 ) ; CR_REMSTAT := A.I > 0 ; END ; { CR_REMSTAT } {$P+} { --------------------------------------------------------- } { Input/Output Procdures } { --------------------------------------------------------- } FUNCTION CR_GETKB{ : CHAR } ; VAR ARAY : TRICK ; BEGIN UNITREAD( KB_UNIT, ARAY.A, 1,, 12 ) ; CR_GETKB := ARAY.A[0] ; END ; { CR_GETKB } FUNCTION CR_GETREM{ : CHAR } ; VAR ARAY : TRICK ; BEGIN UNITREAD( REMIN_UNIT, ARAY.A, 1,, CONTROL ) ; CR_GETREM := ARAY.A[0] ; END ; { CR_GETREM } PROCEDURE CR_PUTREM{ C : CHAR } ; VAR P : TRICK ; BEGIN P.A[0] := C ; UNITWRITE( REMOUT_UNIT, P.A, 1, 0, CONTROL ) ; END ; { CR_PUTREM } {$P+} { --------------------------------------------------------- } { Initialization/Termination Procedures } { --------------------------------------------------------- } PROCEDURE CR_SETADDRESS{ HIGHADDR : INTEGER ; LOWADDR : INTEGER ; VECTOR : INTEGER } ; BEGIN WITH CR_CURRENT_PORT DO BEGIN PART1 := HIGHADDR ; PART2 := LOWADDR ; END ; END ; { CR_SETADDRESS } PROCEDURE CR_SETDTR ; BEGIN END ; PROCEDURE CR_SETRTS ; BEGIN END ; PROCEDURE CR_SETCOMMUNICATIONS{ PARITY : BOOLEAN ; EVEN : BOOLEAN ; RATE : INTEGER ; CHARBITS : INTEGER ; STOPBITS : INTEGER ; DIR : CR_WHOAMI ; MODEL : STRING ; VAR RESULT : CR_BAUD_RESULT } ; BEGIN CONTROL := 12 ; BAUD_SETTABLE := FALSE ; IF (MODEL = 'POLYMORPHIC') OR (MODEL = 'Polymorphic') OR (MODEL = 'POLY' ) OR (MODEL = 'Poly' ) THEN RESULT := CR_SET_OK ELSE RESULT := CR_SELECT_NOT_SUPPORTED ; END ; { CR_SETCOMMUNICATIONS } PROCEDURE CR_COMMINIT{ DIR : CR_WHOAMI ; ATTENTION_CHAR : CHAR ; VAR REMOTE_EXISTS : BOOLEAN ; VAR DIALER_EXITST : BOOLEAN } ; VAR RESULT : CR_BAUD_RESULT ; PROCEDURE NOT_THERE ; BEGIN PAGE( OUTPUT ) ; GOTOXY( 0, 10 ) ; WRITELN(' ':20, 'Required unit failed UNITCLEAR!') ; WRITELN(' ':20, 'Program will terminate.') ; EXIT( PROGRAM ) ; END ; BEGIN { Set no auto-dial. } DIALER_EXISTS := FALSE ; { Check that the required units exist. } REMOTE_EXISTS := TRUE ; UNITCLEAR( REMIN_UNIT ) ; IF IORESULT <> 0 THEN NOT_THERE ; UNITCLEAR( REMOUT_UNIT ) ; IF IORESULT <> 0 THEN NOT_THERE ; UNIT_CARRIER := FALSE ; CR_HOOK( HUNG_UP ) ; MODEL_ID := '' ; DTR_STATE := CR_AUTO ; RTS_STATE := CR_AUTO ; OFF_HOOK := FALSE ; BAUD_SETTABLE := TRUE ; CR_ATTENCHAR := ATTENTION_CHAR ; CR_SETCOMMUNICATIONS( DEFAULT_MODE, DEFAULT_PARITY, DEFAULT_RATE, DEFAULT_CHARBITS, DEFAULT_STOPBITS, CR_ORIG, 'POLYMORPHIC', RESULT ) ; BAUD_SETTABLE := RESULT = CR_SELECT_NOT_SUPPORTED ; END ; { CR_COMMINIT } PROCEDURE CR_COMMQUIT ; VAR RESULT : CR_BAUD_RESULT ; BEGIN CR_HOOK( HUNG_UP ) ; IF BAUD_SETTABLE THEN CR_SETCOMMUNICATIONS( DEFAULT_MODE, DEFAULT_PARITY, DEFAULT_RATE, DEFAULT_CHARBITS, DEFAULT_STOPBITS, CR_ORIG, 'POLYMORPHIC', RESULT ) ; END ; { CR_COMMQUIT } BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL15:teletalker.text ======================================================================================== {TeleTalker to Bob's Standard I/O Spec 10 Jul 82} PROGRAM TeleTalker; {$U *remunit.l3.code } USES RemUnit; CONST Title = ' R a n d y '' s U S U S T e l e T a l k e r'; Version = ' of 10 Jul 82'; Copyright = 'Copyright 1982, Volition Systems. All rights reserved.'; (* |xjm$ver|nx|f8|ef/of/wx|f8|ejb|. This may not be used for commercial gain without Volition's explicit written consent. UPDATE LOG: 10 Jul 82 Initialize DleCount! 09 Jul 82 Notes to implementors added, good luck! 22-Oct-81 cosmetics 07-Oct-81 Hacked to new WD.IO per Bob P's April Draft Note to implementors / adaptors We ask that you leave the Title..Copyright banner. This code was a quick hack, it is in no way warantied. It is meant to get you up, with something you can hack up yourself. You will want to look at: - DleDelay below in the CONSTant list. It determines the delay between successive blanks output to Remote. - PROCEDURE CrtOutput is machine dependent to gain a bit of speed rather than going through the BIOS. - on my box, the IoCtrlPort is used to configure the BIOS. Here it is used to disable all special char detection on kbd input. This allows me to type in control sequences transparently. CONST Contd. *) DleDelay = 66; { MUST BE ADJUSTED FOR EACH MACHINE & BAUD RATE } IOCtrlPort = 128; BlkSz = 512; BlkSzM1 = 511; AttenChar = 1; StopChar = 19; StartChar = 17; XWait = 128; Dle = 16; NoControl = 12; NoCrlf = 8; TYPE Block = PACKED ARRAY [0..BlkSzM1] OF CHAR; VAR C : CHAR; Ch : PACKED ARRAY [0..0] OF CHAR; Sending : BOOLEAN; Recording : BOOLEAN; Frozen : BOOLEAN; Chr0 : CHAR; I : INTEGER; DleCount : INTEGER; XWaitState : (XWIdle, XWWaiting, XWReady); XWaitCnt : INTEGER; TextCharSet : SET OF CHAR; RcvFile : FILE; RcvFilPtr : INTEGER; RcvBlk : Block; RcvBufPtr : INTEGER; RcvName : STRING; XmtFile : FILE; XmtFilPtr : INTEGER; XmtBlk : Block; XmtBufPtr : INTEGER; XmtName : STRING; (*PROCEDURE CrtOutput (C: CHAR); CONST SerialA = -1008; TYPE SerStatType = SET OF ( TransBufEmpty , RecvrBufFull , OverrunError , ParityError , FramingError , CarrierDetect , DataSetReady , DataSetChange ); SerialPort = RECORD Data : INTEGER; Status : SerStatType END {SerialPort}; SerPunType = RECORD CASE BOOLEAN OF TRUE :( Int : INTEGER); FALSE :( Port : ^SerialPort) END {SerAdTrix}; VAR SerAPun : SerPunType; BEGIN SerAPun.Int := SerialA; WITH SerAPun.Port^ DO BEGIN REPEAT UNTIL TransBufEmpty IN Status; Data := ORD (C) END END; *) procedure crtoutput ( c : char ); var ch : packed array [ 0..1 ] of char; begin ch [ 0 ] := c; unitwrite ( 1, ch [ 0 ], 1,, 0 ); end; PROCEDURE Init; VAR Ok : BOOLEAN; Rslt : Cr_BaudResult; Dummy : BOOLEAN; Ch : PACKED ARRAY [0..0] OF CHAR; BEGIN PAGE (OUTPUT); WRITELN; WRITELN (Title); WRITELN; WRITELN (Version); WRITELN; WRITELN (Copyright); WRITELN; CrCommInit ( Cr_Orig, CHR(1), Ok, Dummy ); Cr_SetCommunications ( FALSE, {Parity} FALSE, {Even} 1200, {Baud} 8, {BitsPerChar} 1, {StopBits} Cr_Orig, {Direction} 'VA3451', {Modem} Rslt {Result} ); { UNITREAD (IOCtrlPort, Ch, 0, 0, 2);} Cr_Hook (FALSE ); XmtName := ''; RcvName := ''; Sending := FALSE; Recording := FALSE; Frozen := FALSE; DleCount := 0; TextCharSet := [CHR(13), ' '..'~']; Chr0 := CHR(0) END; PROCEDURE BlkWrite; VAR HoldInx : INTEGER; HoldBuf : PACKED ARRAY [1..BlkSz] OF CHAR; SpareBlk : Block; I : INTEGER; BEGIN HoldInx := 0; REPEAT IF Cr_RemStat THEN BEGIN C := CHR( ORD( ODD(ORD(Cr_GetRem)) AND ODD(127) ) ); CrtOutput (C); IF ORD(C) = StopChar THEN Frozen := TRUE ELSE IF ORD(C) = StartChar THEN Frozen := FALSE ELSE IF (C IN TextCharSet) AND (HoldInx < BlkSz) THEN BEGIN HoldInx := HoldInx + 1; HoldBuf[HoldInx] := C END END; I := 0; WHILE (NOT Cr_RemStat) AND (I < 256) DO I := I + 1; UNTIL NOT Cr_RemStat; {$I-} RcvBufPtr := BLOCKWRITE (RcvFile, RcvBlk, 1, RcvFilPtr); WHILE RcvBufPtr = 1 DO IF (BLOCKREAD (RcvFile, SpareBlk, 1, RcvFilPtr) = 1) AND (SpareBlk = RcvBlk) THEN RcvBufPtr := 0 ELSE RcvBufPtr := BLOCKWRITE (RcvFile,RcvBlk,1,RcvFilPtr); {$I+} RcvFilPtr := RcvFilPtr + 1; FOR I := 1 TO HoldInx DO BEGIN RcvBlk[RcvBufPtr] := HoldBuf[I]; RcvBufPtr := RcvBufPtr + 1 END; Cr_PutRem (CHR(StartChar)) END; PROCEDURE RawOptions; VAR Ch : PACKED ARRAY [0..0] OF CHAR; PROCEDURE UpCase ( VAR Str : STRING ); VAR I : INTEGER; BEGIN FOR I := 1 TO LENGTH (Str) DO IF Str[I] IN ['a'..'z'] THEN Str[I] := CHR( ORD(Str[I]) - ORD('a') + ORD('A') ) END; PROCEDURE RClose; BEGIN RcvBlk[RcvBufPtr] := CHR(13); WHILE RcvBufPtr < (BlkSzM1) DO BEGIN RcvBufPtr := RcvBufPtr + 1; RcvBlk[RcvBufPtr] := Chr0 END; Cr_PutRem (CHR(StopChar)); BlkWrite; IF ODD(RcvFilPtr) THEN BEGIN FILLCHAR (RcvBlk[0], BlkSz, Chr0); Cr_PutRem (CHR(StopChar)); BlkWrite END; CLOSE (RcvFile, CRUNCH) END; BEGIN {RawOptions} REPEAT REPEAT WRITELN; WRITE ('FileOptions: S(end, R(ecord, G(o, E(xit - '); C := Cr_GetKb; IF C = CHR(13) THEN C := 'G' UNTIL C IN ['s','S','r','R','g','G','e','E']; WRITELN (C); CASE C OF 's','S': IF Sending THEN BEGIN WRITE ('Now Sending ', XmtName, ' Close it ? '); C := Cr_GetKb; IF C IN ['y','Y'] THEN BEGIN CLOSE (XmtFile, NORMAL); Sending := FALSE; WRITELN ('Closed') END END ELSE BEGIN REPEAT WRITE ('Send what textfile ? '); READLN (XmtName); UpCase (XmtName); IF LENGTH (XmtName) > 0 THEN IF XmtName[LENGTH(XmtName)] = '.' THEN DELETE (XmtName, LENGTH(XmtName), 1) ELSE XmtName := CONCAT (XmtName, '.TEXT'); {$I-} RESET (XmtFile, XmtName); {$I+} IF IORESULT = 0 THEN BEGIN Sending := TRUE; XWaitState := XWIdle; DleCount := 0; WRITELN (XmtName, ' Opened') END UNTIL (LENGTH(XmtName) = 0) OR (IORESULT = 0); IF COPY (XmtName, LENGTH(XmtName)-4, 5) = '.TEXT' THEN BEGIN IF BLOCKREAD (XmtFile, XmtBlk, 1) = 0 THEN; IF BLOCKREAD (XmtFile, XmtBlk, 1) = 0 THEN END; XmtBufPtr := BlkSz END; 'R','r': IF Recording THEN BEGIN WRITE ('Now Recording ', RcvName, ' C(lose, P(urge ? '); C := Cr_GetKb; CASE C OF 'c','C': BEGIN RClose; Recording := FALSE; WRITELN ('Closed') END; 'p','P': BEGIN CLOSE (RcvFile, PURGE); Recording := FALSE; WRITELN ('Purged') END END END ELSE BEGIN REPEAT WRITE ('Record as what textfile ? '); READLN (RcvName); UpCase (RcvName); IF LENGTH (RcvName) > 0 THEN IF RcvName[LENGTH(RcvName)] = '.' THEN DELETE (RcvName, LENGTH(RcvName), 1) ELSE RcvName := CONCAT (RcvName, '.TEXT'); {$I-} RESET (RcvFile, RcvName); {$I+} IF IORESULT = 0 THEN BEGIN WRITE (RcvName, ' Exists, P(urge ? '); C := Cr_GetKb; IF C IN ['y', 'Y', 'p', 'P'] THEN BEGIN CLOSE (RcvFile, PURGE); WRITELN ('Purged') END ELSE BEGIN CLOSE (RcvFile, LOCK); RcvName := ''; WRITELN ('Saved') END END; IF LENGTH(RcvName) > 0 THEN BEGIN {$I-} REWRITE (RcvFile, RcvName); {$I+} IF IORESULT = 0 THEN BEGIN Recording := TRUE; WRITELN (RcvName, ' Opened') END END UNTIL (LENGTH(RcvName) = 0) OR (IORESULT = 0); IF COPY (RcvName, LENGTH(RcvName)-4, 5) = '.TEXT' THEN BEGIN FILLCHAR (RcvBlk[0], BlkSz, Chr0); IF BLOCKWRITE (RcvFile, RcvBlk, 1) = 1 THEN ; IF BLOCKWRITE (RcvFile, RcvBlk, 1) = 1 THEN ; RcvFilPtr := 2 END ELSE BEGIN RcvFilPtr := 0 END; RcvBufPtr := 0 END; 'E','e': BEGIN IF Recording THEN BEGIN RClose; Recording := FALSE END; Cr_CommQuit; IF Sending THEN CLOSE (XmtFile, NORMAL); EXIT (TeleTalker) END END UNTIL C IN ['g','G']; C := Chr0 END; PROCEDURE NoCts; CONST Msg = 'LOST CARRIER'; VAR I : INTEGER; BEGIN WRITELN (CHR(7)); IF NOT Cr_KbStat THEN WRITE (Msg); REPEAT UNTIL Cr_ClearToSend OR Cr_KbStat; IF NOT Cr_KbStat THEN FOR I := 1 TO LENGTH(Msg) DO WRITE (CHR(8), ' ', CHR(8)) ELSE BEGIN C := Cr_GetKb; RawOptions END END; BEGIN {TeleTalker} Init; {$R-} REPEAT IF NOT Cr_ClearToSend THEN NoCts; IF Cr_RemStat THEN BEGIN C := CHR(ORD( ODD(127) AND ODD(ORD(Cr_GetRem)) )); CrtOutput (C); IF ORD(C) = StopChar THEN Frozen := TRUE ELSE IF ORD(C) = StartChar THEN Frozen := FALSE ELSE IF Recording AND (C IN TextCharSet) THEN BEGIN RcvBlk[RcvBufPtr] := C; IF RcvBufPtr < BlkSzM1 THEN RcvBufPtr := RcvBufPtr + 1 ELSE BEGIN Cr_PutRem (CHR(StopChar)); BlkWrite {slow machines bring inline} END END END ELSE IF NOT Frozen THEN BEGIN C := Chr0; IF Cr_KbStat THEN BEGIN C := Cr_GetKb; IF (ORD(C) = AttenChar) OR Sending THEN RawOptions END ELSE IF DleCount > 0 THEN BEGIN IF (DleCount MOD 2) = 0 THEN C := ' '; DleCount := DleCount - 1 END ELSE IF Sending AND (NOT Cr_RemStat) THEN IF XmtBufPtr >= BlkSz THEN CASE XWaitState OF XWIdle: BEGIN XWaitState := XWWaiting; XWaitCnt := XWait END; XWWaiting: IF XWaitCnt < 0 THEN XWaitState := XWReady ELSE XWaitCnt := XWaitCnt - 1; XWReady: BEGIN {$I-} IF BLOCKREAD (XmtFile, XmtBlk, 1) = 1 {$I+} THEN XmtBufPtr := 0 ELSE BEGIN CLOSE (XmtFile, NORMAL); WRITELN (XmtName, ' Finished'); Sending := FALSE END; XWaitState := XWIdle END END ELSE BEGIN C := XmtBlk[XmtBufPtr]; XmtBufPtr := XmtBufPtr + 1; IF DleCount < 0 THEN BEGIN DleCount := (ORD(C) - 32) * 2; IF DleCount < 0 THEN DleCount := 0; C := Chr0 END ELSE IF ORD(C) = Dle THEN DleCount := -1 ELSE FOR I := 0 TO DleDelay DO; IF NOT (C IN TextCharSet) THEN C := Chr0 END; IF C <> Chr0 THEN Cr_PutRem (C) END UNTIL FALSE END. ======================================================================================== DOCUMENT :usus Folder:VOL15:term.emul.text ======================================================================================== {$P+} {****************************************************************************** Because of their time-sensitive nature, routines after this message SHOULD NOT BE SEGMENTED. ******************************************************************************} PROCEDURE LOGIT{ C : CHAR } ; {$N+} BEGIN IF ORD( C ) IN [BACKSPACE, RUBOUT] THEN IF LOGINDEX > 1 THEN { Subtract 2 here because we add one back later. } LOGINDEX := LOGINDEX - 2 ELSE { NULL STATEMENT } ELSE LOGARRAY[ LOGINDEX ] := C ; IF LOGINDEX = NEARLY THEN BEGIN WRITELN ; WRITELN( ' ***> CURRENTLY AT 80% OF LOG SPACE <***' ) ; WRITELN ; END ; IF LOGINDEX >= LOGLIMIT THEN BEGIN WRITELN ; WRITELN( ' >* LOGLIMIT EXCEEDED *< ', CHR(7), CHR(7) ) ; WRITELN ; { We turn logging off in order to preserve the current logged data, since it is usually easier to remember where we overflowed and restart from there than to restart the entire transaction stream. } LOGTEXT := FALSE ; END ELSE LOGINDEX := LOGINDEX + 1 ; END ; {$N-} {$P+} PROCEDURE DISPLAY{ C : CHAR } ; VAR ORD_C : INTEGER ; P_A : PACKED ARRAY[0..1] OF CHAR ; PROCEDURE V_GOTOXY ; { This routine processes a Videotext GOTOXY sequence. } VAR C : CHAR ; X : INTEGER ; Y : INTEGER ; BEGIN REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_KBSTAT THEN BEGIN C := CR_GETKB ; EXIT( DISPLAY ) ; END ; C := CR_GETREM ; Y := ORD( C ) - 31 ; REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_KBSTAT THEN BEGIN C := CR_GETKB ; EXIT( DISPLAY ) ; END ; C := CR_GETREM ; X := ORD( C ) - 31 ; GOTOXY( X, Y ) ; END ; { V_GOTOXY } {$N+} BEGIN IF VIDEOTEXT AND (C = CHR( ESCAPE )) THEN BEGIN REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_KBSTAT THEN BEGIN C := CR_GETKB ; EXIT( DISPLAY ) ; END ; C := CR_GETREM ; ORD_C := 0 ; CASE C OF 'm', 'l' : ; { Wide character/Normal character } 'A' : ORD_C := ARROW_UP ; { Up arrow } 'B' : ORD_C := ARROW_DOWN ; { Down arrow } 'C' : ORD_C := ARROW_RIGHT ; { Right arrow } 'D' : ORD_C := ARROW_LEFT ; { Left arrow } 'H' : ORD_C := HOME_CURSOR ; { Home } 'K' : ORD_C := CLEAR_EOLN ; { Clear to end of line } 'J' : ORD_C := CLEAR_EOS ; { Clear to end of screen } 'j' : ORD_C := CLEAR_SCREEN ; { Clear screen } 'Y' : V_GOTOXY ; { VIDEOTEXT's GOTOXY } END ; { CASE ORD_C OF } IF ORD_C <> 0 THEN BEGIN P_A[0] := CHR( ORD_C ); UNITWRITE( 1, P_A, 1 ) ; END ; END ELSE BEGIN IF C > CHR( RUBOUT ) THEN C := CHR( ORD_C - (RUBOUT + 1) ) ; IF C <> CHR( LINEFEED ) THEN IF FILTERCONTROL THEN BEGIN IF NOT (C IN FILTERSET) THEN BEGIN P_A[0] := C ; UNITWRITE( 1, P_A, 1 ) ; END ; END ELSE BEGIN P_A[0] := C ; UNITWRITE( 1, P_A, 1 ) ; END ; IF LOGTEXT THEN IF NOT (C IN FILTERSET) THEN LOGIT( C ) ; END ; END ; {$N-} {$P+} {$N+} PROCEDURE EMULATE ; { This procedure exists solely so that native code can be generated without generating native code for the rest of the mainline. } BEGIN DONE := FALSE ; REPEAT IF CR_KBSTAT THEN BEGIN C := CR_GETKB ; IF C = CR_ATTENCHAR THEN BEGIN MENU ; IF NOT (CR_CARRIER OR DONE) THEN CR_HOOK( FALSE ) ; END ELSE BEGIN CR_PUTREM( C ) ; IF ECHO THEN DISPLAY( C ) ; END ; END ; IF NOT CR_CARRIER THEN BEGIN WRITELN ; WRITELN('LOST CARRIER'); WRITELN ; MENU ; IF NOT (CR_CARRIER OR DONE) THEN CR_HOOK( FALSE ) ; END ELSE IF CR_REMSTAT THEN DISPLAY( CR_GETREM ) ; UNTIL DONE ; END ; { EMULATE } {$N-} ======================================================================================== DOCUMENT :usus Folder:VOL15:term.init.text ======================================================================================== {$P+} SEGMENT PROCEDURE INITIALIZE ; VAR AUTOLOGON : BOOLEAN ; B : BOOLEAN ; C : CHAR ; HAVEDIAL : BOOLEAN ; HAVEREM : BOOLEAN ; RESULT : CR_BAUD_RESULT ; SEGMENT PROCEDURE SETLOGON ; CONST { Nine (9) is the max allowed, due to the way its coded. } DEFINED_LOGONS = 5 ; VAR C : CHAR ; INDEX : 1 .. DEFINED_LOGONS ; RESULT : INTEGER ; VALID_LOGONS : INTEGER ; LOGON_LIST : PACKED ARRAY [1..DEFINED_LOGONS] OF RECORD SERVICE : STRING[29] ; USER_ID : STRING[21] ; PASSWORD : STRING[21] ; PROMPT : CHAR ; PHONE_NUM : STRING[21] ; SWITCHES : PACKED RECORD FILTERCONTROL : BOOLEAN ; LOGTEXT : BOOLEAN ; ECHO : BOOLEAN ; VIDEOTEXT : BOOLEAN ; END ; { SWITCHES } END ; PROCEDURE SETUP_LIST ; TYPE STRING7 = STRING[7] ; VAR LINE : STRING ; TRUE_SET : SET OF CHAR ; IN_FILE : TEXT ; PROCEDURE CHECKIT ; BEGIN RESULT := IORESULT ; IF RESULT <> 0 THEN EXIT( SETUP_LIST ) ; IF EOF( IN_FILE ) THEN EXIT( SETUP_LIST ) ; { WRITELN( LINE ) ; }{ Debugging only } END ; FUNCTION TRY_FILE( PREFIX : STRING7 ) : BOOLEAN ; BEGIN {$I-} RESET( IN_FILE, CONCAT( PREFIX, LOGON_FILENAME ) ) ; TRY_FILE := IORESULT = 0 ; {$I+} END ; { TRY_FILE } BEGIN {$I-} VALID_LOGONS := 0 ; IF NOT TRY_FILE( '' ) { Prefix first } THEN IF NOT TRY_FILE( '*' ) { then root } THEN IF NOT TRY_FILE( '#4') { then the world . . . } THEN IF NOT TRY_FILE( '#5') THEN IF NOT TRY_FILE( '#9') THEN IF NOT TRY_FILE( '#10') THEN IF NOT TRY_FILE( '#11') THEN IF NOT TRY_FILE( '#12') THEN IF NOT TRY_FILE( '#13') THEN IF NOT TRY_FILE( '#14') THEN IF NOT TRY_FILE( '#15') THEN IF NOT TRY_FILE( '#16') THEN IF NOT TRY_FILE( '#17') THEN BEGIN WRITELN ; WRITELN( 'Cannot find ', LOGON_FILENAME, ' on any drive. Predefined logon aborted.' ) ; EXIT( SETUP_LIST ) ; END ; TRUE_SET := ['t', 'T', 'y', 'Y'] ; WHILE (NOT EOF( IN_FILE )) AND (VALID_LOGONS < DEFINED_LOGONS) DO WITH LOGON_LIST[ VALID_LOGONS + 1 ] DO BEGIN REPEAT { Skip blank lines. } READLN( IN_FILE, LINE ) ; CHECKIT ; UNTIL LENGTH( LINE ) > 0 ; { This IF will guarantee we don't get a string overflow. } IF SIZEOF( SERVICE ) - 1 >= LENGTH( LINE ) THEN SERVICE := LINE ELSE SERVICE := COPY( LINE, 1, SIZEOF( SERVICE ) - 1 ) ; READLN( IN_FILE, LINE ) ; CHECKIT ; IF SIZEOF( USER_ID ) - 1 >= LENGTH( LINE ) THEN USER_ID := LINE ELSE USER_ID := COPY( LINE, 1, SIZEOF( USER_ID ) - 1 ) ; READLN( IN_FILE, LINE ) ; CHECKIT ; IF SIZEOF( PASSWORD ) - 1 >= LENGTH( LINE ) THEN PASSWORD := LINE ELSE PASSWORD := COPY( LINE, 1, SIZEOF( PASSWORD ) - 1 ) ; READLN( IN_FILE, LINE ) ; CHECKIT ; IF LENGTH( LINE ) > 0 THEN PROMPT := LINE[1] ELSE PROMPT := '?' ; READLN( IN_FILE, LINE ) ; CHECKIT ; IF SIZEOF( PHONE_NUM ) - 1 >= LENGTH( LINE ) THEN PHONE_NUM := LINE ELSE PHONE_NUM := COPY( LINE, 1, SIZEOF( PHONE_NUM ) - 1 ) ; WITH SWITCHES DO BEGIN READLN( IN_FILE, LINE ) ; CHECKIT ; IF LENGTH( LINE ) > 0 THEN FILTERCONTROL := LINE[1] IN TRUE_SET ELSE FILTERCONTROL := FALSE ; READLN( IN_FILE, LINE ) ; CHECKIT ; IF LENGTH( LINE ) > 0 THEN LOGTEXT := LINE[1] IN TRUE_SET ELSE LOGTEXT := FALSE ; READLN( IN_FILE, LINE ) ; CHECKIT ; IF LENGTH( LINE ) > 0 THEN ECHO := LINE[1] IN TRUE_SET ELSE ECHO := FALSE ; READLN( IN_FILE, LINE ) ; CHECKIT ; IF LENGTH( LINE ) > 0 THEN VIDEOTEXT := LINE[1] IN TRUE_SET ELSE VIDEOTEXT := FALSE ; END ; { WITH SWITCHES } VALID_LOGONS := VALID_LOGONS + 1 ; END ; { WITH LOGON_LIST } CLOSE( IN_FILE, LOCK ) ; {$I-} END ; BEGIN LOGON_DEFINED := FALSE ; LOGON1 := '' ; LOGON2 := LOGON1 ; LOGPROMPT := ' ' ; NUMBER := LOGON1 ; TIMESHARE_SERVICE := LOGON1 ; IF QUESTION( 'Auto-Logon ' ) THEN BEGIN IF QUESTION( 'Predefined ' ) THEN BEGIN WRITELN ; WRITELN( 'One moment please . . .' ) ; SETUP_LIST ; IF VALID_LOGONS > 0 THEN BEGIN CLEAR_THE_SCREEN ; WRITELN( 'Predefined logons are' ) ; FOR INDEX := 1 TO VALID_LOGONS DO WITH LOGON_LIST[INDEX] DO WRITELN( INDEX:2, ' ', SERVICE, ' [', USER_ID, ']', ' Phone ', PHONE_NUM ) ; WRITELN ; WRITE( 'Select a digit (Q to select none):' ) ; REPEAT READ( KEYBOARD, C ) ; UNTIL ((ORD( C ) - ORD( '0' )) IN [1..VALID_LOGONS]) OR (C IN ['Q', 'q']) ; WRITE( C ) ; IF C IN ['Q', 'q'] THEN LOGON_DEFINED := FALSE ELSE WITH LOGON_LIST[ORD(C)-ORD('0')] DO BEGIN LOGON_DEFINED := TRUE ; LOGON1 := USER_ID ; LOGON2 := PASSWORD ; LOGPROMPT := PROMPT ; NUMBER := PHONE_NUM ; TIMESHARE_SERVICE := SERVICE ; FILTERCONTROL := SWITCHES.FILTERCONTROL ; LOGTEXT := SWITCHES.LOGTEXT ; ECHO := SWITCHES.ECHO ; VIDEOTEXT := SWITCHES.VIDEOTEXT ; END ; END ; END ; IF NOT LOGON_DEFINED THEN IF QUESTION( 'Specify logon manually' ) THEN BEGIN TIMESHARE_SERVICE := 'Manually specified' ; WRITELN ; REPEAT WRITE('What is the first line?' ) ; READLN( LOGON1 ) ; UNTIL QUESTION( 'OK ' ) ; WRITELN ; REPEAT WRITE('What is the last line?' ) ; READLN( LOGON2 ) ; UNTIL QUESTION( 'OK ' ) ; WRITELN ; REPEAT WRITE( 'What is the last character of the password prompt?' ); READ( LOGPROMPT ) ; UNTIL QUESTION( 'OK ' ) ; WRITELN ; REPEAT WRITE( 'What is the associated phone number?' ) ; READLN( NUMBER ) ; UNTIL QUESTION( CONCAT( 'Is ', NUMBER, ' correct' )) ; OPTIONS ; LOGON_DEFINED := TRUE ; END ; END ; END ; { SETLOGON } SEGMENT PROCEDURE DIAL ; VAR DIAL_RESULT : CR_DIALRESULT ; TEMP : STRING ; BEGIN IF QUESTION( 'Dial' ) THEN REPEAT WRITELN ; WRITE( 'What number (=', NUMBER, ') :' ) ; READLN( TEMP ) ; IF LENGTH( TEMP ) > 0 THEN IF TEMP[1] = CHR( 27 ) { Watch for . } THEN BEGIN PROCEED ; EXIT( DIAL ) ; END ELSE NUMBER := TEMP ; IF LENGTH( NUMBER ) > 0 THEN BEGIN CR_DIAL( NUMBER, ',', DIAL_RESULT ) ; IF DIAL_RESULT <> CR_OFF_HOOK THEN WRITELN( 'Dial failed. Response was ', ORD( DIAL_RESULT ) ) ; END ; UNTIL (LENGTH( NUMBER ) = 0) OR (DIAL_RESULT = CR_OFF_HOOK) ELSE PROCEED ; END ; { DIAL } BEGIN WRITELN ; WRITELN( 'TERMINAL PROGRAM.', VERSION ) ; WRITELN( 'COPYRIGHT 1980, 1981, 1982 BY ROBERT W. PETERSON' ) ; WRITELN( 'ALL RIGHTS RESERVED' ) ; WRITELN( 'Bytes available = ', MEMAVAIL * 2 ) ; WRITELN( 'Log buffer size = ', LOGLIMIT ) ; DONE := FALSE ; FILTERSET := [ CHR( 0 ) .. CHR( BACKSPACE-1 ), CHR( BACKSPACE+1 ) .. CHR( CR-1 ), CHR( CR+1 ) .. CHR( 31 ) ] ; NEARLY := (LOGLIMIT DIV 100) * 80 ; WRITELN ; { The "attention character" is used in several places to allow the user to cancel an activity. For example, while the program is transmitting a file to the other system, the keyboard is monitored. If the "attention character" is read, the transmission is aborted. The "attention character" is constrained to be a non-printing character if it is entered by the user. } IF QUESTION('Is a suitable attention character ') THEN C := CHR( 5 ) ELSE REPEAT WRITELN ; B := FALSE ; REPEAT WRITE( 'What character will be used? ' ) ; WHILE NOT CR_KBSTAT DO ; C := CR_GETKB ; WRITELN( '<', ORD( C ), '>' ) ; IF C IN [' '..'~'] THEN WRITELN( 'You cannot use a displayable character') ELSE B := QUESTION( 'Is this correct ' ) ; UNTIL B ; UNTIL NOT (C IN [' '..'~']) ; WRITELN ; CR_COMMINIT( CR_ORIG, C, HAVEREM, HAVEDIAL ) ; IF NOT HAVEREM THEN BEGIN WRITELN( ' REMOTE not supported in current environment.' ) ; WRITELN( ' Program is terminating.' ) ; EXIT( TERMINAL ) ; END ; { RESULT is set good so that if none of the suggested models are available the program will not call CR_SETCOMMUNICATIONS. } RESULT := CR_SET_OK ; IF QUESTION( 'Is this a 990/5 or Model 2? ' ) THEN IF QUESTION( '1200 BAUD' ) THEN CR_SETCOMMUNICATIONS( FALSE, TRUE, 1200, 8, 1, CR_ORIG, '990/5', RESULT ) ELSE CR_SETCOMMUNICATIONS( TRUE, TRUE, 300, 7, 1, CR_ORIG, '990/5', RESULT ) ELSE IF QUESTION( 'Polymorphic' ) THEN CR_SETCOMMUNICATIONS( TRUE, TRUE, 300, 7, 1, CR_ORIG, 'POLYMORPHIC', RESULT ) ELSE IF QUESTION( 'IBMPC' ) THEN CR_SETCOMMUNICATIONS( FALSE, TRUE, 300, 8, 1, CR_ORIG, 'IBMPC', RESULT ) ; IF RESULT <> CR_SET_OK THEN BEGIN WRITELN ; WRITELN ; WRITELN( 'Setting of baud rate failed! Program is exiting.' ) ; EXIT( PROGRAM ) ; END ; SETLOGON ; { The options are normally set by selecting one of the predefined logons, or by manually specifying a logon. If a logon was not specified, set the options here. } IF NOT LOGON_DEFINED THEN OPTIONS ; { If CR_COMMINIT said dial support is available, try to dial the number. Otherwise simply tell the unit to go off-hook. } IF HAVEDIAL THEN DIAL ELSE PROCEED ; WRITELN ; WRITELN ; END ; ======================================================================================== DOCUMENT :usus Folder:VOL15:term.log.text ======================================================================================== {$P+} SEGMENT PROCEDURE CLOSELOG ; VAR RESULT : INTEGER ; BEGIN IF LOGOPEN THEN BEGIN WRITELN ; IF BLOCKED THEN BEGIN IF LOGINDEX > 0 THEN FLUSHBLOCKED ; WRITELN( 'Current logfile size is ', BLOCKS_WRITTEN, ' blocks.' ) ; IF QUESTION( CONCAT( 'Save ', LOGFILENAME ) ) THEN CLOSE( BLOCKFILE, LOCK ) ELSE CLOSE( BLOCKFILE, PURGE ) ; END ELSE CLOSE( LOGFILE, LOCK ) ; RESULT := IORESULT ; WRITELN ; WRITE( LOGFILENAME ) ; IF RESULT = 0 THEN BEGIN WRITELN(' HAS BEEN CLOSED.' ) ; LOGOPEN := FALSE ; END ELSE WRITELN(' FAILED TO CLOSE. IORESULT = ', RESULT ) ; END ; END ; {$P+} SEGMENT PROCEDURE SETLOGFILENAME ; VAR LEN : INTEGER ; RESULT : INTEGER ; BLOCK : PACKED ARRAY[0..1023] OF CHAR ; PROCEDURE FOLD( VAR STR : STRING ) ; VAR I : INTEGER ; BEGIN FOR I := 1 TO LENGTH( STR ) DO IF STR[I] IN ['a'..'z'] THEN STR[I] := CHR( ORD( STR[I] ) - 32 ) ; END ; { FOLD } BEGIN WRITELN ; CLOSELOG ; (*$I-*) REPEAT WRITELN ; WRITE ( 'What is the new log filename? ') ; READLN ( LOGFILENAME ) ; LEN := LENGTH( LOGFILENAME ) ; IF LEN = 0 THEN EXIT( SETLOGFILENAME ) ; FOLD( LOGFILENAME ) ; IF (LOGFILENAME = 'PRINTER:') OR (LOGFILENAME = '#6:' ) OR (LOGFILENAME = '#6' ) OR (LOGFILENAME = 'CONSOLE:') OR (LOGFILENAME = '#1:' ) OR (LOGFILENAME = '#1' ) THEN BEGIN RESULT := 1 ; BLOCKED := FALSE ; END ELSE BEGIN ADD_TEXT( LOGFILENAME ) ; BLOCKED := TRUE ; RESET ( LOGFILE, LOGFILENAME ) ; RESULT := IORESULT ; END ; IF RESULT = 0 THEN BEGIN CLOSE( LOGFILE, LOCK ) ; RESULT := 1 ; WRITELN ; WRITELN( LOGFILENAME, ' exists! Try another name.' ) ; END ELSE IF LENGTH( LOGFILENAME ) > 0 THEN BEGIN WRITE( 'OPEN OF ', LOGFILENAME, ' ' ) ; IF BLOCKED THEN REWRITE( BLOCKFILE, LOGFILENAME ) ELSE REWRITE( LOGFILE, LOGFILENAME ) ; RESULT := IORESULT ; LOGOPEN := RESULT = 0 ; IF NOT LOGOPEN THEN WRITELN( ' FAILED. REWRITE RESULT = ', RESULT ) ELSE WRITELN( ' WAS SUCCESSFUL.' ) ; END ; UNTIL LOGOPEN ; WRITELN ; IF BLOCKED THEN BEGIN FILLCHAR( BLOCK, SIZEOF(BLOCK), CHR( 0 ) ) ; { Write two blocks of nulls as the first two blocks of the ".TEXT" file. } IF BLOCKWRITE( BLOCKFILE, BLOCK, 2, 0 ) <> 2 THEN WRITELN( 'Error writing overhead blocks!' ) ; BLOCKS_WRITTEN := 2 ; END ; (*$I+*) END ; {$P+} SEGMENT PROCEDURE SAVELOG ; CONST BLANK = ' ' ; RETURNCHAR = 13 ; VAR C : CHAR ; I : 0 .. LOGLIMIT ; LINECOUNT : INTEGER ; RESULT : INTEGER ; TILDE : CHAR ; TRASH : CHAR ; UNITSIZE : INTEGER ; WRITTEN : BOOLEAN ; PROCEDURE DOTS ; BEGIN IF LINECOUNT >= 50 THEN BEGIN WRITELN ; WRITE( ' ': 11 ) ; LINECOUNT := 1 ; END ELSE LINECOUNT := LINECOUNT + 1 ; WRITE( '.' ) ; END ; PROCEDURE DO_BLOCKED ; VAR BASE : INTEGER ; INDEX : 0..1024 ; BLK_BUFFER : PACKED ARRAY[0..1023] OF CHAR ; BEGIN RESULT := 0 ; IF LOGINDEX < 1023 THEN EXIT( DO_BLOCKED ) ; BASE := 0 ; REPEAT MOVELEFT( LOG_ARRAY[BASE], BLK_BUFFER[0], 1024 ) ; INDEX := 1024 ; REPEAT { Find last in buffer } INDEX := INDEX - 1 ; UNTIL (INDEX = 0) OR (BLK_BUFFER[INDEX] = CHR(RETURNCHAR) ); IF INDEX < 1023 THEN FILLCHAR( BLK_BUFFER[INDEX + 1], 1023 - INDEX, CHR( 0 ) ) ; IF BLOCKWRITE( BLOCKFILE, BLK_BUFFER, 2 ) <> 2 THEN BEGIN WRITELN( 'Failure during logsave. Logsave aborted.' ) ; RESULT := 99 ; END ELSE BLOCKS_WRITTEN := BLOCKS_WRITTEN + 2 ; DOTS ; BASE := BASE + INDEX + 1 ; LOGINDEX := LOGINDEX - (INDEX + 1) ; UNTIL (LOGINDEX < 1023) OR (RESULT <> 0) ; MOVELEFT( LOG_ARRAY[BASE], LOG_ARRAY[0], LOGINDEX ) ; IF RESULT <> 0 THEN EXIT(SAVELOG) ; WRITELN ; WRITELN( 'Current logfile size is ', BLOCKS_WRITTEN, ' blocks.' ) ; END ; { DO_BLOCKED } BEGIN WRITELN ; TILDE := '~' ; IF NOT LOGOPEN THEN BEGIN WRITELN( 'THE LOG FILE IS NOT OPEN!' ) ; WRITELN ; EXIT( SAVELOG ) ; END ; IF LOGINDEX < 1 THEN EXIT( SAVELOG ) ; { LOGINDEX points to the next available character position in the buffer. Decrement LOGINDEX by one so that it points to the last character entered. } LOGINDEX := LOGINDEX - 1 ; WRITELN( 'There are ', LOGINDEX, ' characters in the log.'); IF NOT BLOCKED THEN BEGIN REPEAT WRITELN( 'How many lines/page? ' ) ; {$I-} READLN( UNITSIZE ) ; {$I+} UNTIL UNITSIZE > 10 ; PAGE( LOGFILE ) ; WRITELN( 'Writing log to ', LOGFILENAME ) END ELSE BEGIN WRITELN( 'WRITING LOG (', LOGFILENAME, ').' ) ; WRITE ( ' ':11 ) ; END ; LINECOUNT := 0 ; IF BLOCKED THEN DO_BLOCKED ELSE BEGIN FOR I := 0 TO LOGINDEX DO BEGIN C := LOGARRAY[ I ] ; IF (C >= BLANK) AND (C <= TILDE) THEN BEGIN WRITTEN := TRUE ; WRITE( LOGFILE, C ) ; END ELSE IF C = CHR( RETURNCHAR ) THEN IF WRITTEN THEN BEGIN WRITELN( LOGFILE ) ; IF LINECOUNT >= UNITSIZE THEN BEGIN WRITE( 'PRESS ANY KEY TO CONTINUE' ) ; REPEAT UNTIL CR_KBSTAT ; TRASH := CR_GETKB ; LINECOUNT := 0 ; PAGE( LOGFILE ) ; END ELSE LINECOUNT := LINECOUNT + 1 ; END ; CLEAR_LOG ; END ; LOGINDEX := LOGINDEX + 1 ; { Point to next available position. } RESULT := IORESULT ; IF RESULT <> 0 THEN BEGIN WRITELN ; WRITELN( 'BAD RETURN IN SAVELOG: ', RESULT ) ; WRITELN( 'TERMINATING LOG SAVE' ) ; WRITELN ; EXIT( SAVELOG ) ; END ; END ; (* FOR *) WRITELN ; END ; ======================================================================================== DOCUMENT :usus Folder:VOL15:term.main.text ======================================================================================== PROGRAM TERMINAL ; {xL PRINTER: } (* COPYRIGHT 1980, 1981, 1982 BY ROBERT W. PETERSON. ALL RIGHTS RESERVED. This program talks to the REMIN: and REMOUT: and has the following capabilities: 1. Dumb terminal emulation. 2. Logging to a file the text received. 3. Transmitting down the line a file. 4. Echoing or not echoing the characters typed/transmitted. 5. Selecting the name of the log file dynamically. 6. Transmitting a predefined logon sequence to REMOUT: 7. Automatically dialing a telephone number. 8. Optional Videotex copatibility. ================================================================================ This program references the following files at compile time: 1. An implementation of the USUS Standard Remote Unit of August 1981 stored in the file "STD.UNIT.CODE". 2. Include file "TERM.INIT.TEXT", containing the program's initialization procedure. 3. Include file "TERM.LOG.TEXT", containing procedures which are involved in logging text to disk, including opening a log file, moving chunks of the memory buffer to the log file but not placing characters into the memory buffer. 4. Include file "TERM.UTIL.TEXT", containing the program's utility procedures, including menu display, option selection, transmitting of a logon, and other short utilities. 5. Include file "TERM.EMUL.TEXT", containing the actual terminal emulation code, including receiving characters from remote and keyboard, displaying them, and moving them to the memory buffer. ================================================================================ This program was originally developed using Version IV.01 on a machine with only 56K bytes of memory and contains too many segment procedures to successfully compile under most other versions. The procedures are organized such that the largest procedures are in the early part of the source file. These large procedures should probably remain segmented. Later procedures are smaller and can be made memory resident with only a minor expansion of memory requirements. The source code has been marked in the appropriate place for native code generation. *) {$P+} (*============================================================================== Logons are optionally read from the file named in the constant "LOGON_FILENAME". If the file cannot be found, the program ignores its absence and proceeds. Entries in this file consist of nine lines: Line Data 1 Name of the entity being called. For example: "Compuserve", "Source", "Local ABBS" The name can be a maximum of 29 characters. 2 Logon ID. This is the first of two logon lines sent using the send logon command. The ID can be a maximum of 21 characters 3 Password. This is the second of the two logon lines sent using the send logon command. The password can be a maximum of 21 characters 4 Prompt character. The send logon command waits for this character to be sent by the remote system before the second logon line is sent. The first character of the line is used. The rest of the line is ignored. If the line contains no characters, a question mark is used. 5 Phone number. This is the complete telephone number of the remote system. This number will be used if auto-dial support is available in the Remote Unit. The number can be a maximum of 21 characters. The following four lines are flag settings. Each line must begin with a "T" (without quotes) if the associated flag is to be set true. If the flag is to be set false the line must begin with "F". 6 Filter Control Character flag. If this flag is true, control characters sent from the remote system will not be displayed nor will they be moved into the log buffer. This flag is usually true. 7 Logging. If true, received characters will be placed into an internal buffer for later movement to a perpherial device. 8 Echo. If true the terminal program will echo to the screen locally all characters typed. Echo is true for half-duplex systems only. For most systems, this flag is false. 9 VideoText Compatible. If the remote system is sending CRT control characters compatible with Compuserve's VideoText control characters and you wish to respond to those control characters, this flag should be true. Otherwise it should be false. If you intend to set this flag True you must change the constants marked as Videotex to match your CRT requirements. *) {$P+} { The following unit must include the majority of the routines specified in the USUS Standard Remote Unit of 1981. For a specification of the unit, see USUS News #5, Fall 1981. If you are not a USUS member, contact USUS (the UCSD p-System User Society) at P.O. Box 1148, La Jolla, California 92038 for membership information. } USES {$U :STD.UNIT.CODE } REMUNIT ; {$P+} CONST ARROW_DOWN = 18 ; { Used only in Videotex code } ARROW_LEFT = 20 ; { Used only in Videotex code } ARROW_RIGHT = 19 ; { Used only in Videotex code } ARROW_UP = 17 ; { Used only in Videotex code } BACKSPACE = 8 ; CLEAR_EOLN = 29 ; { Used only in Videotex code } CLEAR_EOS = 28 ; { Used only in Videotex code } CLEAR_SCREEN = 12 ; { Used only in Videotex code } CR = 13 ; ESCAPE = 27 ; FORMFEED = 12 ; HOME_CURSOR = 11 ; { Used only in Videotex code } KB = 2 ; LINEFEED = 10 ; LOGLIMIT = 10000 ; LOGON_FILENAME= ':LOGONS.TEXT' ; { Leave the colon on! It is required. } PRINTER = 6 ; REMIN = 7 ; REMOUT = 8 ; RUBOUT = 127 ; VERSION = ' VERSION 2.00 20 May 82 Standard USUS remote unit' ; VAR { Short, frequently referenced variables. } C : CHAR ; BLOCKED : BOOLEAN ; DONE : BOOLEAN ; ECHO : BOOLEAN ; FILTERCONTROL : BOOLEAN ; LOGINDEX : 0 .. LOGLIMIT ; LOGOPEN : BOOLEAN ; LOGPROMPT : CHAR ; LOGTEXT : BOOLEAN ; NEARLY : 0 .. LOGLIMIT ; VIDEOTEXT : BOOLEAN ; FILTERSET : SET OF CHAR ; { Larger, structured or infrequently referenced variables. } BLOCKFILE : FILE ; BLOCKS_WRITTEN: INTEGER ; LOGARRAY : PACKED ARRAY [ 0 .. LOGLIMIT ] OF CHAR ; LOGFILE : TEXT ; LOGFILENAME : STRING[ 30 ] ; LOGON_DEFINED : BOOLEAN ; LOGON1 : STRING ; LOGON2 : STRING ; NUMBER : STRING ; TIMESHARE_SERVICE : STRING[29] ; {$P+} SEGMENT PROCEDURE ADD_TEXT( Var S : STRING ) ; FORWARD ; SEGMENT PROCEDURE CLEAR_LOG ; FORWARD ; PROCEDURE CLEAR_THE_SCREEN ; FORWARD ; PROCEDURE DISPLAY( C : CHAR ) ; FORWARD ; PROCEDURE LOGIT( C : CHAR ) ; FORWARD ; SEGMENT PROCEDURE FLUSHBLOCKED ; FORWARD ; SEGMENT PROCEDURE OPTIONS ; FORWARD ; SEGMENT PROCEDURE PROCEED ; FORWARD ; SEGMENT FUNCTION QUESTION( PROMPT : STRING ) : BOOLEAN;FORWARD ; SEGMENT PROCEDURE SAVELOG ; FORWARD ; SEGMENT PROCEDURE SEND_LOGON ; FORWARD ; {$I :TERM.INIT.TEXT } {$I :TERM.LOG.TEXT } {$I :TERM.UTIL.TEXT } {$I :TERM.EMUL.TEXT } {$P+} BEGIN { TERMINAL } { The following variables are initialized only at program startup. They are not changed when the user requests reinitialization of the program. } BLOCKED := FALSE ; LOG_INDEX := 0 ; LOG_TEXT := FALSE ; LOG_OPEN := FALSE ; INITIALIZE ; EMULATE ; { Do termination here so we can get off the line ASAP. } CR_COMMQUIT ; { Now we can, if necessary, save the log at our leisure. } IF LOGINDEX > 0 THEN BEGIN WRITELN ; WRITE ( 'There are ', LOGINDEX, ' characters in the log which have not' ); WRITELN( ' been written to disk.'); IF QUESTION( 'Do you wish to write the log ' ) THEN BEGIN WRITELN ; IF NOT LOGOPEN THEN SETLOGFILENAME ; IF LOGOPEN THEN BEGIN SAVELOG ; IF BLOCKED THEN FLUSHBLOCKED ; END ; END ELSE { Zero the log index so CLOSELOG won't write anything. } LOGINDEX := 0 ; END ; WRITELN ; CLOSELOG ; END. ======================================================================================== DOCUMENT :usus Folder:VOL15:term.util.text ======================================================================================== {$P+} SEGMENT PROCEDURE DUMPFILE ;{ Move a file to the comm line. } CONST CR = 13 ; LF = 10 ; VAR I : INTEGER ; LINEFEED : BOOLEAN ; LOGSTATUS : BOOLEAN ; PACE : BOOLEAN ; RESULT : INTEGER ; WAIT_CHARACTER : CHAR ; WAIT_CR : BOOLEAN ; READBUFFER : STRING[255] ; XMITFILE : TEXT ; XMITNAME : STRING ; PROCEDURE DUMPIT ; {$N+} BEGIN WRITELN ; WRITELN( 'TRANSMITTING ', XMITNAME ) ; WRITELN( 'USE TO ABORT TRANSMISSION' ) ; WHILE NOT EOF( XMITFILE ) DO BEGIN READLN( XMITFILE, READBUFFER ) ; IF LENGTH( READBUFFER ) = 0 { See if the line is empty. } THEN READBUFFER := ' ' ; { Make the line at least a space long. } { Write the first character before entering the loop. This results in better performance, especially when waiting for each character before sending the next. The reason is simple: The previous character is being returned while the current character is being sent, resulting in a character available quite soon after the program is ready to receive it. This works best when a specific character is looked for at the end of each line, since any extra characters will be displayed while looking for the specific character. That is, it is best if the program looks for a character at the start of each line. A is always available, if nothing else is appropriate. } IF CR_CARRIER AND (LENGTH( READBUFFER ) > 0) THEN CR_PUTREM( READBUFFER[1] ) ; FOR I := 2 TO LENGTH( READBUFFER ) DO BEGIN IF NOT CR_CARRIER THEN BEGIN WRITELN ; WRITELN( 'LOST CARRIER. TRANSMITTING ABORTED.' ) ; EXIT( DUMPIT ) ; END ; CR_PUTREM( READBUFFER[ I ] ) ; IF PACE THEN REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_REMSTAT THEN REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_REMSTAT THEN DISPLAY( CR_GETREM ) ; END ; CR_PUTREM( CHR( CR ) ) ; IF LINEFEED THEN CR_PUTREM( CHR( LF ) ) ; IF WAIT_CR THEN REPEAT IF CR_REMSTAT THEN BEGIN C := CR_GETREM ; DISPLAY( C ) ; END ELSE C := CHR( 0 ) ; UNTIL (C = WAIT_CHARACTER) OR CR_KBSTAT ; IF CR_KBSTAT THEN IF CR_GETKB = CR_ATTENCHAR THEN EXIT( DUMPIT ) ; END END ; {$N-} BEGIN (*$I-*) LOGSTATUS := LOGTEXT ; WRITELN ; WRITELN( 'DUMP A FILE TO REMOUT:' ) ; WRITELN( 'To quit, enter an empty filename.' ) ; WRITELN ; LOGTEXT := QUESTION( 'Log transmitted data' ) ; LINEFEED := QUESTION( 'Transmit Linefeed after each carriage return ' ) ; PACE := QUESTION( 'Wait for each character to be echoed ' ) ; WAIT_CR := QUESTION( 'Wait for a returned character after each line ' ) ; IF WAIT_CR THEN REPEAT WRITELN ; WRITE( 'ENTER THE CHARACTER TO WAIT FOR:' ) ; REPEAT UNTIL CR_KBSTAT ; WAIT_CHARACTER := CR_GETKB ; IF WAIT_CHARACTER IN [' '..'~'] THEN WRITELN( WAIT_CHARACTER ) ELSE WRITELN( '<', ORD(WAIT_CHARACTER), '>' ) ; UNTIL QUESTION( 'Is this the correct character ' ) ELSE WAIT_CHARACTER := CHR( 0 ) ; REPEAT WRITELN ; WRITE ( 'What is the transmit textfile name? ') ; READLN ( XMITNAME ) ; IF LENGTH( XMITNAME ) > 0 THEN BEGIN ADD_TEXT( XMITNAME ) ; RESET ( XMITFILE, XMITNAME ) ; RESULT := IORESULT ; IF RESULT = 0 THEN BEGIN DUMPIT ; WRITE( XMITNAME, ' COMPLETED.' ) ; LOGTEXT := LOGSTATUS ; EXIT( DUMPFILE ) ; END ELSE BEGIN WRITELN ; WRITELN( 'CANNOT FIND ', XMITNAME ) ; END ; END ; UNTIL (LENGTH( XMITNAME ) = 0 ) ; (*$I+*) LOGTEXT := LOGSTATUS ; { Restore original logging status } END ; {$P+} SEGMENT PROCEDURE MENU ; CONST OUTPUTLOGON = '5' ; QUIT = '6' ; RETURNTOTERMINAL = '8' ; VAR GOOD : BOOLEAN ; O : CHAR ; PROCEDURE BACKUP( LINES : INTEGER ) ; CONST MAX_BACKUP = 1024 ; VAR I : INTEGER ; INDEX : 0..LOGLIMIT ; BUFFER : PACKED ARRAY[0..MAX_BACKUP] OF CHAR ; BEGIN IF LOGINDEX < 2 THEN EXIT( BACKUP ) ; INDEX := LOGINDEX ; IF LINES > 23 THEN LINES := 23 ; I := 0 ; REPEAT INDEX := INDEX - 1 ; IF LOG_ARRAY[INDEX] = CHR( 13 ) THEN I := I + 1 ; UNTIL { We have the requested number of lines. } (I > LINES) OR { We've run out of saved characters. } (INDEX = 0) { And be sure we don't overrun the buffer array. } OR ((LOGINDEX - INDEX) >= MAX_BACKUP) ; MOVELEFT( LOG_ARRAY[INDEX], BUFFER[0], LOGINDEX - INDEX ) ; CLEAR_THE_SCREEN ; { Clear the screen. } UNITWRITE( 1, BUFFER, LOGINDEX - INDEX ) ; END ; { BACKUP } BEGIN REPEAT WRITELN ; WRITELN( ' ':10, 'TERMINAL PROGRAM MENU' ) ; WRITELN( 'Total log space = ', LOGLIMIT, '. Space used = ', LOGINDEX, ' (', LOGINDEX DIV (LOGLIMIT DIV 100), '%)' ) ; IF LOGOPEN AND BLOCKED THEN WRITELN( 'The logfile is ', BLOCKS_WRITTEN, ' blocks long.' ) ; WRITE ( '1. Set Options (Currently: ' ) ; IF ECHO THEN WRITE( 'Half Duplex' ) ELSE WRITE( 'Full Duplex' ) ; IF LOGTEXT THEN WRITE( ', Logging' ) ; IF FILTERCONTROL THEN WRITE( ', Filter' ) ; IF VIDEOTEXT THEN WRITELN( ', Videotex)' ) ELSE WRITELN( ')' ) ; WRITELN( '2. Select Log File Name' ) ; IF LOGOPEN THEN WRITELN( '3. Save Log (', LOG_FILE_NAME, ' is open)' ) ELSE WRITELN( '3. Save Log' ) ; WRITELN( '4. Reset (clear) Log' ) ; IF LENGTH( LOGON1 ) > 0 THEN WRITELN( '5. Send Logon String (Service is ', TIMESHARE_SERVICE, '; ID is "', LOGON1, '")' ) ELSE WRITELN( '5. Send Logon String (No string specified)' ) ; WRITELN( '6. QUIT TERMINAL PROGRAM' ) ; WRITELN( '7. Transmit File' ) ; WRITELN( '8. Quit Options & Return to terminal emulation' ) ; WRITELN( '9. ReInitialize program' ) ; WRITELN ; WRITE ( 'Select option number:' ) ; REPEAT READ ( KEYBOARD, O ) ; UNTIL O IN [ '1' .. '9' ] ; WRITE( O ) ; CASE O OF '1' : OPTIONS ; '2' : SETLOGFILENAME ; '3' : SAVELOG ; '4' : CLEARLOG ; OUTPUTLOGON : SENDLOGON ; QUIT: DONE := TRUE ; '7' : DUMPFILE ; RETURNTOTERMINAL : ; '9' : INITIALIZE ; END ; UNTIL O IN [ OUTPUTLOGON, RETURNTOTERMINAL, QUIT, '7', '3' ] ; WRITELN ; IF O IN [OUTPUTLOGON, RETURNTOTERMINAL, '3'] THEN BACKUP( 10 ) ; END ; {$P+} SEGMENT PROCEDURE CLEARLOG ; BEGIN IF QUESTION( 'CLEAR LOG: Are you sure ' ) THEN LOGINDEX := 0 END ; {$P+} SEGMENT PROCEDURE SENDLOGON ; VAR I : 0 .. LOGLIMIT ; BEGIN WRITELN ; WRITELN ; WRITELN( 'Transmitting ', TIMESHARE_SERVICE, ' logon.' ) ; FOR I := 1 TO LENGTH( LOGON1 ) DO BEGIN CR_PUTREM( LOGON1[ I ] ) ; REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; IF CR_REMSTAT THEN DISPLAY( CR_GETREM ) ; END ; CR_PUTREM( CHR(CR) ) ; (* CR *) REPEAT IF CR_REMSTAT THEN BEGIN C := CR_GETREM ; DISPLAY( C ) ; END ELSE C := CHR( 0 ) ; UNTIL (C = LOGPROMPT) OR CR_KBSTAT ; FOR I := 1 TO LENGTH( LOGON2 ) DO CR_PUTREM( LOGON2[ I ] ) ; CR_PUTREM( CHR(CR) ) ; (* CR *) END ; {$P+} SEGMENT FUNCTION QUESTION{ PROMPT : STRING ) : BOOLEAN}; VAR C : CHAR ; BEGIN WRITELN ; WRITELN ; WRITE ( PROMPT, '(Y or N)?' ) ; REPEAT READ( KEYBOARD, C ) ; UNTIL C IN [ 'y', 'n', 'Y', 'N' ] ; WRITE( C ) ; QUESTION := C IN ['y', 'Y'] ; END ; {$P+} SEGMENT PROCEDURE OPTIONS ; BEGIN FILTERCONTROL := QUESTION( 'Do you wish to filter control characters' ) ; LOGTEXT := QUESTION( 'Do you wish to log the text' ) ; ECHO := QUESTION( 'Do you wish to echo the keyboard' ) ; VIDEOTEXT := QUESTION( 'Do you wish to respond to videotext control codes' ) ; WRITELN ; WRITELN ; WRITELN ; END ; {$P+} SEGMENT PROCEDURE ADD_TEXT{ VAR S : STRING } ; VAR I : INTEGER ; LEN : INTEGER ; BEGIN LEN := LENGTH( S ) ; FOR I := 1 TO LEN DO { Make the name all upper-case. } IF S[I] IN ['a'..'z'] THEN S[I] := CHR( ORD( S[I] ) - 32 ) ; IF POS( ']', S ) = 0 { See if a size specified. } THEN IF LEN >= 5 THEN BEGIN IF (POS( '.TEXT', S ) <> LEN - 4) AND (S[LEN] <> '.') THEN S := CONCAT( S, '.TEXT' ) ; END ELSE IF S[LEN] <> '.' THEN S := CONCAT( S, '.TEXT' ) ; END ; {$P+} SEGMENT PROCEDURE PROCEED ; BEGIN { Initialize by going "off hook" then back "on hook" } { This should allow manual dialing (or support direct } { connection of two computers. } CR_HOOK( FALSE ) ; CR_HOOK( TRUE ) ; WRITELN ; WRITELN( 'Proceed when connection has been made.' ) ; END ; {$P+} SEGMENT PROCEDURE FLUSHBLOCKED ; { Write out the remaining characters in the log. } VAR BLK_BUFFER : PACKED ARRAY[0..1023] OF CHAR ; BEGIN IF LOG_INDEX >= 1023 THEN SAVE_LOG ; IF LOG_INDEX > 1023 THEN BEGIN WRITELN( 'INTERNAL ERROR IN "FLUSH_BLOCKED". PROGRAM ABORTS.' ) ; IF QUESTION( CONCAT( 'Save ', LOGFILENAME )) THEN CLOSE( BLOCKFILE, LOCK ) ELSE CLOSE( BLOCKFILE, PURGE ) ; EXIT( PROGRAM ) ; END ; MOVELEFT( LOG_ARRAY[0], BLK_BUFFER[0], LOG_INDEX ) ; IF LOG_INDEX < 1024 THEN BEGIN FILLCHAR( BLK_BUFFER[ LOG_INDEX ], 1024 - LOG_INDEX, CHR( 0 ) ) ; BLK_BUFFER[ LOG_INDEX ] := CHR( 13 ) ; END ; IF BLOCKWRITE( BLOCKFILE, BLK_BUFFER, 2 ) <> 2 THEN WRITELN( 'Error writing last two blocks of log.' ) ELSE BLOCKS_WRITTEN := BLOCKS_WRITTEN + 2 ; LOG_INDEX := 0 ; { We've written everything. } END ; { FLUSHBLOCKED } {$P+} PROCEDURE CLEAR_THE_SCREEN ; BEGIN { For some machines, this might not work! Therefore clearing the screen is centralized for easy modification. } PAGE( OUTPUT ) ; END ; ======================================================================================== DOCUMENT :usus Folder:VOL15:tomus3.a.text ======================================================================================== INSTRUCTIONS FOR TOMUSUS.03 1. GENERAL INFORMATION TOMUSUS stands for "Terminal Option for MUSUS" and is pronounced "to muse us". It is a modified version of Bob Peterson's TERMINAL program which utilizes REMUNIT, the standard communication UNIT adopted by USUS for all terminal communication programs in UCSD Pascal. TOMUSUS.03 is an upgraded version of TOMUSUS.02, which was previously made available for LSI-11 users of MUSUS. TOMUSUS.03 is more efficient for disk operations during transmission and also has the following new features: a. The B(reak option, which transmits the break signal to the remote computer; b. The X(off option, which transmits the XOFF (control-S) signal to the remote computer; c. O(ptions will now present a submenu. It should be noted that REMUNIT.L3, which is used by TOMUSUS.03, utilizes the two external procedures SET_BREAK and CLR_BREAK. These are assembly language programs for the LSI-11 which perform the simple functions of turning on and off the hardware generated break signals. The present code for these procedures assume the standard addresses for REMIN and REMOUT (177520). If any other address is to be used, the value for XCSR in both SET_BREAK and CLR_BREAK must be altered accordingly. 2. CONTENTS OF THE TOMUSUS FILES The MUSUS Library version of TOMUSUS.03 consists of the following five files: TOMUS3.A contains instructions for compiling and executing TOMUSUS.03. (This is what you are reading now.) TOMUS3.B1 contains the external procedure SET_BREAK and should be renamed SET_BREAK.TEXT. TOMUS3.B2 contains the external procedure CLR_BREAK and should be renamed CLR_BREAK.TEXT. TOMUS3.B3 contains the unit REMUNIT for TOMUSUS.03 and should be renamed REMUNIT.L3.TEXT. (The "L" in L3 is to remind you that this unit was written primarily for LSI-11s.) TOMUS3.C1 and TOMUS3.C2 together make up the main TOMUSUS.03 program. TOMUS3.C1 contains program comments that should be inserted at the beginning of the program just after the copyright statement. TOMUS3.C2 contains the main TOMUSUS.03 program. It should be renamed TOMUSUS.03.TEXT. The following instructions for compiling TOMUSUS.03 will assume that you have renamed the files as above. 3. COMPILING TOMUSUS.03 uses the unit REMUNIT.L3 which in turn uses the external procedures SET_BREAK and CLR_BREAK. Hence, the procedure for compiling the entire program must be done in the appropriate sequence of steps, as follows. Step 1: Assemble SET_BREAK.TEXT and get SET_BREAK.CODE. Step 2: Assemble CLR_BREAK.TEXT and get CLR_BREAK.CODE. Step 3: Compile REMUNIT.L3.TEXT and get REMUNIT.L3.CODE. Step 4: By executing the system program *LIBRARY.CODE, create a new library (call it anything you want) which will contain the contents of *SYSTEM.LIBRARY, SET_BREAK.CODE, CLR_BREAK.CODE, and REMUNIT.L3.CODE. Step 5: Do a L(ink of the new library. Step 6: Use the linked library as your new *SYSTEM.LIBRARY. Step 7: R(un TOMUSUS.03.TEXT and get TOMUSUS.03.CODE as well as a test run of the program. 2. EXECUTING TOMUSUS.03.CODE Execution of TOMUSUS should be almost self-explanatory, but the following comments may be of some help. a. After you do an eXecute on TOMUSUS, it will display a brief statement on your screen about the TOMUSUS version, date, author's name, and a copyright statement. It will then ask you to press RETURN. b. After RETURN has been entered, TOMUSUS is ready to communicate with the remote computer of your choice. If you had not already done so, you should connect your modem to the telephone system at this time and dial the remote computer. Nothing else needs to be done as far as TOMUSUS is concerned. c. At anytime during or prior to establishing your remote connection (but after the initial RETURN), you may temporarily enter the offline mode of TOMUSUS by pressing the "attention character". The default for this is control-E (or control-e). When the attention character is pressed, TOMUSUS will temporarily enter an "off-line" mode and display a menu of certain things you may choose to do at this point, as follows: (1) Q(uit will terminate the current TOMUSUS session. (2) C(ontinue will cause an immediate exit from the offline mode. (A control-c will also do the same.) (3) B(reak will send the break signal to the remote. (4) X(off will send the XOFF character (control-s) to the remote. (Other control characters can be sent directly from the keyboard, except for the TOMUSUS attention character.) (5) O(ptions stands for "miscellaneous options". It will display its own submenu. Each selection will result in a question to the user concerning certain transmission characteristics, echoing, or the attention character. If you want to change the attention character or communicate with a half duplex remote, this is where you would change your parameters. (6) L(ogfile will permit you to initiate or terminate logging your session to a diskfile. It will first tell you whether a logfile is currently open or not. If not open, it will ask you if you want to open a logfile. If you answer with a "Y" or "y", it will ask for a file name. You should specify a complete diskfile name. (Remember to use .TEXT if you will subsequently use the Editor on this file.) If you change your mind, a null entry will cancel this operation. If open, it will ask if you want to close the diskfile. Opening and closing diskfiles can be done as many times as is desired during a session. Hence, you can write different portions of your session to different disk files. (7) P(rinter is a toggle switch that allows you to open or close the line printer at any time during your TOMUSUS session. The current print routine sends characters to the printer as they are typed or received from the remote computer. Hence, if your printer does not allow the immediate printing of characters received (or does not have the necessary line buffer to collect a line of characters before printing), you may run into problems. d. The offline mode can be entered at any time and as often as you wish. In the current implementation of REMUNIT, you can Q(uit out of TOMUSUS and re-execute TOMUSUS without affecting your remote communication. This also means that if necessary you can even do some offline maneuvers (like examining your disk directory) and then return to the online mode without affecting your remote connection. 3. KNOWN BUGS There is a bug in TOMUSUS.03 that has not been fixed. This bug is encountered when both the L(ogfile and P(rinter options are on. The result is that both the disk file and printer output will$lose some characters. It does not happen when only one of these options is on. This bug may only affect those who have the same printer configuration as mine, which is a TI-810 connected to a Heath H-11 via the Heath serial I/O board for the TI-810. 4. FINAL COMMENTS Although TOMUSUS bears my copyright statement, it is the result of a cooperative effort between myself and the following persons: Robert W. Peterson, who was kind enough to allow me to use his program TERMINAL and his unit REMUNIT as the starting point for TOMUSUS; Walter B. Farrell, who made most of the necessary changes to Bob Peterson's REMUNIT that allowed the autolog function of TOMUSUS.02 to work properly; and Dr. Richard Yensen, who provided me with the BLOCKWRITE and UNITWRITE changes that speeded up the autolog function. By the way, TOMUSUS was copyrighted primarily to protect Bob Peterson's copyright rather than my own code. If you wish to make further changes for your own use, I see no reason why Bob would object. However, if you distribute any modified version of TOMUSUS, I think that you should check with Bob and me first. I would appreciate any and all comments about TOMUSUS, whether you like it or not. I am sure that many improvements can be made, and would like to have any help you could provide to make TOMUSUS a really useful and enjoyable program. If you have any problems with TOMUSUS, feel free to send me messages on MUSUS or Telemail, or call me at (213)541-2918 any time I'm there (day or night). Mike Ikezawa 03 December 1981 ======================================================================================== DOCUMENT :usus Folder:VOL15:tomus3.c1.text ======================================================================================== { This is a modified version of an unpublished, copyrighted program called TERMINAL by Robert W. Peterson. TOMUSUS uses the unit REMUNIT by R.W. Peterson as modified by Walt Farrell and myself. Modifications by this author are in lower case throughout the program. Since the original TERMINAL code was entirely in upper case, except for a few user prompt output, all modifications can be identified by the use of lower case. Original code that have simply been moved from one location to another retain their upper case. TOMUSUS differs from TERMINAL in the following ways: (1) Saving the log file is done automatically. (2) The logtext option can be switched on and off without re-initializing. (3) The printer can be switched on and off at any time independent of the logtext options. (4) The following options have been deleted: Videotext Filter control characters Logtext to printer and console (5) The menu has been changed. UCSD system style menus are used. The menu is automatically exited after each menu function is completed. Control-E is used to enter the menu. Control-C or the C(ontinue option will exit the menu immediately. The Q(uit option terminate the program after closing previously opened files. The L(ogfile option has sub-options to open or close files. The P(rinter option is a toggle switch that opens and closes the printer file. The T(ransmit option has been simplified by the removal of all sub-options except the filename selection. O(ptions is now the central place for all other options previously residing in other places, e.g. initialization and transmit. TOMUSUS is designed primarily for the LSI-11, but it may work on other hardware running UCSD Version IV.0. It will not run on Version II.0, because the required REMUNIT does not compile on II.0. VERSION 03: Version 03 differs from Version 02 as follows: (1) The Version 03 menu includes the option B(reak. Therefore, it assumes that CR_BREAK has been implemented in REMUNIT. (2) The Version 03 menu also includes the option X(off. This permits XOFF (control-S) to be transmitted to the remote computer. (Typing control-S instead of using X(off causes the p-system to pause rather than the remote system.) No TOMUSUS option is necessary to transmit XON, because control-Q and control-W are passed to the remote system by the p-system. (3) Execution of the Logfile option has been speeded up consider- ably, thanks to Richard Yensen's modification that replaced the WRITE to disk statement with the BLOCKWRITE statement. This change further permitted the deletion of the XOFF/XON sequence thereby making it possible to use the Logfile option when communicating with remote systems that do not recognize XOFF/XON. Yensen also replaced the WRITE to console and WRITE to printer statements with UNITWRITE statements. (4) A submenu has been installed in Options. This permits a more direct access to each TOMUSUS setting. All inquiries about this program should be addressed to: Michael A. Ikezawa 10 Packsaddle Road West Rolling Hills, CA 90274 (213)541-2918 } ======================================================================================== DOCUMENT :usus Folder:VOL15:tomus4.c2.text ======================================================================================== { L printer:} PROGRAM tomusus ; { Version 04 15 July 1982 (C) Copyright 1981 ,1982 by Michael A. Ikezawa } {The comments contained in the MUSUS Library file TOMUS3.C1 should be inserted here. They were made a separate file due to the 30 block limitation of the Screen Editor. MAI} USES (*$U remunit.l3.code*)REMUNIT ; CONST BACKSPACE = 8 ; CR = 13 ; ESCAPE = 27 ; FORMFEED = 12 ; KB = 2 ; LF = 10 ; LOGLIMIT = 1024 ; PRINTER = 6 ; REMIN = 7 ; REMOUT = 8 ; RUBOUT = 127 ; xon = 17 ; xoff = 19 ; VAR C : CHAR ; DONE : BOOLEAN ; ECHO : BOOLEAN ; linefeed : boolean ; LOGARRAY : PACKED ARRAY [ 1 .. LOGLIMIT ] OF CHAR ; {change lower limit from 0 for Yensen stuff} LOGFILE : file ; {Yensen} LOGFILENAME : STRING[ 30 ] ; LOGINDEX : 0 .. LOGLIMIT ; LOGTEXT : BOOLEAN ; pace : boolean; printext : boolean; printfile : text; wait_character: char; wait_cr : boolean; outbuf : packed array [ 1 .. loglimit ] of char; {gws} procedure savelog; forward; procedure openlog; forward; PROCEDURE LOGIT( C : CHAR ) ; BEGIN logindex := succ(logindex) ; {Yensen} LOGARRAY[ LOGINDEX ] := C ; IF LOGINDEX >= LOGLIMIT THEN savelog; END ; PROCEDURE DISPLAY( C : CHAR ) ; BEGIN IF C <> CHR(LF) THEN begin unitwrite(1,C,1,1) ; {Yensen} IF LOGTEXT THEN LOGIT( C ) ; If printext then unitwrite(printer,C,1,1) ; {Yensen} end END ; FUNCTION QUESTION( PROMPT : STRING ) : BOOLEAN ; VAR C : CHAR ; BEGIN WRITE ( PROMPT, ' (y or n)? ' ) ; REPEAT READ( KEYBOARD, C ) ; UNTIL C IN [ 'y', 'n', 'Y', 'N' ] ; WRITEln( C ) ; QUESTION := C IN ['y', 'Y'] ; END ; procedure menu; forward; PROCEDURE OPTIONS ; var C :CHAR; B :BOOLEAN; good :boolean; o :char; quit :boolean; procedure wait; begin wait_cr := question( 'Wait for a returned character after each line' ); IF WAIT_CR THEN REPEAT WRITELN ; write( 'Enter the character to wait for:' ) ; READ( KEYBOARD, WAIT_CHARACTER ) ; IF EOLN (keyboard) THEN WAIT_CHARACTER := CHR( CR ) ; IF WAIT_CHARACTER IN ['A'..'~'] THEN WRITELN( WAIT_CHARACTER ) ELSE writeln( ' CHR(', ORD(WAIT_CHARACTER), ')' ) ; UNTIL QUESTION( 'Is this the correct character ' ) ELSE WAIT_CHARACTER := CHR( 0 ) ; end; procedure attention; {Change attention character} begin REPEAT REPEAT write( 'What attention character will be used? ' ) ; read(keyboard,C); writeln( 'CHR(', ORD( C ), ')' ) ; IF C IN [' '..'~'] THEN WRITELN('You cannot use a displayable character') ELSE B := QUESTION( 'Is this correct' ) ; UNTIL B ; UNTIL NOT (C IN [' '..'~']) ; cr_attenchar := C; end; BEGIN writeln; quit := false; repeat write('OPTIONS: E(cho, L(inefeed, P(ace, W(ait, A(ttention, Q(uit ? '); repeat read(keyboard,o); good := o in ['e','E','l','L','p','P','w','W','a','A','q','Q']; if good then begin writeln(o); writeln; case o of 'e','E' : echo := question( 'Echo the keyboard' ); 'l','L' : linefeed := question( 'Send linefeeds' ); 'p','P' : pace := question( 'Wait for each character to be echoed' ); 'w','W' : wait; 'a','A' : attention; 'q','Q' : quit := true; end; end else write(chr(7)); until good; writeln; until quit; END ; PROCEDURE INITIALIZE ; VAR B : BOOLEAN ; C : CHAR ; HAVEDIAL : BOOLEAN ; HAVEREM : BOOLEAN ; RESULT : CR_BAUD_RESULT ; BEGIN gotoxy(10,7); write('TOMUSUS *********** Version 04, 15 July 1982'); gotoxy(10,9); write('(C) Copyright, 1981, 1982 by Michael A. Ikezawa'); gotoxy(10,11); write( 'This program is based on, and contains material from, the'); gotoxy(10,12); write( 'copyrighted program TERMINAL by Robert W. Peterson, 28Mar81'); writeln; writeln; writeln; DONE := FALSE ; logtext := FALSE ; printext := false; echo := false; linefeed := false; pace := false; wait_cr := false; C := CHR( 5 ); CR_COMMINIT( CR_ORIG, C, HAVEREM, HAVEDIAL ) ; IF NOT HAVEREM THEN BEGIN WRITELN( ' REMOTE not supported in current environment.' ) ; WRITELN( ' Program is terminating.' ) ; EXIT( TOMUSUS ) ; END ; CR_SETCOMMUNICATIONS( TRUE, TRUE, 300, 7, 1, CR_ORIG, 'LSI-11', RESULT ) ; WRITEln( 'Press when connection has been made. Thereafter,' ) ; writeln( 'use attention character (default Control-E) for TOMUSUS menu'); writeln( 'whenever necessary.'); writeln; write('==================== ', 'begin communication ', ' ===================='); READLN( KEYBOARD, C ) ; CR_ANSWER ; WRITELN; END ; PROCEDURE CLEARLOG ; BEGIN fillchar(logarray,loglimit,chr(0)) ; {Yensen} LOGINDEX := 0 END ; PROCEDURE CLOSELOG ; VAR RESULT : INTEGER ; BEGIN IF logtext THEN BEGIN savelog; {$I-} CLOSE( LOGFILE, LOCK ) ; RESULT := IORESULT ; {$I+} WRITE( LOGFILENAME ) ; IF RESULT = 0 THEN begin WRITELN(' closed.' ); logtext := false; end ELSE WRITELN(' Failed to close. IORESULT = ', RESULT ) ; END END ; PROCEDURE openlog ; VAR RESULT : INTEGER ; BEGIN REPEAT WRITE ( 'Log filename? ') ; READLN ( LOGFILENAME ) ; IF LENGTH( LOGFILENAME ) > 0 THEN BEGIN if ( pos ( '.text', logfilename ) = 0 ) and ( pos ( '.TEXT', logfilename ) = 0 ) then logfilename := concat ( logfilename , '.TEXT' ); {gws} WRITE( 'Open of ', LOGFILENAME, ' ' ) ; {$I-} REWRITE( LOGFILE, LOGFILENAME ) ; RESULT := IORESULT ; {$I+} logtext := RESULT = 0 ; IF NOT logtext THEN WRITELN( ' failed. REWRITE RESULT = ', RESULT ) ELSE WRITELN( ' was successful.' ) ; END ; UNTIL logtext OR (LENGTH( LOGFILENAME ) = 0 ) ; clearlog; result := blockwrite ( logfile, logarray, 2 ); {write header block} WRITELN ; END ; PROCEDURE SAVELOG ; {completely rewritten to output a legal textfile - gws} VAR RESULT : INTEGER ; excess_chars : integer; BEGIN if logindex = 0 then exit(savelog); fillchar ( outbuf, sizeof ( outbuf ), chr ( 0 ) ); excess_chars := scan ( -1024, = chr ( 13 ), logarray [ sizeof ( logarray ) ] ); excess_chars := - excess_chars; moveleft ( logarray, outbuf, sizeof ( logarray ) - excess_chars ); result := (blockwrite(logfile,outbuf,2)) ; if result <> 2 then writeln( 'Only ',result,' blocks written') else begin if excess_char <> 0 then begin moveleft ( logarray [ sizeof ( logarray ) - excess_chars + 1 ], logarray, excess_chars ); fillchar ( logarray [ excess_chars + 1 ], sizeof ( logarray ) - excess_chars - 1, chr ( 0 ) ); logindex := excess_chars; end else clear_log; end; END ; PROCEDURE SENDLOGON ; BEGIN END ; PROCEDURE DUMPFILE ; VAR I : INTEGER ; READBUFFER : STRING ; RESULT : INTEGER ; XMITFILE : TEXT ; XMITNAME : STRING ; procedure endmarker; begin writeln; writeln('==================== ', 'end transmission ', ' ===================='); end; PROCEDURE DUMPIT ; BEGIN WRITELN( 'Transmitting ', XMITNAME ) ; WRITELN( 'Use attention character to abort transmission' ) ; writeln('==================== ', 'begin transmission ', ' ===================='); WHILE NOT EOF( XMITFILE ) DO BEGIN READLN( XMITFILE, READBUFFER ) ; FOR I := 1 TO LENGTH( READBUFFER ) DO BEGIN IF NOT CR_CARRIER THEN BEGIN endmarker; WRITELN( 'Lost carrier. Transmitting aborted.' ) ; EXIT( DUMPIT ) ; END ; IF CR_REMSTAT THEN DISPLAY( CR_GETREM ) ; CR_PUTREM( READBUFFER[ I ] ) ; IF PACE THEN REPEAT UNTIL CR_REMSTAT OR CR_KBSTAT ; END ; CR_PUTREM( CHR( CR ) ) ; IF LINEFEED THEN CR_PUTREM( CHR( LF ) ) ; IF WAIT_CR THEN REPEAT IF CR_REMSTAT THEN BEGIN C := CR_GETREM ; DISPLAY( C ) ; END ELSE C := CHR( 0 ) ; UNTIL (C = WAIT_CHARACTER) OR CR_KBSTAT ; IF CR_KBSTAT THEN begin c := cr_getkb; IF c = CR_ATTENCHAR THEN begin endmarker; writeln('Transmission aborted by user.'); EXIT( DUMPIT ) ; end end END; endmarker; END ; BEGIN (*$I-*) WRITE ( 'Transmit filename? ') ; READLN ( XMITNAME ) ; IF LENGTH( XMITNAME ) <> 0 THEN BEGIN RESET ( XMITFILE, XMITNAME ) ; RESULT := IORESULT ; IF RESULT = 0 THEN BEGIN DUMPIT ; WRITE( XMITNAME, ' completed.' ) ; END ELSE BEGIN WRITELN ; WRITELN( 'Cannot find ', XMITNAME ) ; END ; END ; (*$I+*) END ; procedure openprinter; var result :integer; begin {$I-} rewrite(printfile,'printer:'); result := IORESULT; {$I+} if result = 0 then begin printext := true; write(printfile,chr(12)); writeln('Printer opened'); end else writeln('Printer not opened. IORESULT = ',result); end; procedure closeprinter; var result :integer; begin writeln(printfile); {$I-} close(printfile); result := IORESULT; {$I+} if result = 0 then begin printext := false; writeln('Printer closed'); end else writeln('Printer not closed. IORESULT = ',result); end; procedure logswitch; begin if logtext then begin if (question('Logfile is open. Close it')) then closelog end else if (question('Logfile is closed. Open it')) then openlog end; procedure printswitch; var query :boolean; begin if printext then closeprinter else openprinter; end; PROCEDURE MENU ; VAR GOOD : BOOLEAN ; O : CHAR ; BEGIN unitclear(kb); writeln; writeln('==================== ', 'TOMUSUS menu on ', ' ===================='); write('Q(uit, C(ontinue, B(reak, X(off, O(ptions, '); write('L(ogfile, P(rinter, T(ransmit ? '); repeat READ (keyboard, O ) ; GOOD := O IN ['q','Q','c','C','b','B','x','X','o','O', 'l','L','p','P','t','T'] ; IF GOOD THEN begin writeln(o); writeln; CASE O OF 'q','Q' : DONE := TRUE; 'c','C' : ; 'b','B' : cr_break; 'x','X' : cr_putrem(chr(xoff)); 'o','O' : options; 'l','L' : logswitch ; 'p','P' : printswitch ; 't','T' : DUMPFILE ; END ; end else write(chr(7)); until good; writeln; writeln('==================== ', 'TOMUSUS menu off ', ' ===================='); END ; BEGIN INITIALIZE ; REPEAT IF CR_KBSTAT THEN BEGIN C := CR_GETKB ; IF C = CR_ATTENCHAR THEN BEGIN MENU ; IF NOT (CR_CARRIER OR DONE) THEN CR_ANSWER ; END ELSE BEGIN CR_PUTREM( C ) ; IF ECHO THEN DISPLAY( C ) ; if linefeed and (C=chr(CR)) then cr_putrem(chr(LF)); END ; END ; IF NOT CR_CARRIER THEN BEGIN WRITELN ; WRITELN('LOST CARRIER'); WRITELN ; MENU ; IF NOT (CR_CARRIER OR DONE) THEN CR_ANSWER ; END ELSE IF CR_REMSTAT THEN DISPLAY( CR_GETREM ) ; UNTIL DONE ; writeln('==================== ', 'end communication ', ' ===================='); CLOSELOG ; close(printfile); CR_COMMQUIT ; writeln('Exit TOMUSUS'); END. ======================================================================================== DOCUMENT :usus Folder:VOL15:vol15.doc.text ======================================================================================== USUS Volume 15 Communications software HSM.UROOT.TEXT 22 A RemoteUnit for the Hayes SmartModem (uses UNITSTATUS) HSM.UINC1.TEXT 16 an include file of HSM.UROOT.TEXT STD.UNIT.TEXT 24 A RemoteUnit for a dumb modem (uses UNITSTATUS) TERM.MAIN.TEXT 20 Bob Peterson's terminal emulator program TERM.LOG.TEXT 14 an include file of TERM.MAIN.TEXT HSM.UINC2.TEXT 14 ditto TERM.EMUL.TEXT 10 ditto TERM.INIT.TEXT 22 ditto TERM.UTIL.TEXT 22 ditto CONTENTS.TEXT 14 Documentation for TERM.MAIN and Bob's RemoteUnits SMTREMV5.TEXT 26 A terminal emulator specific to the LSI-11 IOUNIT.TEXT 8 a unit for SMTREMV5.TEXT TOMUS4.C2.TEXT 24 Mike Ikezawa's terminal emulator REMUNIT.L3.TEXT 28 Mike's RemoteUnit (specific to an LSI-11) SET_BREAK.TEXT 4 an external procedure for REMUNIT.L3.TEXT CLR_BREAK.TEXT 4 ditto TOMUS3.C1.TEXT 10 comments for TOMUS4.C2.TEXT TOMUS3.A.TEXT 22 Documentation for TOMUS4.C2.TEXT COMM.TEXT 24 Jon Bondy's terminal emulator REMTALK.TEXT 24 A program to transfer files between two closely coupled UCSD computers at a reasonable rate. TELETALKER.TEXT 24 Randy Bush's Communications program. Uses a RemoteUnit. A.///.REMU.TEXT 72 Arley Dealey's Remote Unit for the Apple /// VOL15.DOC.TEXT 14 You're reading it. ----------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 15 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Some notes from the editor: This volume contains a whole bunch of communications software. I put it all in one volume so that users interested in terminal emulators and such could get a lot for very little investment. Several of the programs use Remote Units. A Remote Unit is a pre- compiled module which contains the implementation and hardware specific interface for remote communications. This unit follows a USUS standard, found in News Letter #5. Once a user writes a remote unit for his particular processor, anybody else's terminal emulator will work (assuming that the terminal emulator follows the standard also). In principle this should work, and lo and behold, it really does. I have used Mike Ikezawa's remote unit to test the other emulators on this disk which also follow the standard, but which had never been used on a LSI-11 before. TERM.MAIN This is Bob Peterson's terminal emulator program. It uses a standard remote unit. He has provided two which work with his POLYMORPHIC (8080) computer. One handles a Hayes SmartModem and the other is for a dumb modem. You will may have to modify the IMPLEMENTATION part of Bob's RemoteUnit to work with your computer but this about the most standard version of a remote unit possible. It requires IV.0 to work. If you have an LSI-11, you can use Mike's RemoteUnit instead. TOMUS4.C2.TEXT This is Mike Ikezawa's terminal emulator program. It started life as an old version of Bob's TERMINAL program. Mike has extensively reworked it and it doesn't even look the same. Mike's REMUNIT.L3.TEXT is his remote unit. I modified it slightly to conform to the published standard (USUS NL#5) and it can be used with Bob's program also. I couldn't test Bob's unit with Mike's program as Bob's unit won't work as is with my LSI-11. Mike's unit uses two external procedures to set and clear the break bit. Since it depends on UNITSTATUS, it will not work with version II.0 (where UNITSTATUS doesn't exist). However it could be modified to use UNITBUSY (as it used to) if desired. COMM This is Jon Bondy's terminal emulator program. I couldn't test it as it is specific to his Z-80 adaptable system. You'll have to modify it and write some external procedures to use it. SMTREMV5 and IOUNIT Way back on Volume 2A there is a program called SMTREMOTE. It didn't work. Besides that it was extremely LSI-11 dependant. It was also somewhat of a kludge. However, since it was the closest thing that I had at that time to a terminal emulator for my LSI-11 on the p-system, I dug in and REALLY hacked it up. It is still a kludge, and it is still VERY LSI-11 dependent, but at least it now works. It is also dependent on an H-19 as it uses the status line and function keys. It does some of its i/o in the strangest fashion, with trick records which allow direct access to the hardware buffers. All this brouha is contained in a unit, IOUNIT.TEXT, which in no way is anything like a remote unit. REMTALK RemTalk is a program to allow two closely-coupled UCSD computers to transfer files back and forth. It includes error checking and will work at 9600 baud even with slow computers (like my H-89 for example, which is about as slow as they come). However, even at 9600 baud, the actual data rate is much slower, about 5 seconds per block due to the handshaking and error checking, it would probably be painfully slow at 300 baud. TELETALKER This is Randy Bush's communication submission. It also requires a remote unit (he supplied one for a MicroEngine which will appear on a future Volume). I tested it with Mike's remote unit for the -11. I think that TeleTalker could use a little work. By the way, in case that fire it up and can't figure how to make it quit, try cntl-A. regards - gws ======================================================================================== DOCUMENT :usus Folder:VOL16:8.inch.text ======================================================================================== PROGRAM WRITLABELS; USES (*$U crtinput.code*) CRTINPUT; CONST LinesPerLabel = 12; Labelwidth = 50 {pica characters}; VAR LabelsPerSheet: integer; ch: char; WantsDECFormat: boolean; TypedIn, VolumeLine: STRING; DECNote: string; S: ARRAY [1..LinesPerLabel] OF string; List: text; PROCEDURE GetVolumeData; VAR OK: boolean; BEGIN REPEAT ClearScreen; Gotoxy(0,12); TypedIn := ''; WantsDECFormat := false; Writeln('You are set up for ', LabelsPerSheet , ' labels per sheet.'); Write ('Please type volume number: '); GetString (2, TypedIn); VolumeLine := CONCAT (' VOLUME ', TypedIn, ' -***- '); Writeln; Write ( 'Is the disk format: U)CSD, C)P/M, or W)estern Digital ("U", "C", or "W")? '); REPEAT Read (keyboard,ch) UNTIL (ch IN ['U','u','C','c','W','w']); CASE ch OF 'U', 'u': BEGIN WantsDECFormat := true; VolumeLine := CONCAT (VolumeLine, 'UCSD format') END; 'C', 'c': VolumeLine := CONCAT (VolumeLine, 'CP/M format'); 'W', 'w': VolumeLine := CONCAT (VolumeLine, 'W/D format') END; Writeln; Writeln ('The new label is "', VolumeLine,'".'); OK := Yes ('Answer when ready to print: is this label correct'); IF NOT OK THEN IF Yes('Want to quit') THEN EXIT(program) UNTIL OK END; PROCEDURE DoWrite; VAR LabelNo, i, j: integer; BEGIN IF VolumeLine = '' THEN GetVolumeData ELSE BEGIN Gotoxy(0,0); UnitClear(1); IF Yes ('Do you want to print the same label again') THEN GoAndClearLine(0) ELSE IF Yes('Want to quit') THEN EXIT(program) ELSE GetVolumeData; END; IF WantsDECFormat THEN i := 11 ELSE i := 12; FOR LabelNo := 1 to LabelsPerSheet DO BEGIN Writeln(List,VolumeLine); IF WantsDECFormat THEN Writeln(List,DECNote); FOR j := 2 TO i DO Writeln(list, S[j]); IF (LabelNo MOD 2 = 0) AND (LabelsPerSheet = 3) THEN Writeln(list); END; FOR j := 1 to 6 DO Writeln(list) {eject sheet}; END; BEGIN {main program} S [2] := ''; S [3] := ' USUS Software Library '; S [4] := ' Jim Gagne, Chairman'; S [5] := ' DATAMED RESEARCH, INC.'; S [6] := ' Los Angeles, California 90077'; S [7] := ''; S [8] := ' For not-for-profit use by USUS members only.'; S [9] := ' May be used & distributed only according to'; S [10] := ' the authors'' wishes and stated policy.'; S [11] := ''; S [12] := ''; DECNote :=' (ie, Skew = 6; Interleave = 2; First track = 1) '; Write ('How many labels per sheet? '); Readln(LabelsPerSheet); VolumeLine := ''; Rewrite (list, 'PRINTER:'); REPEAT DoWrite UNTIL false END. ======================================================================================== DOCUMENT :usus Folder:VOL16:add.text ======================================================================================== { Program: Inv an inventory maintanence program. Programmer: Patrick R. Horton Copyright: Copyright 1980 (c), Associated Computer Industries Permission to copy and distribute for non-profit purposes is hereby granted provided that this header is included on all copies } {ADD.TEXT} SEGMENT PROCEDURE Add; VAR ininv: BOOLEAN; irecnum : INTEGER; ch : CHAR; PROCEDURE Addinvrec; BEGIN WRITELN; WRITELN('part #',arcfile^.partnum,' was not found.'); WRITE('do you wish to add an inventory record? '); READ(ch); IF NOT(ch IN ['Y','y']) THEN EXIT(Add); Clear; GOTOXY(0,10); WRITELN('part number ',arcfile^.partnum); GOTOXY(0,0); WRITE('enter the description --->'); Rdata(26,0,24,invfile^.descrip); GOTOXY(0,1); WRITE('enter the vendor part number --->'); Rdata(33,1,16,invfile^.vpart); GOTOXY(0,2); WRITE('what are the units of distribution --->'); Rdata(39,2,5,invfile^.units); invfile^.qty := 0; invfile^.partnum := arcfile^.partnum; nirecs := nirecs + 1; SEEK(invfile,nirecs); PUT(invfile); irecnum := nirecs; Wnirecs; END; PROCEDURE Getqtydateandcode; BEGIN Clear; Clrline(0,7); WRITELN(invfile^.descrip); WRITELN; WRITELN('part # : ',arcfile^.partnum); WRITELN('present qty: ',invfile^.qty:8:2,' ',invfile^.units); WRITELN; WRITE('enter qty in transaction ---->'); Getreal(0,0,arcfile^.qty); Clrline(0,16); WRITE('enter the transaction code --->'); Rdata(31,16,10,arcfile^.code); REPEAT Clrline(0,17);WRITE('enter the transaction date MMDDYY --->'); Rdata(38,17,6,arcfile^.date); UNTIL Chkdate(arcfile^.date); END; PROCEDURE Putrecs; BEGIN narecs := narecs + 1; ntrans := ntrans + 1; Str(ntrans,arcfile^.trans); SEEK(arcfile,narecs); PUT(arcfile); SEEK(invfile,irecnum); PUT(invfile); Wnarecs; END; BEGIN Clear; WRITE('enter part # of items to be added to inventory --->'); Rdata(51,0,16,arcfile^.partnum); ininv := FALSE; FOR temp := 1 TO nirecs DO BEGIN SEEK(invfile,temp); GET(invfile); IF invfile^.partnum = arcfile^.partnum THEN BEGIN irecnum := temp; ininv := TRUE; temp := nirecs; END; END; IF NOT ininv THEN Addinvrec; Getqtydateandcode; invfile^.ldate := arcfile^.date; WRITELN; WRITELN('old qty =',invfile^.qty:8:2,' ',invfile^.units,' ', 'new qty =',(invfile^.qty+arcfile^.qty):8:2,' ',invfile^.units); invfile^.qty := invfile^.qty + arcfile^.qty; WRITELN; WRITE('O.K.? '); READ(ch); IF NOT (ch IN ['Y','y']) THEN EXIT(Add); Putrecs; END; ======================================================================================== DOCUMENT :usus Folder:VOL16:apple.labl.text ======================================================================================== program TypeAppleLabels; uses (*$U crtinput.code *) crtinput; const maxlines = 7; {lines per label} needxtraline = true; {if actual lines per label include a 1/2 line} maxcol = 45; {characters per label} forever = false; type arraylmt = 1..maxlines; var firsttime: boolean; totallines, labelno: integer; volumeno: string [5]; s: ARRAY [arraylmt] OF string; list: text; procedure printlabel; VAR i, j: integer; BEGIN S[2] := CONCAT ('VOLUME ', volumeno, ' -**- APPLE format'); FOR labelno := 1 to 4 DO {print one pair of labels} BEGIN FOR i := 1 to maxlines DO BEGIN j := (MaxCol - Length(s[i])) DIV 2; IF j > 0 THEN Write(list,' ':j); writeln(list, s[i]) END; IF needxtraline AND (labelno = 2) THEN Writeln (List); END; FOR I := 1 TO 6 DO WRITELN(LIST) END; PROCEDURE GetLabel; BEGIN Write ('For what APPLE volume do you wish labels? to quit '); Readln (Volumeno); IF Volumeno = '' THEN EXIT (program) END; BEGIN s[1] := 'USUS SOFTWARE LIBRARY'; s[3] := 'Jim Gagne, Chairman'; s[4] := 'DATAMED RESEARCH, INC.'; s[5] := 'Los Angeles, CA 90077'; s[6] := 'For use by USUS members only.'; s[7] := 'May not be published for profit.'; Rewrite (list, 'PRINTER:'); FirstTime := true; REPEAT IF FirstTime THEN GetLabel ELSE IF NOT Yes('Want the same label again') THEN GetLabel; Printlabel; FirstTime := false UNTIL forever; END. ======================================================================================== DOCUMENT :usus Folder:VOL16:ase.header.text ======================================================================================== (* ASE File Header Page 12 Jul 82 |xjm$v|nx|f8|ejb|. *) (* This is the current (ASE 0.4 through ASE 0.9) version of the ASE Header Page which is the first two blocks of an ASE text file. Please note that it may be changed in the future, and the first field will be used to reflect this change. *) PROGRAM ASEHeaderPage (INPUT, OUTPUT); TYPE MarkRange = 0..29; (* Marker Numbers *) MSwRange = 0..135; (* Maximum ScreenWidth *) Offset = 0..1023; (* Byte offset within a page *) Name = PACKED ARRAY [0..7] OF CHAR; (* of a Marker *) TabAttribute = (None, LeftJust, RightJust, DecimalStop); DateRec = PACKED RECORD (*As used by rest of UCSD system*) Month : 0..12; Day : 0..31; Year : 0..100 END; Content = RECORD Defined : INTEGER; (* Current version is 4 *) Count : INTEGER; (* Count of valid markers *) MarkName : ARRAY [MarkRange] OF Name; PageN : ARRAY [MarkRange] OF INTEGER; POffset : ARRAY [MarkRange] OF Offset; TabStop : PACKED ARRAY [0..127] OF TabAttribute; AutoIndent : BOOLEAN; Filling : BOOLEAN; TokDef : BOOLEAN; LMargin : MSwRange; RMargin : MSwRange; ParaMargin : MSwRange; RunOffCh : CHAR; Created : DateRec; LastUpd : DateRec; Revision : INTEGER; AutoPage : BOOLEAN END; Header = RECORD CASE INTEGER OF 0 : ( Dummy : ARRAY [0..511] OF INTEGER ); 1 : ( Data : Content ) END; BEGIN (* ASEHeaderPage *) WRITELN ('Actual size of used Data Content is ', SIZEOF(Content), ' Bytes'); WRITELN ('Size of a Header Page is ', SIZEOF(Header), ' Bytes') END (* ASEHeaderPage *). ======================================================================================== DOCUMENT :usus Folder:VOL16:basproc.text ======================================================================================== { Program: Inv an inventory maintanence program. Programmer: Patrick R. Horton Copyright: Copyright 1980 (c), Associated Computer Industries Permission to copy and distribute for non-profit purposes is hereby granted provided that this header is included on all copies } {BASPROC.TEXT} FUNCTION rVal{(s : STRING) : REAL}; VAR intr,ints : REAL; ts : STRING; BEGIN ts := s; intr := 0; ints := 0; intr := intr + TRUNC(Val(ts)); IF POS('.',ts)<>0 THEN BEGIN DELETE(ts,1,POS('.',ts)); ints := TRUNC(VAL(ts)); WHILE ints>1 DO ints := ints / 10; WHILE POS('0',ts)=1 DO BEGIN DELETE(ts,1,1); ints := ints/10; END; END; rVal := intr + (ABS(intr)/intr)*ints; END; {$I-} FUNCTION Chkfiles(s : STRING) : BOOLEAN; VAR intb : BOOLEAN; infile : FILE; BEGIN intb := TRUE; RESET(infile,s); IF IORESULT <> 0 THEN intb := FALSE; CLOSE(infile); Chkfiles := intb; END; {$I+} PROCEDURE Readingroups; VAR gfile : TEXT; line : STRING; optr,tptr : ^xrerec; added : BOOLEAN; BEGIN first := NIL; IF NOT Chkfiles('#4:gfile.text') THEN EXIT(Readingroups); RESET(gfile,'#4:gfile.text'); WRITE('Reading in gfile '); WHILE NOT EOF(gfile) DO BEGIN WRITE('.'); READLN(gfile,line); NEW(ptr); WHILE POS(' ',line)=1 DO DELETE(line,1,1); ptr^.part1 := COPY(line,1,POS(' ',line)-1); DELETE(line,1,POS(' ',line)); WHILE POS(' ',line)=1 DO DELETE(line,1,1); ptr^.part2 := COPY(line,1,POS(' ',line)-1); DELETE(line,1,POS(' ',line)); WHILE POS(' ',line)=1 DO DELETE(line,1,1); ptr^.qty := rVal(line); tptr := first; optr := NIL; added := FALSE; WHILE (tptr <> NIL) AND (NOT added) DO BEGIN IF tptr^.part2 <= ptr^.part2 THEN BEGIN IF optr<>NIL THEN BEGIN ptr^.link := tptr; optr^.link := ptr; added := TRUE; END ELSE BEGIN ptr^.link := first; first := ptr; added := TRUE; END; END ELSE BEGIN optr := tptr; tptr := tptr^.link; END; END; IF NOT added THEN IF optr = NIL THEN BEGIN ptr^.link := first; first := ptr; END ELSE BEGIN ptr^.link := NIL; optr^.link := ptr; END; END (* of file *); CLOSE(gfile); END; PROCEDURE Wnirecs; BEGIN Str(nirecs,invfile^.ldate); SEEK(invfile,0); PUT(invfile); END; PROCEDURE Wnarecs; BEGIN Str(ntrans,arcfile^.trans); Str(narecs,arcfile^.date); SEEK(arcfile,0); PUT(arcfile); END; PROCEDURE Uppercase{(VAR s: STRING)}; VAR t : INTEGER; BEGIN FOR t := 1 TO LENGTH(s) DO IF s[t] IN ['a'..'z'] THEN s[t] := CHR(ORD(s[t])-32); END; PROCEDURE Clear; BEGIN gotoxy ( 0, 0 ); WRITE(CHR(27),chr ( 69 )); {h-19 specific} END; PROCEDURE Clrline{(x,y : INTEGER)}; BEGIN GOTOXY(x,y);WRITE(CHR(27),chr ( 75 )); {H-19 specific} END; FUNCTION Val{ (s : STRING) : INTEGER}; VAR i,j,k: INTEGER; BEGIN j := 0; k := 0; i := 1; IF LENGTH(s)<>0 THEN BEGIN IF (LENGTH(s)>0) AND (s[1] = '-') THEN BEGIN k := k + 1;i := -1;END; IF k0 DO BEGIN IF i >= factor THEN BEGIN s := CONCAT(s,COPY(numstr,i DIV factor,1)); i := i - (i DIV factor)*factor; startedstring := TRUE; END ELSE IF startedstring THEN s := CONCAT(s,'0'); factor := factor DIV 10; END; IF LENGTH(s) = 0 THEN s := '0'; END; PROCEDURE Rdata{(x,y,l : INTEGER; VAR s: STRING)}; VAR tmpstr : STRING; BEGIN REPEAT IF (x<>0) OR (y<>0) THEN BEGIN Clrline(x,y); WRITE(' ':l,'<'); GOTOXY(x,y); END; READLN(tmpstr); UNTIL LENGTH(tmpstr)<=l; IF POS('^',tmpstr)=0 THEN s := tmpstr; IF (x<>0) OR (y<>0) THEN BEGIN Clrline(x,y); WRITE(s); END; END; PROCEDURE Getint{(x,y : INTEGER; VAR t1 :INTEGER)}; VAR tstr : STRING; BEGIN Str(t1,tstr); Rdata(x,y,6,tstr); t1 := Val(tstr); END; PROCEDURE Getreal{(x,y : INTEGER; VAR r : REAL)}; VAR tmpstr : STRING; BEGIN Rdata(x,y,8,tmpstr); r := rVal(tmpstr); END; FUNCTION Chkdate{(s: STRING):BOOLEAN}; VAR intb : BOOLEAN; BEGIN intb := FALSE; IF (Val(COPY(s,1,2))>0) AND (Val(COPY(s,1,2))<12) AND (Val(COPY(s,3,2))>0) AND (Val(COPY(s,3,2))<32) AND (Val(COPY(s,5,2))>70) AND (Val(COPY(s,3,2))<90) AND (LENGTH(s)=6) THEN intb := TRUE; Chkdate := intb; END; PROCEDURE Initfiles; (*$I-*) PROCEDURE Makefile( s : STRING); TYPE tarry = ARRAY[1..512] OF 0..15; VAR tafile : FILE; ttarry : tarry; temp1,temp : INTEGER; BEGIN WRITE('Making : ',s); REWRITE(tafile,s); FOR temp := 1 TO 512 DO ttarry[temp] := 0; temp := 0; REPEAT WRITE('.'); temp1 := BLOCKWRITE(tafile,ttarry,1); temp := temp + 1; UNTIL (temp1=0) OR (temp>=242) OR (IORESULT<>0); WRITELN; CLOSE(tafile,lock); END; (*$I+*) BEGIN IF (NOT Chkfiles('#5:inv.data')) AND (NOT Chkfiles('#5:arc.data')) THEN BEGIN WRITELN('Program: Inv'); WRITELN('an inventory maintanence program.'); WRITELN; WRITELN('Programmer: Patrick R. Horton '); WRITELN; WRITELN('Copyright: Copyright 1980 (c), Associated Computer Industries '); WRITELN('Permission to copy and distribute for non-profit '); WRITELN('purposes is hereby granted provided that this header '); WRITELN('is included on all copies '); WRITELN; WRITELN('place a formatted and zeroed diskette in drive #5:'); WRITE(' when ready '); READLN; Makefile('#5:inv.data[*]'); Makefile('#5:arc.data[0]'); END ELSE IF NOT Chkfiles('#5:inv.data') THEN BEGIN WRITELN(' to create ''#5:inv.data'''); READLN; Makefile('#5:inv.data[]') END ELSE IF NOT Chkfiles('#5:arc.data') THEN BEGIN WRITELN(' to create ''#5:arc.data'''); READLN; Makefile('#5:arc.data[]') END; RESET(invfile,'#5:inv.data'); RESET(arcfile,'#5:arc.data'); SEEK(invfile,0); GET(invfile); SEEK(arcfile,0); GET(arcfile); narecs := Val(arcfile^.date); nirecs := Val(invfile^.ldate); ntrans := Val(arcfile^.trans); Readingroups; END; PROCEDURE Closefiles; BEGIN CLOSE(invfile); CLOSE(arcfile); END; ======================================================================================== DOCUMENT :usus Folder:VOL16:basproc2.text ======================================================================================== { Program: Inv an inventory maintanence program. Programmer: Patrick R. Horton Copyright: Copyright 1980 (c), Associated Computer Industries Permission to copy and distribute for non-profit purposes is hereby granted provided that this header is included on all copies } {BASPROC2.TEXT} PROCEDURE Change; VAR temp : INTEGER; opartnum,npartnum : STRING[16]; ch : CHAR; BEGIN Clear; WRITE('Change :: I)nventory, A)rchive, B)oth ::'); READ(ch); IF ch IN ['I','i','A','a','B','b'] THEN BEGIN Clrline(0,2); WRITE('enter partnumber to be changed --->'); Rdata(35,2,16,opartnum); Clrline(0,3); WRITE('enter new partnumber ------------->'); Rdata(35,3,16,npartnum); IF (opartnum='') OR (npartnum='') THEN EXIT(Change); CASE ch OF 'I','i' : BEGIN WRITELN; WRITE('searching inventory'); FOR temp := 1 TO nirecs DO BEGIN SEEK(invfile,temp); GET(invfile); IF invfile^.partnum = opartnum THEN BEGIN invfile^.partnum := npartnum; SEEK(invfile,temp); PUT(invfile); END; WRITE('.'); END; WRITELN; END; 'A','a' : BEGIN WRITELN; WRITE('searching archive'); FOR temp := 1 TO narecs DO BEGIN SEEK(arcfile,temp); GET(arcfile); IF arcfile^.partnum = opartnum THEN BEGIN arcfile^.partnum := npartnum; SEEK(arcfile,temp); PUT(arcfile); END; WRITE('.'); END; WRITELN; END; 'B','b' : BEGIN WRITELN; WRITE('searching inventory'); FOR temp := 1 TO nirecs DO BEGIN SEEK(invfile,temp); GET(invfile); IF invfile^.partnum = opartnum THEN BEGIN invfile^.partnum := npartnum; SEEK(invfile,temp); PUT(invfile); END; WRITE('.'); END; WRITELN; WRITELN; WRITE('searching archive'); FOR temp := 1 TO narecs DO BEGIN SEEK(arcfile,temp); GET(arcfile); IF arcfile^.partnum = opartnum THEN BEGIN arcfile^.partnum := npartnum; SEEK(arcfile,temp); PUT(arcfile); END; WRITE('.'); END; WRITELN; END; END {CASE}; END {IF}; END {Change}; PROCEDURE Delete; VAR temp,temp1 : INTEGER; dpartnum : STRING[16]; ch : CHAR; BEGIN Clear; WRITE('Delete :: A)rchive, I)nventory, B)oth ::'); READ(ch); IF ch IN ['A','a','I','i','B','b'] THEN BEGIN Clrline(2,0); WRITE('enter partnumber to be deleted ---->'); READLN(dpartnum); CASE ch OF 'A','a' : BEGIN WRITELN; WRITE('searching archive'); temp := 0; FOR temp1 := 1 TO narecs DO BEGIN SEEK(arcfile,temp1); GET(arcfile); IF arcfile^.partnum<>dpartnum THEN BEGIN temp := temp + 1; SEEK(arcfile,temp); PUT(arcfile); END; WRITE('.'); END; narecs := temp; Wnarecs; WRITELN; END; 'I','i' : BEGIN WRITELN; WRITE('searching inventory'); temp := 0; FOR temp1 := 1 TO nirecs DO BEGIN SEEK(invfile,temp1); GET(invfile); IF invfile^.partnum <> dpartnum THEN BEGIN temp := temp + 1; SEEK(invfile,temp); PUT(invfile); END; WRITE('.'); END; nirecs := temp; Wnirecs; WRITELN; END; 'B','b' : BEGIN WRITELN; WRITE('searching archive'); temp := 0; FOR temp1 := 1 TO narecs DO BEGIN SEEK(arcfile,temp1); GET(arcfile); IF arcfile^.partnum<>dpartnum THEN BEGIN temp := temp + 1; SEEK(arcfile,temp); PUT(arcfile); END; WRITE('.'); END; narecs := temp; Wnarecs; WRITELN; WRITELN; WRITE('searching inventory'); temp := 0; FOR temp1 := 1 TO nirecs DO BEGIN SEEK(invfile,temp1); GET(invfile); IF invfile^.partnum <> dpartnum THEN BEGIN temp := temp + 1; SEEK(invfile,temp); PUT(invfile); END; WRITE('.'); END; nirecs := temp; Wnirecs; WRITELN; END; END; END; END; PROCEDURE Sort; VAR ch : CHAR; trec1,trec2 : invrec; BEGIN (* Sort *) Clear; WRITE('Are you sure you want to sort the inventory file ?'); READ(ch); IF ch IN ['Y','y'] THEN BEGIN temp := 1; WRITELN;WRITELN('Sorting '); WHILE temp < nirecs DO BEGIN WRITE('.'); SEEK(invfile,temp); GET(invfile); trec1 := invfile^; SEEK(invfile,temp+1); GET(invfile); IF (invfile^.partnum 1 THEN temp := temp - 1; END ELSE temp := temp + 1; END; END; END; ======================================================================================== DOCUMENT :usus Folder:VOL16:bdebug.text ======================================================================================== (*------------------------------------------------------------------*) PROCEDURE errtrap (*errmsg:STRING*); (* Print an error message and halt execution until a is recieved.*) BEGIN WRITELN(' ***ERROR*** ',errmsg,' Hit to continue.'); READLN; END; (*PROCEDURE errtrap*) (*------------------------------------------------------------------*) PROCEDURE bdump (*VAR r: brecord*); (* Dump contents of r to terminal*) VAR j:INTEGER; BEGIN WITH r DO BEGIN CASE use OF 0:BEGIN WRITELN('next free record available is ',nextfree); END;(*case use=0*) 1:BEGIN WRITELN('number of records in use ', desc.nrec); WRITELN; WRITELN('number of records in btree ', desc.maxrec); WRITELN; WRITELN('record number of btree root ', desc.root); WRITELN; WRITELN('first free record in file ', desc.freehead); END;(*case use=1*) 2:BEGIN WITH r.pg DO BEGIN WRITELN('number of keys in this page ', count); WRITELN; WRITELN('parent page is ',prntpage); WRITELN; WRITELN('parent entry is ',prntentry); WRITELN; WRITELN('first pointer in this page ', bpointer[0]); WRITELN; WRITELN(' KEY',' DATA',' POINTER'); FOR j:=1 TO count DO WRITELN(bentry[j].key:15,bentry[j].data:10,bpointer[j]:10); END; (* WITH *) END;(*case use=2*) END; (*CASE*) END;(*WITH*) END; (* PROCEDURE bdump *) (*------------------------------------------------------------------*) PROCEDURE showit(*VAR f:btree; pagenbr : btpointer; entrynbr : bpagesize*); (* Display contents of tree f, at pagenbr,entrynbr , formatted *) VAR entry : btentry; BEGIN bread (f,pagenbr); entry := f^.pg.bentry[entrynbr]; WRITE('Current: '); WRITELN('PAGE':11,'ENTRY':15,'KEY':15,'DATA':15); WRITELN(pagenbr:20,entrynbr:15,entry.key:15,entry.data:15); WRITELN; END; (*PROCEDURE showit*) ======================================================================================== DOCUMENT :usus Folder:VOL16:bdoc1.text ======================================================================================== Documentation for B-Tree Unit The B-Tree is an ingenious storage structure used principally for maintaining ordered indices to files. It can also be used to maintain ordered data directly. It was first reported by Bayer and McCreight in 1972, although it appears to be an outgrowth of a great deal of previous work on multi-way trees and ordered indices. The B-Tree is technically a height-balanced, muti-way tree. It is perhaps best explained by analogy to a binary tree. The single best explanation of both can be found in Niklaus Wirth's book Algorithms + Data Structures = Programs (although the Bayer and McCreight article is fairly accessible). I will attempt to give a short course below. What is a Binary Tree? A binary tree is a data structure in which each record (called a node) contains one datum, one key, and two pointers. Each pointer points to a child node, which has pointers to two more children. When any pointer is null, you have reached a leaf. The first entry is called the root node. A Pascal declaration of a binary tree node might be: binary_tree_node = RECORD person_name : sometype; person_data : someothertype left_child, right_child : pointers; END; The person_name element would be the key, i.e. the part of the record used for ordering the records. The person_data element would be the datum to be retrieved. Left_child and right_child are pointers to the children. They are deliberately not declared as Pascal pointer types because they could be disk block numbers, or some other sort of pointer. An example of what such a tree might look like is shown below. The root is at the top (don't ask, it's the traditional representation of a tree). Only the person_name values are shown. john | ___________|___________ | | _____frank______ ______mike________ | | | | | | | | _______charlie harlan karla ______susie_______ | | | alan roger zelda As you can see, there is no requirement that a binary tree be balanced. A balanced tree can be searched more quickly on the average, but it is very difficult to maintain balance in a binary tree. In general the cost is greater than the payoff. What is a B-Tree? A B-Tree is a multi-way tree. It may have more than one key and more than one child per node. Generally, there are fixed-size nodes which can be partly full. A simple Pascal declaration of a B-Tree node might be: B_Tree_node = RECORD count : integer; person_name1 : sometype; person_data1 : someothertype person_name2 : sometype; person_data2 : someothertype person_name3 : sometype; person_data3 : someothertype child0, child1, child2, child3 : pointers; END; Obviously, this could get out of hand, so some sort of array is usually used. The count variable specifies how many of the key slots are filled. Note that there is one more pointer than keys. Although this is relatively intuitive in a schematic discussion, it can cause no end of trouble in writing or modifying a program if you forget. It sometimes helps to think of the nodes pictorially. The node pictured has room for 3 keys, of which 2 are in use: ________________________________________________________________ | ptr0 | key1 | ptr1 | key2 | ptr2 | key3 | ptr3 | |________|________|________|________|________|________|________| ^ | count = 2 A B-Tree node is generally called a page. The ingenuity of the design begins with the page layout. A B-Tree page is constrained to have between k and 2k entries, where k is an arbitrary number known as the order of the tree. Thus, a B-Tree of order 3 has slots for 6 entries, and is guaranteed to have no fewer than 3 of those slots filled (an odd number is ok, it just dosn't fit the formal definition as well). The root page may have fewer than k entries. The advantage of multiple entries over a binary tree is analogous to that of a Shell sort over a straight insertion sort: fewer comparisons are needed to reach the general neighborhood of the key sought. Every page is either a leaf (no children) or it has j+1 children if it has j keys. All leaves are at the same level, or height (or depth, pick your metaphor) as all other leaves. In other words, the tree is balanced. The main trick is in keeping the tree balanced. The B-Tree's Balancing Act The binary tree has one major problem. If it is completely balanced, the search time among N keys will be of order logN. In the degenerate cases (either all right or all left children) the search time will be of order N. (This business about orders is called the asymptotic complexity of algorithms. If you don't know about it, you probably should find someone who can explain it. I know of no easy text on the subject.) The degenerate case occurs when insertions are performed in sorted order, and the closer to sorted order the keys are when you start, the worse the performance of the binary tree. The B-Tree avoids the degeneration by staying balanced, and thus its worst case performance is about as good as the average for a binary tree. In a B-Tree of order k, with N entries, the worst case search time for an entry is of order log to the base k of (N+1). Balance is maintained during insertion as follows: Insertion always occurs at a leaf. This is not obvious, so make a diagram of a B-Tree and try it. No matter what key you choose to insert, it will always lie between two keys already in the tree (except in the degenerate case of a tree containing 0 or 1 entries in the root, in which case you are at a leaf by definition). Every entry in a non- leaf node always points to an entry which is greater and one which is smaller. If the node pointed-to is a leaf, then you are at a leaf. If not, then a greater and a lesser entry are pointed-to, and so on. It works out that the entry immediately before or after any entry in the tree is always at a leaf node. If the leaf is not full, the insertion is made at the appropriate place in the page. If the node is full, the central entry in the node is inserted into the parent node, and the leaf's keys are distributed between it and new leaf which is allocated dynamically (thus creating two leaf nodes from one). The insertion is then made in the appropriate one of the two leaf nodes. However, the parent page may also be full. The same routine occurs with insertion into the parent node. If all successive parent nodes are full, the split can propagate all the way to the root, causing the tree to grow one level in height (i.e. every path from root to leaf becomes one longer). Deletion proceeds similarly, but for the complication that a key to be deleted may not be at a leaf node. If it is at a leaf node, it is simply deleted. If the key is not at a leaf node, it is swapped with the next greater or smaller key, which is guaranteed to be at a leaf node for the reasons discussed above. If the page count is at least k, we are done. If the page count has fallen below k, then we would be violating the page fullness constraint, so we boost the count by borrowing from adjacent siblings. This is generally called balancing. Of course, if there are fewer than m times k entries to distribute among m siblings, we would still have fewer than k entries in a node. The solution is to delete one node, and distribute its keys among the remaining m minus 1 siblings. As with splitting, this concatenation can propagate when the parent suffers loss of an entry from having one child fewer than before. The tree shrinks in height when the root is concatenated with its two children. Implementation Considerations There are a number of performance considerations in implementing B- Trees that deserve mention. First, one may choose to implement B- Trees entirely in main memory (as is the case shown in most examples) or in secondary storage (which is their principal real-world use). For indices of any serious size, a disk implementation is called for. This means that one must consider optimizing the fetching of pages into main memory. Several common methods include: - Always keeping the root in memory (rewriting it when it is changed) since all searches start at the root. - Making pages an even multiple of the hardware page size, so that fast primitive fetches can be used. - Delaying the splitting of pages just as concatenation is delayed by balancing among adjacent siblings. (Knuth, pp 476-479) - Buffering disk i/o, usually by keeping the most recently used pages in main memory (in a sequential search, you will revisit a non-leaf node once for every node it points to). Second, one would probably like generality of use. The easiest way to achieve some generality is not to mix the data into the tree, but to maintain some sort of pointer to the data. One could go so far as not to keep the keys in the tree either, in order to allow variable length keys. In both cases, the pointers would point into some separately maintained (and unordered) list. Finally, you can add lots of stuff to the basic idea, and tune the program lots of ways. For example, you could allow for duplicate instances of a particular key by some sort of chaining; or perform some kind of compression on the keys (compression plus duplicates could even be used to allow variable length keys). Different strategies can be used for splitting, shifting entries around, balancing, etc. Some have been elevated to the status of a whole separate kind of tree (B+ and B* trees, see Comer). The B-Tree Unit (BUNIT) The B-Tree unit presented here has been run with only trivial modifications on three different p-Systems: It was developed on a bastard version II.0 p-System on an Onyx micro (a Z-8000, hard-disk machine), it was transported to a Northstar running version I.5, and it was transported to an Apple ][ running version II.1. As far as I know it contains no machine or version dependencies. BUNIT's essential character is described by the global declarations. The trees store a single datum, which is an integer. It is envisioned that it would be a record or blocknumber on another file storing the actual data. A key is a string of length keysize. Together, one key and one datum are a btentry. A page consists of btree2k btentry's stored in an array called bentry. A parallel array called bpointer stores btree2kp (btree2k + 1) pointers, each of type btpointer. Pages also contain a count of full keys, and pointers to the page number of the parent page and the subscript of the pointer to this page in the parent. Pages are allocated when a tree is created, and it stays a fixed size. The unit of allocation is actually a brecord, which has a bpage as one variant. The other variants are bdescrip and btpointer. The zeroth brecord of a btree (a file of brecord) is always of the bdescrip variant. It contains nrec: the last record ever used, maxrec: a count of the number of records allocated, root: a pointer to the root of the tree, and freehead: a pointer to the head of a chain of records deallocated by concatenation of pages. All records in the free chain are of the btpointer variant; they contain a single pointer to the next record in the chain. A free pointer equal to 0 indicates the last record in the free chain. To use the unit without understanding it, very little documentation is required. The interface section contains declarations and explanations of the routines accessible to the application programmer. To start a tree, call bnew with a filename and a number of pages to allocate. Bnew recloses the file, so bopen it before using it. All BUNIT procedures pass around the file id, so more than one tree can be open at once. To insert a key, just stick it in a bentry, along with an appropriate datum, and call bsearch. If you find it in the tree, don't insert it. If it's not there, put it in by calling binsert with the page and entry indices returned by bsearch. To delete a key, call bsearch to find out where it is, and if you find it, call bdelete with the information from bsearch. Procedures firstentry and lastentry will return the position of the first and last keys in the tree. Functions nextentry and preventry will move forward and backward along the tree. Bdump will display the contents of a brecord at your terminal, and showit will display formatted information on a particular entry. ======================================================================================== DOCUMENT :usus Folder:VOL16:bdoc2.text ======================================================================================== Understanding BUNIT Understanding the BUNIT well enough to modify it, for example, takes a little more effort. The following is necessarily a little skimpy. It is meant to be read while holding the listings in the other hand. The program is layered, or built-up. First a number of primitive operators were built. The file BIO contains the i/o primitives, which were built first. Should one want to implement buffering, for example, most of the changes would be isolated in these functions. Of the BIO functions, only bnew is not obvious. It basically sets up the descriptor record, creates an empty root page, and marks page 2 as free, pointing back to the descriptor. By seeking a record npages away, it allocates space, then closes the file with a lock to make it permanent. The filesize allocated by bnew is what you are stuck with. If the file cannot be opened, it returns a false result, otherwise it returns true. The next primitives implemented were those in BDEBUG. Errtrap is called with an error message at points where "impossible" things are about to occur. It does nothing except warn you and wait for a carriage return. Bdump and showit are fairly obvious. BHKEEP contains the next set of primitives implemented. Broot reads the descriptor record to find the page number of the root page and returns that value. Getpage is the dynamic page allocation routine. It examines the freehead variable in the descriptor page to see if any free records are present. If so, the first is removed from the chain, and the various pointers updated to promote the next record in the chain. If the free chain is empty, it goes to the end of the pages in use (pointed to by nrec in the descriptor). If there are no records left, it calls errtrap. Note that it only allocates up to the number of records set when bnew was called. Freepage does the reverse of getpage. It deallocates pages which have been discarded in the process of concatenation by returning them to the free list. Newroot is called when a split has propagated to the root and a new root is required. The new root will contain only the central entry from the old root, and pointers to the old root and its new sibling. BMAIN and BINTERN contain the parts that do most of the work of the unit. Bsearch is relatively simple. Given a key and a tree, it returns true if the key exists and false if not. If the key exists, pgnbr and entrynbr will contain the position of the key, otherwise they will contain the position where insertion should take place. Bsearch calls bpgscan to look at each individual page and determine whether the key is there. Bpgscan searches the page, stopping at the point where the key is found, the point where a larger key is encountered, or the end of the page, whichever comes first. It returns, in i, the place where it stopped, and a boolean result indicating whether it found the key. Note that bpgscan is presently implemented as a binary search. The present page size is probably the smallest for which a binary search holds any advantage over a linear search. If bpgscan returns true, then bsearch is done, otherwise, bsearch looks at the pointer in position i. If the pointer is 0, we have reached a leaf without finding the key, and we are done. If the pointer is not 0, we read the page pointed-to and start again. Binsert and bsplit are mutually recursive. If, in the course of insertion, overflow occurs, then binsert will call bsplit to move half of the entries to a new page, and put the central entry into the parent page. Bsplit calls binsert to perform that insertion into the parent. Note that the fact that binsert may be called to do an insertion at a non-leaf page (when it is called by bsplit) is the reason for requiring the argument inspointer. In application programs, that argument must always be zero, since the insertion will always be at a leaf. This double-purpose use of binsert adds a little to its complexity and is a case where additional layering might present a cleaner (and safer) application program interface. Binsert reads the page where insertion is to occur and determines whether it is full. If so it first attempts to balance among siblings by calling bbalance. Stack overflow can occur on recursive split/insert calls on a deep tree, especially if the balance constants are large. This is due to the size of the arrays used for balancing. Removing the call to bbalance will eliminate the problem at the price of lowering storage utilization. It should also speed insertion significantly. If the call to bbalance fails to make room in the page, split is called. Finally, bshiftr is called to move the empty space to the right place in the page, and the entry and pointer are written. Note that binsert may modify the position variables pgnbr and entrynbr by calling bbalance, but that these modifications are only local to binsert. Consequently, do not count on these variables containing a correct position following a call to binsert. An explicit call to bsearch is required. Bsplit is passed a tree and the number of a page to split. It returns the page number of the page it created. It copies the left half of the page into a buffer called oldrec, and the right half into a buffer called newrec. If the old page was the root, then a new root is created containing just the central entry, otherwise binsert is called to put the central entry into the parent. In either event, the left and right half buffers are written out. Fixpointer, called by both binsert and bsplit, is an imperfect solution to an interesting design problem. Backpointers are maintained in the tree so that for any node you can travel up or down without maintaining a search path. This simplifies several of the routines, notably sequential searches. It also makes it likely that a corrupted file can be recovered, since the backpointers are redundant information. Unfortunately, the backpointers extract a serious performance penalty. Every time that an entry is moved around in a page, the backpointer of its child must be updated. If several entries are moved, several pointers must be updated. Fixpointer does this job in a rather straightforward way. Of course, it must read a page to update it, and it is this additional I/O that is the performance killer. Consequently, operations like insertion and deletion perform nowhere near their "book optimum". Searches, on the other hand, are just as fast. In applications where updating is infrequent, this design is satisfactory. With frequent updates, the performance would probably be unacceptable. The sequential search routines firstentry, lastentry, nextentry, and preventry are rather standard tree-traversals. If you follow the use of back-pointers, and the order in which entries are stored, these routines should be easy to follow. If you don't understand any of that stuff, puzzling out these procedures could be tough, but is guaranteed to be educational. The Balancing Act Given the theoretical explanation of a btree, most of the remaining routines are easily understood. The exception is bbalance. It was difficult to write; it was nearly impossible to debug; and it will not be easy to understand. I do not recommend attempting to mess with it unless you are willing to devote a good deal of time to it. Bbalance is passed a tree, a page and position around which to balance (parent_pointer and entry_pointer), and a page and position to keep track of (markpage and markentry). It reads all of the required pointers and entries into a pair of gigantic arrays, then writes out a more or less even number to each of the siblings. It does this even if there is no advantage to be gained, since it can't know that until it has read all of the sibling pages. If the number of entries per page will be fewer than k, bbalance returns a page to the freelist and distributes the entries among the remaining siblings. Thus it serves the concatenation function as well as the balancing function. Three global constants are of particular importance to bbalance. Bal is the number of siblings over which it will attempt to balance. Halfbal is bal DIV 2. Maxentries is the size of the giant arrays, and it must be at least (2k + 1) * (bal + 1). Some performance tuning of these constants is probably desirable based on the choice of page and entry size. A lot of the code in bbalance is bookkeeping to keep track of markentry and markpage. Bbalance may be called in the middle of binsert, before the actual insertion has taken place. Bbalance will move things around, and binsert has to know where to perform the insertion after bbalance is done. Markpage and markentry serve this purpose. The bookkeeping gets particularly complicated if the position where insertion is to take place is beyond the last valid entry in the page. In this case, the markentry is decremented by one at the beginning of bbalance, and the flag moved_marker is set to true. Markentry and markpage are then reset later. The main body of bbalance checks that we are not trying to balance the root (parent_pointer = 0), reads in the page in question, does some initialization, and then calculates the positions at which to begin and end the balancing( first and last). There are four cases: IF The number of valid entries is less than bal. In order not to balance past both ends of the page, we set first to the first entry in the page and last to the last entry in the page. ELSE IF Entry_pointer is so far to the left that we might balance off the left end of the page. To avoid this, we set first to the beginning of the page and last to bal-1. ELSE IF Entry_pointer is so far to the right that the analogous problem may occur there. In this case we set last to the last entry in the page, and first to (count-(bal-1)). ELSE No odd cases exist, so we set first to (entry_pointer- halfbal), and last to (entry_pointer+halfbal). Having established the limits of balancing, bbalance calls local procedure fill_arrays to read up the appropriate pages and stick them into the giant arrays. Then it calculates the number of entries each sibling will have after balancing (newcount). If that number is less than k, it calls condense to return a page to the freelist and recalculate. In either event, it calculates how many pages will have an extra entry (extras), since you hardly ever get a newcount with no remainder. If we didn't run into an odd case in condense (see below), continue will be true, and we will write out the children. First we write out any children with an extra entry, then any children with the average number of entries. A call to the local procedure write_child accomplishes this. Finally we write out the parent page, and check to see if it has fallen below k entries. If so, we recursively call bbalance to remedy the situation. We can, in some cases, reach the root recursively. Since bbalance uses a lot of memory for its activation record (remember the giant arrays?), stack overflow is a possibility here with certain combinations of page size and bal. This tail recursion could easily be replaced by a giant loop around the present body of bbalance, with a little extra code to move up the tree each iteration as necessary. This would cause the same activation record to be reused repeatedly, but at some expense to the readability of the code. Fill_arrays is basically just two loops controlled by index variables outer (for the outer loop) and inner (for the inner loop). Outer varies from first to last, and controls the reading and processing of pages, inner controls the processing of entries within a page. The indexing is very complicated, partly because you have to stick the entries from the parent in among the entries from the children, but leave the pointers from the parent unmolested. Since each child page has one more pointer than entries, it works out, but not without a lot of thought. Ep_index (entry/pointer index) and temp_index are indices to the giant arrays, but ep_index lags temp_index. Write_child is pretty much the opposite of fill_arrays, except that the outer loop has been moved out of the procedure to account for the different number of entries per child induced by remainders in the division (extras). It also has a lot more bookkeeping to contend with for markpage and markentry. Note that place is an index into the big arrays which marks where markentry ended up during fill_arrays. Condense serves the concatenation function in a fairly obvious way. It returns the rightmost child page to the freelist, throws away its pointer in the parent page (by calling bshiftl), and recalculates newcount and last. It also deals with a special case. If we are attempting to condense the root page, and it contains only one entry, it is much easier to deal with as a special case. We copy the two children into the root page, return both children (there can only be two if the root has only one entry) to the freelist, and fix up some back-pointers. By setting continue to false, the body of bbalance is informed that it is not necessary to write the children. If you followed all of that, I salute you. ======================================================================================== DOCUMENT :usus Folder:VOL16:bdoc3.text ======================================================================================== Modification and Optimization There are a number of improvements, changes, and alternatives that have been mentioned throughout the text. Several others have come to mind. I want to close by offering some observations on how the program might be altered. First, the chosen key size, page size, and balancing constants are essentially arbitrary in the submitted version. It is a good idea to choose a key size that matches your application, and then modify the other constants appropriately. Page size should generally be the amount your operating system can grab in one swipe from the disk, or a multiple thereof (for UCSD p-System, 512 bytes). The balancing constants should be optimized for a given key and page size, but I can only suggest an empirical approach to finding an optimum. I would also suggest that most applications could benefit from some form of key compression layered on top of the b-tree. With string keys, for example, one might want to remove spaces and punctuation and convert to a single case (upper or lower). A relatively simple modification would be the allocation of more space, either automatically or on demand. Getpage, rather than calling errtrap when it runs out of space, could allocate more. To be sure that a full volume is handled gracefully, getpage might check to see if the next allocation (rather than this one) will run you out, and attempt to allocate then. That way, if it can't, it could return a code indicating impending disaster. The i/o primitives could be improved in several ways. The easiest is to substitute blockread/blockwrite for get and put. Assuming optimal page sizes, i/o could be sped considerably. A more ambitious project would be to add buffering. If the most recently used pages are kept around in buffers, and supplied to the program on demand instead of reading, fewer i/o's can be expected. Buffering can be dangerous, especially if any kind of program or hardware error occurs before a modified page is written. I would recommend always writing a modified page, even if it is kept in the buffer to avoid a later read. With or without buffering, it might be wise to modify the i/o primitives to keep a change log. Since the integrity of the tree is not guaranteed during balancing, insertion, or deletion, any program or hardware failure during these operations is likely to leave the tree in an indeterminate state. To insure absolute integrity, a log of at least the last (depth-of-tree * bal) page alterations would be necessary. Another difficulty with buffering is that you either need access to the file information block (fib) and window variable (f^) or you need to completely rewrite the way files are passed, read, and written. The first solution is possible if you use the system globals available on Volume 8 of the Library (for version II and III). Two modifications were suggested to deal with deep trees in a limited amount of memory (i.e. avoid stack overflow). First, the call to bbalance in binsert is not required for the integrity of the tree. It just improves storage utilization. Removing it would improve the speed of insertion and avoid memory problems, at the cost of lowered storage efficiency. Perhaps a crunching utility could be written using bbalance to close up unused space when the tree is not otherwise in use. It would be a long-running program, but it would be very useful for highly static data-bases. The other memory modification is to change the tail-recursion in bbalance to iteration. Unlike LISP and LOGO, Pascal is not smart enough to recognize tail-recursion as iteration automatically. A very ambitious project would be to eliminate the backpointers and the fixpointer performance penalty by maintaining an explicit search path. I have begun such a modification and can assure you that it is non-trivial as they say. If you are using the program for multiple files, then you need multiple paths, which need to be passed, along with the tree, to each routine. Treating the path as a stack is the best idea, and you know that its depth will not exceed the depth of the tree (which is unlikely, with a reasonable page size, to exceed 10 or so). One problem is that some routines need to look more than one up the path. Either provide a means of looking back that far, or provide local temporaries to pop the top of stack into. If you don't need the extra performance, don't bother. Finally, the unit's interface is not very transparent. Too much internal detail of the data structure is open to an application program, and too much bookkeeping is required of it. I would suggest adding a layer between the unit and an application program to simplify its use. By using the system globals, for example, an appplication program could actually look at an indexed file as a regular file with special access methods available as a bonus. Another ambitious project... For all of my self-criticism, the unit has one outstanding advantage - it works. It has been in daily use on a fairly large geographic data base for several months without problems. I would not wager a nickel that it is totally bug-free, but I would wager a princely sum (a couple of bucks) that it hasn't any egregious errors, and that it works basically as promised. Use it in good health, and please let me hear about any changes, improvements, bugs, etc. I'm in the USUS membership roster, and on MUSUS (ppn 70105,772). REFERENCES Bayer, R. and McCreight, E. "Organization and Maintenance of Large Ordered Indexes", 12 ACTA INFORMATICA 1, 1972 (Springer-Verlag) p. 173-189. The original work on b-trees by the inventor. A good article. Comer, Douglas "The Ubiquitous B-Tree", COMPUTING SURVEYS Vol.11, Number 2, June 1979 (Assn. for Computing Machinery) p. 121-137. An excellent survey article. Use Comer's bibliography to pur- sue the subject further. Knuth, D.E. THE ART OF COMPUTER PROGRAMMING: VOLUME 3, SEARCHING AND SORTING, 1973 (Addison-Wesley) esp. pages 476-479. The definitive (if unreadable) work on the subject of searching and sorting in general. Some interesting ideas for altering b-trees. Wirth, Niklaus, ALGORITHMS + DATA STRUCTURES = PROGRAMS, 1976 (Prentice-Hall), esp.pages 242-264. The author of Pascal speaks on a variety of subjects, including example programs in Pascal. A good, accessible treatment of b-trees. ======================================================================================== DOCUMENT :usus Folder:VOL16:bdriver.text ======================================================================================== {$S+} PROGRAM btreetest; (* B-tree creation and update routines Marvin White Kyle Goldman Michael Adams Robert Sims Applications Mathematics Research Staff U.S. Census Bureau Washington, D.C. *) USES {$U bunit.code} BUNIT; (*------------------------------------------------------------------*) PROCEDURE seqsearch(VAR f: btree; VAR entrynbr : bpagesize; VAR pagenbr : btpointer); (* Driver for interactive sequential search of a btree (f) starting at pagenbr,entrynbr. These are modified by seqsearch.*) VAR code : CHAR; BEGIN code := 'z'; showit (f,pagenbr, entrynbr); WHILE NOT (code IN ['Q','q']) DO BEGIN WRITE('F(orward, R(everse, B(eginning, E(nd, Q(uit ? '); READ (code); WRITELN; CASE code OF 'F','f' : IF nextentry(f,pagenbr,entrynbr,pagenbr,entrynbr) THEN showit(f,pagenbr,entrynbr) ELSE WRITELN('Cant"t go forward, already at last entry.'); 'R','r' : IF preventry(f,pagenbr,entrynbr,pagenbr,entrynbr) THEN showit(f,pagenbr,entrynbr) ELSE WRITELN('Can"t go back, already at first entry.'); 'B','b' : BEGIN firstentry(f,pagenbr,entrynbr); showit(f,pagenbr,entrynbr); END; 'e','E' : BEGIN lastentry(f,pagenbr,entrynbr); showit(f,pagenbr,entrynbr); END; 'Q','q' : ; END; (*Case*) END;(*While*) END;(*PROCEDURE seqsearch*) (*------------------------------------------------------------------*) PROCEDURE driver; (* Interactive driver for btree testring and debugging*) VAR code: CHAR; name:STRING; f:btree; pages:btpointer; key:bkey; i:INTEGER; entry:btentry; letter: CHAR; pagenbr : btpointer; entrynbr : bpagesize; (*--------------------------------*) PROCEDURE driver1; BEGIN WRITE(' O)pen,'); WRITE(' C)lose,'); WRITE(' N)ew,'); WRITE(' L)ist,'); WRITE(' S)earch,'); WRITE(' I)nsert,'); WRITE(' D)elete,'); WRITE(' Z(earch,'); WRITE(' Q)uit ? '); END; (*PROCEDURE driver1*) (*--------------------------------*) PROCEDURE driver2; procedure delete_it; BEGIN WRITE('Key to delete?'); READLN(entry.key); IF bsearch(f,pagenbr,entrynbr,entry.key) THEN bdelete(f,pagenbr,entrynbr) ELSE WRITELN('KEY ',entry.key,'IS NOT IN TREE'); END; (*case bdelete*) BEGIN READ(code); WRITELN; CASE code OF 'o','O' : BEGIN WRITE('Name of btree ? '); READLN(name); IF bopen(f,name) THEN BEGIN pagenbr := broot(f); entrynbr := 1; WRITELN('Btree ',name,' has been opened.'); END ELSE WRITELN('Can''t open ',name); END; (* case bopen *) 'c','C' : BEGIN bclose(f); WRITELN('Btree ',name,' is closed.'); END; (* case bclose *) 'n','N' : BEGIN WRITE('What is the name of your new tree ? '); READLN(name); WRITE('How many pages maximum ? '); READLN(pages); IF NOT bnew(name,pages) THEN WRITELN('Can''t open ',name); END; (* case bnew *) 'l','L' : BEGIN WRITE('Which page ? '); READLN(pages); bread(f,pages); bdump(f^); END;(*case bdump*) 's','S' : BEGIN WRITE('Key to look for?'); READLN(key); IF bsearch(f,pagenbr,entrynbr,key) THEN BEGIN WRITELN('SUCCESS'); showit(f,pagenbr,entrynbr); END ELSE BEGIN WRITELN('FAILURE'); bdump(f^); END; END; (*case bsearch*) 'i','I' : BEGIN WRITE('Key to insert?'); READLN(entry.key); WRITE('Data to insert?'); READLN(entry.data); IF bsearch(f,pagenbr,entrynbr,entry.key) THEN WRITELN('KEY IS ALREADY THERE.') ELSE binsert(f,entry,0,pagenbr,entrynbr); END; (*case binsert *) 'd','D' : delete_it; 'z','Z' : seqsearch(f,entrynbr,pagenbr); END; (*Cases*) END; (*PROCEDURE driver2*) (*-----------------------------------*) BEGIN (*driver*) i:=1; code := 'o'; WRITELN(chr(12)); (*clear screen with formfeed*) WRITELN('Driver program for BTREE development.'); WRITELN; WHILE NOT (code IN ['q','Q']) DO BEGIN driver1; driver2; END; (*While*) END; (*PROCEDURE driver*) (*----------------------------------------------------------------------*) BEGIN (*PROGRAM btreetest*) driver; WRITELN('End of program btree.'); END. (*PROGRAM btreetest*) ======================================================================================== DOCUMENT :usus Folder:VOL16:bhkeep.text ======================================================================================== (*------------------------------------------------------------------*) FUNCTION broot(*VAR f:btree):btpointer*); (* Returns page number of root of btree f*) BEGIN bread(f,0); broot:=f^.desc.root; END; (* FUNCTION broot *) (*------------------------------------------------------------------*) FUNCTION getpage(VAR f:btree): btpointer; (* Get new page from free list or from end of file *) VAR i, j, k : btpointer; BEGIN bread(f, 0); (* read descriptor *) i := f^.desc.freehead; IF i <> 0 THEN BEGIN bread(f, i); j := f^.nextfree; bread(f, 0); f^.desc.freehead := j; bwrite(f, 0); END (*THEN*) ELSE BEGIN i := f^.desc.nrec + 1; IF i > f^.desc.maxrec THEN errtrap(' File overflow'); f^.desc.nrec := i; bwrite (f, 0); END; bread(f, i); getpage := i; END; (* FUNCTION getpage *) (*------------------------------------------------------------------*) PROCEDURE freepage (VAR f : btree; pgnbr : btpointer); (* Opposite of getpage. Returns page indicated by pgnbr to the head of the free list*) VAR temp : btpointer; BEGIN bread(f, 0); temp := f^.desc.freehead; f^.desc.freehead := pgnbr; bwrite (f, 0); f^.use := 0; f^.nextfree := temp; bwrite(f, pgnbr); END; (*PROCEDURE freepage*) (*------------------------------------------------------------------*) PROCEDURE newroot(VAR f:btree; VAR entry: btentry; p0, p1: btpointer); (* Create a new root consisting of just one entry and two pointers *) VAR r: btpointer; BEGIN r := getpage(f); (* get new page *) f^.use := 2; (* btree page *) f^.pg.count := 1; f^.pg.bentry[1] := entry; f^.pg.bpointer[0] := p0; f^.pg.bpointer[1] := p1; f^.pg.prntpage := 0; bwrite(f, r); bread (f, 0); (*Update desc. to point to new root*) f^.desc.root := r; bwrite (f,0); END; (*PROCEDURE newroot*) ======================================================================================== DOCUMENT :usus Folder:VOL16:bintern.text ======================================================================================== (*------------------------------------------------------------------*) PROCEDURE fixpointer (VAR f : btree; pgnbr, prntpage : btpointer; prntent : bpagesize); (* Read page pointed to by pgnbr, and make backpointers point to prntpage, prntent*) BEGIN IF pgnbr > 0 THEN BEGIN bread (f, pgnbr); f^.pg.prntpage := prntpage; f^.pg.prntentry := prntent; bwrite (f,pgnbr); END; (*If pgnbr*) END; (*PROCEDURE fixpointer*) (*------------------------------------------------------------------*) PROCEDURE bshiftr (VAR f : btree; VAR thispage : bpage; thispgnbr : btpointer; pagepart : bpagesize); (*IF pagepart points to a full space in thispage, move it and everythin to it's right one place to the right, creating a space. In any event, increment the counter.Calling routine must know that thispage isn't full, bshiftr doesn't check. Bshiftr doesn't actually blank the space either. Calling routine should write something there, or you're in a heap of trouble*) VAR subscript : 0..btree2k; BEGIN IF thispage.count < btree2k THEN BEGIN FOR subscript := thispage.count DOWNTO pagepart DO BEGIN thispage.bentry[subscript+1] := thispage.bentry[subscript]; thispage.bpointer[subscript+1] := thispage.bpointer[subscript]; fixpointer (f, thispage.bpointer[subscript], thispgnbr, (subscript+1)); END; (*For subscript*) thispage.count := thispage.count + 1; END; (* IF count*) END; (*PROCEDURE bshiftr*) (*------------------------------------------------------------------*) PROCEDURE bshiftl (VAR f : btree; VAR thispage : bpage; thispgnbr : btpointer; pagepart : bpagesize); (*Move everything to the right of pagepart one space to the left. Calling routine must know that pagepart is empty (or that its okay to overwrite it). Decrement the page counter.*) VAR subscript : 0..btree2k; BEGIN FOR subscript := pagepart TO (thispage.count - 1) DO BEGIN thispage.bentry[subscript] := thispage.bentry[subscript+1]; thispage.bpointer[subscript] := thispage.bpointer[subscript+1]; fixpointer (f, thispage.bpointer[subscript+1],thispgnbr,subscript); END; (*For subscript*) thispage.count := thispage.count - 1; END; (*PROCEDURE bshiftl*) (*------------------------------------------------------------------*) PROCEDURE bbalance (VAR f : btree; parent_pointer : btpointer; entry_pointer : bpagesize; VAR markpage : btpointer; VAR markentry : bpagesize); (*Balance entries (and pointers) among adjacent children of the parent indicate by parent_pointer. Each child gets (total entries DIV number of children). The first (total entries MOD number of children) get one more entry. If deletion has dropped the avg page count to btreek or below, will balance over prnt page's count - 1 pages and return the extra page to freelis Markpage and markentry mark the location of an entry to keep track of following the completion of balance. They are used by binsert. *) VAR entries : ARRAY [0..maxentries] OF btentry; (* holds entries *) pointers : ARRAY [0..maxentries] OF btpointer; (* holds pointers *) parent, child : brecord; place : -1..maxentries; (*index into entries, position of markentry*) first, last : 0..btree2kp; (*begin and end of fill-arrays*) temp_index, ep_index : 0..maxentries; (*index to entry and pointer arrays*) inner, (*index to loop for one child*) outer, (*index to loop for all children of parent*) newcount, (*num of entries per child*) extras : 0..btree2kp; (*num of children w extra entry*) continue, moved_marker : BOOLEAN; (*-------------------------------*) PROCEDURE fill_arrays; (* Local to bbalance*) BEGIN FOR outer := first TO last DO BEGIN (*For each child of parent*) bread (f,parent.pg.bpointer[outer]); (*read a child*) child := f^; FOR inner := 1 TO child.pg.count DO BEGIN (*For each entry in child.*) (*stick the entries into big array of entries, ditto pointers*) temp_index := ep_index + inner; entries[temp_index] := child.pg.bentry[inner]; pointers[temp_index - 1] := child.pg.bpointer[inner - 1]; IF (parent.pg.bpointer[outer] = markpage) AND (inner = markentry) THEN place := temp_index; END; (*For inner*) IF outer < last THEN BEGIN ep_index := temp_index + 1; (*now put parent's entry into big array*) entries[ep_index] := parent.pg.bentry[outer + 1]; END ELSE ep_index := temp_index; (* put last pointer in big array*) pointers[temp_index] := child.pg.bpointer[child.pg.count]; END; (*For outer*) END; (*PROCEDURE fill_array*) (*--------------------------------*) PROCEDURE condense; (*Local to bbalance *) BEGIN IF (parent.pg.prntentry = 0) AND (parent.pg.count = 1) THEN BEGIN parent.pg.count := ep_index; freepage(f,parent.pg.bpointer[0]); freepage(f,parent.pg.bpointer[1]); parent.pg.bpointer[0] := pointers[0]; fixpointer(f, pointers[0],parent_pointer,0); FOR outer := 1 TO ep_index DO BEGIN parent.pg.bentry[outer] := entries[outer]; parent.pg.bpointer[outer] := pointers[outer]; fixpointer(f,pointers[outer],parent_pointer,outer); END; continue := FALSE; END ELSE BEGIN freepage (f,parent.pg.bpointer[last]); bshiftl(f,parent.pg,parent_pointer,last); last := last - 1; newcount := (ep_index - (last-first)) DIV ((last-first)+1); continue := TRUE; END; END; (*Local PROCEDURE condense*) (*--------------------------------*) PROCEDURE write_child (count:bpagesize); (*Local to bbalance*) BEGIN FOR inner := 1 TO count DO BEGIN temp_index := ep_index + inner; child.pg.bentry[inner] := entries[temp_index]; child.pg.bpointer[inner - 1] := pointers[temp_index - 1]; fixpointer (f, child.pg.bpointer[inner - 1], parent.pg.bpointer[outer], inner); IF (temp_index = place) THEN BEGIN markpage := parent.pg.bpointer[outer]; IF moved_marker THEN markentry := inner + 1 ELSE markentry := inner; END; END; (*For inner*) ep_index := temp_index + 1; IF outer < last THEN BEGIN parent.pg.bentry[outer + 1] := entries[ep_index]; IF ep_index = place THEN IF moved_marker THEN BEGIN markpage := parent.pg.bpointer[outer+1]; markentry := 1; END ELSE BEGIN markpage := parent.pg.bpointer[outer]; markentry := count+ 1; END; END; child.pg.prntentry := outer; child.pg.bpointer[count] := pointers[temp_index]; fixpointer(f,pointers[temp_index],parent.pg.bpointer[outer],count); child.pg.count := count; (*now write the child. we didn't disturb the pointers on the parent*) f^ := child; bwrite(f,parent.pg.bpointer[outer]); END; (*PROCEDURE write_child*) (*--------------------------------*) BEGIN (*PROCEDURE bbalance*) IF parent_pointer = 0 THEN exit(bbalance); bread(f,parent_pointer); parent := f^; ep_index := 0; place := 0; continue := TRUE; (*if marker is at count+1,glue it to count*) moved_marker := FALSE; IF markentry > btree2k THEN BEGIN markentry := btree2k; moved_marker := TRUE; END; (*Calculate begin and end for balance *) IF (parent.pg.count + 1) <= bal THEN BEGIN first := 0; last := parent.pg.count; END ELSE IF entry_pointer - halfbal < 0 THEN BEGIN first := 0; last := bal - 1; END ELSE IF entry_pointer + halfbal > parent.pg.count THEN BEGIN first := parent.pg.count - (bal-1); last := parent.pg.count; END ELSE BEGIN first := entry_pointer - halfbal; last := entry_pointer + halfbal; END; fill_arrays; (* Calculate entries per child *) newcount := (ep_index - (last-first)) DIV ((last-first)+1); (* IF deletion has caused # entries to go below k, decrement parent count, return a page to free list, and recalc newcount *) IF newcount < btreek THEN condense; (* Calculate # of children w an extra entry *) extras := (ep_index - (last-first)) MOD ((last-first)+1); (*Since we have entries and entries per child, we reverse the process*) IF continue THEN BEGIN ep_index := 0; IF extras > 0 THEN BEGIN FOR outer := first TO (first+(extras-1)) DO write_child(newcount+1); FOR outer := (first + extras) TO last DO write_child(newcount); END ELSE FOR outer := first TO last DO write_child(newcount); END; f^ := parent; bwrite(f,parent_pointer); (*Now write the parent*) IF parent.pg.count < btreek THEN bbalance (f,parent.pg.prntpage,parent.pg.prntentry,pointers[0],newcount); (*pointers and newcount above are dummies*) END; (*PROCEDURE bbalance*) (*------------------------------------------------------------------*) FUNCTION bpgscan (VAR f: bpage; VAR testkey : bkey; VAR i : INTEGER) : BOOLEAN; (* Given a page (f), searches for testkey. i is place in page where found (if found), or place where insert would take place if not found. Boolean function result indicates found(T) not found (F).*) VAR first, last : bpagesize; found : BOOLEAN; BEGIN first := 1; last := f.count; bpgscan := FALSE; IF (testkey < f.bentry[first].key) OR (last = 0) THEN BEGIN i := first; EXIT(bpgscan); END; IF testkey > f.bentry[last].key THEN BEGIN i := last + 1; EXIT(bpgscan); END; i := (last + first) DIV 2; found := (f.bentry[i].key = testkey); WHILE NOT found AND (i > first) DO BEGIN IF (f.bentry[i].key > testkey) THEN last := i; IF (f.bentry[i].key < testkey) THEN first := i; i := (last + first) DIV 2; found := (f.bentry[i].key = testkey); END; (*While*) IF NOT found THEN i := last; found := (f.bentry[i].key = testkey); bpgscan := found; END; (* FUNCTION bpgscan *) ======================================================================================== DOCUMENT :usus Folder:VOL16:bio.text ======================================================================================== (*------------------------------------------------------------------*) PROCEDURE bread (*VAR f : btree; r: btpointer*); (* Read a btree record *) BEGIN SEEK(f, r); GET(f); END; (* PROCEDURE bread *) (*------------------------------------------------------------------*) PROCEDURE bwrite(VAR f: btree; r:btpointer); (* Write current btree record to file *) BEGIN SEEK (f, r); PUT(f); END; (*PROCEDURE bwrite *) (*------------------------------------------------------------------*) FUNCTION bopen (*VAR f: btree; name: STRING) : BOOLEAN*); (* Open B-tree file name *) BEGIN RESET(f, name); bopen := (ioresult = 0); END; (* FUNCTION bopen *) (*------------------------------------------------------------------*) PROCEDURE bclose (*VAR f: btree*); (* Close btree file f *) BEGIN CLOSE(f); END; (* PROCEDURE bclose *) (*------------------------------------------------------------------*) FUNCTION bnew(*name: STRING; npages: btpointer) : BOOLEAN*); (* Create a new btree named name *) VAR f: btree; BEGIN REWRITE(f, name); IF ioresult = 0 THEN BEGIN bnew := TRUE; WITH f^ DO BEGIN use := 1; (* mark as descriptor rec *) desc.nrec := 2; (* record 2 is first in free chain *) desc.freehead := 2; (* first free rec *) desc.maxrec := npages; (* space to allocate *) desc.root:= 1; (* record 1 is root of empty tree *) END; (* WITH*) PUT(f); WITH f^.pg DO BEGIN (* create empty root *) f^.use := 2; (* mark as page *) count:= 0; (* empty *) bpointer[0] := 0; (*initialize pointer*) prntpage := 0; (*init backpointer*) prntentry := 0; (*ditto*) END; (* WITH *) PUT(f); WITH f^ DO BEGIN use := 0; (* mark as free record *) nextfree := 0; (* end of free chain *) END; (* WITH *) PUT(f); SEEK(f, npages); (* allocate space *) PUT(f); CLOSE(f,LOCK); END {If goodio} ELSE bnew := false; END; (* PROCEDURE bnew *) ======================================================================================== DOCUMENT :usus Folder:VOL16:bmain.text ======================================================================================== (*------------------------------------------------------------------*) FUNCTION bsearch (*VAR f : btree; VAR pgnbr : btpointer; VAR entrynbr : bpagesize;key : bkey) : BOOLEAN*); (* Given a btree (f), searches for key. Returns pgnbr (page) and entrynbr (place in page) where found or where insertion would take place. Calls bpgscan to check each page as necessary. Boolean function result is T if found, F if not found*) VAR p:btpointer; found:BOOLEAN; i: INTEGER; BEGIN p:=broot(f); pgnbr := p; found:=FALSE; WHILE(NOT found) AND (P<>0) DO BEGIN bread(f,p); found:=bpgscan(f^.pg,key,i); entrynbr := i; IF NOT found THEN BEGIN p:=f^.pg.bpointer[i-1]; IF p <> 0 THEN pgnbr := p; END; (*If not found*) END; (* WHILE *) bsearch:=found; END; (* FUNCTION bsearch *) (*------------------------------------------------------------------*) (*PROCEDURE binsert (VAR f : btree; insentry : btentry; inspointer : btpointer; pgnbr : btpointer; entrynbr : bpagesize); FORWARD;*) (*------------------------------------------------------------------*) FUNCTION bsplit (VAR f : btree; oldpgnbr : btpointer) : btpointer; (* Split the page at oldpgnbr and pop the central entry up one level in the tree, by calling binsert (or newroot if the page split was the root). Call to binsert may cause the parent page to overflow, resulting in another call to bsplit by binsert. If the root is split. a new root is created, containing only the central entry. The function returns the page number of the new page it created.*) VAR i,j : bpagesize; newrec, oldrec : brecord; midentry : btentry; midpointer : btpointer; prntpage : btpointer; BEGIN newrec.use := 2; (* set up new page as btree page *) bread (f,oldpgnbr); oldrec := f^; oldrec.pg.count := btreek; newrec.pg.count := btreek; (* half of the old pg *) i := btreek + 1; (*starting index*) midentry := oldrec.pg.bentry[i]; midpointer := getpage(f); newrec.pg.bpointer[0] := oldrec.pg.bpointer[i]; fixpointer(f,newrec.pg.bpointer[0],midpointer,0); FOR j := 1 TO btreek DO BEGIN newrec.pg.bentry[j] := oldrec.pg.bentry[i+j]; newrec.pg.bpointer[j] := oldrec.pg.bpointer[i+j]; fixpointer(f, newrec.pg.bpointer[j],midpointer, j); END; IF oldrec.pg.prntpage = 0 THEN BEGIN newroot (f, midentry, oldpgnbr, midpointer); prntpage := broot(f); newrec.pg.prntpage := prntpage; newrec.pg.prntentry := 1; oldrec.pg.prntpage := prntpage; oldrec.pg.prntentry := 0; f^ := newrec; bwrite(f, midpointer); f^ := oldrec; bwrite(f,oldpgnbr); END ELSE BEGIN IF oldrec.pg.prntentry < btree2k THEN BEGIN newrec.pg.prntentry := oldrec.pg.prntentry + 1; newrec.pg.prntpage := oldrec.pg.prntpage; END; f^ := newrec; bwrite(f,midpointer); f^ := oldrec; bwrite(f, oldpgnbr); binsert (f, midentry, midpointer, oldrec.pg.prntpage, (oldrec.pg.prntentry + 1 )); END; (*Else*) bsplit := midpointer; END; (* FUNCTION bsplit *) (*------------------------------------------------------------------*) PROCEDURE binsert (*VAR f : btree; insentry : btentry; inspointer : btpointer; pgnbr : btpointer; entrynbr : bpagesize*); (* Insert the insentry, inspointer at the place pointed to by pgnbr, entrynbr. If necessary, balance among siblings or split to make room. Split may invoke mutually recursive call of insert.*) VAR dummy : btpointer; buffrec : brecord; BEGIN bread (f, pgnbr); IF f^.pg.count = btree2k THEN BEGIN bbalance (f, f^.pg.prntpage,f^.pg.prntentry,pgnbr,entrynbr); bread (f, pgnbr); END; IF f^.pg.count = btree2k THEN BEGIN IF entrynbr > (btreek + 1) THEN BEGIN pgnbr := bsplit (f, pgnbr); entrynbr := entrynbr - (btreek + 1); END ELSE dummy := bsplit (f, pgnbr); bread (f, pgnbr); END; buffrec := f^; IF entrynbr = btree2kp THEN entrynbr := entrynbr - 1; (*Above will happen only when search put location beyond end of full page and balance was called, opening rightmost slot in page*) bshiftr (f, buffrec.pg, pgnbr, entrynbr); f^ := buffrec; f^.pg.bentry[entrynbr] := insentry; f^.pg.bpointer[entrynbr] := inspointer; bwrite (f, pgnbr); fixpointer(f, inspointer, pgnbr, entrynbr); END; (* PROCEDURE binsert *) (*------------------------------------------------------------------*) FUNCTION nextentry (*VAR f : btree; thispg : btpointer; thisent : bpagesize; VAR nxtpg : btpointer; VAR nxtent : bpagesize) : BOOLEAN*); (* Searches for first entry lexically greater than that pointed to by thispg, thisent. Returns TRUE if there is a next entry, and returns its position as nxtpg, nxtent. If there is no greater entry, returns FALSE. Nxtpag, nxtent are set to thispg,thisent in this case.*) VAR temp : brecord; BEGIN bread (f,thispg); temp := f^; IF temp.pg.bpointer[thisent] = 0 THEN (*At a leaf*) IF thisent <> temp.pg.count THEN BEGIN (*Not at end-of-page*) nxtpg := thispg; IF thisent > temp.pg.count THEN BEGIN nxtpg := thispg; nextentry := FALSE; END ELSE BEGIN nxtent := thisent + 1; nextentry := TRUE; END; END ELSE BEGIN (*At end-of-page*) nxtent := thisent+1; WHILE (temp.pg.count < nxtent) AND (temp.pg.prntpage <> 0) DO BEGIN (*Ascend until not at end-of-page*) nxtent:= temp.pg.prntentry+1; nxtpg := temp.pg.prntpage; bread(f,nxtpg); temp := f^; END; IF (temp.pg.prntpage=0) AND (temp.pg.count < nxtent) THEN BEGIN nextentry := FALSE; nxtent := thisent; nxtpg := thispg; END ELSE nextentry := TRUE; END ELSE BEGIN (*Not at a leaf*) nxtpg := temp.pg.bpointer[thisent]; bread(f,temp.pg.bpointer[thisent]); WHILE f^.pg.bpointer[0] <> 0 DO BEGIN (*descend until leaf*) nxtpg := f^.pg.bpointer[0]; bread (f, nxtpg); END; (*While*) nxtent := 1; nextentry := TRUE; END; (*Else*) END; (*FUNCTION nextentry; (*------------------------------------------------------------------*) FUNCTION preventry (*VAR f : btree; thispg : btpointer; thisent : bpagesize; VAR prvpg : btpointer; VAR prvent : bpagesize) : BOOLEAN*); (* Searches for first entry lexically less than that pointed to by thispg, thisent. Returns TRUE if there is a prev entry, and returns its position as prvpg, prvent. If there is no lesser entry, returns FALSE. Prvpag, prvent are set to thispg,thisent in this case.*) VAR temp : brecord; BEGIN bread (f,thispg); temp := f^; IF temp.pg.bpointer[thisent - 1] = 0 THEN (*At a leaf*) IF thisent <> 1 THEN BEGIN (*Not at begin-of-page*) prvpg := thispg; prvent := thisent - 1; preventry := TRUE; END ELSE BEGIN (*At begin-of-page*) prvent := thisent -1; WHILE (prvent = 0) and (temp.pg.prntpage <> 0) DO BEGIN (*Ascend until not begin-page*) prvent := temp.pg.prntentry; prvpg := temp.pg.prntpage; bread(f,prvpg); temp := f^; END; IF (temp.pg.prntpage = 0) AND (prvent = 0) THEN BEGIN preventry := FALSE; prvent := thisent; prvpg := thispg; END ELSE preventry := TRUE; END ELSE BEGIN (*Not at a Leaf*) prvpg := temp.pg.bpointer[thisent-1]; bread(f,temp.pg.bpointer[thisent - 1]); WHILE f^.pg.bpointer[f^.pg.count] <> 0 DO BEGIN (*Descend until leaf*) prvpg := f^.pg.bpointer[f^.pg.count]; bread (f, prvpg); END; (*While*) prvent := f^.pg.count; preventry := TRUE; END; (*Else*) END; (*FUNCTION preventry; (*------------------------------------------------------------------*) PROCEDURE bdelete (*VAR f : btree; pgnbr : btpointer; entnbr : bpagesize*); (* Deletes entry (and associated pointer) pointed to by entnbr,pgnbr. If necessary, calls bbalance to balance or shrink tree.*) VAR this, next : brecord; nxtpg : btpointer; nxtent : bpagesize; BEGIN bread(f,pgnbr); this := f^; IF (this.pg.bpointer[entnbr] <> 0) AND (*Not at a leaf, next is TRUE*) (nextentry (f,pgnbr,entnbr,nxtpg,nxtent)) THEN BEGIN bread(f,nxtpg); next := f^; this.pg.bentry[entnbr] := next.pg.bentry[nxtent]; bshiftl(f, next.pg, nxtpg, nxtent); f^ := next; bwrite (f, nxtpg); f^ := this; bwrite(f, pgnbr); IF next.pg.count <= btreek THEN bbalance(f,next.pg.prntpage,next.pg.prntentry,pgnbr,entnbr);END ELSE BEGIN (*At a leaf*) bshiftl (f, this.pg, pgnbr, entnbr); f^ := this; bwrite(f, pgnbr); IF this.pg.count <= btreek THEN bbalance(f,this.pg.prntpage,this.pg.prntentry,pgnbr,entnbr);END END; (*PROCEDURE bdelete*) (*------------------------------------------------------------------*) PROCEDURE firstentry (*VAR f : btree; VAR page : btpointer; VAR entry : bpagesize*); (*Returns position of least (first) lexical entry as page, entry*) BEGIN page := broot(f); bread(f,page); WHILE f^.pg.bpointer[0] <> 0 DO BEGIN page := f^.pg.bpointer[0]; bread(f,page); END; entry := 1; END; (*PROCEDURE firstentry*) (*------------------------------------------------------------------*) PROCEDURE lastentry (*VAR f : btree; VAR page : btpointer; VAR entry : bpagesize*); (*Returns position of greatest (last) lexical entry as page, entry*) BEGIN page := broot(f); bread(f,page); WHILE f^.pg.bpointer[f^.pg.count] <> 0 DO BEGIN page := f^.pg.bpointer[f^.pg.count]; bread(f,page); END; entry := f^.pg.count; END; (*PROCEDURE lastentry*) ======================================================================================== DOCUMENT :usus Folder:VOL16:bunit.text ======================================================================================== {$S+} {$R+} {$I-} UNIT bunit; (* B-tree creation and update routines Marvin White Kyle Goldman Michael Adams Robert Sims Applications Mathematics Research Staff U.S. Census Bureau Washington, D.C. *) (******************) INTERFACE (*********************) CONST btreek = 19; (*must be btree2k DIV 2*) btree2kp = 40; (*must be btree2k + 1*) btree2k = 39; (* number of entries / page, must be odd *) bal = 5; (*num of children over which to balance*) halfbal = 2; (* bal DIV 2 *) maxentries =240; (*used only by bbalance, must equal btree2kp * (bal + 1) *) keysize = 21; (* number of INTEGER values in key *) maxpages=32767; (* maximum possible pages *) tempmax = 200; (*DEBUG max on pages*) TYPE btpointer = 0.. maxpages; (* pointer to btree page *) bpagesize = 0..btree2kp; bkey = STRING[keysize]; bdata= INTEGER; (* these btrees have only a single integer datum*) btentry = RECORD key : bkey; data: bdata; END; (* RECORD *) buse = 0..2; (* use designator for page in file *) bdescrip = RECORD (* record 0 in file is descriptor *) nrec: btpointer; (*current last page *) maxrec: btpointer; (* current allocation *) root: btpointer; (* root of tree *) freehead: btpointer; (* head of free list *) END; (* RECORD *) bpage = RECORD (* page in b-tree *) prntpage : btpointer; prntentry : 0..btree2k; (*same # as index of bpointer t???*) count: 0..btree2k; (* entries in this page *) bentry: ARRAY[1..btree2k] OF btentry; bpointer: ARRAY[0..btree2k] OF btpointer; END; (* RECORD *) brecord = RECORD CASE use: buse OF 0: (nextfree: btpointer); (* free record *) 1: (desc: bdescrip); (* record 0 *) 2: (pg: bpage); (* b-tree page *) END; (*CASE*) btree = FILE OF brecord; FUNCTION broot(VAR f:btree):btpointer; { Returns page number of root of btree f } FUNCTION bopen (VAR f: btree; name : STRING):BOOLEAN; { Open the btree file named name, associate with fileid f } PROCEDURE bread (VAR f : btree; r: btpointer); { Read a btree record number r from tree f } PROCEDURE bclose (VAR f: btree); { Close btree fileid f } FUNCTION bnew (name : STRING; npages : btpointer):BOOLEAN; { Create a btree file named name, containing npages, and close it } FUNCTION bsearch (VAR f: btree; VAR pgnbr : btpointer; VAR entrynbr : bpagesize; key : bkey) : BOOLEAN; { search btree file f for key. Return TRUE if found, FALSE if not. If found, pgnbr and entrynbr contain the location. If not found, they contain the correct location for insertion } PROCEDURE binsert (VAR f: btree; insentry : btentry; inspointer : btpointer; pgnbr : btpointer; entrynbr : bpagesize); { Insert insentry, inspointer, into btree file f at location pgnbr, entrynbr. Bsearch must be called first to insure uniqueness, and to determine the insert location. User calls to binsert must set inspointer to zero (0). } PROCEDURE bdelete (VAR f: btree; pgnbr : btpointer; entnbr : bpagesize); { Delete from btree file f the entry found at location pgnbr and entnbr. Bsearch must be called first to determine correct location. } PROCEDURE firstentry (VAR f: btree; VAR page : btpointer; VAR entry : bpagesize); { Find lexically first entry in tree f. Return location in page, entry. } PROCEDURE lastentry (VAR f: btree; VAR page : btpointer; VAR entry : bpagesize); { Find lexically last entry in tree f. Return location in page, entry. } FUNCTION nextentry (VAR f: btree; thispg : btpointer; thisent : bpagesize; VAR nxtpg : btpointer; VAR nxtent : bpagesize) : BOOLEAN; { Start at thispg, thisent in btree f. Find next lexical entry. Return TRUE if not at end, location in nxtpg, nxtent. Return FALSE if at end, location of last entry in nxtpg, nxtent. } FUNCTION preventry (VAR f: btree; thispg : btpointer; thisent : bpagesize; VAR prvpg : btpointer; VAR prvent : bpagesize) : BOOLEAN; { Start at thispg, thisent in btree f. Find previous lexical entry. Return TRUE if not at beginning, location in nxtpg, nxtent. Return FALSE if at beginning, location of last entry in nxtpg, nxtent. } PROCEDURE bdump (VAR r: brecord); (* Dump contents of r to terminal*) PROCEDURE showit(VAR f:btree; pagenbr : btpointer; entrynbr : bpagesize); (* Display contents of tree f, at pagenbr,entrynbr , formatted *) (*******************) IMPLEMENTATION (************************) PROCEDURE errtrap (errmsg : STRING); FORWARD; (*$I BIO.TEXT*) (*$I BDEBUG.TEXT*) (*$I BHKEEP.TEXT*) (*$I BINTERN.TEXT*) (*$I BMAIN.TEXT*) END. ======================================================================================== DOCUMENT :usus Folder:VOL16:checkbook.text ======================================================================================== {$S+} PROGRAM Checkbook; USES (*$U crtinput.code*) CRTInput, (*$U getnumber.code*) GetNumber; CONST DFileName = 'CHECK.MASK.DATA'; BFileName = 'PREV.BAL.TEXT'; MaxX = 79; MaxY = 23; MaxData = 50; MaxArray = 20; PromptLine = 1; MaxChecks = 30; MaxDeposits = 10; TYPE YLimits = 0..MaxY; XLimits = 0..MaxX; DataLimits = 1..MaxData; CheckLimits = 1..MaxChecks; DepositLimits = 1..MaxDeposits; CRTLineArray = PACKED ARRAY [XLimits] OF char; DataRec = PACKED RECORD X: XLimits; Y: YLimits; Lngth, Decimal: XLimits; END; MaskRec = RECORD Line: ARRAY [YLimits] OF CRTLineArray; Data: ARRAY [DataLimits] OF DataRec; END; Money = RECORD Dollars, Cents: integer; END; Entry = RECORD Amount: money; Description: string[12]; END; VAR BS: char; LastCheckNo, LastDepositNo: integer; TotlChecks, TotlDeposits, PrevBal, Balance: Money; PrevDate, Date: String[20]; Check: ARRAY [CheckLimits] OF Entry; Deposit: ARRAY [DepositLimits] OF Entry; Mask: MaskRec; DataFile: FILE OF MaskRec; BalFile: interactive; PROCEDURE WritePrompt (prompt: string); BEGIN GoAndClearLine (PromptLine); Write (prompt) END; FUNCTION WaitForSp (p: string): boolean; VAR ch: char; BEGIN Write(CHR (7), p); Write ('. Type a space to continue, to abort...'); REPEAT Read (keyboard, ch) UNTIL (ch = ' ') OR (ch = CHR (27)); Writeln; WaitForSp := ch = ' ' END; PROCEDURE WriteError (prompt: string); VAR ch: char; BEGIN Gotoxy (0, ErrorLine); Write (CHR(7), prompt, '. Type to go on..'); REPEAT Read (keyboard, ch) UNTIL ch = ' '; GoAndClearLine (ErrorLine); END; PROCEDURE GotoDataField (n: integer); BEGIN WITH Mask.Data[n] DO Gotoxy (x,y) END; PROCEDURE ClearField (n: integer); BEGIN WITH Mask.Data[n] DO BEGIN Gotoxy (X,Y); Write (' ':Lngth) END END; PROCEDURE ReadMaskData; VAR i: integer; BEGIN REPEAT {$I-} Reset (DataFile, DFileName); IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#4:', DFileName)); IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#5:', DFileName)); {$I+} i := IORESULT; IF i > 0 THEN BEGIN Writeln('I can''t find "', DFileName, '", needed to use this program.'); IF NOT Yes ('Do you wish me to try to find it again') THEN EXIT (Program) END; UNTIL i = 0; Mask := Datafile^; ClearScreen; FOR i := 0 TO MaxY-1 DO Writeln (Mask.Line[i]); END; PROCEDURE GetMoney (DN: datalimits; Prompt: string; VAR Amount: Money); BEGIN WritePrompt (Prompt); GetDecimal (Mask.Data[DN].x, Mask.Data[DN].Y, 0, 9999, 2, Amount.Dollars, Amount.Cents); GoAndClearLine (PromptLine); END (*GetMoney*); PROCEDURE WriteMoney (DN: datalimits; amount: money); VAR m: integer; BEGIN WITH Mask.Data[DN] DO BEGIN Gotoxy (X, Y); m := Lngth - 4; IF (Amount.Dollars < 0) OR (Amount.Cents < 0) THEN BEGIN m := m -1; Write ('-'); END ELSE Write (' ', BS); Write (ABS(Amount.dollars):m, '.'); m := ABS (Amount.Cents); IF m DIV 10 = 0 THEN Write ('0'); Write (m MOD 100); END; END; PROCEDURE AddMoney (Add1, Add2: Money; VAR Sum: Money); BEGIN Sum.Dollars := Add1.Dollars + Add2.Dollars; Sum.Cents := Add1.Cents + Add2.Cents; IF Sum.Cents > 99 THEN BEGIN Sum.Cents := Sum.Cents -100; Sum.Dollars := Sum.Dollars + 1; END; END; PROCEDURE SubMoney (minuend, subtrahend: money; VAR result: money); BEGIN Result.Dollars := Minuend.Dollars - Subtrahend.Dollars; Result.Cents := Minuend.Cents - Subtrahend.Cents; WITH Result DO IF (Dollars > 0) AND (Cents < 0) THEN BEGIN Cents := Cents + 100; Dollars := Dollars - 1 END ELSE IF (Dollars < 0) AND (Cents > 0) THEN BEGIN Cents := Cents - 100; Dollars := Dollars + 1 END; END; PROCEDURE GetOrdinate (n: integer; VAR Ordinate: String); VAR prefix: string[2]; BEGIN CASE (n MOD 100) DIV 10 OF 0: prefix := ''; 1: prefix := '1'; 2: prefix := '2'; 3: prefix := '3'; 4: prefix := '4'; 5: prefix := '5'; 6: prefix := '6'; 7: prefix := '7'; 8: prefix := '8'; 9: prefix := '9' END; CASE n MOD 10 OF 0: prefix := CONCAT (prefix, '0'); 1: prefix := CONCAT (prefix, '1'); 2: prefix := CONCAT (prefix, '2'); 3: prefix := CONCAT (prefix, '3'); 4: prefix := CONCAT (prefix, '4'); 5: prefix := CONCAT (prefix, '5'); 6: prefix := CONCAT (prefix, '6'); 7: prefix := CONCAT (prefix, '7'); 8: prefix := CONCAT (prefix, '8'); 9: prefix := CONCAT (prefix, '9') END; IF (n MOD 10 > 3) OR (n MOD 10 = 0) OR (n IN [11..13]) THEN Ordinate := CONCAT (prefix, 'th') ELSE CASE n MOD 10 OF 1: Ordinate := CONCAT (prefix, 'st'); 2: Ordinate := CONCAT (prefix, 'nd'); 3: Ordinate := CONCAT (prefix, 'rd') END; END; PROCEDURE GetAmount(i: integer; n:Datalimits; VAR amount: money; VAR description: string); VAR prompt: string; ordinate: string[5]; j: integer; BEGIN GetOrdinate (i, Ordinate); Prompt := CONCAT ('Please list the number, date, or description of the ', Ordinate, ' item.'); WritePrompt (prompt); GotoDataField (n); FOR i := 1 TO 13 DO Write (BS); GetString (12, Descriptn); GetMoney (n, 'Now the amount.', amount); END; PROCEDURE GetCheck (Checkno: integer); VAR i: integer; BEGIN GotoDataField(CheckNo); FOR i := 1 TO 17 DO Write(BS); Write(CheckNo:2, ':'); WITH Check[CheckNo] DO GetAmount (CheckNo, CheckNo, Amount, Description); END; PROCEDURE GetDeposit (DepositNo: integer); VAR i, Thisfield: integer; BEGIN ThisField := (DepositNo + 30); GotoDataField (ThisField); FOR i := 1 TO 17 DO Write (BS); Write(DepositNo:2, ':'); WITH Deposit[DepositNo] DO GetAmount (DepositNo, ThisField, Amount, Description); END; PROCEDURE AddEntry(ch: char); BEGIN CASE ch OF 'C': IF LastCheckNo < MaxCheck THEN BEGIN LastCheckNo := LastCheckNo +1; GetCheck(LastCheckNo) END ELSE WriteError ( 'Sorry, I don''t have room for that number of checks'); 'D': IF LastDepositNo < MaxDeposit THEN BEGIN LastDepositNo := LastDepositNo+1; GetDeposit (LastDepositNo) END ELSE WriteError ( 'Sorry, I don''t have room for that many deposits'); END END; PROCEDURE FixEntry; VAR i: integer; s: string; BEGIN IF (LastCheckNo = 0) AND (LastDepositNo = 0) THEN WriteError ('First A)dd checks or deposits before correcting') ELSE CASE GetLetter (PromptLine, 'Fix previously entered C)heck or D)eposit', ['C', 'D']) OF 'C': IF LastCheckNo > 0 THEN BEGIN Gotoxy (0, PromptLine); IF LastCheckNo > 1 THEN BEGIN Write('Which check do you wish to fix (1 to ', MaxCheck, ')? '); GetInteger (-1, -1, 1, LastCheckNo, false, i); END ELSE i := 1; GetCheck (i) END ELSE WriteError ('First ADD a check before correcting it'); 'D': IF LastDepositNo > 0 THEN BEGIN Gotoxy (0, PromptLine); IF LastDepositNo > 1 THEN BEGIN Write('Which deposit do you wish to correct (1 to ', MaxDeposit, ')? '); GetInteger (-1, -1, 1, LastDepositNo, false, i); END ELSE i := 1; GetDeposit (i) END ELSE WriteError ('First ADD a deposit before correcting it') END END; PROCEDURE FigureBalance; VAR i: integer; BEGIN TotlChecks.Dollars := 0; TotlChecks.Cents := 0; TotlDeposits.Dollars := 0; TotlDeposits.Cents := 0; FOR i := 1 TO LastCheckNo DO AddMoney (Check[i].Amount, TotlChecks, TotlChecks); WriteMoney (45, TotlChecks); FOR i := 1 TO LastDepositNo DO AddMoney (Deposit[i].Amount, TotlDeposits, TotlDeposits); WriteMoney (46, TotlDeposits); AddMoney (TotlDeposits, PrevBal, Balance); SubMoney (Balance, TotlChecks, Balance); WriteMoney (47, Balance) END; PROCEDURE GetData; VAR quit: boolean; BEGIN quit := false; IF PrevDate <> '' THEN BEGIN WriteMoney (42, PrevBal); GotoDataField (41); Write (PrevDate) END; REPEAT CASE GetLetter (PromptLine, 'add new C)heck or D)eposit, F)ix previous entry, set P)revious balance, Q)uit', ['C', 'D', 'F', 'P', 'Q']) OF 'C': AddEntry('C'); 'D': AddEntry('D'); 'F': FixEntry; 'P': BEGIN GetMoney (42, 'Please enter correct previous balance.', PrevBal); WritePrompt ('Please enter date previous balance was valid.'); GoToDataField (41); GetString (20, PrevDate); END; 'Q': quit := true END; FigureBalance UNTIL quit END; PROCEDURE Initialize; VAR i: integer; BEGIN BS := CHR (backspace); Date := ''; PrevDate := ''; {$I-} Reset (BalFile, BFileName); i := IORESULT; IF i > 0 THEN BEGIN Reset (BalFile, CONCAT ('#4:', BFileName)); i := IORESULT END; IF i > 0 THEN BEGIN Reset (BalFile, CONCAT ('#5:', BFileName)); i := IORESULT; END; {$I+} IF i = 0 THEN BEGIN Writeln ('Reading previously stored account balance...'); Readln (BalFile, PrevBal.Dollars, PrevBal.Cents); Readln (BalFile, PrevDate); Close (BalFile, Lock) END ELSE BEGIN PrevBal.Dollars := 0; PrevBal.Cents := 0 END; LastCheckNo := 0; LastDepositNo := 0; FOR i := 1 TO MaxCheck DO WITH Check[i] DO BEGIN Amount.Dollars := 0; Amount.Cents := 0; Description := '' END; FOR i := 1 TO MaxDeposit DO WITH Deposit[i] DO BEGIN Amount.Dollars := 0; Amount.Cents := 0; Description := '' END; END; PROCEDURE PrintChecks; VAR List: text; i: integer; PROCEDURE PrintMoney (Amount: Money); VAR m: integer; BEGIN Write (List, ' $'); IF (Amount.Dollars < 0) OR (Amount.Cents < 0) THEN BEGIN Write (List, '-'); m := 4 END ELSE m := 5; Write (List, ABS(Amount.dollars):m, '.'); m := ABS (Amount.Cents); IF m DIV 10 = 0 THEN Write (List, '0'); Writeln (List, m MOD 100); END; BEGIN ClearScreen; Rewrite (List, 'PRINTER:'); IF NOT WaitForSp ('Ready to print') THEN EXIT (PrintChecks); Writeln (List, 'CHECKING ACCOUNT STATUS UPDATE'); Writeln (List, ' As of: ', Date); Writeln (List); Writeln (List); Writeln (List, 'I. Summary of Checks.'); FOR i := 1 TO LastCheckNo DO WITH Check[i] DO BEGIN Write(List, Description:12, ':'); PrintMoney (Amount) END; Writeln (List); Write (List, 'Total amount of checks ='); PrintMoney (TotlChecks); Writeln (List); Writeln (List); Writeln (List, 'II. Summary of Deposits.'); FOR i := 1 TO LastDepositNo DO WITH Deposit[i] DO BEGIN Write(List, Description:12, ':'); PrintMoney (Amount) END; Writeln (List); Write (List, 'Total amount of deposits ='); PrintMoney (TotlDeposits); Writeln (List); Write (List, 'III. CURRENT BALANCE AS OF ', Date, ' ='); PrintMoney (Balance); Writeln (List); END; PROCEDURE SaveBalance; BEGIN ClearScreen; Writeln ('Saving your account balance in "', BFilename, '"....'); Rewrite (BalFile, BFileName); Writeln (BalFile, Balance.Dollars, ' ', Balance.Cents); Writeln (BalFile, Date); CLOSE (BalFile, LOCK) END; BEGIN Initialize; REPEAT Write ('Today''s date? '); GetString (20, Date); Writeln UNTIL Yes ('OK'); ReadMaskData; GetData; Gotoxy (0, PromptLine); IF Yes ('Do you want a printed copy of this series of checks/deposits') THEN PrintChecks; IF Yes ('Do you want to save your current balance on the disk') THEN SaveBalance END. ======================================================================================== DOCUMENT :usus Folder:VOL16:crtinput.text ======================================================================================== UNIT CRTINPUT; {Special procedures for controlled CRT input of string, textfile, and boolean variables. COPYRIGHT (c) 1980, James Gagne, President DATAMED RESEARCH 1433 Roscomare Road Los Angeles, CA 90024 213/472-8825 ALL RIGHTS RESERVED. These routines may be used for nonprofit, non- commercial purposes only, unless written consent of the author is obtained.} INTERFACE TYPE FileAction = (GetOld, Create) {equivalent to Reset/Rewrite}; FNameString = string [30]; chset = set OF char; PROCEDURE GoAndClearLine(y: integer); FUNCTION Yes (prompt: string): boolean; PROCEDURE ClearScreen; PROCEDURE AllCaps (VAR s:string); {convert string to all capital letters} FUNCTION GetLetter (y: integer; s: string; cset: chset): char; { Writes S at line Y; reads w/o echo, converting alpha to upper case, until char is in CSET, then returns this char after erasing line Y. The cursor is not moved if Y < 0 or > 23.} PROCEDURE GetString (MaxLength: integer; VAR Typed: string); {See description in IMPLEMENTATION section.} FUNCTION OpenTextFile (Prompt: string {your request for the filename}; VAR FileName: FNameString{filename string}; Action: FileAction {"GetOld" or "Create"}; Startline: integer {linenumber on which to start dialogue}; VAR F: text {file to be opened}) : boolean {true = file opened; false = user aborted}; PROCEDURE GetBoolean (x, y: integer; VAR DesiredValue: boolean); IMPLEMENTATION CONST {ASCII characters} etx = 3; bel = 7; bs = 8; htab = 9; esc = 27; del = 127; RCurs = 18 {Control R ==> move cursor right}; ErrorLine = 23 {last line on screen is for error messages}; VAR Response, ch, EscapeCh: char; FUNCTION Yes (*prompt: string*)(*: boolean*); var ch : char; begin write ( prompt, ' (y/n) ' ); repeat read ( keyboard, ch ); until ch in [ 'Y','y','N','n' ]; if ch in [ 'Y', 'y' ] then begin yes := true; write ( 'yes' ) end else begin yes := false; write ( 'no' ) end; end; PROCEDURE GoAndClearLine(*y: integer*); begin gotoxy ( 0, y ); write ( chr( 27 ), chr ( 75 ) ); {H-19 specific} end; PROCEDURE ClearScreen; BEGIN Write(chr(27), chr(69)) END; {H-19 specific} PROCEDURE OptionalGotoxy (x,y: integer); {Leave the cursor where it is if x or y is < 0} BEGIN IF (x >= 0) AND (y >= 0) THEN Gotoxy (x,y); END; PROCEDURE AllCaps {(VAR s:string)}; VAR i, LittletoBig : integer; BEGIN LittletoBig := ORD ('A') - ORD ('a'); FOR i := 1 TO Length (s) DO IF s[i] IN ['a'..'z'] THEN s[i] := CHR (Ord (s[i]) + LittletoBig); END; FUNCTION GetLetter {(y: integer; s: string; cset: chset): char}; VAR ch: char; BEGIN IF (y>=0) AND (y<24) THEN GoAndClearLine(y); Write(s); REPEAT Read(keyboard, ch); IF (ch IN ['a'..'z']) THEN ch := CHR( ORD(ch) + ORD('A') - ORD('a') ) UNTIL ch IN cset; IF (y >= 0) AND (y < 24) THEN GoAndClearLine (y) ELSE writeln(ch); GetLetter := ch END; {GETSTRING does the following: This routine first types the original string (Typed), followed by dots to the maximum string length. If any char is typed but ETX or ESCAPE, the original string is replaced by a row of dots to the maximum length of the string as passed by the calling routine. GetString then reads characters until terminated by a typed return or escape or at the point that the string is filled by the maximum allowed characters. Typing a control R at any point will fill that character with one from the original string; a horizontal tab will either fill in text, or add spaces, depending on whether the end of the original string has been reached. If at any time escape is typed, the original string (TYPED) is restored and the procedure terminated. Otherwise, either a return or a full string are taken as end-of-string. Backspace and Delete work per the usual UCSD standard.} PROCEDURE GetString {(MaxLength: integer; VAR Typed: string[255])}; CONST MaxString = 250; FillChar = '.'; VAR j, k, MaxL, StringLength: integer; ReadCh: boolean; HTabCh, backsp, DeleteCh: char; Newstring: String[MaxString]; Didtype: PACKED ARRAY [1..MaxString] OF char; BEGIN IF MaxLength > MaxString THEN MaxL := MaxString ELSE MaxL := MaxLength; IF MaxLength = 0 THEN BEGIN Typed := ''; Exit (GetString); END; backsp := CHR (bs); HTabCh := CHR (Htab); EscapeCh := CHR (esc); DeleteCh := CHR (del); REPEAT {loop repeated only if DELETE typed} StringLength := LENGTH (typed); IF StringLength > MaxL THEN BEGIN Delete (Typed, MaxL+1, StringLength-MaxL); StringLength := LENGTH (typed); END; Write (typed); FOR j := StringLength+1 TO maxlength DO Write (FillChar); FOR j := 1 TO Maxlength DO write (backsp); Read (Keyboard, ch); IF ch = EscapeCh THEN BEGIN Write (typed, ' ': MaxL - StringLength); EXIT (GetString) END ELSE BEGIN IF ch = CHR (etx) THEN ReadCh := true ELSE BEGIN {If the 1st char <> control C,} ReadCh := false; {then erase original string. } FOR j := 1 TO StringLength DO Write (FillChar); FOR j := 1 TO StringLength DO Write (backsp); END; j := 1; REPEAT IF ReadCh THEN Read (keyboard, ch); ReadCh := true; IF (ch = CHR (RCurs)) AND (j <= StringLength) THEN BEGIN {The Right-cursor character will keep one } ch := Typed [j]; {character at a time from the original string.} Write (ch); Didtype[j] := ch; j := j + 1 END ELSE IF (ch >= ' ') AND (ch < DeleteCh) THEN BEGIN Write (ch); Didtype[j] := ch; j := j + 1 END ELSE IF ch = HTabCh THEN REPEAT IF j <= StringLength THEN ch := Typed [j] ELSE ch := ' '; Write (ch); Didtype [j] := ch; j := j + 1 UNTIL (j MOD 8 = 1) OR (j > MaxL) ELSE IF (ch = backsp) AND (j > 1) THEN BEGIN Write (backsp, FillChar, backsp); j := j - 1; END UNTIL (j > MaxL) OR (ch IN [EscapeCh, DeleteCh]) OR EOLN (keyboard); k := j - 1; IF EOLN (keyboard) AND (k = 1) THEN k := 0; FOR j := 1 TO k DO Write (backsp); END UNTIL ch < DeleteCh; IF ch <> EscapeCh THEN BEGIN NewString := ''; FOR j := 1 TO k DO BEGIN NewString := CONCAT (NewString, ' '); NewString [j] := Didtype [j] END; Typed := NewString END; {else typed is left alone} Write (typed, ' ':(maxlength - Length (typed))); END (*GetString*); PROCEDURE WriteErr (Message: string); BEGIN Gotoxy (0, ErrorLine); Write (CHR (bel), '-** ERROR **- ', Message, '. Tap to continue...'); REPEAT Read (keyboard, ch) UNTIL ch = ' '; GoAndClearLine (ErrorLine) END; {OPENTEXTFILE will open a textfile, prompting at lines STARTLINE to STARTLINE+3 --except for the error message, which is always at the bottom of the screen. It returns the filename and the opened file. ".TEXT" is added to any filename that needs it. It returns false if the user quit.} FUNCTION OpenTextFile {(Prompt: string; VAR FileName: FNameString; Action: FileAction; Startline: integer; VAR F: text) : boolean}; VAR gotfn: boolean; Typed: string [255]; BEGIN REPEAT GoAndClearLine (StartLine); GoAndClearLine (StartLine+1); GoAndClearLine (StartLine+2); GoAndClearLine (StartLine+3); Gotoxy (5,StartLine); Write (Prompt); Gotoxy (15,StartLine+1); Write ('--> '); Gotoxy (8,StartLine+2); Write (' (Or just press the key if you wish to quit.)'); Typed := ''; Gotoxy (20, StartLine+1); GetString (23, Typed); IF (typed = ' ') OR (typed = '') THEN BEGIN GoAndClearLine (StartLine+3); Gotoxy (11,StartLine+3); IF Yes ('Would you prefer to skip this file') THEN BEGIN OpenTextFile := false; EXIT (OpenTextFile); END; GoAndClearLine (StartLine+3); END ELSE BEGIN FileName := Typed; AllCaps (FileName); (*$I-*) IF Action = getold THEN BEGIN Reset (F, typed); IF IORESULT > 0 THEN Reset (F, CONCAT (typed, '.TEXT')) END ELSE BEGIN IF (POS ('.TEXT', typed) = 0) THEN typed := CONCAT (typed, '.TEXT'); Rewrite (F, typed); END; (*$I+*) Gotfn := IORESULT = 0; IF NOT Gotfn THEN CASE IORESULT OF 1, 4: WriteErr ('Please check your disk--hardware problem'); 2: WriteErr ('Unit number is incorrect'); 5, 9: WriteErr ('Unit or Volume is off line at present'); 6, 10: WriteErr ('Can''t find this file on this disk'); 7: WriteErr ('Illegal file name...probably too long'); 8: WriteErr ('No room on this disk for this file'); END; END(*else*) UNTIL Gotfn; OpenTextFile := true END; {GETBOOLEAN is a routine to read in a boolean variable; gotoxy is optional as before. If you don't want GOTOXY, consider also 'YES' from SCREENCONTROL.} PROCEDURE GetBoolean {(x, y: integer; VAR DesiredValue: boolean)}; VAR ch: char; DontGotoxy: boolean; BEGIN DontGotoxy := (x<0) OR (y<0); Escapech := CHR (esc); IF NOT DontGotoxy THEN BEGIN GoAndClearLine (22); Write (' Type "Y" for yes, or "N" for no.'); Gotoxy (x,y); END; REPEAT Read (keyboard, ch) UNTIL (ch IN ['Y', 'y', 'T', 't', 'N', 'n', 'F', 'f', EscapeCh]); CASE ch OF 'Y', 'y', 'T', 't': BEGIN Write ('YES'); DesiredValue := true END; 'N', 'n', 'F', 'f': BEGIN Write (' no'); DesiredValue := false END END; IF NOT DontGotoxy THEN GoAndClearLine (22) END; END. ======================================================================================== DOCUMENT :usus Folder:VOL16:getnumber.text ======================================================================================== UNIT GetNumber; {Special procedures for controlled CRT input of integers in three flavors. COPYRIGHT (c) 1980, James Gagne, President DATAMED RESEARCH 1433 Roscomare Road Los Angeles, CA 90024 213/472-8825 ALL RIGHTS RESERVED. These routines may be used for nonprofit, non- commercial purposes only, unless written consent of the author is obtained.} INTERFACE uses (*$U crtinput.code *) crtinput; CONST {The first 4 are standard ASCII control characters.} bell = 7; backspace = 8; escape = 27; delete = 127; ErrorLine = 23 {Standard line on the CRT for error messages}; PROCEDURE GetInteger (x, y, {desired x/y displacements for START of integer} {If either x or y is < 0, no X-Y movement done.} LowerLimit, UpperLimit: integer; {bounds of WantedNo values } {If LowerLimit > UpperLimit, then LowerLimit is} { taken as the WIDTH of the field, and limits are} { calculated by width alone within the procedure.} RJustify: boolean; {do you want it justified R or L?} VAR WantedNo: integer); {the number returned: unchanged if} { typed during entry. } PROCEDURE GetDecimal (x, y, {same as GetInteger} LowerLimit, UpperLimit, {same as GetInteger; work on WHOLE no. } MaxPlaces: integer; {boundary for decimal = max # of places} VAR WholePart, FractnPart: integer); {returned values; the fractional value is NORMALIZED to the no. of places, i.e., it = number of 1/(10 EXP MaxPlaces)} IMPLEMENTATION PROCEDURE QuietRead (VAR ch: char); {this is implemented separately in case you wish to modify it.} BEGIN Read (keyboard, ch) END; FUNCTION LengthOf (int: integer): integer; VAR i, j:integer; BEGIN j := int; IF j < 0 THEN BEGIN i := 1 (*leave room for "-" sign*); j := -j END ELSE i := 0; REPEAT i := i + 1; j := j DIV 10; UNTIL j = 0; LengthOf := i END; FUNCTION FigureWidth (x, y: integer): integer; {returns the number of characters of whichever integer is larger} VAR i, j: integer; BEGIN i := LengthOf (x); j := LengthOf (y); IF j > i THEN FigureWidth := j ELSE FigureWidth := i; END; PROCEDURE BackUp (distance: integer); VAR i: integer; bs: char; BEGIN bs := CHR (backspace); FOR i := 1 TO distance DO Write (bs, ' ', bs) END; PROCEDURE GetSpace (XYEnabled: boolean); {for getting attention and then cleaning up the error message} VAR ch: char; BEGIN Write (CHR (Bell), '. Type to continue...'); REPEAT Read (ch) UNTIL ch = ' '; IF XYEnabled THEN GoAndClearLine (errorline) ELSE Writeln; END; FUNCTION IntInProgress (VAR LastCh: char; VAR wanted: integer): boolean; {This function reads a character quietly, accepting only appropriate ones, updates LASTCH (last char typed) and the integer WANTED appropriately, and returns an approximate boolean value of whether we're done. Used by all input routines.} VAR ch: char; ValidChar: boolean; BEGIN ValidChar := false; REPEAT QuietRead (ch) UNTIL (ch IN ['0'..'9', ' ', '+', '-', '.', CHR (delete), CHR (backspace), CHR (escape)]); IF (ch IN ['0'..'9']) AND (ABS (wanted) < MAXINT DIV 10) THEN BEGIN IF wanted >= 0 THEN Wanted := wanted * 10 + ORD (ch) - ORD ('0') ELSE Wanted := wanted * 10 - ORD (ch) + ORD ('0'); ValidChar := true; END ELSE IF ch = CHR (backspace) THEN BEGIN IF Wanted < 0 THEN Wanted := -( (-wanted) DIV 10) ELSE Wanted := wanted DIV 10; ValidChar := true END ELSE IF ch = CHR (delete) THEN BEGIN Wanted := 0; ValidChar := true END ELSE IF ch = '+' THEN BEGIN IF wanted < 0 THEN wanted := - wanted; ValidChar := true END ELSE IF ch = '-' THEN BEGIN IF wanted > 0 THEN wanted := - wanted; ValidChar := true END; LastCh := ch; IntInProgress := ValidChar END; PROCEDURE WriteRFlushInteger (int, width: integer; LastChWasMinus: boolean); VAR i:integer; BEGIN FOR i := LengthOf (int) TO width - 1 DO Write ('.'); IF int = 0 THEN IF LastChWasMinus THEN Write ('-') ELSE Write ('.') ELSE Write (int); END; PROCEDURE WriteLFlushInteger (int, width: integer; LastChWasMinus: boolean); VAR i, j, k: integer; BEGIN j := width - LengthOf (int); k := j; IF int = 0 THEN IF LastChWasMinus THEN Write ('-') ELSE BEGIN k := k + 1; Write ('.') END ELSE Write (int); FOR i := 1 TO j DO Write ('.'); FOR i := 1 TO k DO Write (CHR (backspace)); END; FUNCTION ValidInteger (LowerLimit, UpperLimit, width: integer; RJustify: boolean; VAR LastChTyped: char; VAR Wanted: integer): boolean; {Get an integer, justifying the number appropriately as you do so. Quit if escape or carriage return or period or space typed or the number is as large as it can get within the limits. Return a boolean variable attesting to the validity of the number.} VAR PrevLength: integer; Done, UnderTopLimit, NumberWasWritten, StillShort, WriteAMinus, NegativeOnly, PositiveOnly: boolean; BEGIN IF (Wanted < LowerLimit) OR (Wanted > UpperLimit) THEN Wanted := 0; NumberWasWritten := Wanted <> 0; PrevLength := LengthOf (Wanted); IF RJustify THEN WriteRFlushInteger (Wanted, width, false) ELSE WriteLFlushInteger (Wanted, width, false); Done := false; StillShort := true; UnderTopLimit := true; WriteAMinus := false; NegativeOnly := UpperLimit <= 0; PositiveOnly := LowerLimit >= 0; WHILE UnderTopLimit AND StillShort AND NOT Done DO IF IntInProgress (LastChTyped, Wanted) THEN BEGIN IF PositiveOnly AND (Wanted < 0) THEN Wanted := -Wanted; IF NegativeOnly AND (Wanted > 0) THEN Wanted := -Wanted; UnderTopLimit := Wanted <= UpperLimit; IF UnderTopLimit THEN BEGIN IF RJustify THEN BackUp (width) ELSE IF NumberWasWritten THEN Backup (PrevLength); WriteAMinus := (LastChTyped = '-') AND NOT PositiveOnly; IF RJustify THEN WriteRFlushInteger (Wanted, width, WriteAMinus) ELSE WriteLFlushInteger (Wanted, width, WriteAMinus); NumberWasWritten := (Wanted <> 0) OR WriteAMinus; PrevLength := LengthOf (Wanted); StillShort := (PrevLength < width) AND (UpperLimit >= Wanted * 10) END; END ELSE Done := true; ValidInteger := (LastChTyped IN [' ', '.', '0'..'9']) AND (Wanted >= LowerLimit) AND UnderTopLimit END; PROCEDURE GetInteger {(x, y, LowerLimit, UpperLimit: integer; RJustify: boolean; VAR WantedNo: integer)}; {Main procedure that is used; X & y refer to the START of the field. Field size is inferred from the maximum number of digits in the two limits. Plus or minus signs typed at any time invert the sign if appropriate. An escape typed any time before auto-termination (by a number approaching UpperLimit) will restore the original value of WantedNo. Nice number movement.} VAR TempInt, width, WorkingUpperLimit, WorkingLowerLimit, i, j: integer; XYEnabled, OK, Abort: boolean; Lastch: char; s: string; BEGIN IF LowerLimit > UpperLimit THEN BEGIN width := LowerLimit MOD 20 {just in case, reasonable limit on width}; i := 1; FOR j := 1 TO width DO i := i * 10; WorkingUpperLimit := i - 1; WorkingLowerLimit := (i DIV 10) -1; {room for "-" sign} END ELSE BEGIN WorkingUpperLimit := UpperLimit; WorkingLowerLimit := LowerLimit; width := FigureWidth (UpperLimit, LowerLimit) END; XYEnabled := (X>=0) AND (Y>=0); REPEAT IF XYEnabled THEN Gotoxy (x,y); OK := ValidInteger (WorkingLowerLimit, WorkingUpperLimit, width, RJustify, Lastch, TempInt); IF OK THEN WantedNo := TempInt ELSE IF Lastch = CHR (escape) THEN Abort := true ELSE IF TempInt > WorkingUpperLimit THEN BEGIN IF XYEnabled THEN Gotoxy (0, errorline) ELSE Writeln; Write ('Please type a number less than ', WorkingUpperLimit + 1); GetSpace (XYEnabled); TempInt := WorkingUpperLimit END ELSE IF TempInt < WorkingLowerLimit THEN BEGIN IF XYEnabled THEN Gotoxy (0, errorline) ELSE Writeln; Write ('Please type a number greater than ', WorkingLowerLimit - 1); GetSpace (XYEnabled); TempInt := WorkingLowerLimit END UNTIL OK OR Abort; IF RJustify THEN i := width ELSE i := LengthOf (TempInt); IF XYEnabled THEN Gotoxy (x,y) ELSE Backup (i); IF RJustify THEN Write (WantedNo: width) ELSE Write (WantedNo) END; PROCEDURE WriteAFraction (fractn, decplaces, maxplaces: integer; includedots: boolean); VAR i, j, LeadingZeros: integer; BEGIN i := LengthOf (fractn); IF fractn = 0 THEN i := 0; LeadingZeros := DecPlaces - i; FOR j := 1 TO LeadingZeros DO Write ('0'); IF fractn > 0 THEN Write (fractn); IF IncludeDots THEN BEGIN i := maxplaces - decplaces; FOR j := 1 TO i DO Write ('.'); FOR j := 1 TO i DO Write (CHR(backspace)); END; END; FUNCTION GetValidFraction (Wholepart, MaxPlaces: integer; VAR LastChTyped: char; VAR fractn: integer): boolean; {Workhorse decimal fraction-getter; difficult because leading zeros are much more significant than trailing ones, which I allowed anyway because people like to type them.} VAR dummy, DumpFractn: boolean; i, j, DecPlaces: integer; BEGIN IF fractn < 0 THEN fractn := - fractn; DecPlaces := MaxPlaces; IF fractn = 0 THEN DecPlaces := 0 ELSE WHILE (fractn MOD 10 = 0) DO BEGIN fractn := fractn DIV 10; DecPlaces := DecPlaces - 1 END; IF LengthOf (fractn) > MaxPlaces THEN BEGIN fractn := 0; DecPlaces := 0; END; WriteAFraction (fractn, DecPlaces, MaxPlaces, true); REPEAT dummy := IntInProgress (LastChTyped, fractn); IF fractn < 0 THEN fractn := -fractn; DumpFractn := (LastChTyped IN [CHR (delete), CHR (escape)]) OR ((LastChTyped = '+') AND (WholePart < 0)) OR ((LastChTyped = '-') AND (WholePart > 0)); Backup (DecPlaces); IF (LastChTyped = CHR (backspace)) AND (DecPlaces > 0) THEN DecPlaces := DecPlaces -1; IF (DecPlaces >= MaxPlaces) AND (fractn = 0) THEN DecPlaces := DecPlaces - 1; IF LengthOf (fractn) > MaxPlaces THEN fractn := fractn DIV 10; IF (LastChTyped IN ['0'..'9']) AND (DecPlaces < MaxPlaces) THEN DecPlaces := DecPlaces + 1; WriteAFraction (fractn, DecPlaces, MaxPlaces, true); UNTIL DumpFraction OR (LastChTyped = ' ') OR (DecPlaces >= MaxPlaces); FOR i := DecPlaces TO MaxPlaces - 1 DO fractn := fractn * 10; GetValidFraction := NOT DumpFraction; END; PROCEDURE GetDecimal {(x, y, LowerLimit, UpperLimit, MaxPlaces: integer; VAR WholePart, FractnPart: integer)}; { Main decimal-getting procedure; returns two INTEGERS representing the whole and the fractional parts. The later number is by the maximum number of decimal places allowed (MaxPlaces), so that if you allow 4 decimal places, FractnPart represents integral 1/10,000th's; 2 decimal places returns hundredths. This procedure is the least well debugged of the sequence. I'm going to have to live with the features I provided here to see if I like them: 1) You work on the two parts of the number separately. If you finish the whole number with a period, you can work on the fractional part. If you finish the integral portion with a carriage return or space, the routine exits and the fractional portion is unaltered. Typing an at any time before termination aborts the procedure and returns the original values. 2) During the actual number entry, if the the original values of the integral and fractional portions are within the range set by the user, they are presented for the user's perusal and optional change; otherwise, they are set to zero. 3) It was simply too complicated to allow for omitting x & y parameters; I couldn't keep track of where I was without a GOTOXY.} VAR OK, Abort: boolean; LastCh: char; TempWhole, TempFrac, width, i, j, WorkingLowerLimit, WorkingUpperLimit: integer; BEGIN IF LowerLimit > UpperLimit THEN BEGIN width := LowerLimit MOD 20 {just in case, reasonable limit on width}; i := 1; FOR j := 1 TO width DO i := i * 10; WorkingUpperLimit := i - 1; WorkingLowerLimit := (i DIV 10) -1; {room for "-" sign} END ELSE BEGIN WorkingUpperLimit := UpperLimit; WorkingLowerLimit := LowerLimit; width := FigureWidth (UpperLimit, LowerLimit) END; TempWhole := WholePart; TempFrac := FractnPart; Abort := false; REPEAT Gotoxy (x,y); OK := ValidInteger (WorkingLowerLimit, WorkingUpperLimit, width, true, Lastch, TempWhole); IF NOT OK THEN IF Lastch = CHR (escape) THEN Abort := true ELSE IF TempWhole > WorkingUpperLimit THEN BEGIN Gotoxy (0, ErrorLine); Write ('Please type a number less than ', WorkingUpperLimit + 1); GetSpace (true); TempWhole := WorkingUpperLimit END ELSE IF TempWhole < WorkingLowerLimit THEN BEGIN Gotoxy (0, ErrorLine); Write ('Please type a number greater than ', WorkingLowerLimit - 1); GetSpace (true); TempWhole := WorkingLowerLimit END ELSE Write ('whoops! Forgot About This Error!') ELSE IF Lastch IN ['.', '0'..'9'] THEN BEGIN Write ('.'); OK := GetValidFraction (TempWhole, MaxPlaces, Lastch, TempFrac); IF NOT OK THEN IF LastCh = CHR (escape) THEN Abort := true ELSE IF LastCh IN ['-', '+'] THEN TempWhole := - TempWhole ELSE IF LastCh = CHR (delete) THEN BEGIN TempWhole := 0; TempFrac := 0 END ELSE Write ('whoops! Unforeseen fraction error.') END UNTIL Abort OR OK; IF OK THEN BEGIN WholePart := TempWhole; FractnPart := TempFrac; END; Gotoxy (x,y); Write (WholePart: width, '.'); WriteAFraction (FractnPart, MaxPlaces, MaxPlaces, false) END; END. ======================================================================================== DOCUMENT :usus Folder:VOL16:horton.doc.text ======================================================================================== This is an explanation of those files submitted by Pat Horton. These are all text files of one sort or another. INV is the host file for the inventory system. ADD is the segment which adds to the inventory ISSUE does the distribution of inventory. BASPROC contains the base procedures. BASPROC2 contains Delete, Change, and Sort REPORT generates the reports in the system. INV.DOC is a formatted documentation for the inventory system. TELE is a program to maintain a data base of telephone calls, by whom, to whom, date, time, etc.... P is a quick word processor lacking in those features which generally make word processors hard to use. It is self teaching and very useful. SORTUNIT is a general purpose three key sort. It is a unit which must be linked into the system library before using. SORT2 is a sequential file sort program which allows for header information to not be sorted. XREF is the host text file for the Identifier Cross reference program. XRSEGS contains the segment procedures called by the program. This program is reproduced from the PASCAL SYSTEM USERS GROUP quarterly publication. LIFE is the game of life. I hope that the text for the above programs will come in handy at some point in space-time for someone. Pat Horton 6/8/80 6/20/82 ammended gws ======================================================================================== DOCUMENT :usus Folder:VOL16:inv.doc.text ======================================================================================== Documentation for the program INV Property of Associated Computer Industries with all rights pertaining thereto 17751 Sky Park East, Suite g-h Irvine, Ca. 92714 (714)-557-0560 Patrick Horton, Programmer (Page 1) Welcome to the ACI Inventory Program Users Manual. This program and manual assume some prior use of the operating system, especially the system editor. For further information on the use of the UCSD Pascal Screen Oriented Editor see the WD-90 Pascal Microengine (tm) Reference Manual. TABLE OF CONTENTS page ---------------------------------------------------------- cover ................................................. 1 intro & table of contents ............................. 2 files in the system ................................... 3 GFILE.TEXT ............................................ 4 Getting Started ....................................... 5 A)dd .................................................. 5 I)ssue ................................................ 6 D)elete ............................................... 6 C)hange ............................................... 6 Closing ............................................... 7 R)eports .............................................. 8 (Page 2) Files in the system ------------------- There are four files associated with the Inventory program. They are: the program itself, the inventory file, the transaction archive file, and the assembly group file. In addition to these files you may specify a file for output of any name (usually output is directed to a device however). The inventory file is made up of records which contain the part number, a description of the part, the quantity on hand, and the last date of access. The transaction file (archive) contains an entry for every transaction made to the inventory, including initial quantities. This allows for a complete balance of all transactions. A transaction record is made up of a part number, quantity, date, a transaction number, and a transaction code. The assembly group file contains information to link a single part number or designator to multiple inventory parts. With it you may specify a single part number (as a major assembly number) and individual items will be subtracted from the inventory as nessecary. In other words you might specify major part number A, and this assembly might use two part X's, one part Y, and six part Z's. In this way you can inventory out total assemblies rather than having to make an entry for each screw, washer, etc.... (Page 3) GFILE.TEXT ---------- The file for the groups is a sequential (text) file which you must build with the editor. It must reside on unit #4 and be called 'GFILE.TEXT'. Without such a file the program will not run, so even if you are not going to use this feature you must at least create a dummy file that meets these specifications. The format of this file is a line for each type of part in each major assembly. A line consists of three numbers seperated by spaces. Although they are called partnumbers they may be any combination of alpha-numerics that your system will recognize. The first number is the major assembly part number, the second is the part number that is part of this assembly, and the third number is the quantity of these parts used in this assembly. For example, given the line: A-102 f-100 3 we are told that major assembly number A-102 uses three f-100's. There may be any number of these lines in this file. (Page 4) Getting Started --------------- In order to get started you should first create (with the editor) a file called 'GFILE.TEXT' on unit #4 as described above. You should also have a new formatted and zeroed diskette in unit #5, and the program 'INV.CODE' on a diskette in unit #4. Type 'X' for execute, followed by the word 'INV' and a return . The program will search unit five for the two files: 'INV.DATA' and 'ARC.DATA'. If not found the program will allow you to create them by merely entering another carriage return. Once you have done this you may build your inventory using the A)dd command. A)dd ---- In order to add an item to inventory type 'A' for A)dd and then enter the part number of the item you wish to add. If the part number is not already in inventory you will be allowed to add it. Adding an item to inventory consists essentially of entering a description, the units of distribution, the initial quantity, the date, and a transaction code. This transaction code may be any (up to ten) characters you wish but you should be consistent. A good idea is to use the word 'initial' as the transaction codes for beginning entries. The reason for this is that later you may wish to produce reports by transaction code so it is of utmost importance that the codes be spelled the same (down to the capitilization of individual characters) in order to utilize this facility most effficiently. A)dd is also used when you receive goods to be added to inventory after the number is already in the system. In this case you may specify another transaction code such as 'reciept' or some such string. (Page 5) I)ssue ------ Once you have built an inventory you may distribute it using the I)ssue command. There are two ways to issue items: S)ingle, and G)roup. Issuing a single item amounts to entering a date, transaction code (such as 'sales' or 'returns'), a part number, and a quantity. Issuing a group is done by entering the group number. Then for each line in the GFILE for that group a screen display is made, showing the description and quantity to be used, the quantity in inventory before the transaction and the quantity in inventory after the transaction. When this happens you have three choices. You can enter a carriage return and the transaction will be completed. Or you can enter an escape and the transaction will be aborted (including all subsequent lines in the group). Or lastly, you may enter an 'S' for S)kip and skip that line and go on to the next item in the group. For each return entered above, an individual entry in the transaction file will be made. In this case the transaction code is given the group number. This is automatic and may not be changed by the user. Deleting -------- Sooner or later you are either going to make a mistake in using the system, or are going to stop using a specific item, and you are going to want to delete an item from the inventory. In order to do this you will type 'D' for delete. The program will ask you if you wish to delete from the inventory file, the transaction file, or both. You will enter the proper command followed by the part number you wish to delete and it will be removed from the system. Changing -------- In order to change a part number you must enter the command C)hange. Then you may specify if you wish to change the number in the inventory, the archive, or both. After entering the old number and the new number, the program will change the part number in the specified files. (Page 6) Closing ------- Every so often the archive file is going to become over-crowded. The procedure for taking care of this will be to copy the archive file onto another diskette and then R)emoving it using the filer. The program, when run will make a new version of this file and you may start entering new transactions. This process should be done on a monthly basis depending on individual requirements. (Page 7) Reports ------- There are basically three reports which you may create. They are (once again) inventory, archive, or both. To create a report, type 'R' for report, and then 'I','A', or 'B' as the case may be. The program will then ask you for the output device to which the report will go. You may specify '#6:' for a parallel printer, '#2:' for the screen, and '#8:' for the serial port printer. In addition to these you may enter a filename, if for some reason you wish to save the report. After designating the above parameters, you will be allowed to enter what are called wildcards. In the case of the I)nventory report you will enter only a part number wildcard. With the other reports you will enter part number, date, transaction number, and transaction code wildcards. The wildcards serve as selection criteria by which certain parts of the data are included in the report. If you enter blank carriage returns for all the wildcards then all the information in the file will be included in the report. The format for a wildcard is to specify the items you wish filled with question marks where you don't care. i.e. given the wildcard 'A-???' for part number the report would include all parts that started with 'A-' and that were five or less characters in length. The wildcard '?' for transaction code will pull out all transactions with a single character code. The wildcard '07??80' will pull out all of the transactions for July, 1980. In this way you can look at selected parts of the information without dumping the whole file. (note: It would probably be a good idea to do a B)oth report with no wildcards before closing the archive file out. This way you have a record of all transactions and quantities 'for the books'). (Page 8) ======================================================================================== DOCUMENT :usus Folder:VOL16:inv.text ======================================================================================== { Program: Inv an inventory maintanence program. Programmer: Patrick R. Horton Copyright: Copyright 1980 (c), Associated Computer Industries Permission to copy and distribute for non-profit purposes is hereby granted provided that this header is included on all copies Revised : 7/15/80 to add vendor partnumber } (* {$Q+} {$L-REMOTE:} *) PROGRAM Inventory; TYPE arcrec = RECORD partnum : STRING[16]; code : STRING[10]; date : STRING[6]; trans : STRING[6]; qty : REAL; END; invrec = RECORD partnum : STRING[16]; descrip : STRING[24]; vpart : STRING[16]; units : STRING[5]; ldate : STRING[6]; qty : REAL; END; xrerec = RECORD part1 : STRING[16]; part2 : STRING[16]; qty : REAL; link : ^xrerec; END; VAR invfile : FILE OF invrec; arcfile : FILE OF arcrec; xrefile : TEXT; first, ptr : ^xrerec; ntrans, narecs, nirecs, temp : INTEGER; command2,command : CHAR; PROCEDURE Uppercase(VAR s : STRING); FORWARD; PROCEDURE Clear; FORWARD; PROCEDURE Clrline(x,y : INTEGER); FORWARD; PROCEDURE Str(i : INTEGER; VAR s : STRING); FORWARD; PROCEDURE Rdata(x,y,l : INTEGER; VAR s : STRING); FORWARD; PROCEDURE Getint(x,y : INTEGER; VAR t1 : INTEGER); FORWARD; PROCEDURE Getreal(x,y : INTEGER; VAR r : REAL); FORWARD; PROCEDURE Wnirecs; FORWARD; PROCEDURE Wnarecs; FORWARD; FUNCTION Val(s : STRING):INTEGER; FORWARD; FUNCTION rVal(s : STRING):REAL; FORWARD; FUNCTION Chkdate(s : STRING): BOOLEAN; FORWARD; {$I ADD.TEXT} {$I ISSUE.TEXT} {$I REPORT.TEXT} {$I BASPROC.TEXT} {$I BASPROC2.TEXT} BEGIN Initfiles; Clear; REPEAT Clrline(0,0); WRITE( 'Inventory :: A)dd, C)hange, D)elete, I)ssue, R)eport, S)ort, Q)uit :: '); READ(command); CASE command OF 'A','a' : Add; 'C','c' : Change; 'D','d' : Delete; 'I','i' : Issue; 'R','r' : Report; 'S','s' : Sort; END; UNTIL command IN ['Q','q']; Closefiles; END. ======================================================================================== DOCUMENT :usus Folder:VOL16:invcs.mask.data ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL16:issue.text ======================================================================================== { Program: Inv an inventory maintanence program. Programmer: Patrick R. Horton Copyright: Copyright 1980 (c), Associated Computer Industries Permission to copy and distribute for non-profit purposes is hereby granted provided that this header is included on all copies } {ISSUE.TEXT} SEGMENT PROCEDURE Issue; VAR ch,ch1 : CHAR; found : INTEGER; date : STRING[6]; PROCEDURE Group; VAR iflg : BOOLEAN; BEGIN iflg := FALSE; Clear; WRITE('enter the group number ---->'); Rdata(28,0,16,arcfile^.code); REPEAT Clrline(0,1); WRITE('enter the date ------->'); READLN(date); UNTIL Chkdate(date); ptr := first; WHILE ptr<>NIL DO BEGIN IF ptr^.part1 = arcfile^.code THEN BEGIN found := 0; FOR temp := 1 TO nirecs DO BEGIN SEEK(invfile,temp); GET(invfile); IF invfile^.partnum = ptr^.part2 THEN BEGIN found := temp; temp := nirecs; END; END; IF found <> 0 THEN BEGIN WRITELN; WRITELN('--------------------------------------------------------'); WRITELN('using ',ptr^.qty:8:2,' ',invfile^.units,' ',invfile^.descrip); WRITELN('old qty =',invfile^.qty:8:2,' new qty =', invfile^.qty - ptr^.qty:8:2); IF (invfile^.qty - ptr^.qty) < 0 THEN WRITELN('CAUTION: you are going to exceed the inventory !!',CHR(7)); WRITE(' to continue, <''s''> to skip, to abort '); READ(ch); IF ch = CHR(27) THEN BEGIN Clear; EXIT(Group); END; IF NOT (ch IN ['S','s']) THEN BEGIN IF NOT iflg THEN BEGIN ntrans := ntrans + 1; iflg := TRUE; END; Str(ntrans,arcfile^.trans); arcfile^.date := date; arcfile^.qty := -ptr^.qty; invfile^.ldate := arcfile^.date; arcfile^.partnum := ptr^.part2; invfile^.qty := invfile^.qty - ptr^.qty; narecs := narecs + 1; SEEK(arcfile,narecs); PUT(arcfile); Wnarecs; SEEK(invfile,found); PUT(invfile); END; END; END; ptr := ptr^.link; END; END; BEGIN Clear; WRITE('Issue :: S)ingle, G)roup ::'); READ(ch); CASE ch OF 'S','s' : BEGIN Clear; WRITE('enter partnumber to be issued ---->'); Rdata(35,0,16,arcfile^.partnum); found := 0; FOR temp := 1 TO nirecs DO BEGIN SEEK(invfile,temp); GET(invfile); IF invfile^.partnum = arcfile^.partnum THEN BEGIN found := temp; temp := nirecs; END; END; IF found <> 0 THEN BEGIN WRITELN; WRITELN('there are currently ', invfile^.qty:8:2,' ', invfile^.units,' ', invfile^.descrip,' in the file'); WRITE('how many do you wish to issue --->'); Getreal(0,0,arcfile^.qty); IF arcfile^.qty > invfile^.qty THEN BEGIN WRITELN('Not enough parts to issue ',arcfile^.qty); FOR temp := 1 TO 15000 DO BEGIN END; EXIT(Issue); Clear; END; WRITE('enter the transaction code ---->'); Rdata(0,0,10,arcfile^.code); REPEAT WRITE('enter the date (MMDDYY) ---->'); READLN(arcfile^.date); UNTIL Chkdate(arcfile^.date); invfile^.ldate := arcfile^.date; WRITELN; WRITELN('old qty ',invfile^.qty:8:2,' new qty ', invfile^.qty-arcfile^.qty:8:2); WRITELN; WRITE('O.K.?'); READ(ch1); IF ch1 IN ['Y','y'] THEN BEGIN ntrans := ntrans + 1; Str(ntrans,arcfile^.trans); narecs := narecs + 1; arcfile^.qty := -arcfile^.qty; SEEK(arcfile,narecs); PUT(arcfile); Wnarecs; invfile^.qty := invfile^.qty + arcfile^.qty; SEEK(invfile,found); PUT(invfile); END; END; END; 'G','g' : Group; END; END; ======================================================================================== DOCUMENT :usus Folder:VOL16:p.inc.text ======================================================================================== PROCEDURE Makeformat; BEGIN REWRITE(format,'pformat'); WITH format^ DO BEGIN pmgin := 6; lmgin := 10; rmgin := 10; tmgin := 5; lsize := 80; psize := 66; ofilename := '#6:'; rflg := TRUE; pflg := TRUE; sflg := TRUE; mflg := TRUE; END; SEEK(format,0); PUT(format); CLOSE(format,lock); RESET(format,'pformat'); END; PROCEDURE Chkformat; VAR ch1,ch2,ch3,ch4 : CHAR; PROCEDURE Help1; BEGIN Clear; WRITELN('This is the program ''P'' (for P)rint).'); WRITELN; WRITELN('It is a program to print files and do simple text processing.'); WRITELN('When it is first X)ecuted it will automatically make a file '); WRITELN('called ''PFORMAT'' which will contain information about where'); WRITELN('and how the output should be processed.'); WRITELN; WRITELN('The program takes as input a text file. '); WRITELN; WRITELN('It processes that file for output. You may specify a filename'); WRITELN('for output (such as ''TEST.TEXT'') or you may specify a device'); WRITELN('(such as ''#6:''). The text processor does the task of right'); WRITELN('justification, which is filling a line with blanks so that the'); WRITELN('right margin is nice and even. Any time a blank line or a line '); WRITELN('starting with a blank is encountered it is assumed to start a'); WRITELN('new paragraph.'); WRITELN; WRITELN; WRITELN('for further information type ''^'' followed by a when'); WRITELN('you get the original screen prompt back.'); WRITELN; WRITE(' to continue >'); READLN; END; PROCEDURE Dispformat; BEGIN WITH format^ DO BEGIN Clear; WRITELN; WRITELN; WRITELN('P)aragraph indentation ---->',pmgin); WRITELN('L)eft margin ---->',lmgin); WRITELN('R)ight margin ---->',rmgin); WRITELN('T)op page1 margin ---->',tmgin); WRITELN('C)haracters per line ---->',lsize); WRITELN('N)umber of lines/page ---->',psize); WRITELN('O)utput filename ---->',ofilename); WRITELN; WRITELN; WRITE ('S1) right justify ---->'); IF rflg THEN WRITELN('Yes') ELSE WRITELN('No'); WRITE ('S2) pagination ---->'); IF pflg THEN WRITELN('Yes') ELSE WRITELN('No'); WRITE ('S3) stop between pages ---->'); IF sflg THEN WRITELN('Yes') ELSE WRITELN('No'); WRITE ('S4) use margins always ---->'); IF mflg THEN WRITELN('Yes') ELSE WRITELN('No'); WRITELN; GOTOXY(40,4); WRITELN('H)elp'); GOTOXY(40,5); WRITELN('Q)uit'); END; END; PROCEDURE Help3; VAR ch6 : CHAR; BEGIN GOTOXY(0,0); Clr; WRITE('Which switch ? '); READ(ch6); FOR temp1 := 16 TO 23 DO BEGIN GOTOXY(0,temp1); Clr; END; GOTOXY(0,16); CASE ch6 OF '1' : BEGIN WRITELN('This is the right justification switch.'); WRITELN('It turns the text processor completely on or off.'); WRITELN('When ON all text will be made into paragraphs'); WRITELN('unless specifically marked otherwise'); WRITE(' to continue'); READLN(keyboard); FOR temp1 := 16 TO 23 DO BEGIN GOTOXY(0,temp1); Clr; END; GOTOXY(0,16); WRITELN('The method for marking text which is to be'); WRITELN('right justified or not is to include a ''~'''); WRITELN('in the text. This character (tilde) acts as'); WRITELN('a switch to turn the right justification on'); WRITELN('and off from within the text'); WRITE(' to continue'); READLN(keyboard); FOR temp1 := 16 TO 23 DO BEGIN GOTOXY(0,temp1); Clr; END; GOTOXY(0,16); WRITELN('The switch must be on or the tilde will have no effect.'); WRITELN('The justification starts out on, and upon'); WRITELN('encountering a ''~'' it is turned off.'); WRITELN('every encounter of this character switches'); WRITELN('The right justification to its opposite state'); END; '2' : BEGIN WRITELN('This switch specifies whether or not to'); WRITELN('include page numbers at the end of the'); WRITELN('page.'); END; '3' : BEGIN WRITELN('This switch tells the program to stop after'); WRITELN('every page to allow you to change paper.'); END; '4' : BEGIN WRITELN('This switch allows you to include or not'); WRITELN('include the top and left margins on non-'); WRITELN('right justified text.'); END; END; END; PROCEDURE Help; VAR ch5 : CHAR; BEGIN GOTOXY(0,0); Clr; WRITE('Help with what? '); READ(ch5); FOR temp1 := 16 TO 23 DO BEGIN GOTOXY(0,temp1); Clr; END; GOTOXY(0,16); CASE ch5 OF 'P','p' : BEGIN WRITELN('This is the indentation at the beginning of a '); WRITELN('paragraph. This only comes into play when the '); WRITELN('right justification is set to yes.'); END; 'L','l' : BEGIN WRITELN('This is the left margin. It comes into play when'); WRITELN('either the right justification is set to yes or'); WRITELN('always use margins is set to yes.'); END; 'R','r' : BEGIN WRITELN('This is the right margin setting. It is only active'); WRITELN('When the right justification is set to yes.'); END; 'T','t' : BEGIN WRITELN('This is the top of the page margin. It is only active'); WRITELN('at the top of the FIRST page, and only when right'); WRITELN('justification is set to yes or always use margins'); WRITELN('is set to yes.'); END; 'C','c' : BEGIN WRITELN('This is the number of columns wide the paper is.'); WRITELN('If you are using 8 by 11 paper with ten characters'); WRITELN('per inch then the paper is 80 characters wide.'); END; 'N','n' : BEGIN WRITELN('This is the number of lines per page. If you are'); WRITELN('using 8 by 11 paper with 6 lines per inch then'); WRITELN('the number of lines per page is 66.'); END; 'O','o' : BEGIN WRITELN('This is the output filename. It may be a file'); WRITELN('such as ''TEST.TEXT'', or it may be a device. '); WRITELN('The common devices are: ''#2:'' is the screen,'); WRITELN('''#6:'' is the parallel port printer, and ''#8:'''); WRITELN('is the serial port printer.'); END; 'S','s' : Help3; END; END; ======================================================================================== DOCUMENT :usus Folder:VOL16:p.text ======================================================================================== PROGRAM P; VAR ifile,ofile : TEXT; temp,page,linat, temp1,temp2,nlwg : INTEGER; oline,iline, ifilename, lmarg,pmarg,token : STRING; newpar,epar : BOOLEAN; format : FILE OF RECORD tmgin,pmgin, lmgin,rmgin,lsize,psize : INTEGER; ofilename : STRING; mflg,rflg,pflg,sflg : BOOLEAN; END; PROCEDURE Clear; BEGIN gotoxy (0, 0 ); WRITE(CHR(27),CHR(69)); {H-19 specific} END; PROCEDURE Clr; BEGIN WRITE(CHR(27),chr(75)); {h-19 specific} END; (*$I p.inc.text*) PROCEDURE Chgformat; BEGIN RESET(format,'pformat'); SEEK(format,0); GET(format); Dispformat; REPEAT GOTOXY(0,0); Clr; WRITE('command ? '); READ(ch2); WITH format^ DO CASE ch2 OF 'H','h' : Help; 'P','p' : BEGIN GOTOXY(28,2); Clr; READLN(pmgin); END; 'L','l' : BEGIN GOTOXY(28,3); Clr; READLN(lmgin); END; 'R','r' : BEGIN GOTOXY(28,4); Clr; GOTOXY(40,4); WRITELN('H)elp'); GOTOXY(28,4); READLN(rmgin); END; 'T','t' : BEGIN GOTOXY(28,5); Clr; GOTOXY(40,5); WRITELN('Q)uit'); GOTOXY(28,5); READLN(tmgin); END; 'C','c' : BEGIN GOTOXY(28,6); Clr; READLN(lsize); END; 'N','n' : BEGIN GOTOXY(28,7); Clr; READLN(psize); END; 'O','o' : BEGIN GOTOXY(28,8); Clr; READLN(ofilename); END; 'S','s' : BEGIN GOTOXY(0,0); Clr; WRITE('which switch (1,2 or 3) --->'); READ(ch3); CASE ch3 OF '1' : BEGIN GOTOXY(28,11); Clr; READ(ch4); IF ch4 IN ['Y','y'] THEN BEGIN rflg := TRUE; GOTOXY(28,11); WRITELN('Yes'); END ELSE BEGIN rflg := FALSE; GOTOXY(28,11); WRITELN('No'); END; END; '2' : BEGIN GOTOXY(28,12); Clr; READ(ch4); IF ch4 IN ['Y','y'] THEN BEGIN pflg := TRUE; GOTOXY(28,12); WRITELN('Yes'); END ELSE BEGIN pflg := FALSE; GOTOXY(28,12); WRITELN('No'); END; END; '3' : BEGIN GOTOXY(28,13); Clr; READ(ch4); IF ch4 IN ['Y','y'] THEN BEGIN sflg := TRUE; GOTOXY(28,13); WRITELN('Yes'); END ELSE BEGIN sflg := FALSE; GOTOXY(28,13); WRITELN('No'); END; END; '4' : BEGIN GOTOXY(28,14); Clr; READ(ch4); IF ch4 IN ['Y','y'] THEN BEGIN mflg := TRUE; GOTOXY(28,14); WRITELN('Yes'); END ELSE BEGIN mflg := FALSE; GOTOXY(28,14); WRITELN('No'); END; END; END; END; END; UNTIL ch2 IN ['Q','q']; FOR temp1 := 16 TO 23 DO BEGIN GOTOXY(0,temp1); Clr; END; GOTOXY(0,18); WRITE('update ?'); READ(ch2); IF ch2 IN ['Y','y'] THEN BEGIN SEEK(format,0); PUT(format); END; CLOSE(format); END; BEGIN {$I-} RESET(format,'pformat'); {$I+} IF IORESULT <> 0 THEN Makeformat; CLOSE(format); REPEAT Clear; WRITELN('Welcome to the P)rint program.'); WRITELN; WRITELN; WRITELN('enter a ''H'' followed by a for Help,'); WRITELN('or enter a ''^'' followed by a to change the format,'); WRITELN('or enter a lone to exit the program,'); WRITELN('or enter the filename of a file to be printed followed by .'); WRITELN; WRITE('----->'); READLN(ifilename); IF LENGTH(ifilename)=0 THEN BEGIN Clear; EXIT(P); END; IF LENGTH(ifilename)=1 THEN IF ifilename[1] IN ['H','h'] THEN Help1; IF POS('^',ifilename)=1 THEN Chgformat; FOR temp1 := 1 TO LENGTH(ifilename) DO IF ifilename[temp1] IN ['a'..'z'] THEN ifilename[temp1] := CHR(ORD(ifilename[temp1])-32); IF POS('.TEXT',ifilename)=0 THEN ifilename := CONCAT(ifilename,'.TEXT'); {$I-} RESET(ifile,ifilename); {$I+} UNTIL IORESULT=0; END; PROCEDURE Chkline; VAR ch : CHAR; BEGIN IF format^.ofilename<>'#2:' THEN WRITE('.'); linat := linat + 1; IF format^.pflg AND (linat=format^.psize-3) THEN BEGIN linat := 0; page := page + 1; IF NOT (EOF(ifile) AND (page=1)) THEN BEGIN WRITELN(ofile); WRITE(ofile,' ':((format^.lsize DIV 2)-3)); WRITELN(ofile,'Page ',page:3); WRITELN(ofile); IF format^.sflg THEN BEGIN WRITELN; WRITE(' to continue, to quit >'); READ(keyboard,ch); WRITELN; IF ch = CHR(27) THEN BEGIN Clear; CLOSE(ofile,lock); EXIT(P); END; IF format^.ofilename <> '#2:' THEN WRITE('printing '); END; END ELSE FOR temp1 := 1 TO 3 DO WRITELN(ofile); END; END; PROCEDURE Straightout; BEGIN IF format^.ofilename<>'#2:' THEN BEGIN WRITELN; WRITE ('printing '); END; WHILE NOT(EOF(ifile)) DO BEGIN IF format^.mflg THEN WRITE(ofile,lmarg); READLN(ifile,oline); WRITELN(ofile,oline); Chkline; END; END; PROCEDURE Rjustify; FORWARD; PROCEDURE Outline; BEGIN (* WRITE('outline called w/ '); IF epar THEN WRITE('epar true,') ELSE WRITE('epar false,'); IF newpar THEN WRITELN(' newpar true') ELSE WRITELN(' newpar false'); *) IF NOT epar THEN Rjustify; WRITE(ofile,lmarg); IF newpar THEN WRITE(ofile,pmarg); WRITELN(ofile,oline); Chkline; IF newpar AND (LENGTH(oline)<>0) THEN newpar := FALSE; oline := token; token := ''; END; PROCEDURE Getnext; BEGIN REPEAT iline := ''; READLN(ifile,iline); IF (LENGTH(iline)=0) OR (POS(' ',iline)=1) OR (POS('~',iline)<>0) THEN BEGIN epar := TRUE; WHILE POS(' ',iline)=1 DO DELETE(iline,1,1); IF LENGTH(oline)<>0 THEN Outline; epar := FALSE; newpar := TRUE; IF LENGTH(iline)=0 THEN BEGIN WRITELN(ofile); Chkline; END; IF POS('~',iline)<>0 THEN BEGIN WHILE POS('~',iline)<>0 DO DELETE(iline,POS('~',iline),1); REPEAT IF format^.mflg THEN WRITE(ofile,lmarg); WRITELN(ofile,iline); Chkline; READLN(ifile,iline); UNTIL (EOF(ifile)) OR (POS('~',iline)<>0); WHILE POS('~',iline)<>0 DO DELETE(iline,POS('~',iline),1); WHILE POS(' ',iline)=1 DO DELETE(iline,1,1); IF LENGTH(iline)=0 THEN BEGIN WRITELN(ofile); Chkline; END; END; END; UNTIL (LENGTH(iline)<>0) OR (EOF(ifile)); END; PROCEDURE Getoken; BEGIN token := ''; REPEAT IF LENGTH(iline)=0 THEN Getnext; IF POS(' ',iline)<>0 THEN BEGIN token := COPY(iline,1,POS(' ',iline)-1); DELETE(iline,1,POS(' ',iline)); END ELSE BEGIN token := iline; iline := ''; END; UNTIL (LENGTH(token)<>0) OR (EOF(ifile)); END; FUNCTION Addable : BOOLEAN; VAR intb : BOOLEAN; temp3 : INTEGER; BEGIN intb := FALSE; temp3 := 0; temp3 := LENGTH(oline)+LENGTH(token)+1; IF newpar THEN temp3 := temp3 + format^.pmgin; WITH format^ DO IF temp3 <= (lsize-lmgin-rmgin) THEN intb := TRUE; Addable := intb; END; PROCEDURE Rjustify; VAR srt,srted,pspace,lwg : ARRAY[0..50] OF INTEGER; numtoadd : INTEGER; PROCEDURE Addtoall(i : INTEGER); VAR lstcharspace : BOOLEAN; BEGIN temp1 := 0; lstcharspace := FALSE; WHILE temp1 < LENGTH(oline) DO BEGIN temp1 := temp1 + 1; IF oline[temp1]<>' ' THEN IF lstcharspace THEN BEGIN FOR temp2 := 1 TO i DO INSERT(' ',oline,temp1); temp1 := temp1 + i; lstcharspace := FALSE; END ELSE ELSE lstcharspace := TRUE; END; END; PROCEDURE Addrems(i : INTEGER); VAR prevhi,temp3 : INTEGER; BEGIN FOR temp1 := 1 TO i DO BEGIN prevhi := 0; FOR temp2 := 1 TO i DO IF srted[temp2] > prevhi THEN BEGIN prevhi := srted[temp2]; temp3 := temp2; END; INSERT(' ',oline,pspace[srted[temp3]]+ (srted[temp3]-1)*(numtoadd DIV nlwg)); srted[temp3] := 0; END; END; PROCEDURE Sortlwg; VAR prevhi : INTEGER; BEGIN FOR temp1 := 1 TO nlwg DO srt[temp1] := lwg[temp1]; FOR temp1 := 1 TO nlwg DO BEGIN prevhi := 0; FOR temp2 := 1 TO nlwg DO IF srt[temp2]>prevhi THEN BEGIN prevhi := srt[temp2]; srted[temp1] := temp2; END; srt[srted[temp1]] := 0; END; END; BEGIN (* Rjustify *) temp1 := 0; nlwg := 0; WHILE temp1 < LENGTH(oline) DO BEGIN temp1 := temp1 + 1; IF oline[temp1]=' ' THEN BEGIN nlwg := nlwg + 1; pspace[nlwg] := temp1; END; END; pspace[0] := 0; pspace[nlwg+1] := LENGTH(oline)+1; FOR temp1 := 1 TO nlwg DO lwg[temp1] := pspace[temp1+1] - pspace[temp1-1] - 1; Sortlwg; WITH format^ DO numtoadd := lsize - lmgin - rmgin - LENGTH(oline); IF newpar THEN numtoadd := numtoadd - format^.pmgin; IF nlwg <> 0 THEN BEGIN IF numtoadd DIV nlwg >= 1 THEN Addtoall(numtoadd DIV nlwg); IF numtoadd MOD nlwg >= 1 THEN Addrems(numtoadd MOD nlwg); END; END; PROCEDURE Justout; BEGIN IF format^.ofilename<>'#2:' THEN BEGIN WRITELN; WRITE ('printing '); END; pmarg := ''; oline := ''; iline := ''; FOR temp1 := 1 TO format^.pmgin DO pmarg := CONCAT(pmarg,' '); epar := FALSE; newpar := TRUE; WHILE NOT EOF(ifile) DO BEGIN Getoken; IF Addable THEN BEGIN IF LENGTH(oline)<>0 THEN oline := CONCAT(oline,' ',token) ELSE oline := token; END ELSE Outline; END; END; BEGIN (* P *) REPEAT Clear; Chkformat; GOTOXY(0,20); Clr; WRITE('enter a carriage return when ready >'); READLN; IF format^.rflg OR format^.mflg THEN linat := format^.tmgin ELSE linat := 0; page := 0; REWRITE(ofile,format^.ofilename); lmarg := ''; FOR temp1 := 1 TO format^.lmgin DO lmarg := CONCAT(lmarg,' '); IF format^.rflg OR format^.mflg THEN FOR temp1 := 1 TO format^.tmgin DO WRITELN(ofile); IF NOT format^.rflg THEN Straightout ELSE Justout; IF format^.pflg AND (linat <> 0) THEN REPEAT WRITELN(ofile); Chkline; UNTIL linat = 0; CLOSE(ofile,lock); CLOSE(ifile); UNTIL FALSE; END. ======================================================================================== DOCUMENT :usus Folder:VOL16:report.text ======================================================================================== { Program: Inv an inventory maintanence program. Programmer: Patrick R. Horton Copyright: Copyright 1980 (c), Associated Computer Industries Permission to copy and distribute for non-profit purposes is hereby granted provided that this header is included on all copies } {REPORT.TEXT} SEGMENT PROCEDURE Report; VAR ch737,ch : CHAR; partwild : STRING[16]; codewild : STRING[10]; datewild : STRING[6]; tranwild : STRING[6]; ofile : TEXT; oname : STRING; linat : INTEGER; PROCEDURE Chkpage; VAR ch1 : CHAR; BEGIN IF (linat >=20) AND (oname = '#2:') THEN BEGIN WRITE(' to continue, to quit'); READ(KEYBOARD,ch1); WRITELN(CHR(11)); WRITE(CHR(27),'T',CHR(0),CHR(0),CHR(0),CHR(0)); IF ch1 = CHR(27) THEN BEGIN Clrline(0,0); EXIT(Report); END; linat := 0; END END; FUNCTION Min(a,b : INTEGER) : INTEGER; BEGIN IF a'?') AND (tranwild[temp]<>arcfile^.trans[temp]) THEN intb := FALSE; IF LENGTH(tranwild)>LENGTH(arcfile^.trans) THEN FOR temp := LENGTH(arcfile^.trans)+1 TO LENGTH(tranwild) DO IF tranwild[temp]<>'?' THEN intb := FALSE; IF LENGTH(tranwild)'?') AND (codewild[temp]<>arcfile^.code[temp]) THEN intb := FALSE; IF LENGTH(codewild)>LENGTH(arcfile^.code) THEN FOR temp := LENGTH(arcfile^.code)+1 TO LENGTH(codewild) DO IF codewild[temp]<>'?' THEN intb := FALSE; FOR temp := 1 TO Min(LENGTH(datewild),LENGTH(arcfile^.date)) DO IF (datewild[temp]<>'?') AND (datewild[temp]<>arcfile^.date[temp]) THEN intb := FALSE; IF LENGTH(datewild)>LENGTH(arcfile^.date) THEN FOR temp := LENGTH(arcfile^.date)+1 TO LENGTH(datewild) DO IF datewild[temp]<>'?' THEN intb := FALSE; IF (LENGTH(codewild)'?') AND (partwild[temp]<>invfile^.partnum[temp]) THEN intb := FALSE; IF LENGTH(partwild)>LENGTH(invfile^.partnum) THEN FOR temp := LENGTH(invfile^.partnum)+1 TO LENGTH(partwild) DO IF partwild[temp]<>'?' THEN intb := FALSE; IF LENGTH(partwild)'?') AND (partwild[temp]<>arcfile^.partnum[temp]) THEN intb := FALSE; IF LENGTH(partwild)>LENGTH(arcfile^.partnum) THEN FOR temp := LENGTH(arcfile^.partnum)+1 TO LENGTH(partwild) DO IF partwild[temp]<>'?' THEN intb := FALSE; IF LENGTH(partwild) to quit) --->'); Rdata(0,0,30,oname); ch737 := 'N'; IF oname = '#6:' THEN BEGIN WRITE('Do you have a centronics 737 printer? '); READ(ch737); END; IF LENGTH(oname)=0 THEN oname := '#2:'; IF LENGTH(oname)<>0 THEN IF oname[1]=CHR(27) THEN BEGIN Clear; EXIT(Report); END; {$I-} REWRITE(ofile,oname); IF IORESULT <> 0 THEN BEGIN CLOSE(ofile); Clear; EXIT(Report); END; {$I+} IF ch737 IN ['Y','y'] THEN WRITE(ofile,CHR(27),CHR(19)); WRITELN; WRITE('enter partnumber wildcard ( to quit) ---->'); Rdata(0,0,16,partwild); IF LENGTH(partwild)=0 THEN partwild := '????????????????'; IF LENGTH(partwild)<>0 THEN IF partwild[1]=CHR(27) THEN BEGIN CLOSE(ofile); Clear; EXIT(Report); END; WRITELN; IF ch IN ['A','a','B','b'] THEN BEGIN WRITE('enter code wildcard ( to quit) --->'); Rdata(0,0,10,codewild); IF LENGTH(codewild)=0 THEN codewild := '??????????'; IF LENGTH(codewild)<>0 THEN IF codewild[1]=CHR(27) THEN BEGIN CLOSE(ofile); Clear; EXIT(Report); END; WRITELN; WRITE('enter date wildcard ( to quit) --->'); Rdata(0,0,6,datewild); IF LENGTH(datewild)=0 THEN datewild := '??????'; IF LENGTH(datewild)<>0 THEN IF datewild[1]=CHR(27) THEN BEGIN CLOSE(ofile); Clear; EXIT(Report); END; WRITELN; WRITE('enter transaction wildcard ( to quit) --->'); Rdata(0,0,6,tranwild); IF LENGTH(tranwild)=0 THEN tranwild := '??????'; IF LENGTH(tranwild)<>0 THEN IF tranwild[1]=CHR(27) THEN BEGIN CLOSE(ofile); Clear; EXIT(Report); END; WRITELN; END; WRITELN; END; BEGIN Fpart; linat := 4; CASE ch OF 'I','i' : BEGIN WRITELN(ofile, 'INVENTORY REPORT'); WRITELN(ofile); WRITELN(ofile, 'Partnumber Description Vendor Part# Units Qty' ); WRITELN(ofile, '-------------------------------------------------------------------------' ); END; 'A','a' : BEGIN WRITELN(ofile, 'ARCHIVE REPORT'); WRITELN(ofile); WRITELN(ofile,'Transaction ','Partnumber':16,' ','Code':10,' ', 'Date':6,' ','Qty'); WRITELN(ofile,'-------------', '----------------------------------------------'); END; 'B','b' : BEGIN WRITELN(ofile, 'INVENTORY AND ARCHIVE REPORT'); WRITELN(ofile); WRITELN(ofile, 'Partnumber Description Vendor Part# Units Qty' ); WRITELN(ofile, '-------------------------------------------------------------------------' ); END; END; IF NOT (ch IN ['A','a']) THEN Invreport ELSE BEGIN FOR temp := 1 TO narecs DO BEGIN SEEK(arcfile,temp); GET(arcfile); IF Arcwildok AND Otherwildok THEN BEGIN WITH arcfile^ DO WRITELN(ofile,trans,' ':(13-LENGTH(trans)), partnum:16,' ',code:10,' ',date:6,' ',qty:8:2); linat := linat + 1; Chkpage; END; END; END; IF oname = '#2:' THEN BEGIN WRITE(' to continue'); READLN; END ELSE WRITE(ofile,CHR(12)); CLOSE(ofile,lock); END; ======================================================================================== DOCUMENT :usus Folder:VOL16:usus.inv.text ======================================================================================== {$S+} PROGRAM PRINTINVOICES; USES (*$U crtinput.code *) CRTInput, (*$U getnumber.code *) GetNumber; LABEL 1; CONST MaxX = 79; MaxY = 23; MaxData = 50; MaxArray = 20; PromptLine = 0; TYPE YLimits = 0..MaxY; XLimits = 0..MaxX; DataLimits = 1..MaxData; CRTLineArray = PACKED ARRAY [XLimits] OF char; DataRec = PACKED RECORD X: XLimits; Y: YLimits; Lngth, Decimal: XLimits; END; MaskRec = RECORD Line: ARRAY [YLimits] OF CRTLineArray; Data: ARRAY [DataLimits] OF DataRec; END; ArrayIndex = 1..MaxArray; SystemType = String [20]; FormatType = (None, Stndrd, UCSD, CPM, NorthStar, Apple); Volumes = (i, iia, iib, iii, iv, v, vi, vii, viii, ix, x); OrderedSet = SET OF Volumes; Money = RECORD Dollars: integer; Cents: -100..200 END; CustRecord = RECORD Name: String [40]; Addr1: String [40]; Addr2: String [40]; Addr3: String [40]; Addr4: String [40]; SalesTax, CanadaMex, Foreign: boolean; System: SystemType; Format: FormatType; Ordered: OrderedSet; PrevBal, ThisOrder, PaidNow, BalDue: Money; SpecialInstructns: string; END; VAR j, k, n: integer; running, quit: boolean; CustCount: ArrayIndex; Date: String[20]; ExtraFee, CreditNow: ARRAY [ArrayIndex] OF Money; Frmt: ARRAY [ArrayIndex] OF String [9]; Mask: MaskRec; Customer: ARRAY [ArrayIndex] OF CustRecord; List: text; PROCEDURE WritePrompt (prompt: string); BEGIN GoAndClearLine (PromptLine); Write (prompt) END; FUNCTION WaitForSp (p: string): boolean; VAR ch: char; BEGIN Write(CHR (7), p); Write ('. Type a space to continue, to abort...'); REPEAT Read (keyboard, ch) UNTIL (ch = ' ') OR (ch = CHR (27)); Writeln; WaitForSp := ch = ' ' END; PROCEDURE WriteError(prompt: string); VAR ch: char; BEGIN Gotoxy (0, 2); Write (CHR(7), prompt, ' Type to continue..'); REPEAT Read (keyboard, ch) UNTIL ch = ' '; GoAndClearLine (2); END; PROCEDURE GotoDataField (n: integer); BEGIN WITH Mask.Data[n] DO Gotoxy (x,y) END; PROCEDURE ClearField (n: integer); BEGIN WITH Mask.Data[n] DO BEGIN Gotoxy (X,Y); Write (' ':Lngth) END END; PROCEDURE ReadMaskData; VAR i: integer; DFileName: string[30]; DataFile: FILE OF MaskRec; BEGIN REPEAT DFileName := 'INVCS.MASK.DATA'; {$I-} Reset (DataFile, DFileName); IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#4:', DFileName)); IF IORESULT > 0 THEN Reset (Datafile, CONCAT ('#5:', DFileName)); {$I+} i := IORESULT; IF i > 0 THEN BEGIN Write ('Can''t find "INVCS.MASK.DATA", needed to work this program.'); IF NOT Yes ('Do you wish me to try to find it again?') THEN EXIT (Program) END; UNTIL i = 0; Mask := Datafile^; ClearScreen; Close (Datafile, lock); END; PROCEDURE GetDisk (n: integer); VAR ch: char; BEGIN WITH Customer[n] DO IF Format IN [Stndrd..NorthStar] THEN BEGIN CASE Format OF Stndrd: GotoDataField (9); UCSD: GotoDataField (11); CPM: GotoDataField (14); Apple: GotoDataField (16); NorthStar: GotoDataField (19) END; Write (' '); END; Gotoxy (13,10); ch := GetLetter (PromptLine, 'Please describe the disk format with the appropriate letter.', ['S', 'U', 'C', 'A', 'N']); WITH Customer[n] DO CASE ch OF 'S': BEGIN Format := Stndrd; GotoDataField (9); Frmt[n] := 'standard'; END; 'U': BEGIN Format := UCSD; GotoDataField (11); Frmt[n] := 'UCSD'; END; 'C': BEGIN Format := CPM; GotoDataField (14); Frmt[n] := 'CP/M'; END; 'A': BEGIN Format := Apple; GotoDataField (16); Frmt[n] := 'Apple'; END; 'N': BEGIN Format := NorthStar; GotoDataField (19); Frmt[n] := 'NorthStar'; END END (*case*); Write ('x'); GoAndClearLine (PromptLine); END (*GetDisk*); PROCEDURE DsplyOrders (n: integer); VAR m: Volumes; mark: ARRAY[Volumes] OF char; BEGIN WITH Customer[n] DO FOR m := i TO x DO BEGIN IF m IN Ordered THEN mark[m] := 'x' ELSE mark[m] := ' '; CASE m OF i: GotoDataField(10); iia: GotoDataField(12); iib: GotoDataField(13); iii: GotoDataField(15); iv: GotoDataField(17); v: GotoDataField(18); vi: GotoDataField(20); vii: GotoDataField(21); viii:GotoDataField(22); ix: GotoDataField(23); x: GotoDataField(24) END; Write (mark[m]) END END; PROCEDURE GetOrders (n: integer); VAR ch: char; Selected: Volumes; BEGIN WritePrompt ( 'Type the volume numbers ordered, 1 to 9 or "S". Type a when done.'); REPEAT REPEAT Read (keyboard, ch) UNTIL ch IN ['0'..'9','s','S',' ']; IF ch = 's' THEN ch := 'S'; IF ch IN ['1'..'9','S'] THEN WITH Customer[n] DO BEGIN CASE ch OF '1': Selected := i; '2': BEGIN GotoDataField (30); Write ('Volume 2 A or B?'); REPEAT READ (keyboard, ch) UNTIL (ch IN ['A', 'a', 'B', 'b']); IF (ch IN ['A', 'a']) THEN Selected := iia ELSE Selected := iib; ClearField (30); END; '3': BEGIN WriteError('Are you sure this isn''t discontinued?'); Selected := iii; END; '4': Selected := iv; '5': Selected := v; '6': Selected := vi; '7': Selected := vii; '8': Selected := viii; '9': Selected := ix; 'S': Selected := x END (*case*); IF Selected IN Ordered THEN Ordered := Ordered - [Selected] ELSE Ordered := Ordered + [Selected]; DsplyOrders (n); END UNTIL (ch = '0') OR eoln (keyboard); GoAndClearLine (PromptLine); END (*GetOrders*); PROCEDURE GetMoney (DN: datalimits; Prompt: string; VAR Amount: Money); BEGIN WritePrompt (Prompt); GetDecimal (Mask.Data[DN].x, Mask.Data[DN].Y, -100, 1000, 2, Amount.Dollars, Amount.Cents); GoAndClearLine (PromptLine); END (*GetMoney*); PROCEDURE WriteMoney (DN: datalimits; amount: money); VAR m: integer; BEGIN WITH Mask.Data[DN] DO BEGIN Gotoxy (X, Y); Write (ABS (Amount.dollars):(Lngth-3), '.'); m := ABS (Amount.Cents); IF m DIV 10 = 0 THEN Write ('0'); Write (m MOD 100); IF Amount.Dollars < 0 THEN Write (' *CREDIT*') ELSE Write (' '); END; END; PROCEDURE AddMoney (Add1, Add2: Money; VAR Sum: Money); BEGIN Sum.Dollars := Add1.Dollars + Add2.Dollars; Sum.Cents := Add1.Cents + Add2.Cents; IF Sum.Cents > 99 THEN BEGIN Sum.Cents := Sum.Cents -100; Sum.Dollars := Sum.Dollars + 1; END; END; PROCEDURE SubMoney (minuend, subtrahend: money; VAR result: money); BEGIN Result.Dollars := Minuend.Dollars - Subtrahend.Dollars; Result.Cents := Minuend.Cents - Subtrahend.Cents; WITH Result DO IF (Dollars > 0) AND (Cents < 0) THEN BEGIN Cents := Cents + 100; Dollars := Dollars - 1 END ELSE IF (Dollars < 0) AND (Cents > 0) THEN BEGIN Cents := Cents - 100; Dollars := Dollars + 1 END; END; PROCEDURE FigureInvoice (n: integer); VAR AmountPerVolume: 10..15; p, TaxCents, OrderPrice: integer; TotlCredit: money; Count: Volumes; BEGIN WITH Customer [n] DO BEGIN IF (Format = Apple) OR (Format = NorthStar) THEN AmountPerVolume := 15 ELSE AmountPerVolume := 10; OrderPrice := 0; FOR Count := i TO x DO IF Count IN Ordered THEN OrderPrice := OrderPrice + AmountPerVolume; IF SalesTax THEN BEGIN TaxCents := OrderPrice * 6; ExtraFee[n].Dollars := TaxCents DIV 100; ExtraFee[n].Cents := TaxCents MOD 100 END ELSE IF Foreign THEN BEGIN p := 0; FOR Count := i TO ix DO IF Count IN Ordered THEN p := p + 1; ExtraFee[n].Dollars := 3 + TRUNC ((p-1) * 1.5); IF ODD (p) THEN ExtraFee[n].Cents := 0 ELSE ExtraFee[n].Cents := 50; END ELSE BEGIN ExtraFee[n].Dollars := 0; ExtraFee[n].Cents := 0 END; ThisOrder.Dollars := OrderPrice + PrevBal.Dollars; ThisOrder.Cents := PrevBal.Cents; AddMoney (ThisOrder, ExtraFee[n], ThisOrder); AddMoney (PaidNow, CreditNow[n], TotlCredit); SubMoney (ThisOrder, TotlCredit, BalDue); WriteMoney (29, BalDue); END (*with*) END (*FigureInvoice*); PROCEDURE GetName (n: integer); VAR Ordinate: String[5]; BEGIN IF n > 3 THEN Ordinate := 'th' ELSE CASE n OF 1: Ordinate := 'st'; 2: Ordinate := 'nd'; 3: Ordinate := 'rd' END; GoAndClearLine (PromptLine); Writeln('What is the name/title?'); Write('(This is the ', n, Ordinate, ' customer.)'); GotoDataField (1); GetString (40, Customer[n].Name) END; PROCEDURE GetAddress (n: integer); BEGIN WITH Customer[n] DO BEGIN WritePrompt ('First line of address? '); GotoDataField (2); GetString (40, Addr1); WritePrompt ('Second line of address? '); GotoDataField (3); GetString (40, Addr2); IF (Addr2 = ' ') OR (Addr2 = '') THEN Addr3 := '' ELSE BEGIN WritePrompt ('Third line of address? '); GotoDataField (4); GetString (40, Addr3) END; IF (Addr3 = ' ') OR (Addr3 = '') THEN Addr4 := '' ELSE BEGIN WritePrompt ('Fourth line of address? '); GotoDataField (5); GetString (40, Addr4); END; GoAndClearLine (PromptLine); END END; FUNCTION MaskBoolean (DN: integer; prompt: string): boolean; VAR quick: boolean; BEGIN WritePrompt (prompt); WITH Mask.Data[DN] DO GetBoolean (X, Y, quick); MaskBoolean := quick; GoAndClearLine (PromptLine); END; PROCEDURE InitCustomer (n: integer); BEGIN WITH Customer[n] DO BEGIN Name := ''; Addr1 := ''; Addr2 := ''; Addr3 := ''; Addr4 := ''; System := ''; Format := None; Ordered := []; PrevBal.Dollars := 0; PrevBal.Cents := 0; PaidNow.Dollars := 0; PaidNow.Cents := 0; END; CreditNow[n].Dollars := 0; CreditNow[n].Cents := 0; END; PROCEDURE CheckInvoice (n: integer); CONST Always = false; VAR ch: char; BEGIN REPEAT WITH Customer[n] DO BEGIN ch := GetLetter (PromptLine, 'Now check customer data. Type letter of the field to correct; "Q" when done.', ['N', 'A', 'B', 'D', 'P', 'R', 'M', 'S', 'C', 'O', 'V', 'Q']); Case ch OF 'A': GetAddress (n); 'B': BEGIN GotoDataField (8); GetString (20, System); END; 'D': GetDisk (n); 'N': GetName (n); 'P': GetMoney (26, 'Now correct past due/credits; preceed credits by a "-" sign', PrevBal); 'R': GetMoney (27, 'Correct amount paid by customer.', PaidNow); 'M': GetMoney (28, 'Correct credits being applied TODAY', CreditNow[n]); 'S': BEGIN GotoDataField (25); GetString (56, SpecialInstructns) END; 'C': IF NOT Foreign THEN SalesTax := MaskBoolean (6, 'California sale?') ELSE BEGIN SalesTax := false; GoToDataField (6); Write (' no') END; 'O': IF NOT SalesTax THEN Foreign := MaskBoolean (7, 'Overseas sale?') ELSE BEGIN Foreign := false; GoToDataField (7); Write (' no') END; 'V': GetOrders (n); 'Q': Exit (CheckInvoice); END; FigureInvoice (n); END; UNTIL Always; END; PROCEDURE GetCustData; VAR m, n: integer; MoreToDo: boolean; ch: char; s: string; BEGIN (*GetCustData*) ClearScreen; FOR m := 0 TO MaxY-1 DO Writeln (Mask.Line[m]); n := 1; REPEAT WITH Customer[n] DO BEGIN InitCustomer(n); GetName (n); GetAddress (n); SalesTax := MaskBoolean (6, 'Charge sales tax?'); CanadaMex := false; IF SalesTax THEN Foreign := false ELSE Foreign := MaskBoolean (7, 'Foreign country?'); WritePrompt ('Describe system briefly (if known).'); GotoDataField (8); GetString (20, System); GetDisk (n); GetOrders (n); GetMoney (26, 'Any previous balance (or credit: make negative)?', PrevBal); GetMoney (27, 'Amount paid today?', PaidNow); GetMoney (28, 'Any special credits today?', CreditNow[n]); WritePrompt ('Type any special instructions now.'); SpecialInstructions := ''; GotoDataField (25); GetString (56, SpecialInstructions); END (*with*); FigureInvoice (n); CheckInvoice (n); GoAndClearLine (PromptLine); MoreToDo := Yes ('More orders to process'); CustCount := n; IF MoreToDo THEN BEGIN n := n+1; FOR m := 1 TO 25 DO ClearField (m) END; UNTIL (n >= MaxArray) OR NOT MoreToDo; END (*Procedure*); PROCEDURE DoPrintInvoice (n: integer); VAR IntAmount, LineCount, j, p: integer; FirstLine: boolean; ch: char; SubTotal, TaxAmount, Shipping: Money; Count: Volumes; PROCEDURE PrintVolLine; BEGIN WITH Customer[n] DO FOR Count := i TO x DO IF Count IN Ordered THEN BEGIN Write (List, ' 1 USUS/UCSD Users'' Library, Vol '); CASE Count OF i: Write (List, '1 '); iia: Write (List, '2A'); iib: Write (List, '2B'); iii: Write (List, '3 '); iv: Write (List, '4 '); v: Write (List, '5 '); vi: Write (List, '6 '); vii: Write (List, '7 '); viii: Write (List, '8 '); ix: Write (List, '9 '); x: Write(List,'WD') END (*case*); IF (Format IN [Apple, NorthStar]) THEN Write (List, ' 15 ') ELSE Write (List, ' 10 '); IF FirstLine THEN BEGIN FirstLine := false; Write (List, '$') END ELSE Write (List, ' '); IF (Format IN [Apple, NorthStar]) THEN Writeln (List, '15 00') ELSE Writeln (List, '10 00'); LineCount := LineCount + 1 END (*with*); END (*PrintVolLine*); PROCEDURE PrntHeadLine (s: String; amt: money); VAR x: integer; BEGIN Write (List, s:49, abs (amt.dollars):2); x := abs (amt.cents); IF x < 10 THEN Writeln (List, ' 0', x) ELSE Writeln (List, x:5) END; BEGIN (*DoPrintInvoices*) WITH Customer[n] DO BEGIN Writeln (List, ' ':41, Date); Writeln (List); Writeln (List, Name); Writeln (List, Addr1); Writeln (List, Addr2); Writeln (List, Addr3); Writeln (List, Addr4); FOR j := 1 to 4 DO Writeln (List); IF PrevBal.Dollars + PrevBal.Cents <> 0 THEN BEGIN IF PrevBal.Dollars * 100 + PrevBal.Cents > 0 THEN PrntHeadLine ('PREVIOUS BALANCE: $', PrevBal) ELSE PrntHeadLine ('PREVIOUS CREDIT DUE:$', PrevBal); LineCount := 2; Writeln (List); FirstLine := false END ELSE BEGIN LineCount := 0; FirstLine := true END; IF POS ('USUS', System) > 0 THEN BEGIN Writeln (list, ' -- ** -- This order through USUS -- ** --'); LineCount := LineCount + 1 END; Writeln (list, 'Disks were ordered in ', Frmt[n], ' format.'); Writeln (list); PrintVolLine; Writeln (List, '________':56); IF SalesTax OR Foreign THEN BEGIN SubMoney (ThisOrder, ExtraFee[n], SubTotal); PrntHeadLine ('SUBTOTAL $', SubTotal); Writeln (List); IF SalesTax THEN PrntHeadLine ('SALES TAX ', ExtraFee[n]) ELSE PrntHeadLine ('SHIPPING ', ExtraFee[n]); Writeln (List, '________':56); LineCount := LineCount + 4 END; PrntHeadLine ('TOTAL $', ThisOrder); Writeln (List); PrntHeadLine ('RECEIVED (check) ', PaidNow); IF CreditNow[n].Dollars + CreditNow[n].Cents > 0 THEN BEGIN PrntHeadLine ('OTHER CREDITS ', CreditNow[n]); LineCount := LineCount + 1 END; Writeln (List, '________':56); IF (BalDue.Dollars < 0) OR (BalDue.Cents < 0) THEN PrntHeadLine ('CREDIT $', BalDue) ELSE PrntHeadLine ('BALANCE DUE $', BalDue); Writeln (List); IF (SpecialInstructions = '') OR (SpecialInstructions = ' ') THEN Writeln (list) ELSE Writeln (list, ' -***- SPECIAL INSTRUCTIONS -***-'); Writeln (list, SpecialInstructions); FOR j := LineCount TO 28 DO Writeln (List) END (*for*) END; PROCEDURE PrintLabels; BEGIN IF WaitForSp('Ready to print labels') THEN FOR n := 1 TO CustCount DO WITH Customer [n] DO BEGIN Writeln (List, name); Writeln (List, Addr1); Writeln (List, Addr2); Writeln (List, Addr3); Writeln (List, Addr4); Writeln (List); IF NOT WaitForSp('Align labels again') THEN EXIT(PrintLabels) END END; PROCEDURE SaveRecords; VAR ch: char; Opened: boolean; CustStore: CustRecord; Savefile: FILE OF CustRecord; BEGIN Writeln; Writeln; IF NOT Yes ('Would you like to save the customer data on the disk') THEN EXIT (SaveRecords); Writeln ('Opening UCSDUSERS.DATA.....'); (*$I-*) Reset (Savefile, '#5:UCSDUSERS.DATA'); IF IORESULT = 0 THEN Opened := true ELSE BEGIN Reset (Savefile, 'UCSDUSERS.DATA'); Opened := (IORESULT = 0); END; (*$I+*) IF Opened THEN WHILE NOT eof (Savefile) DO Get (Savefile) ELSE Rewrite (Savefile, '#5:UCSDUSERS.DATA'); Writeln ('Writing new customer data.....'); FOR j := 1 TO CustCount DO BEGIN Savefile^ := Customer [j]; Put (Savefile) END; Close (Savefile, lock) END; BEGIN REPEAT Write ('Today''s date? '); Readln (Date) UNTIL Yes ('OK'); Rewrite (List, 'PRINTER:'); ReadMaskData; GetCustData; quit := false; REPEAT ClearScreen; running := true; CASE GetLetter (0, 'PRINT: I(nvoices or L(abels; "Q" = Q(uit printing (type "I", "L", or "Q"): ', ['I', 'L', 'Q']) OF 'I': FOR n := 1 TO CustCount DO IF running THEN BEGIN IF (n-1) MOD 5 = 0 THEN IF NOT WaitForSp('Align invoices in printer') THEN running := false; IF running THEN DoPrintInvoice (n); END; 'L': PrintLabels; 'Q': quit := true END UNTIL quit; SaveRecords END. ======================================================================================== DOCUMENT :usus Folder:VOL16:vol16.doc.text ======================================================================================== USUS Library Volume 16 A little something from almost everyone P.TEXT 24 A simple text formatter which is easy to use P.INC.TEXT 16 an include file for P INV.TEXT 8 An inventory management program from Pat Horton ISSUE.TEXT 10 an include file for INV BASPROC2.TEXT 12 ditto ADD.TEXT 8 ditto REPORT.TEXT 20 ditto BASPROC.TEXT 18 ditto INV.DOC.TEXT 34 documentation for INV Z80.SEEK.TEXT 8 A fast Z80 seek procedure. Should have been on Volume 8 CHECKBOOK.TEXT 26 Jim Gagne's checkbook balancer USUS.INV.TEXT 36 A USUS disk order entry program INVCS.MASK.DATA 5 a data file for USUS.INV 8.INCH.TEXT 8 Prints 8" disk labels APPLE.LABL.TEXT 6 Prints Apple disk labels CRTINPUT.TEXT 22 A unit used by Jim's programs GETNUMBER.TEXT 30 Another unit used by Jim's programs ASE.HEADER.TEXT 6 The declarations for the ASE Header Page BUNIT.TEXT 12 Mike Adams's B-tree unit BDEBUG.TEXT 6 an include file of BUNIT BHKEEP.TEXT 6 ditto BINTERN.TEXT 24 ditto BIO.TEXT 8 ditto BMAIN.TEXT 22 ditto BDRIVER.TEXT 12 A main program which uses and demos BUNIT BDOC1.TEXT 30 Excellent documentation for Mike Adams's B-tree BDOC2.TEXT 30 More documentation on the b-tree BDOC3.TEXT 16 Even more documenation VOL16.DOC.TEXT 12 You're reading it ----------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 16 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Some notes from the editor: P This is a simple, easy-to-use, and useful text formatter submitted by Pat Horton. It basically does what the UCSD editor does not, justify pre-filled paragraphs. It has a nice user interface and built in help functions. All funtions are controlled interactively, no imbedded commands are used. INV This is a fairly elaborate inventory system submitted by Pat Horton. It is easy to use and it works well. Z80.SEEK This routine was supposed to be on Volume 8, but it didn't make it into many of the masters. It needs the GLOBALS from volume 8 to compile. ----------------------------------------------------------- Jim Gagne's submission -- four utility programs and two units CHECKBOOK Checkbook will balance your checkbook for you and also act a little like a calculator. It uses CRTINPUT and GETNUMBER. USUS.INV This is the program Jim uses to process USUS orders. Nice menu. It uses CRTINPUT and GETNUMBER. 8.INCH This program will print a label for a USUS volume on standard 8" disk labels. Use it if you copy disks for another USUS member. It uses CRTINPUT. APPLE.LABL Same as above except for Apple labels. CRTINPUT This is a collection of utility procedures. A version of it is found on volume 5, but this one doesn't have any EXTERNAL procedures. GETNUMBER More utility routines, specifically to get numbers from the user. ASE.HEADER The RECORD declaration for the first "page" of an ASE TextFile. This is meant as an aid for folks writing RunOffs, Spellers, and Grammarians which might wish to use ASE files. BUNIT and BDRIVER This is Mike Adams's B-tree implementation. There is a general purpose b- tree unit and a demo program. The demo is pretty simple, it is intended to store only integers, probably to be used as keys to another file, but the unit itself is very general. Mike has supplied excellent documentation of what a b-tree is, what it does and why it works better than other ways to store data. He describes his own implementation and how to use it, and how you might modify it to make it work better for your own application. ======================================================================================== DOCUMENT :usus Folder:VOL16:z80.seek.text ======================================================================================== {Copyright 1980 by Stuart Lynne 1350 Clifton Ave. Coquitlam, British Columbia, Canada V3J 5K6 Permission granted to use for noncommercial purposes. All other rights reserved} { z80.seek } {$U-,S+} {$I globals } { * * Z80 Seek * * * This version of the UCSD Pascal Seek algorithm uses a seperate * assembler routine to calculate the block number and offset given * the record number and record size. * * } {$C Copyright (c) 1980, by Stuart Lynne. All rights reserved } (*----------------------------------------------------------*) Separate unit Z80_Seek; interface Procedure Fseek(var F: FIB; RECNUM: INTEGER); implementation Procedure Mul_Div (var Byte: integer; var Block: integer; Rec_Num, Rec_Size: integer); external; PROCEDURE FSEEK(*VAR F: FIB; RECNUM: INTEGER*); LABEL 1; VAR BYTE,BLOCK,N: INTEGER; BEGIN SYSCOM^.IORSLT := INOERROR; IF F.FISOPEN THEN WITH F,FHEADER DO BEGIN IF (RECNUM < 0) OR NOT FSOFTBUF OR ((DFKIND = TEXTFILE) AND (FRECSIZE = 1)) THEN GOTO 1; (*NO SEEK ALLOWED*) { * Block := RECNUM*FRECSIZE DIV FBLKSIZE + 1; * Byte := RECNUM*FRECSIZE MOD FBLKSIZE; } Mul_Div ( Byte, Block, Recnum, Frecsize); Block := Block + 1; IF BYTE = 0 THEN BEGIN BYTE := FBLKSIZE; BLOCK := BLOCK - 1; END; N := DLASTBLK-DFIRSTBLK; IF (BLOCK > N) OR ((BLOCK = N) AND (BYTE >= DLASTBYTE)) THEN BEGIN BLOCK := N; BYTE := DLASTBYTE END; IF BLOCK <> FNXTBLK THEN BEGIN IF FBUFCHNGD THEN BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE; UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1); IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END; IF (BLOCK <= FMAXBLK) AND (BYTE <> FBLKSIZE) THEN BEGIN UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+BLOCK-1); IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END END; IF FNXTBLK > FMAXBLK THEN BEGIN FMAXBLK := FNXTBLK; FMAXBYTE := FNXTBYTE END ELSE IF (FNXTBLK = FMAXBLK) AND (FNXTBYTE > FMAXBYTE) THEN FMAXBYTE := FNXTBYTE; FEOF := FALSE; FEOLN := FALSE; FREPTCNT := 0; IF FSTATE <> FJANDW THEN FSTATE := FNEEDCHAR; FNXTBLK := BLOCK; FNXTBYTE := BYTE END ELSE SYSCOM^.IORSLT := INOTOPEN; 1: END (*FSEEK*) ; END { PASCALIO } ; (*Dummy level 0 outerblock*) BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL17:booter.text ======================================================================================== PROGRAM BOOTSTRAPCOPIER; CONST BOOTSIZE = 1024; VAR BOOT: PACKED ARRAY[1..BOOTSIZE] OF CHAR; BEGIN IF EOLN THEN READLN; WRITE('Please insert the floppy with the source boot and type '); READLN; UNITREAD(4,BOOT,BOOTSIZE,0); IF IORESULT <> 0 THEN BEGIN WRITELN('Error encountered reading boot.'); EXIT(PROGRAM) END; WRITELN('Please insert the floppy onto which the boot is to be written and'); WRITE('type '); READLN; UNITWRITE(4,BOOT,BOOTSIZE,0); IF IORESULT <> 0 THEN BEGIN WRITELN('Error encountered writing boot.'); EXIT(PROGRAM) END; WRITELN('Bootstrap has been copied.'); END. ======================================================================================== DOCUMENT :usus Folder:VOL17:comp.a.text ======================================================================================== (*$U-*) PROGRAM PASCALSYSTEM; (************************************************) (* *) (* UCSD PASCAL COMPILER *) (* *) (* BASED ON ZURICH P2 PORTABLE *) (* COMPILER, EXTENSIVLY *) (* MODIFIED BY ROGER T. SUMNER *) (* 1976..1977 *) (* *) (* INSTITUTE FOR INFORMATION SYSTEMS *) (* UC SAN DIEGO, LA JOLLA, CA *) (* *) (* KENNETH L. BOWLES, DIRECTOR *) (* *) (* THIS SOFTWARE IS THE PROPERTY OF THE *) (* REGENTS OF THE UNIVERSITY OF CALIFORNIA. *) (* *) (************************************************) TYPE PHYLE = FILE; INFOREC = RECORD WORKSYM,WORKCODE: ^PHYLE; ERRSYM,ERRBLK,ERRNUM: INTEGER; STUPID: BOOLEAN END; PROGRAM PROCEDURE USERPROGRAM; BEGIN END (*USERPROGRAM*) ; PROGRAM PROCEDURE COMPILER(VAR USERINFO: INFOREC); CONST DISPLIMIT = 12; MAXLEVEL = 8; MAXADDR = 28000; INTSIZE = 1; REALSIZE = 2; BITSPERWD = 16; CHARSIZE = 1; BOOLSIZE = 1; PTRSIZE = 1; FILESIZE = 300; NILFILESIZE = 34; BITSPERCHR = 8; CHRSPERWD = 2; STRINGSIZE = 0; STRGLGTH = 255; MAXINT = 32767; DEFSTRGLGTH = 80; LCAFTERMARKSTACK = 1; EOL = 13; MAXCURSOR = 1023; MAXCODE = 1299; MAXJTAB = 24; MAXSEG = 15; MAXPROCNUM = 149; TYPE (*BASIC SYMBOLS*) SYMBOL = (IDENT,COMMA,COLON,SEMICOLON,LPARENT,RPARENT,DOSY,TOSY, DOWNTOSY,ENDSY,UNTILSY,OFSY,THENSY,ELSESY,BECOMES,LBRACK, RBRACK,ARROW,PERIOD,BEGINSY,IFSY,CASESY,REPEATSY,WHILESY, FORSY,WITHSY,GOTOSY,LABELSY,CONSTSY,TYPESY,VARSY,PROCSY, FUNCSY,PROGSY,FORWARDSY,INTCONST,REALCONST,STRINGCONST, NOTSY,MULOP,ADDOP,RELOP,SETSY,PACKEDSY,ARRAYSY,RECORDSY, FILESY,OTHERSY); OPERATOR = (MUL,RDIV,ANDOP,IDIV,IMOD,PLUS,MINUS,OROP,LTOP,LEOP, GEOP,GTOP,NEOP,EQOP,INOP,NOOP); SETOFSYS = SET OF SYMBOL; (*CONSTANTS*) CSTCLASS = (REEL,PSET,STRG,TRIX); CSP = ^ CONSTREC; CONSTREC = RECORD CASE CCLASS: CSTCLASS OF TRIX: (CSTVAL: ARRAY [1..8] OF INTEGER); REEL: (RVAL: REAL); PSET: (PVAL: SET OF 0..127); STRG: (SLGTH: 0..STRGLGTH; SVAL: PACKED ARRAY [1..STRGLGTH] OF CHAR) END; VALU = RECORD CASE BOOLEAN OF TRUE: (IVAL: INTEGER); FALSE: (VALP: CSP) END; (*DATA STRUCTURES*) BITRANGE = 0..BITSPERWD; OPRANGE = 0..80; CURSRANGE = 0..MAXCURSOR; PROCRANGE = 0..MAXPROCNUM; LEVRANGE = 0..MAXLEVEL; ADDRRANGE = 0..MAXADDR; JTABRANGE = 0..MAXJTAB; SEGRANGE = 0..MAXSEG; DISPRANGE = 0..DISPLIMIT; STRUCTFORM = (SCALAR,SUBRANGE,POINTER,POWER,ARRAYS, RECORDS,FILES,TAGFLD,VARIANT); DECLKIND = (STANDARD,DECLARED,SPECIAL); STP = ^ STRUCTURE; CTP = ^ IDENTIFIER; STRUCTURE = RECORD SIZE: ADDRRANGE; CASE FORM: STRUCTFORM OF SCALAR: (CASE SCALKIND: DECLKIND OF DECLARED: (FCONST: CTP)); SUBRANGE: (RANGETYPE: STP; MIN,MAX: VALU); POINTER: (ELTYPE: STP); POWER: (ELSET: STP); ARRAYS: (AELTYPE,INXTYPE: STP; CASE AISPACKD:BOOLEAN OF TRUE: (ELSPERWD,ELWIDTH: BITRANGE; CASE AISSTRNG: BOOLEAN OF TRUE:(MAXLENG: 1..STRGLGTH))); RECORDS: (FSTFLD: CTP; RECVAR: STP); FILES: (FILTYPE: STP); TAGFLD: (TAGFIELDP: CTP; FSTVAR: STP); VARIANT: (NXTVAR,SUBVAR: STP; VARVAL: VALU) END; (*NAMES*) IDCLASS = (TYPES,KONST,VARS,FIELD,PROC,FUNC); SETOFIDS = SET OF IDCLASS; IDKIND = (ACTUAL,FORMAL); ALPHA = PACKED ARRAY [1..8] OF CHAR; IDENTIFIER = RECORD NAME: ALPHA; LLINK, RLINK: CTP; IDTYPE: STP; NEXT: CTP; CASE KLASS: IDCLASS OF KONST: (VALUES: VALU); VARS: (VKIND: IDKIND; VLEV: LEVRANGE; VADDR: ADDRRANGE); FIELD: (FLDADDR: ADDRRANGE; CASE FISPACKD: BOOLEAN OF TRUE: (FLDRBIT,FLDWIDTH: BITRANGE)); PROC, FUNC: (CASE PFDECKIND: DECLKIND OF SPECIAL: (KEY: 1..23); STANDARD: (CSPNUM: 1..40); DECLARED: (PFLEV: LEVRANGE; PFNAME: PROCRANGE; PFSEG: SEGRANGE; CASE PFKIND: IDKIND OF ACTUAL: (LOCALLC: ADDRRANGE; FORWDECL, INSCOPE: BOOLEAN))) END; WHERE = (BLCK,CREC,VREC,REC); (*EXPRESSIONS*) ATTRKIND = (CST,VARBL,EXPR); VACCESS = (DRCT,INDRCT,PACKD,MULTI,BYTE); ATTR = RECORD TYPTR: STP; CASE KIND: ATTRKIND OF CST: (CVAL: VALU); VARBL: (CASE ACCESS: VACCESS OF DRCT: (VLEVEL: LEVRANGE; DPLMT: ADDRRANGE); INDRCT: (IDPLMT: ADDRRANGE)) END; TESTP = ^ TESTPOINTER; TESTPOINTER = RECORD ELT1,ELT2 : STP; LASTTESTP : TESTP END; (*LABELS*) LBP = ^ CODELABEL; CODELABEL = RECORD CASE DEFINED: BOOLEAN OF FALSE: (REFLIST: ADDRRANGE); TRUE: (OCCURIC: ADDRRANGE; JTABINX: JTABRANGE) END; LABELP = ^ USERLABEL; USERLABEL = RECORD LABVAL: INTEGER; NEXTLAB: LABELP; CODELBP: LBP END; CODEARRAY = PACKED ARRAY [0..MAXCODE] OF CHAR; SYMBUFARRAY = PACKED ARRAY [CURSRANGE] OF CHAR; (*--------------------------------------------------------------------*) VAR CODEP: ^ CODEARRAY; (*CODE BUFFER UNTIL WRITEOUT*) SYMBUFP: ^ SYMBUFARRAY; (*SYMBOLIC BUFFER...ASCII OR CODED*) GATTR: ATTR; (*DESCRIBES CURRENT EXPRESSION*) VAL: VALU; (*VALUE OF LAST CONSTANT*) DISX, (*LEVEL OF LAST ID SEARCHED*) TOP: DISPRANGE; (*TOP OF DISPLAY*) (*SCANNER GLOBALS...NEXT FOUR VARS*) (*MUST BE IN THIS ORDER FOR IDSEARCH*) SYMCURSOR: CURSRANGE; (*CURRENT SCANNING INDEX IN SYMBUFP^*) SY: SYMBOL; (*SYMBOL FOUND BY INSYMBOL*) OP: OPERATOR; (*CLASSIFICATION OF LAST SYMBOL*) ID: ALPHA; (*LAST IDENTIFIER FOUND*) LGTH: INTEGER; (*LENGTH OF LAST STRING CONSTANT*) LCMAX,LC,IC: ADDRRANGE; (*LOCATION AND INSTRUCT COUNTERS*) (*SWITCHES:*) PRTERR,GOTOOK,RANGECHECK,CODEINSEG,IOCHECK, LIST,TEST,SYSCOMP,DP,INCLUDING: BOOLEAN; (*POINTERS:*) INTPTR,REALPTR,CHARPTR,BOOLPTR, TEXTPTR,NILPTR,STRGPTR: STP; (*POINTERS TO STANDARD IDS*) UTYPPTR,UCSTPTR,UVARPTR, UFLDPTR,UPRCPTR,UFCTPTR, (*POINTERS TO UNDECLARED IDS*) INPUTPTR,OUTPUTPTR, OUTERBLOCK,FWPTR: CTP; GLOBTESTP: TESTP; (*LAST TESTPOINTER*) LEVEL: LEVRANGE; (*CURRENT STATIC LEVEL*) SEG,NEXTSEG: SEGRANGE; (*CURRENT SEGMENT #*) SEGINX: INTEGER; (*CURRENT INDEX IN SEGMENT*) SCONST: CSP; (*INSYMBOL STRING RESULTS*) LOWTIME,LINEINFO,SCREENDOTS,STARTDOTS,SYMBLK: INTEGER; LINESTART: CURSRANGE; CURPROC,NEXTPROC: PROCRANGE; (*PROCEDURE NUMBER ASSIGNMENT*) CONSTBEGSYS,SIMPTYPEBEGSYS,TYPEBEGSYS,BLOCKBEGSYS, SELECTSYS,FACBEGSYS,STATBEGSYS,TYPEDELS: SETOFSYS; DISPLAY: ARRAY [DISPRANGE] OF RECORD FNAME: CTP; CASE OCCUR: WHERE OF BLCK: (FFILE: CTP; FLABEL: LABELP); CREC: (CLEV: LEVRANGE; CDSPL: ADDRRANGE); VREC: (VDSPL: ADDRRANGE) END; PROCTABLE: ARRAY [PROCRANGE] OF INTEGER; SEGTABLE: ARRAY [SEGRANGE] OF RECORD DISKADDR,CODELENG: INTEGER; SEGNAME: ALPHA END (*SEGTABLE*) ; NEXTJTAB: JTABRANGE; JTAB: ARRAY [JTABRANGE] OF INTEGER; OLDSYMBLK: INTEGER; OLDSYMCURSOR: CURSRANGE; INCLFILE: FILE; CURBYTE, CURBLK: INTEGER; DISKBUF: PACKED ARRAY [0..511] OF CHAR; (*--------------------------------------------------------------------*) PROCEDURE INSYMBOL; FORWARD; PROCEDURE ERROR(ERRORNUM: INTEGER); FORWARD; PROCEDURE ENTERID(FCP: CTP); FORWARD; PROCEDURE GETNEXTPAGE; FORWARD; PROGRAM PROCEDURE COMPINIT; PROCEDURE ENTSTDTYPES; VAR SP: STP; BEGIN NEW(INTPTR,SCALAR,STANDARD); WITH INTPTR^ DO BEGIN SIZE := INTSIZE; FORM := SCALAR; SCALKIND := STANDARD END; NEW(REALPTR,SCALAR,STANDARD); WITH REALPTR^ DO BEGIN SIZE := REALSIZE; FORM := SCALAR; SCALKIND := STANDARD END; NEW(CHARPTR,SCALAR,STANDARD); WITH CHARPTR^ DO BEGIN SIZE := CHARSIZE; FORM := SCALAR; SCALKIND := STANDARD END; NEW(BOOLPTR,SCALAR,DECLARED); WITH BOOLPTR^ DO BEGIN SIZE := BOOLSIZE; FORM := SCALAR; SCALKIND := DECLARED END; NEW(NILPTR,POINTER); WITH NILPTR^ DO BEGIN SIZE := PTRSIZE; FORM := POINTER; ELTYPE := NIL END; NEW(TEXTPTR,FILES); WITH TEXTPTR^ DO BEGIN SIZE := FILESIZE+CHARSIZE; FORM := FILES; FILTYPE := CHARPTR END; NEW(STRGPTR,ARRAYS,TRUE,TRUE); WITH STRGPTR^ DO BEGIN FORM := ARRAYS; SIZE := (DEFSTRGLGTH + CHRSPERWD) DIV CHRSPERWD; AISPACKD := TRUE; AISSTRNG := TRUE; INXTYPE := INTPTR; ELWIDTH := BITSPERCHR; ELSPERWD := CHRSPERWD; AELTYPE := CHARPTR; MAXLENG := DEFSTRGLGTH; END END (*ENTSTDTYPES*) ; PROCEDURE ENTSTDNAMES; VAR CP,CP1: CTP; I: INTEGER; BEGIN NEW(CP,TYPES); WITH CP^ DO BEGIN NAME := 'INTEGER '; IDTYPE := INTPTR; KLASS := TYPES END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN NAME := 'REAL '; IDTYPE := REALPTR; KLASS := TYPES END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN NAME := 'CHAR '; IDTYPE := CHARPTR; KLASS := TYPES END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN NAME := 'BOOLEAN '; IDTYPE := BOOLPTR; KLASS := TYPES END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN NAME := 'STRING '; IDTYPE := STRGPTR; KLASS := TYPES END; ENTERID(CP); NEW(CP,TYPES); WITH CP^ DO BEGIN NAME := 'TEXT '; IDTYPE := TEXTPTR; KLASS := TYPES END; ENTERID(CP); NEW(INPUTPTR,VARS); WITH INPUTPTR^ DO BEGIN NAME := 'INPUT '; IDTYPE := TEXTPTR; KLASS := VARS; VKIND := FORMAL; VLEV := 0; VADDR := 2 END; ENTERID(INPUTPTR); NEW(OUTPUTPTR,VARS); WITH OUTPUTPTR^ DO BEGIN NAME := 'OUTPUT '; IDTYPE := TEXTPTR; KLASS := VARS; VKIND := FORMAL; VLEV := 0; VADDR := 3 END; ENTERID(OUTPUTPTR); NEW(CP,VARS); WITH CP^ DO BEGIN NAME := 'KEYBOARD'; IDTYPE := TEXTPTR; KLASS := VARS; VKIND := FORMAL; VLEV := 0; VADDR := 4 END; ENTERID(CP); CP1 := NIL; FOR I := 0 TO 1 DO BEGIN NEW(CP,KONST); WITH CP^ DO BEGIN IDTYPE := BOOLPTR; IF I = 0 THEN NAME := 'FALSE ' ELSE NAME := 'TRUE '; NEXT := CP1; VALUES.IVAL := I; KLASS := KONST END; ENTERID(CP); CP1 := CP END; BOOLPTR^.FCONST := CP; NEW(CP,KONST); WITH CP^ DO BEGIN NAME := 'NIL '; IDTYPE := NILPTR; NEXT := NIL; VALUES.IVAL := 0; KLASS := KONST END; ENTERID(CP); END (*ENTSTDNAMES*) ; PROCEDURE ENTUNDECL; BEGIN NEW(UTYPPTR,TYPES); WITH UTYPPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; KLASS := TYPES END; NEW(UCSTPTR,KONST); WITH UCSTPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; NEXT := NIL; VALUES.IVAL := 0; KLASS := KONST END; NEW(UVARPTR,VARS); WITH UVARPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; VKIND := ACTUAL; NEXT := NIL; VLEV := 0; VADDR := 0; KLASS := VARS END; NEW(UFLDPTR,FIELD); WITH UFLDPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; NEXT := NIL; FLDADDR := 0; KLASS := FIELD END; NEW(UPRCPTR,PROC,DECLARED,ACTUAL); WITH UPRCPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; FORWDECL := FALSE; NEXT := NIL; INSCOPE := FALSE; LOCALLC := 0; PFLEV := 0; PFNAME := 0; PFSEG := 0; KLASS := PROC; PFDECKIND := DECLARED; PFKIND := ACTUAL END; NEW(UFCTPTR,FUNC,DECLARED,ACTUAL); WITH UFCTPTR^ DO BEGIN NAME := ' '; IDTYPE := NIL; NEXT := NIL; FORWDECL := FALSE; INSCOPE := FALSE; LOCALLC := 0; PFLEV := 0; PFNAME := 0; PFSEG := 0; KLASS := FUNC; PFDECKIND := DECLARED; PFKIND := ACTUAL END END (*ENTUNDECL*) ; PROCEDURE ENTSPCPROCS; VAR LCP: CTP; I: INTEGER; ISFUNC: BOOLEAN; NA: ARRAY [1..42] OF ALPHA; BEGIN NA[ 1] := 'READ '; NA[ 2] := 'READLN '; NA[ 3] := 'WRITE '; NA[ 4] := 'WRITELN '; NA[ 5] := 'EOF '; NA[ 6] := 'EOLN '; NA[ 7] := 'PRED '; NA[ 8] := 'SUCC '; NA[ 9] := 'ORD '; NA[10] := 'SQR '; NA[11] := 'ABS '; NA[12] := 'NEW '; NA[13] := 'UNITREAD'; NA[14] := 'UNITWRIT'; NA[15] := 'CONCAT '; NA[16] := 'LENGTH '; NA[17] := 'INSERT '; NA[18] := 'DELETE '; NA[19] := 'COPY '; NA[20] := 'POS '; NA[21] := 'MOVELEFT'; NA[22] := 'MOVERIGH'; NA[23] := 'EXIT '; NA[24] := 'IDSEARCH'; NA[25] := 'TREESEAR'; NA[26] := 'TIME '; NA[27] := 'FILLCHAR'; NA[28] := 'OPENNEW '; NA[29] := 'OPENOLD '; NA[30] := 'OPENIO '; NA[31] := 'CLOSE '; NA[32] := 'SEEK '; NA[33] := 'RESET '; NA[34] := 'GET '; NA[35] := 'PUT '; NA[36] := 'SCAN '; NA[37] := 'BLOCKREA'; NA[38] := 'BLOCKWRI'; NA[39] := 'DRAWLINE'; NA[40] := 'PAGE '; NA[41] := 'SIZEOF '; NA[42] := 'DRAWBLOC'; FOR I := 1 TO 42 DO BEGIN ISFUNC := I IN [5,6,7,8,9,10,11,15,16,19,20,25,36,37,38,41]; IF ISFUNC THEN NEW(LCP,FUNC,SPECIAL) ELSE NEW(LCP,PROC,SPECIAL); WITH LCP^ DO BEGIN NAME := NA[I]; NEXT := NIL; IDTYPE := NIL; IF ISFUNC THEN KLASS := FUNC ELSE KLASS := PROC; PFDECKIND := SPECIAL; KEY := I END; ENTERID(LCP) END END (*ENTSPCPROCS*) ; PROCEDURE ENTSTDPROCS; VAR LCP,PARAM: CTP; LSP,FTYPE: STP; I: INTEGER; ISPROC: BOOLEAN; NA: ARRAY [1..19] OF ALPHA; BEGIN NA[ 1] := 'ODD '; NA[ 2] := 'CHR '; NA[ 3] := 'TRUNC '; NA[ 4] := 'ROUND '; NA[ 5] := 'SIN '; NA[ 6] := 'COS '; NA[ 7] := 'LOG '; NA[ 8] := 'ATAN '; NA[ 9] := 'LN '; NA[10] := 'EXP '; NA[11] := 'SQRT '; NA[12] := 'MARK '; NA[13] := 'RELEASE '; NA[14] := 'IORESULT'; NA[15] := 'UNITBUSY'; NA[16] := 'PWROFTEN'; NA[17] := 'UNITWAIT'; NA[18] := 'UNITCLEA'; NA[19] := 'HALT '; FOR I := 1 TO 19 DO BEGIN ISPROC := I IN [12,13,17,18,19]; CASE I OF 1: BEGIN FTYPE := BOOLPTR; NEW(PARAM,VARS); WITH PARAM^ DO BEGIN IDTYPE := INTPTR; VKIND := ACTUAL END; END; 2: FTYPE := CHARPTR; 3: BEGIN FTYPE := INTPTR; NEW(PARAM,VARS); WITH PARAM^ DO BEGIN IDTYPE := REALPTR; VKIND := ACTUAL END; END; 5: FTYPE := REALPTR; 12: BEGIN FTYPE := NIL; NEW(PARAM,VARS); NEW(LSP,POINTER); WITH LSP^ DO BEGIN SIZE := PTRSIZE; FORM := POINTER; ELTYPE := NIL END; WITH PARAM^ DO BEGIN IDTYPE := LSP; VKIND := FORMAL END; END; 14: BEGIN FTYPE := INTPTR; PARAM := NIL END; 15: BEGIN FTYPE := BOOLPTR; NEW(PARAM,VARS); WITH PARAM^ DO BEGIN IDTYPE := INTPTR; VKIND := ACTUAL END; END; 16: FTYPE := REALPTR; 17: FTYPE := NIL; 19: BEGIN FTYPE := NIL; PARAM := NIL END END (*PARAM AND TYPE CASES*) ; IF ISPROC THEN NEW(LCP,PROC,STANDARD) ELSE NEW(LCP,FUNC,STANDARD); WITH LCP^ DO BEGIN NAME := NA[I]; PFDECKIND := STANDARD; CSPNUM := I + 20; IF ISPROC THEN KLASS := PROC ELSE KLASS := FUNC; IF PARAM <> NIL THEN WITH PARAM^ DO BEGIN KLASS := VARS; NEXT := NIL END; IDTYPE := FTYPE; NEXT := PARAM END; ENTERID(LCP) END END (*ENTSTDPROCS*) ; PROCEDURE INITSCALARS; BEGIN FWPTR := NIL; GLOBTESTP := NIL; LINESTART := 0; LINEINFO := LCAFTERMARKSTACK; LIST := FALSE; SYMBLK := 2; SCREENDOTS := 0; STARTDOTS := 0; FOR SEG := 0 TO MAXSEG DO WITH SEGTABLE[SEG] DO BEGIN DISKADDR := 0; CODELENG := 0; SEGNAME := ' ' END; LC := LCAFTERMARKSTACK; IOCHECK := TRUE; DP := TRUE; SEGINX := 0; NEXTJTAB := 1; NEXTPROC := 2; CURPROC := 1; NEW(SCONST); NEW(SYMBUFP); NEW(CODEP); SEG := 1; NEXTSEG := 10; CURBLK := 1; CURBYTE := 0; GOTOOK := FALSE; RANGECHECK := TRUE; SYSCOMP := FALSE; CODEINSEG := FALSE; PRTERR := TRUE; INCLUDING := FALSE END (*INITSCALARS*) ; PROCEDURE INITSETS; BEGIN CONSTBEGSYS := [ADDOP,INTCONST,REALCONST,STRINGCONST,IDENT]; SIMPTYPEBEGSYS := [LPARENT] + CONSTBEGSYS; TYPEBEGSYS := [ARROW,PACKEDSY,ARRAYSY,RECORDSY,SETSY,FILESY] + SIMPTYPEBEGSYS; TYPEDELS := [ARRAYSY,RECORDSY,SETSY,FILESY]; BLOCKBEGSYS := [LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY,PROGSY,BEGINSY]; SELECTSYS := [ARROW,PERIOD,LBRACK]; FACBEGSYS := [INTCONST,REALCONST,STRINGCONST,IDENT,LPARENT,LBRACK,NOTSY]; STATBEGSYS := [BEGINSY,GOTOSY,IFSY,WHILESY,REPEATSY,FORSY,WITHSY,CASESY] END (*INITSETS*) ; BEGIN (*COMPINIT*) INITSCALARS; INITSETS; LEVEL := 0; TOP := 0; WITH DISPLAY[0] DO BEGIN FNAME := NIL; FFILE := NIL; FLABEL := NIL; OCCUR := BLCK END; ENTSTDTYPES; ENTSTDNAMES; ENTUNDECL; ENTSPCPROCS; ENTSTDPROCS; GETNEXTPAGE; UNITWRITE(3,PROCTABLE[-1200],35); FOR IC := 1 TO 7 DO WRITELN(OUTPUT); WRITELN(OUTPUT,'PASCAL compilation'); WRITE(OUTPUT,'< 0>'); INSYMBOL; IF SYSCOMP THEN BEGIN OUTERBLOCK := NIL; SEG := 0; NEXTSEG := 1 END ELSE BEGIN TOP := 1; LEVEL := 1; WITH DISPLAY[1] DO BEGIN FNAME := NIL; FFILE := NIL; FLABEL := NIL; OCCUR := BLCK END; LC := LC+2; (*KEEP STACK STRAIGHT FOR NOW*) NEW(OUTERBLOCK,PROC,DECLARED,ACTUAL); WITH OUTERBLOCK^ DO BEGIN NEXT := NIL; LOCALLC := LC; NAME := 'PROGRAM '; IDTYPE := NIL; KLASS := PROC; PFDECKIND := DECLARED; PFLEV := 0; PFNAME := 1; PFSEG := SEG; PFKIND := ACTUAL; FORWDECL := FALSE; INSCOPE := TRUE END END; IF SY = PROGSY THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN SEGTABLE[SEG].SEGNAME := ID; IF OUTERBLOCK <> NIL THEN OUTERBLOCK^.NAME := ID END ELSE ERROR(2); INSYMBOL; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14) END END (*COMPINIT*) ; ======================================================================================== DOCUMENT :usus Folder:VOL17:comp.b.text ======================================================================================== PROCEDURE ERROR(*ERRORNUM: INTEGER*); VAR CH: CHAR; BEGIN WITH USERINFO DO IF (ERRSYM <> SYMCURSOR) OR (ERRBLK <> SYMBLK) THEN BEGIN ERRSYM := SYMCURSOR; ERRBLK := SYMBLK; ERRNUM := ERRORNUM; IF STUPID THEN EXIT(COMPILER); WRITELN(OUTPUT); CH := ' '; WRITE(OUTPUT,SYMBUFP^:SYMCURSOR); WRITELN(OUTPUT,' <<<< Error # ',ERRORNUM:0); WRITE(OUTPUT,'Hit to continue'); REPEAT UNITREAD(2,CH,1); UNTIL (CH = ' ') OR (CH = CHR(27)); IF (ERRORNUM > 400) OR (CH = CHR(27)) THEN EXIT(COMPILER); WRITELN(OUTPUT); WRITE(OUTPUT,'<',SCREENDOTS:4,'>') END END (*ERROR*) ; PROCEDURE GETNEXTPAGE; BEGIN SYMCURSOR := 0; IF INCLUDING THEN IF BLOCKREAD(INCLFILE,SYMBUFP^,2,SYMBLK) = 0 THEN BEGIN CLOSE(INCLFILE); INCLUDING := FALSE; SYMBLK := OLDSYMBLK; SYMCURSOR := OLDSYMCURSOR; LINESTART := SYMCURSOR (*AT CR...WILL PRINT EXTRA LINE*) END; IF NOT INCLUDING THEN IF BLOCKREAD(USERINFO.WORKSYM^,SYMBUFP^,2,SYMBLK) <> 2 THEN ERROR(401); SYMBLK := SYMBLK+2 END (*GETNEXTPAGE*) ; PROCEDURE PRINTLINE; VAR LPUNIT: INTEGER; A: PACKED ARRAY [0..1] OF CHAR; PROCEDURE WRITEINT(IVAL: INTEGER); VAR I,IPOT: INTEGER; CH: CHAR; ZAP: BOOLEAN; A: PACKED ARRAY [0..5] OF CHAR; BEGIN ZAP := TRUE; IPOT := 10000; A[0] := ' '; FOR I := 1 TO 5 DO BEGIN CH := CHR(IVAL DIV IPOT + ORD('0')); IF I <> 5 THEN IF ZAP THEN IF CH = '0' THEN CH := ' ' ELSE ZAP := FALSE; A[I] := CH; IVAL := IVAL MOD IPOT; IPOT := IPOT DIV 10 END; UNITWRITE(LPUNIT,A,6) END (*WRITEINT*) ; BEGIN LPUNIT := 6; (*PRINTLINE*) WRITEINT(SCREENDOTS); WRITEINT(CURPROC); A[0] := ':'; IF DP THEN A[1] := 'D' ELSE A[1] := 'C'; UNITWRITE(LPUNIT,A,2); WRITEINT(LINEINFO); A := ' '; UNITWRITE(LPUNIT,A,2); UNITWRITE(LPUNIT,A,2); UNITWRITE(LPUNIT,SYMBUFP^[LINESTART],SYMCURSOR-LINESTART,,TRUE) END (*PRINTLINE*) ; PROCEDURE STARTINCL; (*I APOLOGIZE FOR SUCH KLOODGE AS THIS BUT IT HAS TO BE IN RIGHT NOW...*) VAR TSTART,TLENG: INTEGER; TITLE: STRING[40]; BEGIN TSTART := SYMCURSOR+2; SYMCURSOR := SCAN(80,=CHR(EOL),SYMBUFP^[TSTART])+TSTART+1; TLENG := SYMCURSOR-TSTART-3; TITLE[0] := CHR(TLENG); MOVELEFT(SYMBUFP^[TSTART],TITLE[1],TLENG); OPENOLD(INCLFILE,TITLE); IF IORESULT <> 0 THEN BEGIN OPENOLD(INCLFILE,CONCAT(TITLE,'.TEXT')); IF IORESULT <> 0 THEN ERROR(403) END; SCREENDOTS := SCREENDOTS+1; IF LIST THEN PRINTLINE; INCLUDING := TRUE; OLDSYMCURSOR := SYMCURSOR-1; (*POINT AT CR...PREVENT END PAGE BLOWUP*) OLDSYMBLK := SYMBLK-2; (*SYMBLK IS NEXT TO READ...SAVE CUR PAGE#*) SYMBLK := 2; GETNEXTPAGE; LINESTART := SYMCURSOR; INSYMBOL; EXIT(INSYMBOL) (*WEIRD, ISNT IT...*) END (*STARTINCL*) ; PROCEDURE INSYMBOL; (* COMPILER VERSION 3.4 06-NOV-76 *) LABEL 1; VAR LVP: CSP; X: INTEGER; PROCEDURE CHECKEND; BEGIN (* CHECKS FOR THE END OF THE PAGE *) WRITE(OUTPUT,'.'); SCREENDOTS := SCREENDOTS+1; SYMCURSOR := SYMCURSOR + 1; IF (SCREENDOTS-STARTDOTS) MOD 50 = 0 THEN BEGIN WRITELN(OUTPUT); WRITE(OUTPUT,'<',SCREENDOTS:4,'>') END; IF LIST THEN PRINTLINE; IF SYMBUFP^[SYMCURSOR]=CHR(0) THEN GETNEXTPAGE; LINESTART := SYMCURSOR; IF SYMBUFP^[SYMCURSOR] = CHR(16) (*DLE*) THEN SYMCURSOR := SYMCURSOR+2 ELSE BEGIN SYMCURSOR := SYMCURSOR+SCAN(80,<>CHR(9),SYMBUFP^[SYMCURSOR]); SYMCURSOR := SYMCURSOR+SCAN(80,<>' ',SYMBUFP^[SYMCURSOR]) END; IF DP THEN LINEINFO := LC ELSE LINEINFO := IC END; PROCEDURE COMMENTER; VAR CH,SW,DEL: CHAR; BEGIN SYMCURSOR := SYMCURSOR+2; (* POINT TO THE FIRST CH PAST "(*" *) IF SYMBUFP^[SYMCURSOR]='$' THEN BEGIN IF SYMBUFP^[SYMCURSOR+1] <> '*' THEN REPEAT CH := SYMBUFP^[SYMCURSOR+1]; SW := SYMBUFP^[SYMCURSOR+2]; DEL := SYMBUFP^[SYMCURSOR+3]; CASE CH OF 'G': GOTOOK := (SW='+'); 'I': IF (SW='+') OR (SW='-') THEN IOCHECK := (SW='+') ELSE STARTINCL; 'L': LIST := (SW='+'); 'R': RANGECHECK := (SW='+'); 'U': BEGIN SYSCOMP := (SW = '-'); RANGECHECK := NOT SYSCOMP; IOCHECK := RANGECHECK; GOTOOK := SYSCOMP END END (*CASES*); SYMCURSOR := SYMCURSOR+3; UNTIL DEL <> ','; END; SYMCURSOR := SYMCURSOR-1; (* ADJUST *) REPEAT REPEAT SYMCURSOR := SYMCURSOR+1; WHILE SYMBUFP^[SYMCURSOR] = CHR(EOL) DO CHECKEND UNTIL SYMBUFP^[SYMCURSOR]='*'; UNTIL SYMBUFP^[SYMCURSOR+1]=')'; SYMCURSOR := SYMCURSOR+2; END (*COMMENTER*); PROCEDURE STRING; VAR T: PACKED ARRAY [1..80] OF CHAR; TP,NBLANKS,L: INTEGER; DUPLE: BOOLEAN; BEGIN DUPLE := FALSE; (* INDICATES WHEN '' IS PRESENT *) TP := 0; (* INDEX INTO TEMPORARY STRING *) REPEAT IF DUPLE THEN SYMCURSOR := SYMCURSOR+1; REPEAT SYMCURSOR := SYMCURSOR+1; TP := TP+1; IF SYMBUFP^[SYMCURSOR] = CHR(EOL) THEN BEGIN ERROR(202); CHECKEND END; T[TP] := SYMBUFP^[SYMCURSOR]; UNTIL SYMBUFP^[SYMCURSOR]=''''; DUPLE := TRUE; UNTIL SYMBUFP^[SYMCURSOR+1]<>''''; TP := TP-1; (* ADJUST *) SY := STRINGCONST; OP := NOOP; LGTH := TP; (* GROSS *) IF TP=1 (* SINGLE CHARACTER CONSTANT *) THEN VAL.IVAL := ORD(T[1]) ELSE WITH SCONST@ DO BEGIN CCLASS := STRG; SLGTH := TP; MOVELEFT(T[1],SVAL[1],TP); VAL.VALP := SCONST END END(*STRING*); PROCEDURE NUMBER; VAR EXPONENT,ENDI,ENDF,ENDE,SIGN,IPART,FPART,EPART, ISUM: INTEGER; TIPE: (REALTIPE,INTEGERTIPE); RSUM: REAL; J: INTEGER; BEGIN (* TAKES A NUMBER AND DECIDES WHETHER IT'S REAL OR INTEGER AND CONVERTS IT TO THE INTERNAL FORM. *) TIPE := INTEGERTIPE; ENDI := 0; ENDF := 0; ENDE := 0; SIGN := 1; EPART := 9999; (* OUT OF REACH *) IPART := SYMCURSOR; (* INTEGER PART STARTS HERE *) REPEAT SYMCURSOR := SYMCURSOR+1 UNTIL (SYMBUFP^[SYMCURSOR]<'0') OR (SYMBUFP^[SYMCURSOR]>'9'); (* SYMCURSOR NOW POINTS AT FIRST CHARACTER PAST INTEGER PART *) ENDI := SYMCURSOR-1; (* MARK THE END OF IPART *) IF SYMBUFP^[SYMCURSOR]='.' THEN IF SYMBUFP^[SYMCURSOR+1]<>'.' (* WATCH OUT FOR '..' *) THEN BEGIN TIPE := REALTIPE; SYMCURSOR := SYMCURSOR+1; FPART := SYMCURSOR; (* BEGINNING OF FPART *) REPEAT SYMCURSOR := SYMCURSOR+1 UNTIL (SYMBUFP^[SYMCURSOR]<'0') OR (SYMBUFP^[SYMCURSOR]>'9'); ENDF := SYMCURSOR-1; END; IF SYMBUFP^[SYMCURSOR]='E' THEN BEGIN TIPE := REALTIPE; SYMCURSOR := SYMCURSOR+1; IF SYMBUFP^[SYMCURSOR]='-' THEN BEGIN SYMCURSOR := SYMCURSOR+1; SIGN := -1; END ELSE IF SYMBUFP^[SYMCURSOR]='+' THEN SYMCURSOR := SYMCURSOR+1; EPART := SYMCURSOR; (* BEGINNING OF EXPONENT *) WHILE (SYMBUFP^[SYMCURSOR]>='0') AND (SYMBUFP^[SYMCURSOR]<='9') DO SYMCURSOR := SYMCURSOR+1; ENDE := SYMCURSOR-1; IF ENDE3276) OR ((ISUM=3276) AND (SYMBUFP^[J]>'7')) THEN BEGIN ERROR(203); J := ENDI END ELSE ISUM := ISUM*10+ORD(SYMBUFP^[J])-ORD('0'); END; SY := INTCONST; OP := NOOP; VAL.IVAL := ISUM; END ELSE BEGIN (* REAL NUMBER HERE *) RSUM := 0; FOR J := IPART TO ENDI DO BEGIN RSUM := RSUM*10+(ORD(SYMBUFP^[J])-ORD('0')); END; FOR J := ENDF DOWNTO FPART DO RSUM := RSUM+(ORD(SYMBUFP^[J])-ORD('0'))/PWROFTEN(J-FPART+1); EXPONENT := 0; FOR J := EPART TO ENDE DO EXPONENT := EXPONENT*10+ORD(SYMBUFP^[J])-ORD('0'); IF SIGN=-1 THEN RSUM := RSUM/PWROFTEN(EXPONENT) ELSE RSUM := RSUM*PWROFTEN(EXPONENT); SY := REALCONST; OP := NOOP; NEW(LVP,REEL); LVP^.CCLASS := REEL; LVP^.RVAL := RSUM; VAL.VALP := LVP; END; SYMCURSOR := SYMCURSOR-1; (* ADJUST FOR POSTERITY *) END; BEGIN (* INSYMBOL *) OP := NOOP; 1: SY := OTHERSY; (* IF NO CASES EXERCISED BLOW UP *) CASE SYMBUFP^[SYMCURSOR] OF '''':STRING; '0','1','2','3','4','5','6','7','8','9': NUMBER; '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': IDSEARCH(SYMCURSOR,SYMBUFP^); (* MAGIC PROC *) '(': BEGIN IF SYMBUFP^[SYMCURSOR+1]='*' THEN BEGIN COMMENTER; GOTO 1; (* GET ANOTHER TOKEN *) END ELSE SY := LPARENT; END; ')': SY := RPARENT; ',': SY := COMMA; ' ',' ': BEGIN SYMCURSOR := SYMCURSOR+1; GOTO 1; END; '.': BEGIN IF SYMBUFP^[SYMCURSOR+1]='.' THEN BEGIN SYMCURSOR := SYMCURSOR+1; SY := COLON END ELSE SY := PERIOD; END; ':': IF SYMBUFP^[SYMCURSOR+1]='=' THEN BEGIN SYMCURSOR := SYMCURSOR+1; SY := BECOMES; END ELSE SY := COLON; ';': SY := SEMICOLON; '@','^': SY := ARROW; '[': SY := LBRACK; ']': SY := RBRACK; '*': BEGIN SY := MULOP; OP := MUL END; '+': BEGIN SY := ADDOP; OP := PLUS END; '-': BEGIN SY := ADDOP; OP := MINUS END; '/': BEGIN SY := MULOP; OP := RDIV END; '<': BEGIN SY := RELOP; OP := LTOP; CASE SYMBUFP^[SYMCURSOR+1] OF '>': BEGIN OP := NEOP; SYMCURSOR := SYMCURSOR+1 END; '=': BEGIN OP := LEOP; SYMCURSOR := SYMCURSOR+1 END END; END; '=': BEGIN SY := RELOP; OP := EQOP END; '>': BEGIN SY := RELOP; IF SYMBUFP^[SYMCURSOR+1]='=' THEN BEGIN OP := GEOP; SYMCURSOR := SYMCURSOR+1; END ELSE OP := GTOP; END END (* CASE SYMBUFP^[SYMCURSOR] OF *); IF SY=OTHERSY THEN IF SYMBUFP^[SYMCURSOR] = CHR(EOL) THEN BEGIN CHECKEND; GOTO 1 END ELSE ERROR(400); SYMCURSOR := SYMCURSOR+1; (* NEXT CALL TALKS ABOUT NEXT TOKEN *) END (*INSYMBOL*) ; PROCEDURE ENTERID(*FCP: CTP*); VAR LCP,LCP1: CTP; I: INTEGER; BEGIN LCP := DISPLAY[TOP].FNAME; IF LCP = NIL THEN DISPLAY[TOP].FNAME := FCP ELSE BEGIN I := TREESEARCH(LCP,LCP1,FCP^.NAME); WHILE I = 0 DO BEGIN ERROR(101); IF LCP1^.RLINK = NIL THEN I := 1 ELSE I := TREESEARCH(LCP1^.RLINK,LCP1,FCP^.NAME) END; IF I = 1 THEN LCP1^.RLINK := FCP ELSE LCP1^.LLINK := FCP END; FCP^.LLINK := NIL; FCP^.RLINK := NIL END (*ENTERID*) ; PROCEDURE SEARCHSECTION(FCP: CTP; VAR FCP1: CTP); BEGIN IF FCP <> NIL THEN IF TREESEARCH(FCP,FCP1,ID) = 0 THEN (*NADA*) ELSE FCP1 := NIL ELSE FCP1 := NIL END (*SEARCHSECTION*) ; PROCEDURE SEARCHID(FIDCLS: SETOFIDS; VAR FCP: CTP); LABEL 1; VAR LCP: CTP; BEGIN FOR DISX := TOP DOWNTO 0 DO BEGIN LCP := DISPLAY[DISX].FNAME; IF LCP <> NIL THEN IF TREESEARCH(LCP,LCP,ID) = 0 THEN IF LCP^.KLASS IN FIDCLS THEN GOTO 1 ELSE IF PRTERR THEN ERROR(103) ELSE LCP := NIL ELSE LCP := NIL END; IF PRTERR THEN BEGIN ERROR(104); IF TYPES IN FIDCLS THEN LCP := UTYPPTR ELSE IF VARS IN FIDCLS THEN LCP := UVARPTR ELSE IF FIELD IN FIDCLS THEN LCP := UFLDPTR ELSE IF KONST IN FIDCLS THEN LCP := UCSTPTR ELSE IF PROC IN FIDCLS THEN LCP := UPRCPTR ELSE LCP := UFCTPTR END; 1: FCP := LCP END (*SEARCHID*) ; PROCEDURE GETBOUNDS(FSP: STP; VAR FMIN,FMAX: INTEGER); BEGIN WITH FSP^ DO IF FORM = SUBRANGE THEN BEGIN FMIN := MIN.IVAL; FMAX := MAX.IVAL END ELSE BEGIN FMIN := 0; IF FSP = CHARPTR THEN FMAX := 255 ELSE IF FSP^.FCONST <> NIL THEN FMAX := FSP^.FCONST^.VALUES.IVAL ELSE FMAX := 0 END END (*GETBOUNDS*) ; PROCEDURE SKIP(FSYS: SETOFSYS); BEGIN WHILE NOT(SY IN FSYS) DO INSYMBOL END (*SKIP*) ; FUNCTION PAOFCHAR(FSP: STP): BOOLEAN; BEGIN PAOFCHAR := FALSE; IF FSP <> NIL THEN IF FSP^.FORM = ARRAYS THEN PAOFCHAR := FSP^.AISPACKD AND (FSP^.AELTYPE = CHARPTR) END (*PAOFCHAR*) ; FUNCTION STRGTYPE(FSP: STP) : BOOLEAN; BEGIN STRGTYPE := FALSE; IF PAOFCHAR(FSP) THEN STRGTYPE := FSP^.AISSTRNG END (*STRGTYPE*) ; PROCEDURE CONSTANT(FSYS: SETOFSYS; VAR FSP: STP; VAR FVALU: VALU); VAR LSP: STP; LCP: CTP; SIGN: (NONE,POS,NEG); LVP: CSP; BEGIN LSP := NIL; FVALU.IVAL := 0; IF NOT(SY IN CONSTBEGSYS) THEN BEGIN ERROR(50); SKIP(FSYS+CONSTBEGSYS) END; IF SY IN CONSTBEGSYS THEN BEGIN IF SY = STRINGCONSTSY THEN BEGIN IF LGTH = 1 THEN LSP := CHARPTR ELSE BEGIN NEW(LSP,ARRAYS,TRUE,TRUE); LSP^ := STRGPTR^; LSP^.MAXLENG := LGTH; LSP^.INXTYPE := NIL; NEW(LVP); LVP^ := VAL.VALP^; VAL.VALP := LVP END; FVALU := VAL; INSYMBOL END ELSE BEGIN SIGN := NONE; IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN BEGIN IF OP = PLUS THEN SIGN := POS ELSE SIGN := NEG; INSYMBOL END; IF SY = IDENT THEN BEGIN SEARCHID([KONST],LCP); WITH LCP^ DO BEGIN LSP := IDTYPE; FVALU := VALUES END; IF SIGN <> NONE THEN IF LSP = INTPTR THEN BEGIN IF SIGN = NEG THEN FVALU.IVAL := -FVALU.IVAL END ELSE IF LSP = REALPTR THEN BEGIN IF SIGN = NEG THEN BEGIN NEW(LVP,REEL); LVP^.CCLASS := REEL; LVP^.RVAL := -FVALU.VALP^.RVAL; FVALU.VALP := LVP; END END ELSE ERROR(105); INSYMBOL; END ELSE IF SY = INTCONST THEN BEGIN IF SIGN = NEG THEN VAL.IVAL := -VAL.IVAL; LSP := INTPTR; FVALU := VAL; INSYMBOL END ELSE IF SY = REALCONST THEN BEGIN IF SIGN = NEG THEN VAL.VALP^.RVAL := -VAL.VALP^.RVAL; LSP := REALPTR; FVALU := VAL; INSYMBOL END ELSE BEGIN ERROR(106); SKIP(FSYS) END END; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END; FSP := LSP END (*CONSTANT*) ; FUNCTION COMPTYPES(FSP1,FSP2: STP) : BOOLEAN; VAR NXT1,NXT2: CTP; COMP: BOOLEAN; LTESTP1,LTESTP2 : TESTP; BEGIN IF FSP1 = FSP2 THEN COMPTYPES := TRUE ELSE IF (FSP1 = NIL) OR (FSP2 = NIL) THEN COMPTYPES := TRUE ELSE IF FSP1^.FORM = FSP2^.FORM THEN CASE FSP1^.FORM OF SCALAR: COMPTYPES := FALSE; SUBRANGE: COMPTYPES := COMPTYPES(FSP1^.RANGETYPE, FSP2^.RANGETYPE); POINTER: BEGIN COMP := FALSE; LTESTP1 := GLOBTESTP; LTESTP2 := GLOBTESTP; WHILE LTESTP1 <> NIL DO WITH LTESTP1^ DO BEGIN IF (ELT1 = FSP1^.ELTYPE) AND (ELT2 = FSP2^.ELTYPE) THEN COMP := TRUE; LTESTP1 := LASTTESTP END; IF NOT COMP THEN BEGIN NEW(LTESTP1); WITH LTESTP1^ DO BEGIN ELT1 := FSP1^.ELTYPE; ELT2 := FSP2^.ELTYPE; LASTTESTP := GLOBTESTP END; GLOBTESTP := LTESTP1; COMP := COMPTYPES(FSP1^.ELTYPE,FSP2^.ELTYPE) END; COMPTYPES := COMP; GLOBTESTP := LTESTP2 END; POWER: COMPTYPES := COMPTYPES(FSP1^.ELSET,FSP2^.ELSET); ARRAYS: BEGIN COMP := COMPTYPES(FSP1^.AELTYPE,FSP2^.AELTYPE) AND (FSP1^.AISPACKD = FSP2^.AISPACKD); IF COMP AND FSP1^.AISPACKD THEN COMP := (FSP1^.ELSPERWD = FSP2^.ELSPERWD) AND (FSP1^.ELWIDTH = FSP2^.ELWIDTH) AND (FSP1^.AISSTRNG = FSP2^.AISSTRNG); IF COMP AND NOT STRGTYPE(FSP1) THEN COMP := (FSP1^.SIZE = FSP2^.SIZE); COMPTYPES := COMP; END; RECORDS: BEGIN NXT1 := FSP1^.FSTFLD; NXT2 := FSP2^.FSTFLD; COMP := TRUE; WHILE (NXT1 <> NIL) AND (NXT2 <> NIL) AND COMP DO BEGIN COMP:=COMPTYPES(NXT1^.IDTYPE,NXT2^.IDTYPE); NXT1 := NXT1^.NEXT; NXT2 := NXT2^.NEXT END; COMPTYPES := COMP AND (NXT1 = NIL) AND (NXT2 = NIL) AND (FSP1^.RECVAR = NIL) AND (FSP2^.RECVAR = NIL) END; FILES: COMPTYPES := COMPTYPES(FSP1^.FILTYPE,FSP2^.FILTYPE) END (*CASE*) ELSE (*FSP1^.FORM <> FSP2^.FORM*) IF FSP1^.FORM = SUBRANGE THEN COMPTYPES := COMPTYPES(FSP1^.RANGETYPE,FSP2) ELSE IF FSP2^.FORM = SUBRANGE THEN COMPTYPES := COMPTYPES(FSP1,FSP2^.RANGETYPE) ELSE COMPTYPES := FALSE END (*COMPTYPES*) ; ======================================================================================== DOCUMENT :usus Folder:VOL17:comp.c.text ======================================================================================== PROCEDURE TYP(FSYS: SETOFSYS; VAR FSP: STP; VAR FSIZE: ADDRRANGE); VAR LSP,LSP1,LSP2: STP; OLDTOP: DISPRANGE; LCP: CTP; LSIZE,DISPL: ADDRRANGE; LMIN,LMAX: INTEGER; PACKING: BOOLEAN; NEXTBIT,NUMBITS: BITRANGE; PROCEDURE SIMPLETYPE(FSYS:SETOFSYS; VAR FSP:STP; VAR FSIZE:ADDRRANGE); VAR LSP,LSP1: STP; LCP,LCP1: CTP; TTOP: DISPRANGE; LCNT: INTEGER; LVALU: VALU; BEGIN FSIZE := 1; IF NOT (SY IN SIMPTYPEBEGSYS) THEN BEGIN ERROR(1); SKIP(FSYS + SIMPTYPEBEGSYS) END; IF SY IN SIMPTYPEBEGSYS THEN BEGIN IF SY = LPARENT THEN BEGIN TTOP := TOP; WHILE DISPLAY[TOP].OCCUR <> BLCK DO TOP := TOP - 1; NEW(LSP,SCALAR,DECLARED); WITH LSP^ DO BEGIN SIZE := INTSIZE; FORM := SCALAR; SCALKIND := DECLARED END; LCP1 := NIL; LCNT := 0; REPEAT INSYMBOL; IF SY = IDENT THEN BEGIN NEW(LCP,KONST); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := LSP; NEXT := LCP1; VALUES.IVAL := LCNT; KLASS := KONST END; ENTERID(LCP); LCNT := LCNT + 1; LCP1 := LCP; INSYMBOL END ELSE ERROR(2); IF NOT (SY IN FSYS + [COMMA,RPARENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [COMMA,RPARENT]) END UNTIL SY <> COMMA; LSP^.FCONST := LCP1; TOP := TTOP; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END ELSE BEGIN IF SY = IDENT THEN BEGIN SEARCHID([TYPES,KONST],LCP); INSYMBOL; IF LCP^.KLASS = KONST THEN BEGIN NEW(LSP,SUBRANGE); WITH LSP^, LCP^ DO BEGIN RANGETYPE := IDTYPE; FORM := SUBRANGE; IF STRGTYPE(RANGETYPE) THEN BEGIN ERROR(148); RANGETYPE := NIL END; MIN := VALUES; SIZE := INTSIZE END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); CONSTANT(FSYS,LSP1,LVALU); LSP^.MAX := LVALU; IF LSP^.RANGETYPE <> LSP1 THEN ERROR(107) END ELSE BEGIN LSP := LCP^.IDTYPE; IF (LSP = STRGPTR) AND (SY = LBRACK) THEN BEGIN INSYMBOL; CONSTANT(FSYS + [RBRACK],LSP1,LVALU); IF LSP1 = INTPTR THEN BEGIN IF (LVALU.IVAL <= 0) OR (LVALU.IVAL > STRGLGTH) THEN BEGIN ERROR(203); LVALU.IVAL := DEFSTRGLGTH END; IF LVALU.IVAL <> DEFSTRGLGTH THEN BEGIN NEW(LSP,ARRAYS,TRUE,TRUE); LSP^ := STRGPTR^; WITH LSP^,LVALU DO BEGIN MAXLENG := IVAL; SIZE := (IVAL+CHRSPERWD) DIV CHRSPERWD END END END ELSE ERROR(15); IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12) END; IF LSP <> NIL THEN FSIZE := LSP^.SIZE END END (*SY = IDENT*) ELSE BEGIN NEW(LSP,SUBRANGE); LSP^.FORM := SUBRANGE; CONSTANT(FSYS + [COLON],LSP1,LVALU); IF STRGTYPE(LSP1) THEN BEGIN ERROR(148); LSP1 := NIL END; WITH LSP^ DO BEGIN RANGETYPE:=LSP1; MIN:=LVALU; SIZE:=INTSIZE END; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); CONSTANT(FSYS,LSP1,LVALU); LSP^.MAX := LVALU; IF LSP^.RANGETYPE <> LSP1 THEN ERROR(107) END; IF LSP <> NIL THEN WITH LSP^ DO IF FORM = SUBRANGE THEN IF RANGETYPE <> NIL THEN IF RANGETYPE = REALPTR THEN ERROR(399) ELSE IF MIN.IVAL > MAX.IVAL THEN BEGIN ERROR(102); MAX.IVAL := MIN.IVAL END END; FSP := LSP; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE FSP := NIL END (*SIMPLETYPE*) ; FUNCTION PACKABLE(FSP: STP): BOOLEAN; VAR LMIN,LMAX: INTEGER; BEGIN PACKABLE := FALSE; IF (FSP <> NIL) AND PACKING THEN WITH FSP^ DO CASE FORM OF SUBRANGE, SCALAR: IF (FSP <> INTPTR) AND (FSP <> REALPTR) THEN BEGIN GETBOUNDS(FSP,LMIN,LMAX); IF LMIN >= 0 THEN BEGIN PACKABLE := TRUE; NUMBITS := 1; LMIN := 1; WHILE LMIN < LMAX DO BEGIN LMIN := LMIN + 1; LMIN := LMIN + LMIN - 1; NUMBITS := NUMBITS + 1 END END END; POWER: IF PACKABLE(ELSET) THEN BEGIN GETBOUNDS(ELSET,LMIN,LMAX); LMAX := LMAX + 1; IF LMAX < BITSPERWD THEN BEGIN PACKABLE := TRUE; NUMBITS := LMAX END END END (* CASES *); END (*PACKABLE*) ; PROCEDURE FIELDLIST(FSYS: SETOFSYS; VAR FRECVAR: STP); VAR LCP,LCP1,NXT,NXT1,LAST: CTP; LSP,LSP1,LSP2,LSP3,LSP4: STP; MINSIZE,MAXSIZE,LSIZE: ADDRRANGE; LVALU: VALU; MAXBIT,MINBIT: BITRANGE; PROCEDURE ALLOCATE(FCP: CTP); VAR ONBOUND: BOOLEAN; BEGIN ONBOUND := FALSE; WITH FCP^ DO IF PACKABLE(IDTYPE) THEN BEGIN IF (NUMBITS + NEXTBIT) > BITSPERWD THEN BEGIN DISPL := DISPL + 1; NEXTBIT := 0; ONBOUND := TRUE END; FLDADDR := DISPL; FISPACKD := TRUE; FLDWIDTH := NUMBITS; FLDRBIT := NEXTBIT; NEXTBIT := NEXTBIT + NUMBITS END ELSE BEGIN DISPL := DISPL + ORD(NEXTBIT > 0); NEXTBIT := 0; ONBOUND := TRUE; FISPACKD := FALSE; FLDADDR := DISPL; IF IDTYPE <> NIL THEN DISPL := DISPL + IDTYPE^.SIZE END; IF ONBOUND AND (LAST <> NIL) THEN WITH LAST^ DO IF FISPACKD THEN IF FLDRBIT = 0 THEN FISPACKD := FALSE ELSE IF (FLDWIDTH <= 8) AND (FLDRBIT <= 8) THEN BEGIN FLDWIDTH := 8; FLDRBIT := 8 END END (*ALLOCATE*) ; PROCEDURE VARIANTLIST; VAR GOTTAGNAME: BOOLEAN; BEGIN NEW(LSP,TAGFLD); WITH LSP^ DO BEGIN TAGFIELDP := NIL; FSTVAR := NIL; FORM := TAGFLD END; FRECVAR := LSP; INSYMBOL; IF SY = IDENT THEN BEGIN IF PACKING THEN NEW(LCP,FIELD,TRUE) ELSE NEW(LCP,FIELD,FALSE); WITH LCP^ DO BEGIN IDTYPE := NIL; KLASS:=FIELD; NEXT := NIL; FISPACKD := FALSE END; GOTTAGNAME := FALSE; PRTERR := FALSE; SEARCHID([TYPES],LCP1); PRTERR := TRUE; IF LCP1 = NIL THEN BEGIN GOTTAGNAME := TRUE; LCP^.NAME := ID; ENTERID(LCP); INSYMBOL; IF SY = COLON THEN INSYMBOL ELSE ERROR(5) END; IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP1); LSP1 := LCP1^.IDTYPE; IF LSP1 <> NIL THEN BEGIN IF LSP1^.FORM <= SUBRANGE THEN BEGIN IF COMPTYPES(REALPTR,LSP1) THEN ERROR(109); LCP^.IDTYPE := LSP1; LSP^.TAGFIELDP := LCP; IF GOTTAGNAME THEN ALLOCATE(LCP) END ELSE ERROR(110) END; INSYMBOL END ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END END ELSE BEGIN ERROR(2); SKIP(FSYS + [OFSY,LPARENT]) END; LSP^.SIZE := DISPL + ORD(NEXTBIT > 0); IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); LSP1 := NIL; MINSIZE := DISPL; MAXSIZE := DISPL; MINBIT := NEXTBIT; MAXBIT := NEXTBIT; REPEAT LSP2 := NIL; REPEAT CONSTANT(FSYS + [COMMA,COLON,LPARENT],LSP3,LVALU); IF LSP^.TAGFIELDP <> NIL THEN IF NOT COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP3) THEN ERROR(111); NEW(LSP3,VARIANT); WITH LSP3^ DO BEGIN NXTVAR := LSP1; SUBVAR := LSP2; VARVAL := LVALU; FORM := VARIANT END; LSP1 := LSP3; LSP2 := LSP3; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); IF SY = LPARENT THEN INSYMBOL ELSE ERROR(9); IF SY = RPARENT THEN LSP2 := NIL ELSE FIELDLIST(FSYS + [RPARENT,SEMICOLON],LSP2); IF DISPL > MAXSIZE THEN BEGIN MAXSIZE := DISPL; MAXBIT := NEXTBIT END ELSE IF (DISPL = MAXSIZE) AND (NEXTBIT > MAXBIT) THEN MAXBIT := NEXTBIT; WHILE LSP3 <> NIL DO BEGIN LSP4 := LSP3^.SUBVAR; LSP3^.SUBVAR := LSP2; LSP3^.SIZE := DISPL + ORD(NEXTBIT > 0); LSP3 := LSP4 END; IF SY = RPARENT THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [SEMICOLON]) THEN BEGIN ERROR(6); SKIP(FSYS + [SEMICOLON]) END END ELSE ERROR(4); TEST := SY <> SEMICOLON; IF NOT TEST THEN BEGIN INSYMBOL; DISPL := MINSIZE; NEXTBIT := MINBIT END UNTIL TEST; DISPL := MAXSIZE; NEXTBIT := MAXBIT; LSP^.FSTVAR := LSP1 END (*VARIANTLIST*) ; BEGIN (*FIELDLIST*) NXT1 := NIL; LSP := NIL; LAST := NIL; IF NOT (SY IN [IDENT,CASESY]) THEN BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END; WHILE SY = IDENT DO BEGIN NXT := NXT1; REPEAT IF SY = IDENT THEN BEGIN IF PACKING THEN NEW(LCP,FIELD,TRUE) ELSE NEW(LCP,FIELD,FALSE); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := NXT; KLASS := FIELD; FISPACKD := FALSE END; NXT := LCP; ENTERID(LCP); INSYMBOL END ELSE ERROR(2); IF NOT (SY IN [COMMA,COLON]) THEN BEGIN ERROR(6); SKIP(FSYS + [COMMA,COLON,SEMICOLON,CASESY]) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); TYP(FSYS + [CASESY,SEMICOLON],LSP,LSIZE); IF LSP <> NIL THEN IF LSP^.FORM = FILES THEN ERROR(108); WHILE NXT <> NXT1 DO WITH NXT^ DO BEGIN IDTYPE := LSP; ALLOCATE(NXT); IF NEXT = NXT1 THEN LAST := NXT; NXT := NEXT END; NXT1 := LCP; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN [IDENT,CASESY]) THEN BEGIN ERROR(19); SKIP(FSYS + [IDENT,CASESY]) END END END (*WHILE*); NXT := NIL; WHILE NXT1 <> NIL DO WITH NXT1^ DO BEGIN LCP := NEXT; NEXT := NXT; NXT := NXT1; NXT1 := LCP END; IF SY = CASESY THEN VARIANTLIST ELSE FRECVAR := NIL END (*FIELDLIST*) ; PROCEDURE POINTERTYPE; BEGIN NEW(LSP,POINTER); FSP := LSP; WITH LSP^ DO BEGIN ELTYPE := NIL; SIZE := PTRSIZE; FORM := POINTER END; INSYMBOL; IF SY = IDENT THEN BEGIN PRTERR := FALSE; SEARCHID([TYPES],LCP); PRTERR := TRUE; IF LCP = NIL THEN (*FORWARD REFERENCED TYPE ID*) BEGIN NEW(LCP,TYPES); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := LSP; NEXT := FWPTR; KLASS := TYPES END; FWPTR := LCP END ELSE BEGIN IF LCP^.IDTYPE <> NIL THEN IF (LCP^.IDTYPE^.FORM <> FILES) OR SYSCOMP THEN LSP^.ELTYPE := LCP^.IDTYPE ELSE ERROR(108) END; INSYMBOL; END ELSE ERROR(2) END (*POINTERTYPE*) ; BEGIN (*TYP*) PACKING := FALSE; IF NOT (SY IN TYPEBEGSYS) THEN BEGIN ERROR(10); SKIP(FSYS + TYPEBEGSYS) END; IF SY IN TYPEBEGSYS THEN BEGIN IF SY IN SIMPTYPEBEGSYS THEN SIMPLETYPE(FSYS,FSP,FSIZE) ELSE (*^*) IF SY = ARROW THEN POINTERTYPE ELSE BEGIN IF SY = PACKEDSY THEN BEGIN INSYMBOL; PACKING := TRUE; IF NOT (SY IN TYPEDELS) THEN BEGIN ERROR(10); SKIP(FSYS + TYPEDELS) END END; (*ARRAY*) IF SY = ARRAYSY THEN BEGIN INSYMBOL; IF SY = LBRACK THEN INSYMBOL ELSE ERROR(11); LSP1 := NIL; REPEAT IF PACKING THEN NEW(LSP,ARRAYS,TRUE,FALSE) ELSE NEW(LSP,ARRAYS,FALSE); WITH LSP^ DO BEGIN AELTYPE := LSP1; INXTYPE := NIL; IF PACKING THEN AISSTRNG := FALSE; AISPACKD := FALSE; FORM := ARRAYS END; LSP1 := LSP; SIMPLETYPE(FSYS + [COMMA,RBRACK,OFSY],LSP2,LSIZE); LSP1^.SIZE := LSIZE; IF LSP2 <> NIL THEN IF LSP2^.FORM <= SUBRANGE THEN BEGIN IF LSP2 = REALPTR THEN BEGIN ERROR(109); LSP2 := NIL END ELSE IF LSP2 = INTPTR THEN BEGIN ERROR(149); LSP2 := NIL END; LSP^.INXTYPE := LSP2 END ELSE BEGIN ERROR(113); LSP2 := NIL END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12); IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); TYP(FSYS,LSP,LSIZE); IF LSP <> NIL THEN IF LSP^.FORM = FILES THEN ERROR(108); IF PACKABLE(LSP) THEN IF NUMBITS + NUMBITS <= BITSPERWD THEN WITH LSP1^ DO BEGIN AISPACKD := TRUE; ELSPERWD := BITSPERWD DIV NUMBITS; ELWIDTH := NUMBITS END; REPEAT WITH LSP1^ DO BEGIN LSP2 := AELTYPE; AELTYPE := LSP; IF INXTYPE <> NIL THEN BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); IF AISPACKD THEN LSIZE := (LMAX-LMIN+ELSPERWD) DIV ELSPERWD ELSE LSIZE := LSIZE*(LMAX - LMIN + 1); IF LSIZE <= 0 THEN BEGIN ERROR(398); LSIZE := 1 END; SIZE := LSIZE END END; LSP := LSP1; LSP1 := LSP2 UNTIL LSP1 = NIL END ELSE (*RECORD*) IF SY = RECORDSY THEN BEGIN INSYMBOL; OLDTOP := TOP; IF TOP < DISPLIMIT THEN BEGIN TOP := TOP + 1; WITH DISPLAY[TOP] DO BEGIN FNAME := NIL; OCCUR := REC END END ELSE ERROR(250); DISPL := 0; NEXTBIT := 0; FIELDLIST(FSYS-[SEMICOLON]+[ENDSY],LSP1); DISPL := DISPL + ORD(NEXTBIT > 0); NEW(LSP,RECORDS); WITH LSP^ DO BEGIN FSTFLD := DISPLAY[TOP].FNAME; RECVAR := LSP1; SIZE := DISPL; FORM := RECORDS END; TOP := OLDTOP; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13) END ELSE (*SET*) IF SY = SETSY THEN BEGIN INSYMBOL; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); SIMPLETYPE(FSYS,LSP1,LSIZE); IF LSP1 <> NIL THEN IF LSP1^.FORM > SUBRANGE THEN BEGIN ERROR(115); LSP1 := NIL END ELSE IF LSP1 = REALPTR THEN BEGIN ERROR(114); LSP1 := NIL END; NEW(LSP,POWER); WITH LSP^ DO BEGIN ELSET := LSP1; FORM := POWER; IF LSP1 <> NIL THEN BEGIN GETBOUNDS(LSP1,LMIN,LMAX); SIZE := (LMAX + BITSPERWD) DIV BITSPERWD END ELSE SIZE := 0 END END ELSE (*FILE*) IF SY = FILESY THEN BEGIN INSYMBOL; NEW(LSP,FILES); WITH LSP^ DO BEGIN FORM := FILES; FILTYPE := NIL END; IF SY = OFSY THEN BEGIN INSYMBOL; TYP(FSYS,LSP1,LSIZE) END ELSE LSP1 := NIL; LSP^.FILTYPE := LSP1; IF LSP1 <> NIL THEN LSP^.SIZE := FILESIZE + LSP1^.SIZE ELSE LSP^.SIZE := NILFILESIZE END; FSP := LSP END; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE FSP := NIL; IF FSP = NIL THEN FSIZE := 1 ELSE FSIZE := FSP^.SIZE END (*TYP*) ; PROCEDURE GENLDC(IVAL: INTEGER); FORWARD; PROCEDURE GENBYTE(FBYTE: INTEGER); BEGIN CODEP^[IC] := CHR(FBYTE); IC := IC+1 END (*GENBYTE*) ; PROCEDURE GENWORD(FWORD: INTEGER); BEGIN IF ODD(IC) THEN IC := IC + 1; MOVELEFT(FWORD,CODEP^[IC],2); IC := IC + 2 END (*GENWORD*) ; PROCEDURE GENBIG(IVAL: INTEGER); VAR LOWORDER: CHAR; BEGIN IF IVAL <= 127 THEN GENBYTE(IVAL) ELSE BEGIN MOVELEFT(IVAL,CODEP^[IC],2); LOWORDER := CODEP^[IC]; CODEP^[IC] := CHR(ORD(CODEP^[IC+1])+128); CODEP^[IC+1] := LOWORDER; IC := IC+2 END END (*GENBIG*) ; PROCEDURE GEN0(FOP: OPRANGE); VAR I: INTEGER; BEGIN GENBYTE(FOP+128); IF FOP = 38(*LCA*) THEN WITH GATTR.CVAL.VALP^ DO BEGIN GENBYTE(SLGTH); FOR I := 1 TO SLGTH DO GENBYTE(ORD(SVAL[I])) END END (*GEN0*) ; PROCEDURE GEN1(FOP: OPRANGE; FP2: INTEGER); LABEL 1; VAR I,J: INTEGER; BEGIN GENBYTE(FOP+128); IF FOP = 51(*LDC*) THEN BEGIN IF FP2 = 2 THEN I := REALSIZE ELSE BEGIN I := 8; WHILE I > 0 DO IF GATTR.CVAL.VALP^.CSTVAL[I] <> 0 THEN GOTO 1 ELSE I := I - 1; 1: END; GATTR.TYPTR^.SIZE := I; IF I > 1 THEN BEGIN GENBYTE(I); FOR J := I DOWNTO 1 DO GENWORD(GATTR.CVAL.VALP^.CSTVAL[J]) END ELSE BEGIN IC := IC - 1; IF I = 1 THEN GENLDC(GATTR.CVAL.VALP^.CSTVAL[1]) END END ELSE IF FOP IN [30(*CSP*),32(*ADJ*),45(*RNP*), 46(*CIP*),60(*LDM*),61(*STM*), 65(*RBP*),66(*CBP*),78(*CLP*), 42(*SAS*),79(*CGP*)] THEN GENBYTE(FP2) ELSE IF ((FOP = 74(*LDL*)) OR (FOP = 39(*LDO*))) AND (FP2 <= 16) THEN BEGIN IC := IC-1; IF FOP = 39(*LDO*) THEN GENBYTE(231+FP2) ELSE GENBYTE(215+FP2) END ELSE IF (FOP = 35(*IND*)) AND (FP2 <= 7) THEN BEGIN IC := IC-1; GENBYTE(248+FP2) END ELSE GENBIG(FP2) END (*GEN1*) ; PROCEDURE GEN2(FOP: OPRANGE; FP1,FP2: INTEGER); BEGIN IF (FOP = 64(*IXP*)) OR (FOP = 77(*CXP*)) THEN BEGIN GENBYTE(FOP+128); GENBYTE(FP1); GENBYTE(FP2); END ELSE IF FOP IN [47(*EQU*),48(*GEQ*),49(*GRT*), 52(*LEQ*),53(*LES*),55(*NEQ*)] THEN IF FP1 = 0 THEN GEN0(FOP+20) ELSE BEGIN GEN1(FOP,FP1+FP1); IF FP1 > 4 THEN GENBIG(FP2) END ELSE BEGIN (*LDA,LOD,STR*) IF FP1 = 0 THEN GEN1(FOP+20,FP2) ELSE BEGIN GENBYTE(FOP+128); GENBYTE(FP1); GENBIG(FP2) END END; END (*GEN2*) ; PROCEDURE GENLDC; BEGIN IF (IVAL >= 0) AND (IVAL <= 127) THEN GENBYTE(IVAL) ELSE BEGIN GENBYTE(51(*LDC*)+148); MOVELEFT(IVAL,CODEP^[IC],2); IC := IC+2 END END (*GENLDC*) ; PROCEDURE GENJMP(FOP: OPRANGE; FLBP: LBP); VAR DISP: INTEGER; BEGIN WITH FLBP^ DO IF DEFINED THEN BEGIN GENBYTE(FOP+128); DISP := OCCURIC-IC-1; IF (DISP >= 0) AND (DISP <= 127) THEN GENBYTE(DISP) ELSE BEGIN IF JTABINX = 0 THEN BEGIN JTABINX := NEXTJTAB; IF NEXTJTAB = MAXJTAB THEN ERROR(253) ELSE NEXTJTAB := NEXTJTAB + 1; JTAB[JTABINX] := OCCURIC END; DISP := -JTABINX; GENBYTE(248-JTABINX-JTABINX) END; END ELSE BEGIN MOVELEFT(REFLIST,CODEP^[IC],2); IF FOP = 57(*UJP*) THEN DISP := IC + 4096 ELSE DISP := IC; REFLIST := DISP; IC := IC+2 END; END (*GENJMP*) ; PROCEDURE LOAD; FORWARD; PROCEDURE GENFJP(FLBP: LBP); BEGIN LOAD; IF GATTR.TYPTR <> BOOLPTR THEN ERROR(135); GENJMP(33(*FJP*),FLBP) END (*GENFJP*) ; PROCEDURE GENLABEL(VAR FLBP: LBP); BEGIN NEW(FLBP); WITH FLBP^ DO BEGIN DEFINED := FALSE; REFLIST := MAXADDR END END (*GENLABEL*) ; PROCEDURE PUTLABEL(FLBP: LBP); VAR LREF: INTEGER; LOP: OPRANGE; BEGIN WITH FLBP^ DO BEGIN LREF := REFLIST; DEFINED := TRUE; OCCURIC := IC; JTABINX := 0; WHILE LREF < MAXADDR DO BEGIN IF LREF >= 4096 THEN BEGIN LREF := LREF - 4096; LOP := 57(*UJP*) END ELSE LOP := 33(*FJP*); IC := LREF; MOVELEFT(CODEP^[IC],LREF,2); GENJMP(LOP,FLBP) END; IC := OCCURIC END END (*PUTLABEL*) ; PROCEDURE LOAD; BEGIN WITH GATTR DO IF TYPTR <> NIL THEN BEGIN CASE KIND OF CST: IF (TYPTR^.FORM = SCALAR) AND (TYPTR <> REALPTR) THEN GENLDC(CVAL.IVAL) ELSE IF TYPTR = NILPTR THEN GEN0(31(*LDCN*)) ELSE IF TYPTR = REALPTR THEN GEN1(51(*LDC*),2) ELSE GEN1(51(*LDC*),5); VARBL: CASE ACCESS OF DRCT: IF VLEVEL = 1 THEN GEN1(39(*LDO*),DPLMT) ELSE GEN2(54(*LOD*),LEVEL-VLEVEL,DPLMT); INDRCT: GEN1(35(*IND*),IDPLMT); PACKD: GEN0(58(*LDP*)); MULTI: GEN1(60(*LDM*),TYPTR^.SIZE); BYTE: GEN0(62(*LDB*)) END; EXPR: END; IF (TYPTR^.FORM = POWER) AND (KIND <> EXPR) THEN GENLDC(TYPTR^.SIZE); KIND := EXPR END END (*LOAD*) ; PROCEDURE STORE(VAR FATTR: ATTR); BEGIN WITH FATTR DO IF TYPTR <> NIL THEN CASE ACCESS OF DRCT: IF VLEVEL = 1 THEN GEN1(43(*SRO*),DPLMT) ELSE GEN2(56(*STR*),LEVEL-VLEVEL,DPLMT); INDRCT: IF IDPLMT <> 0 THEN ERROR(400) ELSE GEN0(26(*STO*)); PACKD: GEN0(59(*STP*)); MULTI: GEN1(61(*STM*),TYPTR^.SIZE); BYTE: GEN0(63(*STB*)) END END (*STORE*) ; PROCEDURE LOADADDRESS; BEGIN WITH GATTR DO IF TYPTR <> NIL THEN BEGIN CASE KIND OF CST: IF STRGTYPE(TYPTR) THEN GEN0(38(*LCA*)) ELSE ERROR(400); VARBL: CASE ACCESS OF DRCT: IF VLEVEL = 1 THEN GEN1(37(*LAO*),DPLMT) ELSE GEN2(50(*LDA*),LEVEL-VLEVEL,DPLMT); INDRCT: IF IDPLMT <> 0 THEN GEN1(34(*INC*),IDPLMT+IDPLMT); PACKD: ERROR(103) END END; KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0 END END (*LOADADDRESS*) ; PROCEDURE WRITECODE(FORCEBUF: BOOLEAN); VAR CODEINX,LIC,I: INTEGER; BEGIN CODEINX := 0; LIC := IC; REPEAT I := 512-CURBYTE; IF I > LIC THEN I := LIC; MOVELEFT(CODEP^[CODEINX],DISKBUF[CURBYTE],I); CODEINX := CODEINX+I; CURBYTE := CURBYTE+I; IF (CURBYTE = 512) OR FORCEBUF THEN BEGIN IF BLOCKWRITE(USERINFO.WORKCODE^,DISKBUF,1,CURBLK) <> 1 THEN ERROR(402); CURBLK := CURBLK+1; CURBYTE := 0 END; LIC := LIC-I UNTIL LIC = 0; END (*WRITECODE*) ; PROCEDURE FINISHSEG; VAR I: INTEGER; BEGIN IC := 0; FOR I := NEXTPROC-1 DOWNTO 1 DO GENWORD(SEGINX+IC-PROCTABLE[I]); GENBYTE(SEG); GENBYTE(NEXTPROC-1); SEGTABLE[SEG].CODELENG := SEGINX+IC; WRITECODE(TRUE); SEGINX := 0; CODEINSEG := FALSE END (*FINISHSEG*) ; ======================================================================================== DOCUMENT :usus Folder:VOL17:comp.d.text ======================================================================================== PROCEDURE EXPRESSION(FSYS: SETOFSYS); FORWARD; PROCEDURE SELECTOR(FSYS: SETOFSYS; FCP: CTP); VAR LATTR: ATTR; LCP: CTP; LMIN,LMAX: INTEGER; BEGIN WITH FCP^, GATTR DO BEGIN TYPTR := IDTYPE; KIND := VARBL; CASE KLASS OF VARS: IF VKIND = ACTUAL THEN BEGIN ACCESS := DRCT; VLEVEL := VLEV; DPLMT := VADDR END ELSE BEGIN IF VLEV = 1 THEN GEN1(39(*LDO*),VADDR) ELSE GEN2(54(*LOD*),LEVEL-VLEV,VADDR); ACCESS := INDRCT; IDPLMT := 0 END; FIELD: WITH DISPLAY[DISX] DO BEGIN IF OCCUR = CREC THEN BEGIN ACCESS := DRCT; VLEVEL := CLEV; DPLMT := CDSPL + FLDADDR END ELSE BEGIN IF LEVEL = 1 THEN GEN1(39(*LDO*),VDSPL) ELSE GEN2(54(*LOD*),0,VDSPL); ACCESS := INDRCT; IDPLMT := FLDADDR END; IF FISPACKD THEN BEGIN LOADADDRESS; IF ((FLDRBIT = 0) OR (FLDRBIT = 8)) AND (FLDWIDTH = 8) THEN BEGIN ACCESS := BYTE; IF FLDRBIT = 8 THEN GEN1(34(*INC*),1) END ELSE BEGIN ACCESS := PACKD; GENLDC(FLDWIDTH); GENLDC(FLDRBIT) END END END; FUNC: IF PFDECKIND <> DECLARED THEN ERROR(150) ELSE IF NOT INSCOPE THEN ERROR(103) ELSE BEGIN ACCESS := DRCT; VLEVEL := PFLEV + 1; DPLMT := LCAFTERMARKSTACK END END (*CASE*); IF TYPTR <> NIL THEN IF (TYPTR^.FORM <= POWER) AND (TYPTR^.SIZE > PTRSIZE) THEN BEGIN LOADADDRESS; ACCESS := MULTI END END (*WITH*); IF NOT (SY IN SELECTSYS + FSYS) THEN BEGIN ERROR(59); SKIP(SELECTSYS + FSYS) END; WHILE SY IN SELECTSYS DO BEGIN (*[*) IF SY = LBRACK THEN BEGIN REPEAT LATTR := GATTR; WITH LATTR DO IF TYPTR <> NIL THEN IF TYPTR^.FORM <> ARRAYS THEN BEGIN ERROR(138); TYPTR := NIL END; LOADADDRESS; INSYMBOL; EXPRESSION(FSYS + [COMMA,RBRACK]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(113); IF LATTR.TYPTR <> NIL THEN WITH LATTR.TYPTR^ DO BEGIN IF COMPTYPES(INXTYPE,GATTR.TYPTR) THEN BEGIN IF (INXTYPE <> NIL) AND NOT STRGTYPE(LATTR.TYPTR) THEN BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); IF RANGECHECK THEN BEGIN GENLDC(LMIN); GENLDC(LMAX); GEN0(8(*CHK*)) END; IF LMIN <> 0 THEN BEGIN GENLDC(ABS(LMIN)); IF LMIN > 0 THEN GEN0(21(*SBI*)) ELSE GEN0(2(*ADI*)) END END END ELSE ERROR(139); WITH GATTR DO BEGIN TYPTR := AELTYPE; KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0; IF TYPTR <> NIL THEN IF AISPACKD THEN IF ELWIDTH = 8 THEN BEGIN ACCESS := BYTE; IF STRGTYPE(LATTR.TYPTR) AND RANGECHECK THEN GEN0(27(*IXS*)) ELSE GEN0(2(*ADI*)) END ELSE BEGIN ACCESS := PACKD; GEN2(64(*IXP*),ELSPERWD,ELWIDTH) END ELSE BEGIN GEN1(36(*IXA*),TYPTR^.SIZE); IF (TYPTR^.FORM <= POWER) AND (TYPTR^.SIZE > PTRSIZE) THEN ACCESS := MULTI END END END UNTIL SY <> COMMA; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12) END (*IF SY = LBRACK*) ELSE (*.*) IF SY = PERIOD THEN BEGIN WITH GATTR DO BEGIN IF TYPTR <> NIL THEN IF TYPTR^.FORM <> RECORDS THEN BEGIN ERROR(140); TYPTR := NIL END; INSYMBOL; IF SY = IDENT THEN BEGIN IF TYPTR <> NIL THEN BEGIN SEARCHSECTION(TYPTR^.FSTFLD,LCP); IF LCP = NIL THEN BEGIN ERROR(152); TYPTR := NIL END ELSE WITH LCP^ DO BEGIN TYPTR := IDTYPE; CASE ACCESS OF DRCT: DPLMT := DPLMT + FLDADDR; INDRCT: IDPLMT := IDPLMT + FLDADDR; MULTI,BYTE, PACKD: ERROR(400) END (*CASE ACCESS*); IF FISPACKD THEN BEGIN LOADADDRESS; IF ((FLDRBIT = 0) OR (FLDRBIT = 8)) AND (FLDWIDTH = 8) THEN BEGIN ACCESS := BYTE; IF FLDRBIT = 8 THEN GEN1(34(*INC*),1) END ELSE BEGIN ACCESS := PACKD; GENLDC(FLDWIDTH); GENLDC(FLDRBIT) END END; IF TYPTR <> NIL THEN IF (TYPTR^.FORM <= POWER) AND (TYPTR^.SIZE > PTRSIZE) THEN BEGIN LOADADDRESS; ACCESS := MULTI END END END; INSYMBOL END (*SY = IDENT*) ELSE ERROR(2) END (*WITH GATTR*) END (*IF SY = PERIOD*) ELSE (*^*) BEGIN IF GATTR.TYPTR <> NIL THEN WITH GATTR,TYPTR^ DO IF (FORM = POINTER) OR (FORM = FILES) THEN BEGIN LOAD; KIND := VARBL; ACCESS := INDRCT; IDPLMT := 0; IF FORM = POINTER THEN TYPTR := ELTYPE ELSE BEGIN TYPTR := FILTYPE; IF TYPTR = NIL THEN ERROR(399) END; IF TYPTR <> NIL THEN IF (TYPTR^.FORM <= POWER) AND (TYPTR^.SIZE > PTRSIZE) THEN ACCESS := MULTI END ELSE ERROR(141); INSYMBOL END; IF NOT (SY IN FSYS + SELECTSYS) THEN BEGIN ERROR(6); SKIP(FSYS + SELECTSYS) END END (*WHILE*) END (*SELECTOR*) ; PROCEDURE CALL(FSYS: SETOFSYS; FCP: CTP); VAR LKEY: 1..40; WASLPARENT: BOOLEAN; PROCEDURE VARIABLE(FSYS: SETOFSYS); VAR LCP: CTP; BEGIN IF SY = IDENT THEN BEGIN SEARCHID([FIELD,VARS],LCP); INSYMBOL END ELSE BEGIN ERROR(2); LCP := UVARPTR END; SELECTOR(FSYS,LCP) END (*VARIABLE*) ; PROCEDURE STRGVAR(FSYS: SETOFSYS; MUSTBEVAR: BOOLEAN); BEGIN EXPRESSION(FSYS); WITH GATTR DO IF ((KIND = CST) AND (TYPTR = CHARPTR)) OR STRGTYPE(TYPTR) THEN IF KIND = VARBL THEN LOADADDRESS ELSE BEGIN IF MUSTBEVAR THEN ERROR(154); IF KIND = CST THEN BEGIN IF TYPTR = CHARPTR THEN BEGIN WITH SCONST^ DO BEGIN CCLASS := STRG; SLGTH := 1; SVAL[1] := CHR(CVAL.IVAL) END; CVAL.VALP := SCONST; NEW(TYPTR,ARRAYS,TRUE,TRUE); TYPTR^ := STRGPTR^; TYPTR^.MAXLENG := 1 END; LOADADDRESS END END ELSE BEGIN IF GATTR.TYPTR <> NIL THEN ERROR(125); GATTR.TYPTR := STRGPTR END END (*STRGVAR*) ; PROCEDURE NEWSTMT; LABEL 1; VAR LSP,LSP1: STP; VARTS,LMIN,LMAX: INTEGER; LSIZE,LSZ: ADDRRANGE; LVAL: VALU; BEGIN VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS; LSP := NIL; VARTS := 0; LSIZE := 0; IF GATTR.TYPTR <> NIL THEN WITH GATTR.TYPTR^ DO IF FORM = POINTER THEN BEGIN IF ELTYPE <> NIL THEN WITH ELTYPE^ DO BEGIN LSIZE := SIZE; IF FORM = RECORDS THEN LSP := RECVAR END END ELSE ERROR(116); WHILE SY = COMMA DO BEGIN INSYMBOL; CONSTANT(FSYS + [COMMA,RPARENT],LSP1,LVAL); VARTS := VARTS + 1; IF LSP = NIL THEN ERROR(158) ELSE IF LSP^.FORM <> TAGFLD THEN ERROR(162) ELSE IF LSP^.TAGFIELDP <> NIL THEN IF STRGTYPE(LSP1) OR (LSP1 = REALPTR) THEN ERROR(159) ELSE IF COMPTYPES(LSP^.TAGFIELDP^.IDTYPE,LSP1) THEN BEGIN LSP1 := LSP^.FSTVAR; WHILE LSP1 <> NIL DO WITH LSP1^ DO IF VARVAL.IVAL = LVAL.IVAL THEN BEGIN LSIZE := SIZE; LSP := SUBVAR; GOTO 1 END ELSE LSP1 := NXTVAR; LSIZE := LSP^.SIZE; LSP := NIL; END ELSE ERROR(116); 1: END (*WHILE*) ; GENLDC(LSIZE); GEN1(30(*CSP*),1(*NEW*)) END (*NEWSTMT*) ; PROCEDURE MOVE; BEGIN VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); IF LKEY = 27 THEN BEGIN EXPRESSION(FSYS + [COMMA]); LOAD END ELSE BEGIN VARIABLE(FSYS + [COMMA]); LOADADDRESS END; IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); EXPRESSION(FSYS + [RPARENT]); LOAD; IF LKEY = 27 THEN GEN1(30(*CSP*),10(*FLC*)) ELSE IF LKEY = 21 THEN GEN1(30(*CSP*),2(*MVL*)) ELSE GEN1(30(*CSP*),3(*MVR*)) END (*MOVE*) ; PROCEDURE EXIT; VAR LCP: CTP; BEGIN IF SY = IDENT THEN BEGIN SEARCHID([PROC,FUNC],LCP); INSYMBOL END ELSE IF (SY = PROGSY) THEN BEGIN LCP := OUTERBLOCK; INSYMBOL END ELSE LCP := NIL; IF LCP <> NIL THEN IF LCP^.PFDECKIND = DECLARED THEN BEGIN GENLDC(LCP^.PFSEG); GENLDC(LCP^.PFNAME) END ELSE ERROR(125) ELSE ERROR(125); GEN1(30(*CSP*),4(*XIT*)) END (*EXIT*) ; PROCEDURE UNITIO; BEGIN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD; IF GATTR.TYPTR <> INTPTR THEN ERROR(125); IF SY = COMMA THEN BEGIN INSYMBOL; IF SY = COMMA THEN GENLDC(0) ELSE BEGIN EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD; IF GATTR.TYPTR <> INTPTR THEN ERROR(125) END END ELSE GENLDC(0); IF SY = COMMA THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT]); LOAD; IF GATTR.TYPTR <> BOOLPTR THEN ERROR(135) END ELSE GENLDC(0); IF LKEY = 13 THEN GEN1(30(*CSP*),5(*URD*)) ELSE GEN1(30(*CSP*),6(*UWT*)) END (*UNITIO*); PROCEDURE CONCAT; VAR LLC: ADDRRANGE; TEMPLGTH: INTEGER; BEGIN TEMPLGTH := 0; LLC := LC; LC := LC + (STRGLGTH DIV CHRSPERWD) + 1; GENLDC(0); GEN2(56(*STR*),0,LLC); GEN2(50(*LDA*),0,LLC); REPEAT STRGVAR(FSYS + [COMMA,RPARENT],FALSE); TEMPLGTH := TEMPLGTH + GATTR.TYPTR^.MAXLENG; IF TEMPLGTH < STRGLGTH THEN GENLDC(TEMPLGTH) ELSE GENLDC(STRGLGTH); GEN2(77(*CXP*),0(*SYS*),23(*SCONCAT*)); GEN2(50(*LDA*),0,LLC); TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF TEMPLGTH < STRGLGTH THEN LC := LLC + (TEMPLGTH DIV CHRSPERWD) + 1 ELSE TEMPLGTH := STRGLGTH; IF LC > LCMAX THEN LCMAX := LC; LC := LLC; WITH GATTR DO BEGIN NEW(TYPTR,ARRAYS,TRUE,TRUE); TYPTR^ := STRGPTR^; TYPTR^.MAXLENG := TEMPLGTH END END (*CONCAT*) ; PROCEDURE COPYDELETE; VAR LLC: ADDRRANGE; LSP: STP; BEGIN IF LKEY = 19 THEN BEGIN LLC := LC; LC := LC + (STRGLGTH DIV CHRSPERWD) + 1; END; STRGVAR(FSYS + [COMMA], LKEY = 18); IF LKEY = 19 THEN BEGIN LSP := GATTR.TYPTR; GEN2(50(*LDA*),0,LLC) END; IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); EXPRESSION(FSYS + [COMMA]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); EXPRESSION(FSYS + [RPARENT]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); IF LKEY = 19 THEN BEGIN GEN2(77(*CXP*),0(*SYS*),25(*SCOPY*)); GEN2(50(*LDA*),0,LLC); IF LSP^.MAXLENG < STRGLGTH THEN LC := LLC + (LSP^.MAXLENG DIV CHRSPERWD) + 1; IF LC > LCMAX THEN LCMAX := LC; LC := LLC; GATTR.TYPTR := LSP END ELSE GEN2(77(*CXP*),0(*SYS*),26(*SDELETE*)) END (*COPYDELETE*) ; PROCEDURE CLOSE; BEGIN VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125); IF SY = COMMA THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN IF ID = 'NORMAL ' THEN GENLDC(0) ELSE IF ID = 'LOCK ' THEN GENLDC(1) ELSE IF ID = 'PURGE ' THEN GENLDC(2) ELSE IF ID = 'CRUNCH ' THEN GENLDC(3) ELSE ERROR(2); INSYMBOL END ELSE ERROR(2) END ELSE GENLDC(0); GEN2(77(*CXP*),0(*SYS*),6(*FCLOSE*)); IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*)) END (*CLOSE*) ; PROCEDURE GETPUTETC; BEGIN VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125); CASE LKEY OF 32: BEGIN IF SY = COMMA THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT]); LOAD; IF GATTR.TYPTR <> INTPTR THEN ERROR(125) END ELSE ERROR(125); GEN2(77(*CXP*),0(*SYS*),9(*FSEEK*)) END; 33: GEN2(77(*CXP*),0(*SYS*),4(*FRESET*)); 34: GEN2(77(*CXP*),0(*SYS*),7(*FGET*)); 35: GEN2(77(*CXP*),0(*SYS*),8(*FPUT*)); 40: BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FILTYPE <> CHARPTR THEN ERROR(399); GENLDC(12); GENLDC(0); GEN2(77(*CXP*),0(*SYS*),17(*WRC*)) END END (*CASE*) ; IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*)) END (*GETPUTETC*) ; PROCEDURE SCAN; BEGIN IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); IF SY = RELOP THEN BEGIN IF OP = EQOP THEN GENLDC(0) ELSE IF OP = NEOP THEN GENLDC(1) ELSE ERROR(125); INSYMBOL END ELSE ERROR(125); EXPRESSION(FSYS + [COMMA]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> CHARPTR THEN ERROR(125); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS; IF SY = COMMA THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT]); LOAD END ELSE GENLDC(0); GEN1(30(*CSP*),11(*SCN*)); GATTR.TYPTR := INTPTR END (*SCAN*) ; PROCEDURE BLOCKIO; BEGIN VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125) ELSE IF GATTR.TYPTR^.FILTYPE <> NIL THEN ERROR(399); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD; IF GATTR.TYPTR <> INTPTR THEN ERROR(125); IF SY = COMMA THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT]); LOAD; IF GATTR.TYPTR <> INTPTR THEN ERROR(125) END ELSE GENLDC(-1); IF LKEY = 37 THEN GENLDC(1) ELSE GENLDC(0); GENLDC(0); GENLDC(0); GEN2(77(*CXP*),0(*SYS*),28(*BLOCKIO*)); IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*)); GATTR.TYPTR := INTPTR END (*BLOCKIO*) ; PROCEDURE DRAWSTUFF; VAR I,N: INTEGER; BEGIN VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF LKEY = 42 THEN N := 6 ELSE N := 5; FOR I := 0 TO N DO BEGIN IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125) END; IF LKEY = 42 THEN N := 13 ELSE N := 12; GEN1(30(*CSP*),N) END (*DRAWSTUFF*) ; PROCEDURE SIZEOF; VAR LCP: CTP; BEGIN IF SY = IDENT THEN BEGIN SEARCHID([TYPES,VARS,FIELD],LCP); INSYMBOL; IF LCP^.IDTYPE <> NIL THEN GENLDC(LCP^.IDTYPE^.SIZE*CHRSPERWD) END; GATTR.TYPTR := INTPTR END (*SIZEOF*) ; PROCEDURE LOADIDADDR(FCP: CTP); BEGIN WITH FCP^ DO IF VKIND = ACTUAL THEN IF VLEV = 1 THEN GEN1(37(*LAO*),VADDR) ELSE GEN2(50(*LDA*),LEVEL-VLEV,VADDR) ELSE IF VLEV = 1 THEN GEN1(39(*LDO*),VADDR) ELSE GEN2(54(*LOD*),LEVEL-VLEV,VADDR) END (*LOADIDADDR*) ; PROCEDURE READ; VAR FILEPTR,LCP: CTP; BEGIN FILEPTR := INPUTPTR; IF (SY = IDENT) AND WASLPARENT THEN BEGIN SEARCHID([FIELD,VARS],LCP); IF LCP^.IDTYPE <> NIL THEN IF LCP^.IDTYPE^.FORM = FILES THEN IF LCP^.IDTYPE^.FILTYPE = CHARPTR THEN BEGIN INSYMBOL; FILEPTR := LCP; IF NOT (SY IN [COMMA,RPARENT]) THEN ERROR(20); IF SY = COMMA THEN INSYMBOL END END ELSE IF WASLPARENT THEN ERROR(2); IF (SY = IDENT) AND WASLPARENT THEN BEGIN REPEAT LOADIDADDR(FILEPTR); VARIABLE(FSYS + [COMMA,RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF COMPTYPES(INTPTR,GATTR.TYPTR) THEN GEN2(77(*CXP*),0(*SYS*),12(*FRDI*)) ELSE IF COMPTYPES(REALPTR,GATTR.TYPTR) THEN GEN2(77(*CXP*),0(*SYS*),14(*FRDR*)) ELSE IF COMPTYPES(CHARPTR,GATTR.TYPTR) THEN GEN2(77(*CXP*),0(*SYS*),16(*FRDC*)) ELSE IF STRGTYPE(GATTR.TYPTR) THEN BEGIN GENLDC(GATTR.TYPTR^.MAXLENG); GEN2(77(*CXP*),0(*SYS*),18(*FRDS*)) END ELSE ERROR(125); IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*)); TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST END; IF LKEY = 2 THEN BEGIN LOADIDADDR(FILEPTR); GEN2(77(*CXP*),0(*SYS*),21(*FRLN*)); IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*)) END END (*READ*) ; PROCEDURE WRITE; VAR LSP: STP; DEFAULT: BOOLEAN; FILEPTR,LCP: CTP; LEN,LMIN,LMAX: INTEGER; BEGIN FILEPTR := OUTPUTPTR; IF (SY = IDENT) AND WASLPARENT THEN BEGIN SEARCHID([FIELD,VARS,KONST,FUNC],LCP); IF LCP^.IDTYPE <> NIL THEN IF LCP^.IDTYPE^.FORM = FILES THEN IF LCP^.IDTYPE^.FILTYPE = CHARPTR THEN BEGIN INSYMBOL; FILEPTR := LCP; IF NOT (SY IN [COMMA,RPARENT]) THEN ERROR(20); IF SY = COMMA THEN INSYMBOL END END; IF (SY IN FACBEGSYS) AND WASLPARENT THEN BEGIN REPEAT LOADIDADDR(FILEPTR); EXPRESSION(FSYS + [COMMA,COLON,RPARENT]); LSP := GATTR.TYPTR; IF LSP <> NIL THEN IF LSP^.FORM <= SUBRANGE THEN LOAD ELSE LOADADDRESS; IF SY = COLON THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,COLON,RPARENT]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(20); LOAD; DEFAULT := FALSE END ELSE DEFAULT := TRUE; IF LSP = INTPTR THEN BEGIN IF DEFAULT THEN GENLDC(0); GEN2(77(*CXP*),0(*SYS*),13(*FWRI*)) END ELSE IF LSP = REALPTR THEN BEGIN IF DEFAULT THEN GENLDC(0); IF SY = COLON THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125) END ELSE GENLDC(0); GEN2(77(*CXP*),0(*SYS*),15(*FWRR*)) END ELSE IF LSP = CHARPTR THEN BEGIN IF DEFAULT THEN GENLDC(0); GEN2(77(*CXP*),0(*SYS*),17(*FWRC*)) END ELSE IF STRGTYPE(LSP) THEN BEGIN IF DEFAULT THEN GENLDC(0); GEN2(77(*CXP*),0(*SYS*),19(*FWRS*)) END ELSE IF PAOFCHAR(LSP) THEN BEGIN LMAX := 0; IF LSP^.INXTYPE <> NIL THEN BEGIN GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX); LMAX := LMAX - LMIN + 1 END; IF DEFAULT THEN GENLDC(LMAX); GENLDC(LMAX); GEN2(77(*CXP*),0(*SYS*),20(*FWRB*)) END ELSE ERROR(125); IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*)); TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; END; IF LKEY = 4 THEN (*WRITELN*) BEGIN LOADIDADDR(FILEPTR); GEN2(77(*CXP*),0(*SYS*),22(*FWLN*)); IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*)) END END (*WRITE*) ; PROCEDURE CALLNONSPECIAL; VAR NXT,LCP: CTP; LSP: STP; LB: BOOLEAN; LMIN,LMAX: INTEGER; BEGIN WITH FCP^ DO BEGIN NXT := NEXT; IF PFDECKIND = DECLARED THEN IF PFKIND <> ACTUAL THEN ERROR(400) END; IF SY = LPARENT THEN BEGIN REPEAT IF NXT = NIL THEN ERROR(126); INSYMBOL; EXPRESSION(FSYS + [COMMA,RPARENT]); IF (GATTR.TYPTR <> NIL) AND (NXT <> NIL) THEN BEGIN LSP := NXT^.IDTYPE; IF LSP <> NIL THEN BEGIN IF NXT^.VKIND = ACTUAL THEN IF GATTR.TYPTR^.FORM <= POWER THEN BEGIN LB := (GATTR.TYPTR = CHARPTR) AND (GATTR.KIND = CST); LOAD; IF LSP^.FORM = POWER THEN GEN1(32(*ADJ*),LSP^.SIZE) ELSE IF (LSP^.FORM = SUBRANGE) AND RANGECHECK THEN BEGIN GENLDC(LSP^.MIN.IVAL); GENLDC(LSP^.MAX.IVAL); GEN0(8(*CHK*)) END ELSE IF (GATTR.TYPTR = INTPTR) AND COMPTYPES(LSP,REALPTR) THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END ELSE IF LB AND STRGTYPE(LSP) THEN GATTR.TYPTR := STRGPTR END ELSE (*FORM > POWER*) BEGIN LB := STRGTYPE(GATTR.TYPTR) AND (GATTR.KIND = CST); LOADADDRESS; IF LB AND PAOFCHAR(LSP) THEN IF NOT LSP^.AISSTRNG THEN BEGIN GEN0(80(*S1P*)); IF LSP^.INXTYPE <> NIL THEN BEGIN GETBOUNDS(LSP^.INXTYPE,LMIN,LMAX); IF LMAX-LMIN+1 <> GATTR.TYPTR^.MAXLENG THEN ERROR(142); END; GATTR.TYPTR := LSP END END ELSE (*VKIND = FORMAL*) IF GATTR.KIND = VARBL THEN BEGIN LOADADDRESS; IF (LSP^.FORM=POWER) THEN IF GATTR.TYPTR^.SIZE <> LSP^.SIZE THEN ERROR(142) END ELSE ERROR(154); IF NOT COMPTYPES(LSP,GATTR.TYPTR) THEN ERROR(142) END END; IF NXT <> NIL THEN NXT := NXT^.NEXT UNTIL SY <> COMMA; IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*LPARENT*) ; IF NXT <> NIL THEN ERROR(126); WITH FCP^ DO IF PFDECKIND = DECLARED THEN BEGIN IF KLASS = FUNC THEN BEGIN GENLDC(0); GENLDC(0) END; IF PFSEG <> SEG THEN GEN2(77(*CXP*),PFSEG,PFNAME) ELSE IF PFLEV = 0 THEN GEN1(66(*CBP*),PFNAME) ELSE IF PFLEV = LEVEL THEN GEN1(78(*CLP*),PFNAME) ELSE IF PFLEV = 1 THEN GEN1(79(*CGP*),PFNAME) ELSE GEN1(46(*CIP*),PFNAME) END ELSE IF (CSPNUM <> 21) AND (CSPNUM <> 22) THEN GEN1(30(*CSP*),CSPNUM); GATTR.TYPTR := FCP^.IDTYPE END (*CALLNONSPECIAL*) ; BEGIN (*CALL*) IF FCP^.PFDECKIND = SPECIAL THEN BEGIN WASLPARENT := TRUE; LKEY := FCP^.KEY; IF SY = LPARENT THEN INSYMBOL ELSE IF LKEY IN [2,4,5,6] THEN WASLPARENT := FALSE ELSE ERROR(9); IF LKEY IN [7,8,9,10,11,13,14,25,36] THEN BEGIN EXPRESSION(FSYS + [COMMA,RPARENT]); LOAD END; CASE LKEY OF 1,2: READ; 3,4: WRITE; 5,6: BEGIN (*EOF & EOLN*) IF WASLPARENT THEN BEGIN VARIABLE(FSYS + [RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125) ELSE IF (GATTR.TYPTR^.FILTYPE <> CHARPTR) AND (LKEY = 6) THEN ERROR(399) END ELSE LOADIDADDR(INPUTPTR); GENLDC(0); GENLDC(0); IF LKEY = 5 THEN GEN2(77(*CXP*),0(*SYS*),10(*FEOF*)) ELSE GEN2(77(*CXP*),0(*SYS*),11(*FEOLN*)); GATTR.TYPTR := BOOLPTR END (*EOF*) ; 7,8: BEGIN GENLDC(1); (*PREDSUCC*) IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM = SCALAR THEN IF LKEY = 8 THEN GEN0(2(*ADI*)) ELSE GEN0(21(*SBI*)) ELSE ERROR(115) END (*PREDSUCC*) ; 9: BEGIN (*ORD*) IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM >= POWER THEN ERROR(125); GATTR.TYPTR := INTPTR END (*ORD*) ; 10: BEGIN (*SQR*) IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR = INTPTR THEN GEN0(24(*SQI*)) ELSE IF GATTR.TYPTR = REALPTR THEN GEN0(25(*SQR*)) ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END END (*SQR*) ; 11: BEGIN (*ABS*) IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR = INTPTR THEN GEN0(0(*ABI*)) ELSE IF GATTR.TYPTR = REALPTR THEN GEN0(1(*ABR*)) ELSE BEGIN ERROR(125); GATTR.TYPTR := INTPTR END END (*ABS*) ; 12: NEWSTMT; 13,14: UNITIO; 15: CONCAT; 16: BEGIN (*LENGTH*) STRGVAR(FSYS + [RPARENT],FALSE); GEN0(62(*LDB*)); GATTR.TYPTR := INTPTR END (*LENGTH*) ; 17: BEGIN (*INSERT*) STRGVAR(FSYS + [COMMA],FALSE); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); STRGVAR(FSYS + [COMMA],TRUE); GENLDC(GATTR.TYPTR^.MAXLENG); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); EXPRESSION(FSYS + [RPARENT]); LOAD; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GEN2(77(*CXP*),0(*SYS*),24(*SINSERT*)) END (*INSERT*) ; 18,19: COPYDELETE; 20: BEGIN (*POS*) STRGVAR(FSYS + [COMMA],FALSE); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); STRGVAR(FSYS + [RPARENT],FALSE); GENLDC(0); GENLDC(0); GEN2(77(*CXP*),0(*SYS*),27(*SPOS*)); GATTR.TYPTR := INTPTR END (*POS*) ; 27,21,22: MOVE; 23: EXIT; 24: BEGIN (*IDSEARCH*) VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS + [RPARENT]); LOADADDRESS; GEN1(30(*CSP*),7(*IDS*)) END (*IDSEARCH*) ; 25: BEGIN (*TREESEARCH*) IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS + [RPARENT]); LOADADDRESS; GATTR.TYPTR := INTPTR; GEN1(30(*CSP*),8(*TRS*)) END (*TREESEARCH*) ; 26: BEGIN (*TIME*) VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); VARIABLE(FSYS + [RPARENT]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> INTPTR THEN ERROR(125); GEN1(30(*CSP*),9(*TIM*)) END (*TIME*) ; 28,29,30: BEGIN (*OPEN*) VARIABLE(FSYS + [COMMA]); LOADADDRESS; IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> FILES THEN ERROR(125); IF SY = COMMA THEN INSYMBOL ELSE ERROR(20); STRGVAR(FSYS + [RPARENT],FALSE); IF LKEY = 28 THEN GENLDC(0) ELSE GENLDC(1); GENLDC(0); GEN2(77(*CXP*),0(*SYS*),5(*FOPEN*)); IF IOCHECK THEN GEN1(30(*CSP*),0(*IOC*)) END (*OPEN*) ; 31: CLOSE; 32,33,34,35,40: GETPUTETC; 36: SCAN; 37,38: BLOCKIO; 39,42: DRAWSTUFF; 41: SIZEOF END (*SPECIAL CASES*) ; IF WASLPARENT THEN IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END (*SPECIAL PROCEDURES AND FUNCTIONS*) ELSE CALLNONSPECIAL END (*CALL*) ; ======================================================================================== DOCUMENT :usus Folder:VOL17:comp.e.text ======================================================================================== PROCEDURE EXPRESSION; VAR LATTR: ATTR; LOP: OPERATOR; TYPIND: INTEGER; LSIZE: ADDRRANGE; LSTRING,GSTRING: BOOLEAN; LMIN,LMAX: INTEGER; PROCEDURE FLOATIT(VAR FSP: STP); BEGIN IF GATTR.TYPTR = INTPTR THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; IF FSP = INTPTR THEN BEGIN GEN0(9(*FLO*)); FSP := REALPTR END END (*FLOATIT*) ; PROCEDURE SIMPLEEXPRESSION(FSYS: SETOFSYS); VAR LATTR: ATTR; LOP: OPERATOR; SIGNED: BOOLEAN; PROCEDURE TERM(FSYS: SETOFSYS); VAR LATTR: ATTR; LOP: OPERATOR; PROCEDURE FACTOR(FSYS: SETOFSYS); VAR LCP: CTP; LVP: CSP; VARPART,ALLCONST: BOOLEAN; LSP: STP; HIGHVAL,LOWVAL,LIC,LOP: INTEGER; CSTPART: SET OF 0..127; BEGIN IF NOT (SY IN FACBEGSYS) THEN BEGIN ERROR(58); SKIP(FSYS + FACBEGSYS); GATTR.TYPTR := NIL END; WHILE SY IN FACBEGSYS DO BEGIN CASE SY OF (*ID*) IDENT: BEGIN SEARCHID([KONST,VARS,FIELD,FUNC],LCP); INSYMBOL; IF LCP^.KLASS = FUNC THEN BEGIN CALL(FSYS,LCP); GATTR.KIND := EXPR END ELSE IF LCP^.KLASS = KONST THEN WITH GATTR, LCP^ DO BEGIN TYPTR := IDTYPE; KIND := CST; CVAL := VALUES END ELSE SELECTOR(FSYS,LCP); IF GATTR.TYPTR <> NIL THEN WITH GATTR,TYPTR^ DO IF FORM = SUBRANGE THEN TYPTR := RANGETYPE END; (*CST*) INTCONST: BEGIN WITH GATTR DO BEGIN TYPTR := INTPTR; KIND := CST; CVAL := VAL END; INSYMBOL END; REALCONST: BEGIN WITH GATTR DO BEGIN TYPTR := REALPTR; KIND := CST; CVAL := VAL END; INSYMBOL END; STRINGCONST: BEGIN WITH GATTR DO BEGIN IF LGTH = 1 THEN TYPTR := CHARPTR ELSE BEGIN NEW(LSP,ARRAYS,TRUE,TRUE); LSP^ := STRGPTR^; LSP^.MAXLENG := LGTH; TYPTR := LSP END; KIND := CST; CVAL := VAL END; INSYMBOL END; (*(*) LPARENT: BEGIN INSYMBOL; EXPRESSION(FSYS + [RPARENT]); IF SY = RPARENT THEN INSYMBOL ELSE ERROR(4) END; (*NOT*) NOTSY: BEGIN INSYMBOL; FACTOR(FSYS); LOAD; GEN0(19(*NOT*)); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR <> BOOLPTR THEN BEGIN ERROR(135); GATTR.TYPTR := NIL END; END; (*[*) LBRACK: BEGIN INSYMBOL; CSTPART := [ ]; VARPART := FALSE; NEW(LSP,POWER); WITH LSP^ DO BEGIN ELSET := NIL; SIZE := 0; FORM := POWER END; IF SY = RBRACK THEN BEGIN WITH GATTR DO BEGIN TYPTR := LSP; KIND := CST END; INSYMBOL END ELSE BEGIN REPEAT EXPRESSION(FSYS + [COMMA,RBRACK,COLON]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN BEGIN ERROR(136); GATTR.TYPTR := NIL END ELSE IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR) THEN BEGIN ALLCONST := FALSE; LOP := 23(*SGS*); IF (GATTR.KIND = CST) AND (GATTR.CVAL.IVAL <= 127) THEN BEGIN ALLCONST := TRUE; LOWVAL := GATTR.CVAL.IVAL; HIGHVAL := LOWVAL END; LIC := IC; LOAD; IF SY = COLON THEN BEGIN INSYMBOL; LOP := 20(*SRS*); EXPRESSION(FSYS + [COMMA,RBRACK]); IF COMPTYPES(LSP^.ELSET,GATTR.TYPTR) THEN ELSE BEGIN ERROR(137); GATTR.TYPTR:=NIL END; IF ALLCONST THEN IF (GATTR.KIND = CST) AND (GATTR.CVAL.IVAL <= 127) THEN HIGHVAL := GATTR.CVAL.IVAL ELSE BEGIN LOAD; ALLCONST := FALSE END ELSE LOAD END; IF ALLCONST THEN BEGIN IC := LIC; (*FORGET FIRST CONST*) CSTPART := CSTPART + [LOWVAL..HIGHVAL] END ELSE BEGIN GEN0(LOP); IF VARPART THEN GEN0(28(*UNI*)) ELSE VARPART := TRUE END; LSP^.ELSET := GATTR.TYPTR; GATTR.TYPTR := LSP END ELSE ERROR(137); TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = RBRACK THEN INSYMBOL ELSE ERROR(12) END; IF VARPART THEN BEGIN IF CSTPART <> [ ] THEN BEGIN SCONST^.PVAL := CSTPART; SCONST^.CCLASS := PSET; GATTR.CVAL.VALP := SCONST; GATTR.KIND := CST; LOAD; GEN0(28(*UNI*)) END; GATTR.KIND := EXPR END ELSE BEGIN SCONST^.PVAL := CSTPART; SCONST^.CCLASS := PSET; GATTR.CVAL.VALP := SCONST; GATTR.KIND := CST END END END (*CASE*) ; IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS + FACBEGSYS) END END (*WHILE*) END (*FACTOR*) ; BEGIN (*TERM*) FACTOR(FSYS + [MULOP]); WHILE SY = MULOP DO BEGIN LOAD; LATTR := GATTR; LOP := OP; INSYMBOL; FACTOR(FSYS + [MULOP]); LOAD; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN CASE LOP OF (***) MUL: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN0(15(*MPI*)) ELSE BEGIN FLOATIT(LATTR.TYPTR); IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GEN0(16(*MPR*)) ELSE IF (LATTR.TYPTR^.FORM = POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN GEN0(12(*INT*)) ELSE BEGIN ERROR(134); GATTR.TYPTR:=NIL END END; (*/*) RDIV: BEGIN FLOATIT(LATTR.TYPTR); IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GEN0(7(*DVR*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; (*DIV*) IDIV: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN0(6(*DVI*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END; (*MOD*) IMOD: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN0(14(*MOD*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END; (*AND*) ANDOP:IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) THEN GEN0(4(*AND*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END (*CASE*) ELSE GATTR.TYPTR := NIL END (*WHILE*) END (*TERM*) ; BEGIN (*SIMPLEEXPRESSION*) SIGNED := FALSE; IF (SY = ADDOP) AND (OP IN [PLUS,MINUS]) THEN BEGIN SIGNED := OP = MINUS; INSYMBOL END; TERM(FSYS + [ADDOP]); IF SIGNED THEN BEGIN LOAD; IF GATTR.TYPTR = INTPTR THEN GEN0(17(*NGI*)) ELSE IF GATTR.TYPTR = REALPTR THEN GEN0(18(*NGR*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; WHILE SY = ADDOP DO BEGIN LOAD; LATTR := GATTR; LOP := OP; INSYMBOL; TERM(FSYS + [ADDOP]); LOAD; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN CASE LOP OF (*+*) PLUS: IF (LATTR.TYPTR = INTPTR)AND(GATTR.TYPTR = INTPTR) THEN GEN0(2(*ADI*)) ELSE BEGIN FLOATIT(LATTR.TYPTR); IF (LATTR.TYPTR = REALPTR)AND(GATTR.TYPTR = REALPTR) THEN GEN0(3(*ADR*)) ELSE IF (LATTR.TYPTR^.FORM = POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN GEN0(28(*UNI*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; (*-*) MINUS: IF (LATTR.TYPTR = INTPTR) AND (GATTR.TYPTR = INTPTR) THEN GEN0(21(*SBI*)) ELSE BEGIN FLOATIT(LATTR.TYPTR); IF (LATTR.TYPTR = REALPTR) AND (GATTR.TYPTR = REALPTR) THEN GEN0(22(*SBR*)) ELSE IF (LATTR.TYPTR^.FORM = POWER) AND COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN GEN0(5(*DIF*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END; (*OR*) OROP: IF (LATTR.TYPTR = BOOLPTR) AND (GATTR.TYPTR = BOOLPTR) THEN GEN0(13(*IOR*)) ELSE BEGIN ERROR(134); GATTR.TYPTR := NIL END END (*CASE*) ELSE GATTR.TYPTR := NIL END (*WHILE*) END (*SIMPLEEXPRESSION*) ; PROCEDURE MAKEPA(VAR STRGFSP: STP; PAFSP: STP); VAR LMIN,LMAX: INTEGER; BEGIN IF PAFSP^.INXTYPE <> NIL THEN BEGIN GETBOUNDS(PAFSP^.INXTYPE,LMIN,LMAX); IF LMAX-LMIN+1 <> STRGFSP^.MAXLENG THEN ERROR(129) END; STRGFSP := PAFSP END (*MAKEPA*) ; BEGIN (*EXPRESSION*) SIMPLEEXPRESSION(FSYS + [RELOP]); IF SY = RELOP THEN BEGIN LSTRING := STRGTYPE(GATTR.TYPTR) AND (GATTR.KIND = CST); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <= POWER THEN LOAD ELSE LOADADDRESS; LATTR := GATTR; LOP := OP; INSYMBOL; SIMPLEEXPRESSION(FSYS); GSTRING := STRGTYPE(GATTR.TYPTR) AND (GATTR.KIND = CST); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <= POWER THEN LOAD ELSE LOADADDRESS; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN IF LOP = INOP THEN IF GATTR.TYPTR^.FORM = POWER THEN IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR^.ELSET) THEN GEN0(11(*INN*)) ELSE BEGIN ERROR(129); GATTR.TYPTR := NIL END ELSE BEGIN ERROR(130); GATTR.TYPTR := NIL END ELSE BEGIN IF LATTR.TYPTR <> GATTR.TYPTR THEN FLOATIT(LATTR.TYPTR); IF LSTRING THEN BEGIN IF PAOFCHAR(GATTR.TYPTR) THEN IF NOT GATTR.TYPTR^.AISSTRNG THEN BEGIN GEN0(29(*S2P*)); MAKEPA(LATTR.TYPTR,GATTR.TYPTR) END END ELSE IF GSTRING THEN BEGIN IF PAOFCHAR(LATTR.TYPTR) THEN IF NOT LATTR.TYPTR^.AISSTRNG THEN BEGIN GEN0(80(*S1P*)); MAKEPA(GATTR.TYPTR,LATTR.TYPTR) END; END; IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LSIZE := LATTR.TYPTR^.SIZE; CASE LATTR.TYPTR^.FORM OF SCALAR: IF LATTR.TYPTR = REALPTR THEN TYPIND := 1 ELSE IF LATTR.TYPTR = BOOLPTR THEN TYPIND := 3 ELSE TYPIND := 0; POINTER: BEGIN IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131); TYPIND := 0 END; POWER: BEGIN IF LOP IN [LTOP,GTOP] THEN ERROR(132); TYPIND := 4 END; ARRAYS: BEGIN TYPIND := 6; IF PAOFCHAR(LATTR.TYPTR) THEN IF LATTR.TYPTR^.AISSTRNG THEN TYPIND := 2 ELSE BEGIN TYPIND := 5; IF LATTR.TYPTR^.INXTYPE <> NIL THEN BEGIN GETBOUNDS(LATTR.TYPTR^.INXTYPE,LMIN,LMAX); LSIZE := LMAX - LMIN + 1 END END ELSE IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131) END; RECORDS: BEGIN IF LOP IN [LTOP,LEOP,GTOP,GEOP] THEN ERROR(131); TYPIND := 6 END; FILES: BEGIN ERROR(133); TYPIND := 0 END END; CASE LOP OF LTOP: GEN2(53(*LES*),TYPIND,LSIZE); LEOP: GEN2(52(*LEQ*),TYPIND,LSIZE); GTOP: GEN2(49(*GRT*),TYPIND,LSIZE); GEOP: GEN2(48(*GEQ*),TYPIND,LSIZE); NEOP: GEN2(55(*NEQ*),TYPIND,LSIZE); EQOP: GEN2(47(*EQU*),TYPIND,LSIZE) END END ELSE ERROR(129) END; GATTR.TYPTR := BOOLPTR; GATTR.KIND := EXPR END (*SY = RELOP*) END (*EXPRESSION*) ; PROCEDURE STATEMENT(FSYS: SETOFSYS); LABEL 1; VAR LCP: CTP; TTOP: DISPRANGE; LLP: LABELP; HEAP: ^INTEGER; PROCEDURE ASSIGNMENT(FCP: CTP); VAR LATTR: ATTR; CSTRING,PAONLEFT: BOOLEAN; LMIN,LMAX: INTEGER; BEGIN SELECTOR(FSYS + [BECOMES],FCP); IF SY = BECOMES THEN BEGIN LMAX := 0; CSTRING := FALSE; IF GATTR.TYPTR <> NIL THEN IF (GATTR.ACCESS = INDRCT) OR (GATTR.TYPTR^.FORM > POWER) THEN LOADADDRESS; PAONLEFT := PAOFCHAR(GATTR.TYPTR); LATTR := GATTR; INSYMBOL; EXPRESSION(FSYS); IF GATTR.KIND = CST THEN CSTRING := (GATTR.TYPTR = CHARPTR) OR STRGTYPE(GATTR.TYPTR); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <= POWER THEN LOAD ELSE LOADADDRESS; IF (LATTR.TYPTR <> NIL) AND (GATTR.TYPTR <> NIL) THEN BEGIN IF GATTR.TYPTR = INTPTR THEN IF COMPTYPES(REALPTR,LATTR.TYPTR) THEN BEGIN GEN0(10(*FLT*)); GATTR.TYPTR := REALPTR END; IF PAONLEFT THEN IF LATTR.TYPTR^.AISSTRNG THEN IF CSTRING AND (GATTR.TYPTR = CHARPTR) THEN GATTR.TYPTR := STRGPTR ELSE ELSE IF LATTR.TYPTR^.INXTYPE <> NIL THEN BEGIN GETBOUNDS(LATTR.TYPTR^.INXTYPE,LMIN,LMAX); LMAX := LMAX - LMIN + 1; IF CSTRING AND (GATTR.TYPTR <> CHARPTR) THEN BEGIN GEN0(80(*S1P*)); IF LMAX <> GATTR.TYPTR^.MAXLENG THEN ERROR(129); GATTR.TYPTR := LATTR.TYPTR END END ELSE GATTR.TYPTR := LATTR.TYPTR; IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN CASE LATTR.TYPTR^.FORM OF SUBRANGE: BEGIN IF RANGECHECK THEN BEGIN GENLDC(LATTR.TYPTR^.MIN.IVAL); GENLDC(LATTR.TYPTR^.MAX.IVAL); GEN0(8(*CHK*)) END; STORE(LATTR) END; POWER: BEGIN GEN1(32(*ADJ*),LATTR.TYPTR^.SIZE); STORE(LATTR) END; SCALAR, POINTER: STORE(LATTR); ARRAYS: IF PAONLEFT THEN IF LATTR.TYPTR^.AISSTRNG THEN GEN1(42(*SAS*),LATTR.TYPTR^.MAXLENG) ELSE GEN1(41(*MVB*),LMAX) ELSE GEN1(40(*MOV*),LATTR.TYPTR^.SIZE); RECORDS: GEN1(40(*MOV*),LATTR.TYPTR^.SIZE); FILES: ERROR(146) END ELSE ERROR(129) END END (*SY = BECOMES*) ELSE ERROR(51) END (*ASSIGNMENT*) ; PROCEDURE GOTOSTATEMENT; VAR LLP: LABELP; FOUND: BOOLEAN; TTOP: DISPRANGE; BEGIN IF NOT GOTOOK THEN ERROR(6); IF SY = INTCONST THEN BEGIN FOUND := FALSE; TTOP := TOP; WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP - 1; LLP := DISPLAY[TTOP].FLABEL; WHILE (LLP <> NIL) AND NOT FOUND DO WITH LLP^ DO IF LABVAL = VAL.IVAL THEN BEGIN FOUND := TRUE; GENJMP(57(*UJP*),CODELBP) END ELSE LLP := NEXTLAB; IF NOT FOUND THEN ERROR(167); INSYMBOL END ELSE ERROR(15) END (*GOTOSTATEMENT*) ; PROCEDURE COMPOUNDSTATEMENT; BEGIN REPEAT REPEAT STATEMENT(FSYS + [SEMICOLON,ENDSY]) UNTIL NOT (SY IN STATBEGSYS); TEST := SY <> SEMICOLON; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13) END (*COMPOUNDSTATEMENET*) ; PROCEDURE IFSTATEMENT; VAR LCIX1,LCIX2: LBP; BEGIN EXPRESSION(FSYS + [THENSY]); GENLABEL(LCIX1); GENFJP(LCIX1); IF SY = THENSY THEN INSYMBOL ELSE ERROR(52); STATEMENT(FSYS + [ELSESY]); IF SY = ELSESY THEN BEGIN GENLABEL(LCIX2); GENJMP(57(*UJP*),LCIX2); PUTLABEL(LCIX1); INSYMBOL; STATEMENT(FSYS); PUTLABEL(LCIX2) END ELSE PUTLABEL(LCIX1) END (*IFSTATEMENT*) ; PROCEDURE CASESTATEMENT; LABEL 1; TYPE CIP = ^CASEINFO; CASEINFO = RECORD NEXT: CIP; CSSTART: INTEGER; CSLAB: INTEGER END; VAR LSP,LSP1: STP; FSTPTR,LPT1,LPT2,LPT3: CIP; LVAL: VALU; LADDR, LCIX: LBP; NULSTMT, LMIN, LMAX: INTEGER; BEGIN EXPRESSION(FSYS + [OFSY,COMMA,COLON]); LOAD; GENLABEL(LCIX); GENJMP(57(*UJP*),LCIX); LSP := GATTR.TYPTR; IF LSP <> NIL THEN IF (LSP^.FORM <> SCALAR) OR (LSP = REALPTR) THEN BEGIN ERROR(144); LSP := NIL END; IF SY = OFSY THEN INSYMBOL ELSE ERROR(8); FSTPTR := NIL; GENLABEL(LADDR); REPEAT LPT3 := NIL; REPEAT CONSTANT(FSYS + [COMMA,COLON],LSP1,LVAL); IF LSP <> NIL THEN IF COMPTYPES(LSP,LSP1) THEN BEGIN LPT1 := FSTPTR; LPT2 := NIL; WHILE LPT1 <> NIL DO WITH LPT1^ DO BEGIN IF CSLAB <= LVAL.IVAL THEN BEGIN IF CSLAB = LVAL.IVAL THEN ERROR(156); GOTO 1 END; LPT2 := LPT1; LPT1 := NEXT END; 1: NEW(LPT3); WITH LPT3^ DO BEGIN NEXT := LPT1; CSLAB := LVAL.IVAL; CSSTART := IC END; IF LPT2 = NIL THEN FSTPTR := LPT3 ELSE LPT2^.NEXT := LPT3 END ELSE ERROR(147); TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); REPEAT STATEMENT(FSYS + [SEMICOLON]) UNTIL NOT (SY IN STATBEGSYS); IF LPT3 <> NIL THEN GENJMP(57(*UJP*),LADDR); TEST := SY <> SEMICOLON; IF NOT TEST THEN INSYMBOL UNTIL TEST; PUTLABEL(LCIX); IF FSTPTR <> NIL THEN BEGIN LMAX := FSTPTR^.CSLAB; LPT1 := FSTPTR; FSTPTR := NIL; REPEAT LPT2 := LPT1^.NEXT; LPT1^.NEXT := FSTPTR; FSTPTR := LPT1; LPT1 := LPT2 UNTIL LPT1 = NIL; LMIN := FSTPTR^.CSLAB; GEN0(44(*XJP*)); GENWORD(LMIN); GENWORD(LMAX); NULSTMT := IC; GENJMP(57(*UJP*),LADDR); REPEAT WITH FSTPTR^ DO BEGIN WHILE CSLAB > LMIN DO BEGIN GENWORD(IC-NULSTMT); LMIN := LMIN + 1 END; GENWORD(IC-CSSTART); FSTPTR := NEXT; LMIN := LMIN + 1 END UNTIL FSTPTR = NIL; PUTLABEL(LADDR) END; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13) END (*CASESTATEMENT*) ; PROCEDURE REPEATSTATEMENT; VAR LADDR: LBP; BEGIN GENLABEL(LADDR); PUTLABEL(LADDR); REPEAT REPEAT STATEMENT(FSYS + [SEMICOLON,UNTILSY]) UNTIL NOT (SY IN STATBEGSYS); TEST := SY <> SEMICOLON; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = UNTILSY THEN BEGIN INSYMBOL; EXPRESSION(FSYS); GENFJP(LADDR) END ELSE ERROR(53) END (*REPEATSTATEMENT*) ; PROCEDURE WHILESTATEMENT; VAR LADDR, LCIX: LBP; BEGIN GENLABEL(LADDR); PUTLABEL(LADDR); EXPRESSION(FSYS + [DOSY]); GENLABEL(LCIX); GENFJP(LCIX); IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); GENJMP(57(*UJP*),LADDR); PUTLABEL(LCIX) END (*WHILESTATEMENT*) ; PROCEDURE FORSTATEMENT; VAR LATTR: ATTR; LSP: STP; LSY: SYMBOL; LCIX, LADDR: LBP; BEGIN IF SY = IDENT THEN BEGIN SEARCHID([VARS],LCP); WITH LCP^, LATTR DO BEGIN TYPTR := IDTYPE; KIND := VARBL; IF VKIND = ACTUAL THEN BEGIN ACCESS := DRCT; VLEVEL := VLEV; DPLMT := VADDR END ELSE BEGIN ERROR(155); TYPTR := NIL END END; IF LATTR.TYPTR <> NIL THEN IF (LATTR.TYPTR^.FORM > SUBRANGE) OR COMPTYPES(REALPTR,LATTR.TYPTR) THEN BEGIN ERROR(143); LATTR.TYPTR := NIL END; INSYMBOL END ELSE BEGIN ERROR(2); SKIP(FSYS + [BECOMES,TOSY,DOWNTOSY,DOSY]) END; IF SY = BECOMES THEN BEGIN INSYMBOL; EXPRESSION(FSYS + [TOSY,DOWNTOSY,DOSY]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(144) ELSE IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LOAD; IF LATTR.TYPTR <> NIL THEN IF (LATTR.TYPTR^.FORM = SUBRANGE) AND RANGECHECK THEN BEGIN GENLDC(LATTR.TYPTR^.MIN.IVAL); GENLDC(LATTR.TYPTR^.MAX.IVAL); GEN0(8(*CHK*)) END; STORE(LATTR) END ELSE ERROR(145) END ELSE BEGIN ERROR(51); SKIP(FSYS + [TOSY,DOWNTOSY,DOSY]) END; GENLABEL(LADDR); IF SY IN [TOSY,DOWNTOSY] THEN BEGIN LSY := SY; INSYMBOL; EXPRESSION(FSYS + [DOSY]); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM <> SCALAR THEN ERROR(144) ELSE IF COMPTYPES(LATTR.TYPTR,GATTR.TYPTR) THEN BEGIN LOAD; IF LATTR.TYPTR <> NIL THEN IF (LATTR.TYPTR^.FORM = SUBRANGE) AND RANGECHECK THEN BEGIN GENLDC(LATTR.TYPTR^.MIN.IVAL); GENLDC(LATTR.TYPTR^.MAX.IVAL); GEN0(8(*CHK*)) END; GEN2(56(*STR*),0,LC); PUTLABEL(LADDR); GATTR := LATTR; LOAD; GEN2(54(*LOD*),0,LC); LC := LC + INTSIZE; IF LC > LCMAX THEN LCMAX := LC; IF LSY = TOSY THEN GEN2(52(*LEQ*),0,INTSIZE) ELSE GEN2(48(*GEQ*),0,INTSIZE); END ELSE ERROR(145) END ELSE BEGIN ERROR(55); SKIP(FSYS + [DOSY]) END; GENLABEL(LCIX); GENJMP(33(*FJP*),LCIX); IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); GATTR := LATTR; LOAD; GENLDC(1); IF LSY = TOSY THEN GEN0(2(*ADI*)) ELSE GEN0(21(*SBI*)); STORE(LATTR); GENJMP(57(*UJP*),LADDR); PUTLABEL(LCIX); LC := LC - INTSIZE END (*FORSTATEMENT*) ; PROCEDURE WITHSTATEMENT; VAR LCP: CTP; LCNT1,LCNT2: DISPRANGE; BEGIN LCNT1 := 0; LCNT2 := 0; REPEAT IF SY = IDENT THEN BEGIN SEARCHID([VARS,FIELD],LCP); INSYMBOL END ELSE BEGIN ERROR(2); LCP := UVARPTR END; SELECTOR(FSYS + [COMMA,DOSY],LCP); IF GATTR.TYPTR <> NIL THEN IF GATTR.TYPTR^.FORM = RECORDS THEN IF TOP < DISPLIMIT THEN BEGIN TOP := TOP + 1; LCNT1 := LCNT1 + 1; WITH DISPLAY[TOP] DO BEGIN FNAME := GATTR.TYPTR^.FSTFLD END; IF GATTR.ACCESS = DRCT THEN WITH DISPLAY[TOP] DO BEGIN OCCUR := CREC; CLEV := GATTR.VLEVEL; CDSPL := GATTR.DPLMT END ELSE BEGIN LOADADDRESS; GEN2(56(*STR*),0,LC); WITH DISPLAY[TOP] DO BEGIN OCCUR := VREC; VDSPL := LC END; LC := LC + PTRSIZE; LCNT2 := LCNT2 + PTRSIZE; IF LC > LCMAX THEN LCMAX := LC END END ELSE ERROR(250) ELSE ERROR(140); TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = DOSY THEN INSYMBOL ELSE ERROR(54); STATEMENT(FSYS); TOP := TOP - LCNT1; LC := LC - LCNT2; END (*WITHSTATEMENT*) ; BEGIN (*STATEMENT*) IF SY = INTCONST THEN (*LABEL*) BEGIN TTOP := TOP; WHILE DISPLAY[TTOP].OCCUR <> BLCK DO TTOP := TTOP-1; LLP := DISPLAY[TTOP].FLABEL; WHILE LLP <> NIL DO WITH LLP^ DO IF LABVAL = VAL.IVAL THEN BEGIN IF CODELBP^.DEFINED THEN ERROR(165); PUTLABEL(CODELBP); GOTO 1 END ELSE LLP := NEXTLAB; ERROR(167); 1: INSYMBOL; IF SY = COLON THEN INSYMBOL ELSE ERROR(5) END; IF NOT (SY IN FSYS + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS) END; IF SY IN STATBEGSYS + [IDENT] THEN BEGIN MARK(HEAP); (*FOR LABEL CLEANUP*) CASE SY OF IDENT: BEGIN SEARCHID([VARS,FIELD,FUNC,PROC],LCP); INSYMBOL; IF LCP^.KLASS = PROC THEN CALL(FSYS,LCP) ELSE ASSIGNMENT(LCP) END; BEGINSY: BEGIN INSYMBOL; COMPOUNDSTATEMENT END; GOTOSY: BEGIN INSYMBOL; GOTOSTATEMENT END; IFSY: BEGIN INSYMBOL; IFSTATEMENT END; CASESY: BEGIN INSYMBOL; CASESTATEMENT END; WHILESY: BEGIN INSYMBOL; WHILESTATEMENT END; REPEATSY: BEGIN INSYMBOL; REPEATSTATEMENT END; FORSY: BEGIN INSYMBOL; FORSTATEMENT END; WITHSY: BEGIN INSYMBOL; WITHSTATEMENT END END; RELEASE(HEAP); IF IC + 100 > MAXCODE THEN BEGIN ERROR(253); IC := 0 END; IF NOT (SY IN [SEMICOLON,ENDSY,ELSESY,UNTILSY]) THEN BEGIN ERROR(6); SKIP(FSYS) END END END (*STATEMENT*) ; ======================================================================================== DOCUMENT :usus Folder:VOL17:comp.f.text ======================================================================================== PROCEDURE BLOCK(FSYS: SETOFSYS; FSY: SYMBOL; FPROCP: CTP); VAR LSY: SYMBOL; PROCEDURE LABELDECLARATION; VAR LLP: LABELP; REDEF: BOOLEAN; BEGIN REPEAT IF SY = INTCONST THEN WITH DISPLAY[TOP] DO BEGIN LLP := FLABEL; REDEF := FALSE; WHILE (LLP <> NIL) AND NOT REDEF DO IF LLP^.LABVAL <> VAL.IVAL THEN LLP := LLP^.NEXTLAB ELSE BEGIN REDEF := TRUE; ERROR(166) END; IF NOT REDEF THEN BEGIN NEW(LLP); WITH LLP^ DO BEGIN LABVAL := VAL.IVAL; CODELBP := NIL; NEXTLAB := FLABEL END; FLABEL := LLP END; INSYMBOL END ELSE ERROR(15); IF NOT ( SY IN FSYS + [COMMA, SEMICOLON] ) THEN BEGIN ERROR(6); SKIP(FSYS+[COMMA,SEMICOLON]) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14) END (* LABELDECLARATION *) ; PROCEDURE CONSTDECLARATION; VAR LCP: CTP; LSP: STP; LVALU: VALU; BEGIN IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END; WHILE SY = IDENT DO BEGIN NEW(LCP,KONST); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; NEXT := NIL; KLASS := KONST END; INSYMBOL; IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16); CONSTANT(FSYS + [SEMICOLON],LSP,LVALU); ENTERID(LCP); LCP^.IDTYPE := LSP; LCP^.VALUES := LVALU; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END END ELSE ERROR(14) END END (*CONSTDECLARATION*) ; PROCEDURE TYPEDECLARATION; VAR LCP,LCP1,LCP2: CTP; LSP: STP; LSIZE: ADDRRANGE; BEGIN IF SY <> IDENT THEN BEGIN ERROR(2); SKIP(FSYS + [IDENT]) END; WHILE SY = IDENT DO BEGIN NEW(LCP,TYPES); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; KLASS := TYPES END; INSYMBOL; IF (SY = RELOP) AND (OP = EQOP) THEN INSYMBOL ELSE ERROR(16); TYP(FSYS + [SEMICOLON],LSP,LSIZE); ENTERID(LCP); LCP^.IDTYPE := LSP; LCP1 := FWPTR; WHILE LCP1 <> NIL DO BEGIN IF LCP1^.NAME = LCP^.NAME THEN BEGIN LCP1^.IDTYPE^.ELTYPE := LCP^.IDTYPE; IF LCP1 <> FWPTR THEN LCP2^.NEXT := LCP1^.NEXT ELSE FWPTR := LCP1^.NEXT; END; LCP2 := LCP1; LCP1 := LCP1^.NEXT END; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END END ELSE ERROR(14) END; IF FWPTR <> NIL THEN BEGIN ERROR(117); FWPTR := NIL END END (*TYPEDECLARATION*) ; PROCEDURE VARDECLARATION; VAR LCP,NXT,IDLIST: CTP; LSP: STP; LSIZE: ADDRRANGE; BEGIN NXT := NIL; REPEAT REPEAT IF SY = IDENT THEN BEGIN NEW(LCP,VARS); WITH LCP^ DO BEGIN NAME := ID; NEXT := NXT; KLASS := VARS; IDTYPE := NIL; VKIND := ACTUAL; VLEV := LEVEL END; ENTERID(LCP); NXT := LCP; INSYMBOL; END ELSE ERROR(2); IF NOT (SY IN FSYS + [COMMA,COLON] + TYPEDELS) THEN BEGIN ERROR(6); SKIP(FSYS+[COMMA,COLON,SEMICOLON]+TYPEDELS) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN INSYMBOL ELSE ERROR(5); IDLIST := NXT; TYP(FSYS + [SEMICOLON] + TYPEDELS,LSP,LSIZE); WHILE NXT <> NIL DO WITH NXT^ DO BEGIN IDTYPE := LSP; VADDR := LC; LC := LC + LSIZE; NXT := NEXT; IF NEXT = NIL THEN IF LSP <> NIL THEN IF LSP^.FORM = FILES THEN BEGIN (*PUT IDLIST INTO LOCAL FILE LIST*) NEXT := DISPLAY[TOP].FFILE; DISPLAY[TOP].FFILE := IDLIST END END; IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT]) THEN BEGIN ERROR(6); SKIP(FSYS + [IDENT]) END END ELSE ERROR(14) UNTIL (SY <> IDENT) AND NOT (SY IN TYPEDELS); IF FWPTR <> NIL THEN BEGIN ERROR(117); FWPTR := NIL END END (*VARDECLARATION*) ; PROCEDURE PROCDECLARATION(FSY: SYMBOL); VAR OLDLEV: 0..MAXLEVEL; LSY: SYMBOL; LCP,LCP1: CTP; LSP: STP; FORW: BOOLEAN; OLDTOP: DISPRANGE; OLDPROC: PROCRANGE; LLC,LCM: ADDRRANGE; MARKP: ^INTEGER; PROCEDURE PARAMETERLIST(FSY: SETOFSYS; VAR FPAR: CTP; FCP: CTP); VAR LCP,LCP1,LCP2,LCP3: CTP; LSP: STP; LKIND: IDKIND; LLC,LEN : ADDRRANGE; COUNT : INTEGER; BEGIN LCP1 := NIL; LLC := LC; IF NOT (SY IN FSY + [LPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS + FSY + [LPARENT]) END; IF SY = LPARENT THEN BEGIN IF FORW THEN ERROR(119); INSYMBOL; IF NOT (SY IN [IDENT,VARSY]) THEN BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END; WHILE SY IN [IDENT,VARSY] DO BEGIN IF SY = VARSY THEN BEGIN LKIND := FORMAL; INSYMBOL END ELSE LKIND := ACTUAL; LCP2 := NIL; COUNT := 0; REPEAT IF SY = IDENT THEN BEGIN NEW(LCP,VARS); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; VKIND := LKIND; NEXT := LCP2; KLASS := VARS; VLEV := LEVEL END; ENTERID(LCP); LCP2 := LCP; COUNT := COUNT + 1; INSYMBOL END; IF NOT (SY IN FSYS + [COMMA,COLON]) THEN BEGIN ERROR(7); SKIP(FSYS + [COMMA,SEMICOLON,RPARENT,COLON]) END; TEST := SY <> COMMA; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = COLON THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN SEARCHID([TYPES],LCP); LSP := LCP^.IDTYPE; LCP3 := LCP2; LEN := PTRSIZE; IF LSP <> NIL THEN IF LKIND = ACTUAL THEN IF LSP^.FORM = FILES THEN ERROR(121) ELSE IF LSP^.FORM <= POWER THEN LEN := LSP^.SIZE; LC := LC + COUNT * LEN; WHILE LCP2 <> NIL DO BEGIN LCP := LCP2; WITH LCP2^ DO BEGIN IDTYPE := LSP; LCP2 := NEXT END END; LCP^.NEXT := LCP1; LCP1 := LCP3; INSYMBOL END ELSE ERROR(2); IF NOT (SY IN FSYS + [SEMICOLON,RPARENT]) THEN BEGIN ERROR(7); SKIP(FSYS + [SEMICOLON,RPARENT]) END; END ELSE ERROR(5); IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN FSYS + [IDENT,VARSY]) THEN BEGIN ERROR(7); SKIP(FSYS + [IDENT,RPARENT]) END END END (*WHILE*) ; IF SY = RPARENT THEN BEGIN INSYMBOL; IF NOT (SY IN FSY + FSYS) THEN BEGIN ERROR(6); SKIP(FSY + FSYS) END END ELSE ERROR(4); FCP^.LOCALLC := LC; LCP3 := NIL; WHILE LCP1 <> NIL DO WITH LCP1^ DO BEGIN LCP2 := NEXT; NEXT := LCP3; IF (KLASS = VARS) AND (IDTYPE <> NIL) THEN IF (IDTYPE^.FORM <= POWER) OR (VKIND = FORMAL) THEN BEGIN VADDR := LLC; IF VKIND = FORMAL THEN LLC := LLC + PTRSIZE ELSE LLC := LLC + IDTYPE^.SIZE END ELSE BEGIN VADDR := LC; LC := LC + IDTYPE^.SIZE; LLC := LLC + PTRSIZE END; LCP3 := LCP1; LCP1 := LCP2 END; FPAR := LCP3 END ELSE FPAR := NIL END (*PARAMETERLIST*) ; BEGIN (*PROCDECLARATION*) LLC := LC; LC := LCAFTERMARKSTACK; IF FSY = FUNCSY THEN LC := LC + REALSIZE; LINEINFO := LC; DP := TRUE; IF SY = IDENT THEN BEGIN SEARCHSECTION(DISPLAY[TOP].FNAME,LCP); IF LCP <> NIL THEN BEGIN IF LCP^.KLASS = PROC THEN FORW := LCP^.FORWDECL AND (FSY = PROCSY) AND (LCP^.PFKIND = ACTUAL) ELSE IF LCP^.KLASS = FUNC THEN FORW := LCP^.FORWDECL AND (FSY = FUNCSY) AND (LCP^.PFKIND = ACTUAL) ELSE FORW := FALSE; IF NOT FORW THEN ERROR(160) END ELSE FORW := FALSE; IF NOT FORW THEN BEGIN IF FSY = PROCSY THEN NEW(LCP,PROC,DECLARED,ACTUAL) ELSE NEW(LCP,FUNC,DECLARED,ACTUAL); WITH LCP^ DO BEGIN NAME := ID; IDTYPE := NIL; LOCALLC := LC; PFDECKIND := DECLARED; PFKIND := ACTUAL; INSCOPE := FALSE; PFLEV := LEVEL; PFNAME := NEXTPROC; PFSEG := SEG; IF NEXTPROC = MAXPROCNUM THEN ERROR(251) ELSE NEXTPROC := NEXTPROC + 1; IF FSY = PROCSY THEN KLASS := PROC ELSE KLASS := FUNC END; ENTERID(LCP) END ELSE BEGIN LCP1 := LCP^.NEXT; WHILE LCP1 <> NIL DO BEGIN WITH LCP1^ DO IF KLASS = VARS THEN IF IDTYPE <> NIL THEN BEGIN IF VKIND = FORMAL THEN LCM := VADDR + PTRSIZE ELSE LCM := VADDR + IDTYPE^.SIZE; IF LCM > LC THEN LC := LCM END; LCP1 := LCP1^.NEXT END END; INSYMBOL END ELSE BEGIN ERROR(2); LCP := UPRCPTR END; OLDLEV := LEVEL; OLDTOP := TOP; OLDPROC := CURPROC; CURPROC := LCP^.PFNAME; IF LEVEL < MAXLEVEL THEN LEVEL := LEVEL + 1 ELSE ERROR(251); IF TOP < DISPLIMIT THEN BEGIN TOP := TOP + 1; WITH DISPLAY[TOP] DO BEGIN IF FORW THEN FNAME := LCP^.NEXT ELSE FNAME := NIL; FLABEL := NIL; FFILE := NIL; OCCUR := BLCK END END ELSE ERROR(250); IF FSY = PROCSY THEN BEGIN PARAMETERLIST([SEMICOLON],LCP1,LCP); IF NOT FORW THEN LCP^.NEXT := LCP1 END ELSE BEGIN PARAMETERLIST([SEMICOLON,COLON],LCP1,LCP); IF NOT FORW THEN LCP^.NEXT := LCP1; IF SY = COLON THEN BEGIN INSYMBOL; IF SY = IDENT THEN BEGIN IF FORW THEN ERROR(122); SEARCHID([TYPES],LCP1); LSP := LCP1^.IDTYPE; LCP^.IDTYPE := LSP; IF LSP <> NIL THEN IF NOT (LSP^.FORM IN [SCALAR,SUBRANGE,POINTER]) THEN BEGIN ERROR(120); LCP^.IDTYPE := NIL END; INSYMBOL END ELSE BEGIN ERROR(2); SKIP(FSYS + [SEMICOLON]) END END ELSE IF NOT FORW THEN ERROR(123) END; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); IF SY = FORWARDSY THEN BEGIN IF FORW THEN ERROR(161) ELSE LCP^.FORWDECL := TRUE; INSYMBOL; IF SY = SEMICOLON THEN INSYMBOL ELSE ERROR(14); IF NOT (SY IN FSYS) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE BEGIN MARK(MARKP); WITH LCP^ DO BEGIN FORWDECL := FALSE; INSCOPE := TRUE END; REPEAT BLOCK(FSYS,SEMICOLON,LCP); RELEASE(MARKP); IF SY = SEMICOLON THEN BEGIN INSYMBOL; IF NOT (SY IN [BEGINSY,PROCSY,FUNCSY,PROGSY]) THEN BEGIN ERROR(6); SKIP(FSYS) END END ELSE ERROR(14) UNTIL SY IN [BEGINSY,PROCSY,FUNCSY,PROGSY]; LCP^.INSCOPE := FALSE END; LEVEL := OLDLEV; TOP := OLDTOP; LC := LLC; CURPROC := OLDPROC END (*PROCDECLARATION*) ; PROCEDURE SEGDECLARATION; VAR LSY: SYMBOL; OLDPROC: PROCRANGE; OLDSEG: SEGRANGE; BEGIN IF CODEINSEG THEN BEGIN ERROR(399); SEGINX := 0; CURBYTE := 0 END; OLDSEG := SEG; SEG := NEXTSEG; OLDPROC := NEXTPROC; IF NEXTSEG > MAXSEG THEN ERROR(250) ELSE NEXTSEG := NEXTSEG + 1; NEXTPROC := 1; LSY := SY; IF SY IN [PROCSY,FUNCSY] THEN INSYMBOL ELSE BEGIN ERROR(399); LSY := PROCSY END; IF SY = IDENT THEN SEGTABLE[SEG].SEGNAME := ID; PROCDECLARATION(LSY); IF CODEINSEG THEN FINISHSEG; NEXTPROC := OLDPROC; SEG := OLDSEG END (*SEGDECLARATION*) ; PROCEDURE BODY(FSYS: SETOFSYS); VAR LLC1,EXITIC: ADDRRANGE; LCP,LLCP: CTP; LOP: OPRANGE; LLP: LABELP; LMIN,LMAX: INTEGER; JTINX: JTABRANGE; BEGIN NEXTJTAB := 1; WRITELN(OUTPUT); IF FPROCP = NIL THEN WRITELN(OUTPUT,'SYSTEM') ELSE BEGIN WRITELN(OUTPUT,FPROCP^.NAME); LLC1 := FPROCP^.LOCALLC; LCP := FPROCP^.NEXT; WHILE LCP <> NIL DO WITH LCP^ DO BEGIN IF KLASS = VARS THEN IF IDTYPE <> NIL THEN IF (VKIND = ACTUAL) AND (IDTYPE^.FORM > POWER) THEN BEGIN LLC1 := LLC1 - PTRSIZE; GEN2(50(*LDA*),0,VADDR); GEN2(54(*LOD*),0,LLC1); IF PAOFCHAR(IDTYPE) THEN WITH IDTYPE^ DO IF AISSTRNG THEN GEN1(42(*SAS*),MAXLENG) ELSE IF INXTYPE <> NIL THEN BEGIN GETBOUNDS(INXTYPE,LMIN,LMAX); GEN1(41(*MVB*),LMAX - LMIN + 1) END ELSE ELSE GEN1(40(*MOV*),IDTYPE^.SIZE) END ELSE IF VKIND = FORMAL THEN LLC1 := LLC1 - PTRSIZE ELSE LLC1 := LLC1 - IDTYPE^.SIZE; LCP := NEXT END; END; WRITE(OUTPUT,'<',SCREENDOTS:4,'>'); STARTDOTS := SCREENDOTS; LCMAX := LC; LLP := DISPLAY[TOP].FLABEL; WHILE LLP <> NIL DO BEGIN GENLABEL(LLP^.CODELBP); LLP := LLP^.NEXTLAB END; LCP := DISPLAY[TOP].FFILE; WHILE LCP <> NIL DO WITH LCP^,IDTYPE^ DO BEGIN GEN2(50(*LDA*),0,VADDR); GEN2(50(*LDA*),0,VADDR+FILESIZE); IF FILTYPE = NIL THEN GENLDC(-1) ELSE IF FILTYPE = CHARPTR THEN GENLDC(0) ELSE GENLDC(FILTYPE^.SIZE); GEN2(77(*CXP*),0(*SYS*),3(*FINIT*)); LCP := NEXT END; REPEAT REPEAT STATEMENT(FSYS + [SEMICOLON,ENDSY]) UNTIL NOT (SY IN STATBEGSYS); TEST := SY <> SEMICOLON; IF NOT TEST THEN INSYMBOL UNTIL TEST; IF SY = ENDSY THEN INSYMBOL ELSE ERROR(13); EXITIC := IC; LCP := DISPLAY[TOP].FFILE; WHILE LCP <> NIL DO WITH LCP^ DO BEGIN GEN2(50(*LDA*),0,VADDR); GENLDC(0); GEN2(77(*CXP*),0(*SYS*),6(*FCLOSE*)); LCP := NEXT END; IF FPROCP = NIL THEN GEN0(86(*XIT*)) ELSE BEGIN IF FPROCP^.PFLEV = 0 THEN LOP := 65(*RBP*) ELSE LOP := 45(*RNP*); IF FPROCP^.IDTYPE = NIL THEN GEN1(LOP,0) ELSE GEN1(LOP,FPROCP^.IDTYPE^.SIZE) END; LLP := DISPLAY[TOP].FLABEL; (* CHECK UNDEFINED LABELS *) WHILE LLP <> NIL DO WITH LLP^,CODELBP^ DO BEGIN IF NOT DEFINED THEN IF REFLIST <> MAXADDR THEN ERROR(168); LLP := NEXTLAB END; JTINX := NEXTJTAB - 1; IF ODD(IC) THEN IC := IC + 1; WHILE JTINX > 0 DO BEGIN GENWORD(IC-JTAB[JTINX]); JTINX := JTINX-1 END; IF FPROCP = NIL THEN BEGIN GENWORD((LCMAX-LCAFTERMARKSTACK)*2); GENWORD(0) END ELSE WITH FPROCP^ DO BEGIN GENWORD((LCMAX-LOCALLC)*2); GENWORD((LOCALLC-LCAFTERMARKSTACK)*2) END; GENWORD(IC-EXITIC); GENWORD(IC); GENBYTE(CURPROC); GENBYTE(LEVEL-1); IF NOT CODEINSEG THEN BEGIN CODEINSEG := TRUE; SEGTABLE[SEG].DISKADDR := CURBLK END; WRITECODE(FALSE); SEGINX := SEGINX + IC; PROCTABLE[CURPROC] := SEGINX - 2 END (*BODY*) ; PROCEDURE FINDFORW(FCP: CTP); BEGIN IF FCP <> NIL THEN WITH FCP^ DO BEGIN IF KLASS IN [PROC,FUNC] THEN IF PFDECKIND = DECLARED THEN IF PFKIND = ACTUAL THEN IF FORWDECL THEN BEGIN USERINFO.ERRNUM := 117; WRITELN(OUTPUT); WRITE(OUTPUT,NAME,' undefined') END; FINDFORW(RLINK); FINDFORW(LLINK) END END (*FINDFORW*) ; BEGIN (*BLOCK*) REPEAT IF SY = LABELSY THEN BEGIN INSYMBOL; LABELDECLARATION END; IF SY = CONSTSY THEN BEGIN INSYMBOL; CONSTDECLARATION END; IF SY = TYPESY THEN BEGIN INSYMBOL; TYPEDECLARATION END; IF SY = VARSY THEN BEGIN INSYMBOL; VARDECLARATION END; WHILE SY IN [PROCSY,FUNCSY,PROGSY] DO BEGIN LSY := SY; INSYMBOL; IF LSY = PROGSY THEN SEGDECLARATION ELSE PROCDECLARATION(LSY) END; IF SY <> BEGINSY THEN IF NOT (INCLUDING AND (SY IN [LABELSY,CONSTSY,TYPESY,VARSY,PROCSY,FUNCSY,PROGSY])) THEN BEGIN ERROR(18); SKIP(FSYS) END UNTIL SY IN STATBEGSYS; DP := FALSE; IC := 0; LINEINFO := 0; IF SY = BEGINSY THEN INSYMBOL ELSE ERROR(17); IF NOT SYSCOMP THEN FINDFORW(DISPLAY[TOP].FNAME); REPEAT BODY(FSYS + [CASESY]); IF SY <> FSY THEN BEGIN ERROR(6); SKIP(FSYS + [FSY]) END UNTIL (SY = FSY) OR (SY IN BLOCKBEGSYS); END (*BLOCK*) ; BEGIN (*COMPILER*) COMPINIT; TIME(LGTH,LOWTIME); BLOCK(BLOCKBEGSYS+STATBEGSYS-[CASESY],PERIOD,OUTERBLOCK); IF SY <> PERIOD THEN ERROR(21); IF LIST THEN BEGIN SCREENDOTS := SCREENDOTS+1; SYMBUFP^[SYMCURSOR] := CHR(EOL); SYMCURSOR := SYMCURSOR+1; PRINTLINE END; FINISHSEG; TIME(LGTH,STARTDOTS); LOWTIME := STARTDOTS-LOWTIME; UNITWRITE(3,IC,7); WRITELN(OUTPUT); WRITE(OUTPUT,SCREENDOTS,' lines'); IF LOWTIME > 0 THEN WRITE(OUTPUT,', ',(LOWTIME+30) DIV 60,' secs, ', ROUND((3600/LOWTIME)*SCREENDOTS),' lines/min'); IC := 0; FOR SEG := 0 TO MAXSEG DO WITH SEGTABLE[SEG] DO BEGIN GENWORD(DISKADDR); GENWORD(CODELENG) END; FOR SEG := 0 TO MAXSEG DO WITH SEGTABLE[SEG] DO FOR LGTH := 1 TO 8 DO GENBYTE(ORD(SEGNAME[LGTH])); CURBLK := 0; CURBYTE := 0; WRITECODE(TRUE) END (*COMPILE*) ; BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL17:filer.text ======================================================================================== SEGMENT PROCEDURE USERPROGRAM; BEGIN END; SEGMENT PROCEDURE COMPILER; SEGMENT PROCEDURE COMPINIT; BEGIN END; BEGIN END; SEGMENT PROCEDURE EDITOR; BEGIN END; SEGMENT PROCEDURE FILEHANDLER; VAR GCH: CHAR; GDIR: DIRP; GINX: DIRRANGE; BADCOMMAND: BOOLEAN; GSEGS: INTEGER; GKIND: FILEKIND; GUNIT: UNITNUM; GBUF: WINDOWP; GBUFBLKS: INTEGER; SYMSAVED,CODESAVED: BOOLEAN; (*WORKFILE INFO...HANDY*) GVID: VID; GTID: TID; GS: STRING; GVIDTID: STRING[25]; GTITLE: STRING[39]; INSTRING: STRING[127]; GFIB: FIB; MONTHS: ARRAY [0..15] OF STRING[3]; PROCEDURE FILERINIT; TYPE ABLOCK = PACKED ARRAY [1..FBLKSIZE] OF CHAR; VAR ONEBLOCK: ^ABLOCK; GAPSIZE,QUITSIZE: INTEGER; BEGIN SYMSAVED := TRUE; CODESAVED := TRUE; WITH USERINFO DO BEGIN IF GOTSYM THEN SYMSAVED := SYMTID <> 'SYSTEM.WRK.TEXT'; IF GOTCODE THEN CODESAVED := CODETID <> 'SYSTEM.WRK.CODE' END; MONTHS[ 0] := 'XXX'; (*LEAVE THIS LINE IN!*) MONTHS[ 1] := 'JAN'; MONTHS[ 2] := 'FEB'; MONTHS[ 3] := 'MAR'; MONTHS[ 4] := 'APR'; MONTHS[ 5] := 'MAY'; MONTHS[ 6] := 'JUN'; MONTHS[ 7] := 'JUL'; MONTHS[ 8] := 'AUG'; MONTHS[ 9] := 'SEP'; MONTHS[10] := 'OCT'; MONTHS[11] := 'NOV'; MONTHS[12] := 'DEC'; MONTHS[13] := 'BAD'; MONTHS[14] := 'BAD'; MONTHS[15] := 'BAD'; BADCOMMAND := FALSE; FINIT(GFIB,NIL,-1); MARK(GBUF); GBUFBLKS := 0; QUITSIZE := SIZEOF(DIRECTORY)+SIZEOF(FIB)+1400; REPEAT NEW(ONEBLOCK); GBUFBLKS := GBUFBLKS+1; GAPSIZE := ORD(SYSCOM^.LASTMP)-ORD(ONEBLOCK)-FBLKSIZE UNTIL ((GAPSIZE > 0) AND (GAPSIZE < QUITSIZE)) OR (GBUFBLKS = 63); (*PREVENT INTEGER OFLOW*) END (*FILERINIT*) ; FUNCTION CHECKRSLT(RSLT: INTEGER): BOOLEAN; BEGIN CHECKRSLT := RSLT = 0; CASE RSLT OF 1: WRITE(OUTPUT,'Hard parity (CRC) error'); 2: WRITE(OUTPUT,'Illegal unit number'); 3: WRITE(OUTPUT,'Illegal operation on unit'); 4: WRITE(OUTPUT,'Undefined hardware error'); 5: WRITE(OUTPUT,'Volume has gone off-line'); 6: WRITE(OUTPUT,'File lost in directory'); 7: WRITE(OUTPUT,'Illegal file name'); 8: WRITE(OUTPUT,'Insufficient space on volume'); 9: WRITE(OUTPUT,'No such volume on-line'); 10: WRITE(OUTPUT,'No such file on volume'); 11: WRITE(OUTPUT,'Duplicate directory entries'); 12: WRITE(OUTPUT,'Filer bug!! not closed file') END END (* CHECKRSLT *) ; FUNCTION GETTITLE(MSG: STRING): BOOLEAN; VAR I: INTEGER; BEGIN GETTITLE := FALSE; GVIDTID := ''; GTITLE := ''; IF LENGTH(INSTRING) = 0 THEN BEGIN WRITE(OUTPUT,MSG); IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN WRITE(OUTPUT,' what file'); WRITE(OUTPUT,'? '); READLN(INPUT,INSTRING) END; IF LENGTH(INSTRING) > 0 THEN BEGIN I := SCAN(LENGTH(INSTRING), = ',', INSTRING[1]); IF I < LENGTH(INSTRING) THEN BEGIN GTITLE := COPY(INSTRING,1,I); DELETE(INSTRING,1,I+1) END ELSE BEGIN GTITLE := INSTRING; INSTRING := '' END; IF SCANTITLE(GTITLE,GVID,GTID,GSEGS,GKIND) THEN BEGIN GETTITLE := TRUE; GVIDTID := CONCAT(GVID,':',GTID) END ELSE WRITE(OUTPUT,'Illegal file name') END END (* GETTITLE *) ; FUNCTION GETVOLUME(LOOKHARD: BOOLEAN): BOOLEAN; LABEL 1; BEGIN GETVOLUME := FALSE; WRITE(OUTPUT,GS); READLN(INPUT,GS); INSERT(':',GS,LENGTH(GS)+1); IF SCANTITLE(GS,GVID,GTID,GSEGS,GKIND) THEN BEGIN GUNIT := VOLSEARCH(GVID,LOOKHARD,GDIR); GETVOLUME := GUNIT > 0; IF GUNIT = 0 THEN WRITE(OUTPUT,GVID,': is not on-line') ELSE IF LOOKHARD AND NOT UNITABLE[GUNIT].UISBLKD THEN BEGIN GETVOLUME := FALSE; WRITE(OUTPUT,GVID,': does not have a directory') END END ELSE WRITE(OUTPUT,'Illegal volume name') END (*GETVOLUME*) ; PROCEDURE WHATWORK; BEGIN WITH USERINFO DO BEGIN WRITELN(OUTPUT); IF GOTSYM OR GOTCODE THEN BEGIN WRITE(OUTPUT,'Workfile is '); IF LENGTH(WORKTID) > 0 THEN WRITE(OUTPUT,WORKTID) ELSE WRITE(OUTPUT,'not named'); IF NOT (SYMSAVED AND CODESAVED) THEN WRITE(OUTPUT,' (not saved)') END ELSE WRITE(OUTPUT,'No workfile') END END (*WHATWORK*) ; PROCEDURE NEWWORK(GIVEBLURB: BOOLEAN); LABEL 1; BEGIN WITH USERINFO DO BEGIN IF NOT (SYMSAVED AND CODESAVED) THEN BEGIN WRITE(OUTPUT,'Throw away current workfile? '); IF GETCHAR(FALSE) <> 'Y' THEN GOTO 1; IF NOT GIVEBLURB THEN WRITELN(OUTPUT) END; IF NOT SYMSAVED THEN BEGIN GS := '*SYSTEM.WRK.TEXT'; FOPEN(GFIB,GS,TRUE,NIL); FCLOSE(GFIB,CPURGE) END; IF NOT CODESAVED THEN BEGIN GS := '*SYSTEM.WRK.CODE'; FOPEN(GFIB,GS,TRUE,NIL); FCLOSE(GFIB,CPURGE) END; SYMSAVED := TRUE; CODESAVED := TRUE; GOTSYM := FALSE; GOTCODE := FALSE; WORKTID := ''; SYMTID := ''; CODETID := ''; IF GIVEBLURB THEN BEGIN WRITELN(OUTPUT); WRITE(OUTPUT,'Empty workfile created') END END; 1: END (*NEWWORK*) ; PROCEDURE GETWORK; BEGIN NEWWORK(FALSE); WITH USERINFO DO IF NOT (GOTSYM OR GOTCODE) THEN IF GETTITLE('Get') THEN IF (LENGTH(GTID) > 0) AND (LENGTH(GTID) <= TIDLENG-5) THEN BEGIN WORKVID := GVID; WORKTID := GTID; SYMTID := CONCAT(GTID,'.TEXT'); SYMVID := GVID; GVIDTID := CONCAT(SYMVID,':',SYMTID); FOPEN(GFIB,GVIDTID,TRUE,NIL); GOTSYM := GFIB.FISOPEN; IF GOTSYM THEN FCLOSE(GFIB,CNORMAL) ELSE SYMTID := ''; CODETID := CONCAT(GTID,'.CODE'); CODEVID := GVID; GVIDTID := CONCAT(CODEVID,':',CODETID); FOPEN(GFIB,GVIDTID,TRUE,NIL); GOTCODE := GFIB.FISOPEN; IF GOTCODE THEN FCLOSE(GFIB,CNORMAL) ELSE CODETID := ''; IF GOTSYM THEN WRITE(OUTPUT,'Text '); IF GOTSYM AND GOTCODE THEN WRITE(OUTPUT,'and '); IF GOTCODE THEN WRITE(OUTPUT,'Code '); IF NOT (GOTSYM OR GOTCODE) THEN BEGIN WORKTID := ''; WRITE(OUTPUT,'No ') END; WRITE(OUTPUT,'file loaded') END ELSE BEGIN WORKTID := ''; WRITE(OUTPUT,'Illegal workfile name') END END (*GETWORK*) ; PROCEDURE SAVEWORK; LABEL 1; VAR GETNEWTID: BOOLEAN; BEGIN WITH USERINFO DO BEGIN IF SYMSAVED AND CODESAVED THEN BEGIN WRITELN(OUTPUT); IF GOTSYM OR GOTCODE THEN WRITE(OUTPUT,'Workfile already saved') ELSE WRITE(OUTPUT,'No workfile to save'); GOTO 1 END; IF WORKVID <> SYVID THEN WORKTID := ''; GETNEWTID := LENGTH(WORKTID) = 0; IF NOT GETNEWTID THEN BEGIN WRITE(OUTPUT,'Save as ',WORKTID,'? '); GETNEWTID := GETCHAR(TRUE) <> 'Y'; WRITELN(OUTPUT) END; IF GETNEWTID THEN IF GETTITLE('Save as') THEN BEGIN WORKVID := GVID; WORKTID := GTID END ELSE GOTO 1; IF (LENGTH(WORKTID) = 0) OR (LENGTH(WORKTID) > TIDLENG-5) THEN BEGIN WORKTID := ''; WRITE(OUTPUT,'Illegal workfile name'); GOTO 1 END; IF WORKVID <> SYVID THEN BEGIN WORKTID := ''; WRITE(OUTPUT,'Must save on system disk for now'); GOTO 1 END; IF NOT SYMSAVED THEN BEGIN GTITLE := '*SYSTEM.WRK.TEXT'; FOPEN(GFIB,GTITLE,TRUE,NIL); IF GFIB.FISOPEN THEN WITH GFIB.FHEADER DO BEGIN DACCESS.YEAR := 100; SYMTID := CONCAT(WORKTID,'.TEXT'); DTID := SYMTID; FCLOSE(GFIB,CNORMAL) END ELSE BEGIN GOTSYM := FALSE; WRITELN(OUTPUT,'Lost workfile!') END; SYMSAVED := TRUE; WRITE(OUTPUT,'Text '); IF NOT CODESAVED THEN WRITE(OUTPUT,'and ') END; IF NOT CODESAVED THEN BEGIN GTITLE := '*SYSTEM.WRK.CODE'; FOPEN(GFIB,GTITLE,TRUE,NIL); IF GFIB.FISOPEN THEN WITH GFIB.FHEADER DO BEGIN DACCESS.YEAR := 100; CODETID := CONCAT(WORKTID,'.CODE'); DTID := CODETID; FCLOSE(GFIB,CNORMAL) END ELSE BEGIN GOTCODE := FALSE; WRITE(OUTPUT,'Lost workfile!') END; CODESAVED := TRUE; WRITE(OUTPUT,'Code ') END; WRITE(OUTPUT,'file saved') END; 1: END (*SAVEWORK*) ; PROCEDURE PREFIXER; BEGIN GS := 'Default prefix volume name? '; IF NOT GETVOLUME(TRUE) THEN WRITELN(OUTPUT); DKVID := GVID; WRITE(OUTPUT,'Default prefix is ',DKVID,':') END (*PREFIXER*) ; PROCEDURE CHANGER; VAR LFIB: FIB; BEGIN REPEAT IF GETTITLE('Change') THEN BEGIN FOPEN(GFIB,GVIDTID,TRUE,NIL); IF CHECKRSLT(IORESULT) THEN BEGIN IF GETTITLE('To') THEN WITH GFIB DO BEGIN FINIT(LFIB,NIL,-1); IF FISBLKD AND (LENGTH(FHEADER.DTID) > 0) THEN BEGIN GVID := FVID; GVIDTID := CONCAT(GVID,':',GTID) END; FOPEN(LFIB,GVIDTID,TRUE,NIL); IF FISBLKD AND (LENGTH(FHEADER.DTID) > 0) THEN IF LENGTH(GTID) = 0 THEN WRITE(OUTPUT,'Must specify both titles') ELSE BEGIN IF LFIB.FISOPEN THEN BEGIN WRITE(OUTPUT,GTID,' exists...remove it? '); IF GETCHAR(TRUE) = 'Y' THEN BEGIN FCLOSE(LFIB,CNORMAL); WRITELN(OUTPUT) END END; IF NOT LFIB.FISOPEN THEN BEGIN WRITE(OUTPUT,FVID,':',FHEADER.DTID, ' changed to ',GTID); FHEADER.DTID := GTID; FHEADER.DACCESS.YEAR := 100 END END ELSE IF LENGTH(GTID) > 0 THEN WRITE(OUTPUT,'No title may be specified') ELSE IF LFIB.FISOPEN THEN WRITE(OUTPUT,'No duplicate volume names') ELSE BEGIN UNITABLE[FUNIT].UVID := GVID; IF FISBLKD THEN BEGIN (*CHANGE VOLUME NAME IN DIR*) NEW(GDIR); UNITREAD(FUNIT,GDIR^,SIZEOF(DIRECTORY),DIRBLK); GDIR^[0].DVID := GVID; UNITWRITE(FUNIT,GDIR^,(GDIR^[0].DNUMFILES+1) *SIZEOF(DIRENTRY),DIRBLK); RELEASE(GDIR) END; WRITE(OUTPUT,FVID,': changed to ',GVID,':'); FVID := GVID END; FCLOSE(LFIB,CNORMAL) END; FCLOSE(GFIB,CNORMAL) END END; IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT) UNTIL LENGTH(INSTRING) = 0 END (*CHANGER*) ; PROCEDURE REMOVER; BEGIN REPEAT IF GETTITLE('Remove') THEN BEGIN FOPEN(GFIB,GTITLE,TRUE,NIL); IF CHECKRSLT(IORESULT) THEN BEGIN FCLOSE(GFIB,CPURGE); IF CHECKRSLT(IORESULT) THEN WRITE(OUTPUT,GVIDTID,' removed') END END; IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT) UNTIL LENGTH(INSTRING) = 0 END (*REMOVER*) ; PROCEDURE TRANSFER; VAR NBLOCKS,RSLT: INTEGER; LFIB: FIB; BEGIN REPEAT IF GETTITLE('Transfer') THEN BEGIN FOPEN(GFIB,GTITLE,TRUE,NIL); IF CHECKRSLT(IORESULT) THEN BEGIN NBLOCKS := FBLOCKIO(GFIB,GBUF^,GBUFBLKS,-1,TRUE); IF CHECKRSLT(IORESULT) THEN IF GETTITLE('To') THEN BEGIN FINIT(LFIB,NIL,-1); FOPEN(LFIB,GTITLE,FALSE,NIL); IF CHECKRSLT(IORESULT) THEN BEGIN WHILE NBLOCKS > 0 DO BEGIN RSLT := FBLOCKIO(LFIB,GBUF^,NBLOCKS, -1,FALSE); IF RSLT = NBLOCKS THEN IF GFIB.FEOF THEN NBLOCKS := 0 ELSE BEGIN NBLOCKS := FBLOCKIO(GFIB,GBUF^,GBUFBLKS, -1,TRUE); IF NOT CHECKRSLT(IORESULT) THEN BEGIN NBLOCKS := 0; FCLOSE(LFIB,CPURGE) END END ELSE BEGIN NBLOCKS := 0; FCLOSE(LFIB,CPURGE); WRITE(OUTPUT,'Output file full') END END; IF LFIB.FISOPEN THEN BEGIN WRITE(OUTPUT,GFIB.FVID,':',GFIB.FHEADER.DTID, ' transferred to ',LFIB.FVID, ':',LFIB.FHEADER.DTID); WITH LFIB,GFIB.FHEADER DO BEGIN FHEADER.DLASTBYTE := DLASTBYTE; FHEADER.DFKIND := DFKIND; FHEADER.DACCESS := DACCESS; IF (DACCESS.MONTH = 0) AND (THEDATE.MONTH > 0) THEN FHEADER.DACCESS := THEDATE END; FCLOSE(LFIB,CLOCK) END END END; FCLOSE(GFIB,CNORMAL) END END; IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT) UNTIL LENGTH(INSTRING) = 0 END (*TRANSFER*) ; PROCEDURE MAKEFILE; BEGIN REPEAT IF GETTITLE('Make') THEN BEGIN FOPEN(GFIB,GTITLE,FALSE,NIL); IF CHECKRSLT(IORESULT) THEN BEGIN WITH GFIB DO FMAXBLK := FHEADER.DLASTBLK-FHEADER.DFIRSTBLK; FCLOSE(GFIB,CLOCK); IF CHECKRSLT(IORESULT) THEN WRITE(OUTPUT,GVIDTID,' created') END END; IF LENGTH(INSTRING) > 0 THEN WRITELN(OUTPUT) UNTIL LENGTH(INSTRING) = 0 END (*MAKEFILE*) ; PROCEDURE LISTDIR(DETAIL: BOOLEAN); VAR I: DIRRANGE; LINE,LARGEST,FREEBLKS,USEDAREA,USEDBLKS: INTEGER; PROCEDURE WRITELINE; BEGIN IF LINE = SYSCOM^.CRTINFO.HEIGHT THEN BEGIN IF SPACEWAIT THEN EXIT(LISTDIR); CLEARSCREEN; LINE := 2; WRITELN(OUTPUT); WRITE(OUTPUT,GVID,':') END; LINE := LINE+1; WRITELN(OUTPUT) END (*WRITELINE*) ; PROCEDURE FREECHECK(FIRSTOPEN,NEXTUSED: INTEGER); VAR FREEAREA: INTEGER; BEGIN FREEAREA := NEXTUSED-FIRSTOPEN; IF FREEAREA > LARGEST THEN LARGEST := FREEAREA; IF FREEAREA > 0 THEN BEGIN FREEBLKS := FREEBLKS+FREEAREA; IF DETAIL THEN BEGIN WRITE(OUTPUT,'< UNUSED > ', FREEAREA:4,' ':11,FIRSTOPEN:6); WRITELINE END END; END (*FREECHECK*) ; BEGIN (*LISTDIR*) GS := 'Directory of what volume? '; IF GETVOLUME(TRUE) THEN BEGIN FREEBLKS := 0; USEDBLKS := 0; LARGEST := 0; LINE := 3; WRITELN(OUTPUT,GVID,':'); FOR I := 1 TO GDIR^[0].DNUMFILES DO WITH GDIR^[I] DO BEGIN FREECHECK(GDIR^[I-1].DLASTBLK,DFIRSTBLK); USEDAREA := DLASTBLK-DFIRSTBLK; USEDBLKS := USEDBLKS+USEDAREA; WRITE(OUTPUT,DTID,' ':TIDLENG-LENGTH(DTID)+1,USEDAREA:4); IF DACCESS.MONTH > 0 THEN WRITE(OUTPUT,' ':2,DACCESS.DAY:2,'-', MONTHS[DACCESS.MONTH],'-',DACCESS.YEAR:2); IF DETAIL THEN BEGIN IF DACCESS.MONTH = 0 THEN WRITE(OUTPUT,' ':11); WRITE(OUTPUT,DFIRSTBLK:6,DLASTBYTE:6); GS := 'ILLEGAL'; CASE DFKIND OF XDSKFILE: GS := 'Bad disk'; CODEFILE: GS := 'Codefile'; TEXTFILE: GS := 'Textfile'; INFOFILE: GS := 'Infofile'; DATAFILE: GS := 'Datafile'; GRAFFILE: GS := 'Graffile'; FOTOFILE: GS := 'Fotofile' END; WRITE(OUTPUT,' ':2,GS) END; WRITELINE END; FREECHECK(GDIR^[I-1].DLASTBLK,GDIR^[0].DEOVBLK); WRITE(OUTPUT,GDIR^[0].DNUMFILES,' files, ', USEDBLKS,' blocks in use, ', FREEBLKS,' unused'); IF DETAIL THEN WRITE(OUTPUT,', ',LARGEST,' in largest area') END END (*LISTDIR*) ; PROCEDURE LISTVOLS; BEGIN WRITELN(OUTPUT,'Volumes currently on-line:'); GVID := ''; GUNIT := VOLSEARCH(GVID,TRUE,GDIR); FOR GUNIT := 1 TO MAXUNIT DO WITH UNITABLE[GUNIT] DO IF LENGTH(UVID) > 0 THEN BEGIN WRITE(OUTPUT,GUNIT:3); IF UVID = SYVID THEN WRITE(OUTPUT,' * ') ELSE IF UVID = DKVID THEN WRITE(OUTPUT,' P ') ELSE IF UISBLKD THEN WRITE(OUTPUT,' # ') ELSE WRITE(OUTPUT,' '); WRITELN(OUTPUT,UVID,':') END END (*LISTVOLS*) ; PROCEDURE BADBLOCKS; VAR I: INTEGER; A: PACKED ARRAY [0..FBLKSIZE] OF CHAR; BEGIN GS := 'Bad blocks of what volume? '; IF GETVOLUME(TRUE) THEN FOR I := 0 TO GDIR^[0].DEOVBLK-1 DO BEGIN UNITREAD(GUNIT,A,FBLKSIZE,I); IF SYSCOM^.IORSLT <> INOERROR THEN WRITELN(OUTPUT,'Block ',I,' is bad') END END (*BADBLOCKS*) ; PROCEDURE ZEROVOLUME; LABEL 1; VAR LDE: DIRENTRY; BEGIN GUNIT := 0; WRITE(OUTPUT,'Zero what unit? '); READ(INPUT,GUNIT); IF NOT EOLN(INPUT) THEN WRITELN(OUTPUT); IF (GUNIT <= 0) OR (GUNIT > MAXUNIT) THEN BEGIN WRITE(OUTPUT,'Illegal unit #'); GOTO 1 END; IF NOT UNITABLE[GUNIT].UISBLKD THEN BEGIN WRITE(OUTPUT,'Unit cannot be zeroed'); GOTO 1 END; WRITE(OUTPUT,'New volume name ( to escape)? '); READLN(INPUT,GVID); IF LENGTH(GVID) = 0 THEN GOTO 1; WITH LDE DO BEGIN DFIRSTBLK := 0; DLASTBLK := 6; DFKIND := UNTYPEDFILE; DVID := GVID; DEOVBLK := -1; DNUMFILES := 0; WRITE(OUTPUT,'Number of blocks on volume? '); READ(INPUT,DEOVBLK); IF NOT EOLN(INPUT) THEN WRITELN(OUTPUT); IF DEOVBLK <= 0 THEN BEGIN WRITE(OUTPUT,'Illegal number of blocks'); GOTO 1 END; UNITWRITE(GUNIT,LDE,SIZEOF(LDE),DIRBLK); WRITE(OUTPUT,GVID,': zeroed') END; 1: END (*ZEROVOLUME*) ; PROCEDURE DATESET; LABEL 1; VAR MONINDX,DAYNUM,YEARNUM,I: INTEGER; OK: BOOLEAN; CH: CHAR; DELIMS: SET OF ' '..'/'; FUNCTION EATSPACES: BOOLEAN; VAR DONE: BOOLEAN; BEGIN IF LENGTH(GS) > 0 THEN REPEAT DONE := GS[1] <> ' '; IF NOT DONE THEN DELETE(GS,1,1) UNTIL DONE OR (LENGTH(GS) = 0); EATSPACES := LENGTH(GS) = 0 END (*EATSPACES*) ; BEGIN (*DATESET*) DELIMS := [' ','-','/']; PL := 'DATESET: <1..31>--<00..99> OR '; PROMPT; WRITELN(OUTPUT); WITH THEDATE DO IF MONTH = 0 THEN WRITELN(OUTPUT,'No current date') ELSE WRITELN(OUTPUT,'Today is ',DAY:2,'-',MONTHS[MONTH],'-',YEAR:2); WRITE(OUTPUT,'New date? '); READLN(INPUT,GS); IF EATSPACES THEN EXIT(DATESET); DAYNUM := 0; REPEAT OK := GS[1] IN ['0'..'9']; IF OK THEN BEGIN DAYNUM := DAYNUM*10+ORD(GS[1])-ORD('0'); OK := DAYNUM <= 9; DELETE(GS,1,1) END UNTIL (LENGTH(GS) = 0) OR NOT OK; IF (DAYNUM < 1) OR (DAYNUM > 31) THEN GOTO 1; IF EATSPACES THEN GOTO 1; IF NOT (GS[1] IN DELIMS) THEN GOTO 1; DELETE(GS,1,1); IF EATSPACES OR (LENGTH(GS) < 3) THEN GOTO 1; MONINDX := 12; FOR I := 1 TO 3 DO BEGIN CH := GS[I]; IF CH >= 'a' THEN CH := CHR(ORD(CH)-ORD('a')+ORD('A')); MONTHS[0,I] := CH END; WHILE MONTHS[MONINDX] <> MONTHS[0] DO MONINDX := MONINDX-1; IF MONINDX = 0 THEN GOTO 1; DELETE(GS,1,3); IF EATSPACES THEN GOTO 1; IF NOT (GS[1] IN DELIMS) THEN GOTO 1; DELETE(GS,1,1); IF EATSPACES THEN GOTO 1; YEARNUM := 0; REPEAT OK := GS[1] IN ['0'..'9']; IF OK THEN BEGIN YEARNUM := YEARNUM*10+ORD(GS[1])-ORD('0'); OK := YEARNUM <= 999; DELETE(GS,1,1) END UNTIL (LENGTH(GS) = 0) OR NOT OK; IF LENGTH(GS) > 0 THEN GOTO 1; WITH THEDATE DO BEGIN YEAR := YEARNUM MOD 100; MONTH := MONINDX; DAY := DAYNUM; WRITE(OUTPUT,'New date is ',DAY:2,'-',MONTHS[MONTH],'-',YEAR:2) END; IF FALSE THEN 1: WRITE(OUTPUT,'Illegal date specification'); END (* DATESET *) ; PROCEDURE XBLOCKS; LABEL 1; VAR LINX: DIRRANGE; CONFLICT: BOOLEAN; FIRSTBLK,LASTBLK,MAXBLK,MINBLK,LBLK,I: INTEGER; LDE: DIRENTRY; A,B: ARRAY [0..255] OF INTEGER; BEGIN GS := 'Examine blocks of what volume? '; IF GETVOLUME(TRUE) THEN BEGIN CONFLICT := FALSE; MINBLK := 32767; MAXBLK := -1; FIRSTBLK := 0; LASTBLK := 0; WRITE(OUTPUT,'What block number-range? '); READ(INPUT,FIRSTBLK); IF EOLN(INPUT) THEN LASTBLK := FIRSTBLK ELSE BEGIN READ(INPUT,LASTBLK); IF NOT EOLN(INPUT) THEN WRITELN(OUTPUT); IF LASTBLK < 0 THEN LASTBLK := ABS(LASTBLK); IF LASTBLK < FIRSTBLK THEN BEGIN I := FIRSTBLK; FIRSTBLK := LASTBLK; LASTBLK := I END END; IF FIRSTBLK < GDIR^[0].DLASTBLK THEN BEGIN WRITE(OUTPUT,'You want to risk the directory? '); IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1; WRITELN(OUTPUT) END; FOR LINX := 1 TO GDIR^[0].DNUMFILES DO WITH GDIR^[LINX] DO IF (FIRSTBLK < DLASTBLK) AND (LASTBLK >= DFIRSTBLK) THEN BEGIN IF NOT CONFLICT THEN BEGIN CONFLICT := TRUE; WRITELN(OUTPUT,'File(s) endangered:') END; WRITELN(OUTPUT,DTID,' ':TIDLENG-LENGTH(DTID)+1, DFIRSTBLK:6,DLASTBLK:6) END; IF CONFLICT THEN BEGIN WRITE(OUTPUT,'Do you want to risk them? '); IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1; WRITELN(OUTPUT) END; FOR LBLK := FIRSTBLK TO LASTBLK DO BEGIN WRITE(OUTPUT,'Block ',LBLK); UNITREAD(GUNIT,A,FBLKSIZE,LBLK); B := A; UNITWRITE(GUNIT,A,FBLKSIZE,LBLK); IF IORESULT = 0 THEN UNITREAD(GUNIT,B,FBLKSIZE,LBLK); IF (IORESULT = 0) AND (A = B) THEN WRITELN(OUTPUT,' may be recoverable') ELSE BEGIN WRITELN(OUTPUT,' is not recoverable'); IF LBLK < MINBLK THEN MINBLK := LBLK; IF LBLK > MAXBLK THEN MAXBLK := LBLK END END; IF MAXBLK < 0 THEN GOTO 1; IF MINBLK = MAXBLK THEN WRITE(OUTPUT,'Block ',MINBLK,' has a hard error') ELSE WRITE(OUTPUT,'Blocks ',MINBLK,' through ',MAXBLK, ' have hard errors'); WRITELN(OUTPUT); WRITE(OUTPUT,'Mark as bad'); IF CONFLICT THEN WRITE(OUTPUT,' (may remove files!)'); WRITE(OUTPUT,'? '); IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1; WRITELN(OUTPUT); IF CONFLICT THEN BEGIN LINX := 1; (*ZAP CONFLICTS*) WHILE LINX <= GDIR^[0].DNUMFILES DO WITH GDIR^[LINX] DO IF (MINBLK < DLASTBLK) AND (MAXBLK >= DFIRSTBLK) THEN DELENTRY(LINX,GDIR) ELSE LINX := LINX+1 END; IF GDIR^[0].DNUMFILES = MAXDIR THEN BEGIN WRITE(OUTPUT,'No room in directory'); GOTO 1 END; WITH LDE DO BEGIN DFIRSTBLK := MINBLK; DLASTBLK := MAXBLK+1; DFKIND := XDSKFILE; DLASTBYTE := FBLKSIZE; DACCESS := THEDATE; DTID := 'BAD.xxxxx.BAD'; FIRSTBLK := MINBLK; FOR I := 4 DOWNTO 0 DO BEGIN DTID[9-I] := CHR(FIRSTBLK DIV IPOT[I] + ORD('0')); FIRSTBLK := FIRSTBLK MOD IPOT[I] END END; LINX := GDIR^[0].DNUMFILES; WHILE MINBLK < GDIR^[LINX].DLASTBLK DO LINX := LINX-1; INSENTRY(LDE,LINX+1,GDIR); WRITEDIR(GUNIT,GDIR); WRITE(OUTPUT,LDE.DTID,' marked') END; 1: END (*XBLOCKS*) ; PROCEDURE KRUNCH; LABEL 1; VAR LINX: DIRRANGE; NBLOCKS,DESTBLK: INTEGER; RELBLOCK,CHUNKSIZE,AINX,LBLOCK: INTEGER; REBOOT: BOOLEAN; BEGIN GS := 'Crunch what volume? '; IF GETVOLUME(TRUE) THEN BEGIN WRITE(OUTPUT,'Are you sure you want to crunch ',GVID,': ? '); IF GETCHAR(TRUE) <> 'Y' THEN GOTO 1; WRITELN(OUTPUT); SYSCOM^.MISCINFO.NOBREAK := TRUE; FOR LINX := 1 TO GDIR^[0].DNUMFILES DO WITH GDIR^[LINX] DO IF (DFKIND <> XDSKFILE) AND (DFIRSTBLK > GDIR^[LINX-1].DLASTBLK) THEN BEGIN WRITELN(OUTPUT,'Moving ',DTID); NBLOCKS := DLASTBLK-DFIRSTBLK; DESTBLK := GDIR^[LINX-1].DLASTBLK; RELBLOCK := 0; REPEAT CHUNKSIZE := NBLOCKS-RELBLOCK; IF CHUNKSIZE > GBUFBLKS THEN CHUNKSIZE := GBUFBLKS; IF CHUNKSIZE > 0 THEN BEGIN AINX := 0; FOR LBLOCK := DFIRSTBLK+RELBLOCK TO DFIRSTBLK+RELBLOCK+CHUNKSIZE-1 DO BEGIN UNITREAD(GUNIT,GBUF^[AINX],FBLKSIZE,LBLOCK); IF IORESULT <> 0 THEN WRITELN(OUTPUT,'Read error, rel ', LBLOCK-DFIRSTBLK,', abs ',LBLOCK); AINX := AINX+FBLKSIZE END; AINX := 0; FOR LBLOCK := DESTBLK+RELBLOCK TO DESTBLK+RELBLOCK+CHUNKSIZE-1 DO BEGIN UNITWRITE(GUNIT,GBUF^[AINX],FBLKSIZE,LBLOCK); IF IORESULT <> 0 THEN WRITELN(OUTPUT,'Write error, rel ', LBLOCK-DESTBLK,', abs ',LBLOCK); AINX := AINX+FBLKSIZE END; RELBLOCK := RELBLOCK+CHUNKSIZE END UNTIL CHUNKSIZE = 0; DFIRSTBLK := DESTBLK; DLASTBLK := DESTBLK+NBLOCKS END; WRITEDIR(GUNIT,GDIR); WRITELN(OUTPUT,GVID,': crunched'); REBOOT := GVID = SYVID; IF NOT REBOOT THEN WITH USERINFO DO IF GOTSYM THEN REBOOT := SYMVID = GVID ELSE IF GOTCODE THEN REBOOT := CODEVID = GVID; IF REBOOT THEN BEGIN WRITELN(OUTPUT,'Please bootload'); REPEAT UNTIL FALSE END; SYSCOM^.MISCINFO.NOBREAK := FALSE END; 1: END (*KRUNCH*) ; BEGIN (*FILEHANDLER*) FILERINIT; REPEAT PL := 'Filer: G(et, S(ave, W(hat, N(ew, L(dir, R(em, C(hng, T(rans, D(ate, Q(uit'; PROMPT; GCH := GETCHAR(BADCOMMAND); CLEARSCREEN; BADCOMMAND := NOT (GCH IN ['G','S','W','N','L','E','C','R','D', 'T','M','V','B','Z','P','X','K']); INSTRING := ''; (*IN CASE OF REMOVE ETC*) CASE GCH OF 'G': GETWORK; 'S': SAVEWORK; 'W': WHATWORK; 'N': NEWWORK(TRUE); 'L': LISTDIR(FALSE); 'E': LISTDIR(TRUE); 'C': CHANGER; 'R': REMOVER; 'P': PREFIXER; 'T': TRANSFER; 'M': MAKEFILE; 'V': LISTVOLS; 'B': BADBLOCKS; 'Z': ZEROVOLUME; 'X': XBLOCKS; 'K': KRUNCH; 'D': DATESET END UNTIL GCH = 'Q' END (*FILEHANDLER*) ; BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL17:globals.text ======================================================================================== (*$U-*) PROGRAM PASCALSYSTEM; (************************************************) (* *) (* UCSD PASCAL OPERATING SYSTEM *) (* *) (* RELEASE LEVEL: I.3 AUGUST, 1977 *) (* *) (* WRITTEN BY ROGER T. SUMNER *) (* WINTER 1977 *) (* *) (* INSTITUTE FOR INFORMATION SYSTEMS *) (* UC SAN DIEGO, LA JOLLA, CA *) (* *) (* KENNETH L. BOWLES, DIRECTOR *) (* *) (* THIS SOFTWARE IS THE PROPERTY OF THE *) (* REGENTS OF THE UNIVERSITY OF CALIFORNIA. *) (* *) (************************************************) CONST MAXUNIT = 8; (*MAXIMUM PHYSICAL UNIT # FOR UREAD*) MAXDIR = 77; (*MAX NUMBER OF ENTRIES IN A DIRECTORY*) VIDLENG = 7; (*NUMBER OF CHARS IN A VOLUME ID*) TIDLENG = 15; (*NUMBER OF CHARS IN TITLE ID*) MAXSEG = 15; (*MAX CODE SEGMENT NUMBER*) FBLKSIZE = 512; (*STANDARD DISK BLOCK LENGTH*) DIRBLK = 2; (*DISK ADDR OF DIRECTORY*) AGELIMIT = 300; (*MAX AGE FOR GDIRP...IN TICKS*) EOL = 13; (*END-OF-LINE...ASCII CR*) TYPE IORSLTWD = (INOERROR,IBADBLOCK,IBADUNIT,IBADMODE,IHARDXTRA, ILOSTUNIT,ILOSTFILE,IBADTITLE,INOROOM,INOUNIT, INOFILE,IDUPFILE,INOTCLOSED,INOTOPEN,IBADFORMAT); (*ARCHIVAL INFO...THE DATE*) DATEREC = PACKED RECORD MONTH: 0..12; (*0 IMPLIES DATE NOT MEANINGFUL*) DAY: 0..31; (*DAY OF MONTH*) YEAR: 0..100 (*100 IS TEMP DISK FLAG*) END (*DATEREC*) ; (*VOLUME TABLES*) UNITNUM = 0..MAXUNIT; VID = STRING[VIDLENG]; (*DISK DIRECTORIES*) DIRRANGE = 0..MAXDIR; TID = STRING[TIDLENG]; FILEKIND = (UNTYPEDFILE,XDSKFILE,CODEFILE,TEXTFILE, INFOFILE,DATAFILE,GRAFFILE,FOTOFILE); DIRENTRY = RECORD DFIRSTBLK: INTEGER; (*FIRST PHYSICAL DISK ADDR*) DLASTBLK: INTEGER; (*POINTS AT BLOCK FOLLOWING*) CASE DFKIND: FILEKIND OF UNTYPEDFILE: (*ONLY IN DIR[0]...VOLUME INFO*) (DVID: VID; (*NAME OF DISK VOLUME*) DEOVBLK: INTEGER; (*LASTBLK OF VOLUME*) DNUMFILES: DIRRANGE; (*NUM FILES IN DIR*) DLOADTIME: INTEGER); (*TIME OF LAST ACCESS*) XDSKFILE,CODEFILE,TEXTFILE,INFOFILE, DATAFILE,GRAFFILE,FOTOFILE: (DTID: TID; (*TITLE OF FILE*) DLASTBYTE: 1..FBLKSIZE; (*NUM BYTES IN LAST BLOCK*) DACCESS: DATEREC) (*LAST MODIFICATION DATE*) END (*DIRENTRY*) ; DIRP = ^DIRECTORY; DIRECTORY = ARRAY [DIRRANGE] OF DIRENTRY; (*FILE INFORMATION*) CLOSETYPE = (CNORMAL,CLOCK,CPURGE,CCRUNCH); WINDOWP = ^WINDOW; WINDOW = PACKED ARRAY [0..0] OF CHAR; FIBP = ^FIB; FIB = RECORD FWINDOW: WINDOWP; (*USER WINDOW...F^, USED BY GET-PUT*) FEOF,FEOLN: BOOLEAN; FRECSIZE: INTEGER; (*IN BYTES...0=>BLOCKFILE, 1=>CHARFILE*) CASE FISOPEN: BOOLEAN OF TRUE: (FISBLKD, (*FILE IS ON BLOCK DEVICE*) FGOTACHAR:BOOLEAN;(*MARK FOR CHAR LOOK-AHEAD*) FUNIT: UNITNUM; (*PHYSICAL UNIT #*) FVID: VID; (*VOLUME NAME*) FNXTBLK, (*NEXT REL BLOCK TO IO*) FMAXBLK: INTEGER; (*MAX REL BLOCK ACCESSED*) FMODIFIED:BOOLEAN;(*PLEASE SET NEW DATE IN CLOSE*) FHEADER: DIRENTRY;(*COPY OF DISK DIR ENTRY*) CASE FSOFTBUF: BOOLEAN OF (*DISK GET-PUT STUFF*) TRUE: (FNXTBYTE,FMAXBYTE: INTEGER; FBUFCHNGD: BOOLEAN; FBUFFER: PACKED ARRAY [0..FBLKSIZE] OF CHAR)) END (*FIB*) ; (*USER WORKFILE STUFF*) INFOREC = RECORD SYMFIBP,CODEFIBP: FIBP; (*WORKFILES FOR SCRATCH*) ERRSYM,ERRBLK,ERRNUM: INTEGER; (*ERROR STUFF IN EDIT*) STUPID: BOOLEAN; (*STUDENT PROGRAMMER ID!!*) GOTSYM,GOTCODE: BOOLEAN; (*TITLES ARE MEANINGFUL*) WORKVID,SYMVID,CODEVID: VID; (*PERM&CUR WORKFILE VOLUMES*) WORKTID,SYMTID,CODETID: TID (*PERM&CUR WORKFILES TITLE*) END (*INFOREC*) ; (*CODE SEGMENT LAYOUTS*) SEGRANGE = 0..MAXSEG; SEGDESC = RECORD DISKADDR: INTEGER; (*REL # IN CODE...ABS # IN SYSCOM^*) CODELENG: INTEGER (*# BYTES TO READ IN*) END (*SEGDESC*) ; (*DEBUGGER STUFF*) BYTERANGE = 0..255; TRICKARRAY = ARRAY [0..0] OF INTEGER; (* FOR MEMORY DIDDLING*) MSCWP = ^ MSCW; (*MARK STACK RECORD POINTER*) MSCW = RECORD STATLINK: MSCWP; (*POINTER TO PARENT MSCW*) DYNLINK: MSCWP; (*POINTER TO CALLER'S MSCW*) MSSEG,MSJTAB: ^TRICKARRAY; MSIPC: INTEGER; LOCALDATA: TRICKARRAY END (*MSCW*) ; (*SYSTEM COMMUNICATION AREA*) (*SEE INTERPRETERS...NOTE *) (*THAT WE ASSUME BACKWARD *) (*FIELD ALLOCATION IS DONE *) SYSCOMREC = RECORD IORSLT: IORSLTWD; (*RESULT OF LAST IO CALL*) XEQERR: INTEGER; (*REASON FOR EXECERROR CALL*) SYSUNIT: UNITNUM; (*PHYSICAL UNIT OF BOOTLOAD*) BUGSTATE: INTEGER;(*DEBUGGER INFO*) GDIRP: DIRP; (*GLOBAL DIR POINTER,SEE VOLSEARCH*) LASTMP,STKBASE,BOMBP: MSCWP; MEMTOP,SEG,JTAB: INTEGER; BOMBIPC: INTEGER; (*WHERE XEQERR BLOWUP WAS*) EXPANSION: ARRAY [0..14] OF INTEGER; HIGHTIME,LOWTIME: INTEGER; MISCINFO: PACKED RECORD NOBREAK,STUPID,SLOWTERM, HASXYCRT,HASLCCRT,HAS8510A,HASCLOCK: BOOLEAN END; CRTTYPE: INTEGER; CRTCTRL: PACKED RECORD RLF,NDFS,ERASEEOL,ERASEEOS,HOME,ESCAPE: CHAR; BACKSPACE: CHAR; FILLCOUNT: 0..255; EXPANSION: PACKED ARRAY [0..3] OF CHAR END; CRTINFO: PACKED RECORD WIDTH,HEIGHT: INTEGER; RIGHT,LEFT,DOWN,UP: CHAR; BADCH,CHARDEL,STOP,BREAK,FLUSH,EOF: CHAR; ALTMODE,LINEDEL: CHAR; EXPANSION: PACKED ARRAY [0..5] OF CHAR END; SEGTABLE: ARRAY [SEGRANGE] OF RECORD CODEUNIT: UNITNUM; CODEDESC: SEGDESC END END (*SYSCOM*); VAR SYSCOM: ^SYSCOMREC; (*MAGIC PARAM...SET UP IN BOOT*) GFILES: ARRAY [0..5] OF FIBP; (*GLOBAL FILES, 0=INPUT, 1=OUTPUT*) EMPTYHEAP: ^INTEGER; (*HEAP MARK FOR MEM MANAGING*) INPUTFIB,OUTPUTFIB,SYSTERM: FIBP; (*ACTUAL FILES...GFILES ARE COPIES*) SYVID,DKVID: VID; (*SYSUNIT VOLID & DEFAULT VOLID*) THEDATE: DATEREC; (*TODAY...SET IN FILER OR SIGN ON*) DEBUGINFO: ^INTEGER; (*DEBUGGERS GLOBAL INFO WHILE RUNIN*) PL: STRING; (*PROMPTLINE STRING...SEE PROMPT*) IPOT: ARRAY [0..4] OF INTEGER; (*INTEGER POWERS OF TEN*) FILLER: STRING[11]; (*NULLS FOR CARRIAGE DELAY*) USERINFO: INFOREC; (*WORK STUFF FOR COMPILER ETC*) UNITABLE: ARRAY [UNITNUM] OF (*0 NOT USED*) RECORD UVID: VID; (*VOLUME ID FOR UNIT*) CASE UISBLKD: BOOLEAN OF TRUE: (UEOVBLK: INTEGER) END (*UNITABLE*) ; (*-------------------------------------------------------------------------*) (* SYSTEM PROCEDURE FORWARD DECLARATIONS *) (* THESE ARE ADDRESSED BY OBJECT CODE... *) (* DO NOT MOVE WITHOUT CAREFUL THOUGHT *) PROCEDURE EXECERROR; FORWARD; PROCEDURE FINIT(VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER); FORWARD; PROCEDURE FRESET(VAR F: FIB); FORWARD; PROCEDURE FOPEN(VAR F: FIB; VAR FTITLE: STRING; FOPENOLD: BOOLEAN; JUNK: FIBP); FORWARD; PROCEDURE FCLOSE(VAR F: FIB; FTYPE: CLOSETYPE); FORWARD; PROCEDURE FGET(VAR F: FIB); FORWARD; PROCEDURE FPUT(VAR F: FIB); FORWARD; PROCEDURE FSEEK(VAR F: FIB); FORWARD; FUNCTION FEOF(VAR F: FIB): BOOLEAN; FORWARD; FUNCTION FEOLN(VAR F: FIB): BOOLEAN; FORWARD; PROCEDURE FREADINT(VAR F: FIB; VAR I: INTEGER); FORWARD; PROCEDURE FWRITEINT(VAR F: FIB; I,RLENG: INTEGER); FORWARD; PROCEDURE FREADREAL(VAR F: FIB; VAR X: REAL); FORWARD; PROCEDURE FWRITEREAL(VAR F: FIB; X: REAL; W,D: INTEGER); FORWARD; PROCEDURE FREADCHAR(VAR F: FIB; VAR CH: CHAR); FORWARD; PROCEDURE FWRITECHAR(VAR F: FIB; CH: CHAR; RLENG: INTEGER); FORWARD; PROCEDURE FREADSTRING(VAR F: FIB; VAR S: STRING; SLENG: INTEGER); FORWARD; PROCEDURE FWRITESTRING(VAR F: FIB; VAR S: STRING; RLENG: INTEGER); FORWARD; PROCEDURE FWRITEBYTES(VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER); FORWARD; PROCEDURE FREADLN(VAR F: FIB); FORWARD; PROCEDURE FWRITELN(VAR F: FIB); FORWARD; PROCEDURE SCONCAT(VAR DEST,SRC: STRING; DESTLENG: INTEGER); FORWARD; PROCEDURE SINSERT(VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER); FORWARD; PROCEDURE SCOPY(VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER); FORWARD; PROCEDURE SDELETE(VAR DEST: STRING; DELINX,DELLENG: INTEGER); FORWARD; FUNCTION SPOS(VAR TARGET,SRC: STRING): INTEGER; FORWARD; FUNCTION FBLOCKIO(VAR F: FIB; VAR A: WINDOW; NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN): INTEGER; FORWARD; (* NON FIXED FORWARD DECLARATIONS *) FUNCTION VOLSEARCH(VAR FVID: VID; LOOKHARD: BOOLEAN; VAR FDIR: DIRP): UNITNUM; FORWARD; PROCEDURE WRITEDIR(FUNIT: UNITNUM; FDIR: DIRP); FORWARD; FUNCTION DIRSEARCH(VAR FTID: TID; FINDPERM: BOOLEAN; FDIR: DIRP): DIRRANGE; FORWARD; FUNCTION SCANTITLE(FTITLE: STRING; VAR FVID: VID; VAR FTID: TID; VAR FSEGS: INTEGER; VAR FKIND: FILEKIND): BOOLEAN; FORWARD; PROCEDURE DELENTRY(FINX: DIRRANGE; FDIR: DIRP); FORWARD; PROCEDURE INSENTRY(VAR FENTRY: DIRENTRY; FINX: DIRRANGE; FDIR: DIRP); FORWARD; PROCEDURE CLEARSCREEN; FORWARD; PROCEDURE PROMPT; FORWARD; FUNCTION SPACEWAIT: BOOLEAN; FORWARD; FUNCTION GETCHAR(FLUSH: BOOLEAN): CHAR; FORWARD; PROCEDURE EXECUTE(RUNWORKFILE: BOOLEAN); FORWARD; PROCEDURE COMMAND; FORWARD; ======================================================================================== DOCUMENT :usus Folder:VOL17:linker.text ======================================================================================== (*$R+,I-*) PROGRAM LINKER; CONST MAXSEG = 15; TYPE SEGNUM = 0..MAXSEG; BLOCK0 = RECORD SEGDESC: ARRAY [SEGNUM] OF RECORD DISKADDR: INTEGER; CODELENG: INTEGER END; SEGNAME: ARRAY [SEGNUM] OF PACKED ARRAY [0..7] OF CHAR; FILLER: PACKED ARRAY [1..320] OF CHAR END; VAR NBLOCKS,RSLT,OUTBLOCK: INTEGER; BUF: ^INTEGER; SEG: SEGNUM; TITLE: STRING; CODETBL: BLOCK0; CODE,INFILE: FILE; FUNCTION CHECKIO:BOOLEAN; VAR RSLT:INTEGER; BEGIN CHECKIO:=IORESULT=0; IF IORESULT <> 0 THEN BEGIN RSLT:=IORESULT; WRITELN(OUTPUT,'I/O error # ',RSLT); END; END; (* CHECKIO *) FUNCTION OPENFILE: BOOLEAN; BEGIN REPEAT WRITE(OUTPUT,'Link Code File? '); READLN(INPUT,TITLE); IF LENGTH(TITLE) > 0 THEN OPENOLD(INFILE,TITLE); UNTIL (CHECKIO) OR (LENGTH(TITLE) = 0); OPENFILE := LENGTH(TITLE) > 0 END (*OPENFILE*) ; PROCEDURE LINKCODE; VAR NBLOCKS: INTEGER; INTBL: BLOCK0; FUNCTION CONFIRM:BOOLEAN; VAR CH:CHAR; BEGIN CONFIRM:=FALSE; WITH INTBL DO BEGIN IF SEGDESC[SEG].CODELENG > 24 THEN BEGIN WRITE(OUTPUT,'Linking ',SEGNAME[SEG],'. Please Confirm (y/n)'); READ(INPUT,CH); WRITELN(OUTPUT); IF (CODETBL.SEGDESC[SEG].CODELENG <> 0) AND (CH='Y') THEN BEGIN WRITE(OUTPUT, 'WARNING - This segment has already been linked in. Please Reconfirm'); READ(INPUT,CH); WRITELN(OUTPUT); END; CONFIRM := CH = 'Y'; END; END; END; (* CONFIRM *) BEGIN IF BLOCKREAD(INFILE,INTBL,1,0) = 1 THEN BEGIN WITH INTBL DO FOR SEG := 0 TO MAXSEG DO WITH SEGDESC[SEG] DO IF CONFIRM THEN BEGIN NBLOCKS := (CODELENG+511) DIV 512; IF BLOCKREAD(INFILE,BUF^,NBLOCKS,DISKADDR) <> NBLOCKS THEN WRITELN(OUTPUT,'Error reading seg ',SEG) ELSE IF BLOCKWRITE(CODE,BUF^,NBLOCKS,OUTBLOCK) <> NBLOCKS THEN WRITELN(OUTPUT,'I/O error - no room on disk') ELSE BEGIN WRITELN(OUTPUT,SEGNAME[SEG],' Seg # ',SEG,', Block ', OUTBLOCK,', ',CODELENG,' Bytes'); CODETBL.SEGNAME[SEG] := SEGNAME[SEG]; CODETBL.SEGDESC[SEG].CODELENG := CODELENG; CODETBL.SEGDESC[SEG].DISKADDR := OUTBLOCK; OUTBLOCK := OUTBLOCK + NBLOCKS END END END ELSE BEGIN RSLT:=IORESULT; WRITELN(OUTPUT,'Input file read error # ',RSLT); END; CLOSE(INFILE) END (*LINKCODE*) ; BEGIN REPEAT WRITE(OUTPUT,'Output code file? '); READLN(INPUT,TITLE); IF LENGTH(TITLE) > 0 THEN OPENNEW(CODE,TITLE) UNTIL (LENGTH(TITLE) = 0) OR (CHECKIO); IF LENGTH(TITLE) > 0 THEN BEGIN OUTBLOCK := 1; NEW(BUF); WITH CODETBL DO FOR SEG := 0 TO MAXSEG DO BEGIN SEGNAME[SEG] := ' '; SEGDESC[SEG].CODELENG := 0; SEGDESC[SEG].DISKADDR := 0 END; WHILE OPENFILE DO LINKCODE; IF BLOCKWRITE(CODE,CODETBL,1,0) = 1 THEN CLOSE(CODE,LOCK) ELSE WRITELN(OUTPUT,'Code file write error ') END END. ======================================================================================== DOCUMENT :usus Folder:VOL17:system.a.text ======================================================================================== SEGMENT PROCEDURE USERPROGRAM(VAR INPUT,OUTPUT: FIB); BEGIN FWRITELN(SYSTERM^); PL := 'No user program linked in'; FWRITESTRING(SYSTERM^,PL,0) END (*USERPROGRAM*) ; SEGMENT PROCEDURE COMPILER(VAR USERINFO: INFOREC); SEGMENT PROCEDURE COMPINIT; BEGIN END (*COMPINIT*) ; BEGIN FWRITELN(SYSTERM^); PL := 'No compiler linked in'; USERINFO.ERRNUM := 400; FWRITESTRING(SYSTERM^,PL,0) END (*COMPILER*) ; SEGMENT PROCEDURE EDITOR; BEGIN FWRITELN(SYSTERM^); PL := 'No editor linked in'; FWRITESTRING(SYSTERM^,PL,0) END (*EDITOR*) ; SEGMENT PROCEDURE FILEHANDLER; BEGIN FWRITELN(SYSTERM^); PL := 'No file handler linked in'; FWRITESTRING(SYSTERM^,PL,0) END (*FILEHANDLER*) ; SEGMENT PROCEDURE DEBUGGER; BEGIN FWRITELN(SYSTERM^); PL := 'No debugger linked in'; FWRITESTRING(SYSTERM^,PL,0) END (*DEBUGGER*) ; SEGMENT PROCEDURE INITIALIZE; VAR DOTRITON,JUSTBOOTED: BOOLEAN; LTITLE: STRING[20]; DISPLAY: ARRAY [0..79,0..19] OF INTEGER; (*FOR TRITON*) PROCEDURE BUILDUNITABLE; VAR LUNIT: UNITNUM; LDIR: DIRP; BEGIN FOR LUNIT := 0 TO MAXUNIT DO WITH UNITABLE[LUNIT] DO BEGIN UISBLKD := FALSE; UVID := ''; IF UNITBUSY(LUNIT) THEN UNITCLEAR(LUNIT) END; UNITABLE[1].UVID := 'CONSOLE'; UNITABLE[2].UVID := 'SYSTERM'; UNITABLE[4].UISBLKD := TRUE; UNITABLE[4].UEOVBLK := 0; UNITABLE[5].UISBLKD := TRUE; UNITABLE[5].UEOVBLK := 0; SYVID := ''; LUNIT := VOLSEARCH(SYVID,TRUE,LDIR); SYVID := UNITABLE[SYSCOM^.SYSUNIT].UVID; IF LENGTH(SYVID) = 0 THEN HALT; UNITCLEAR(6); IF IORESULT = ORD(INOERROR) THEN UNITABLE[6].UVID := 'PRINTER'; UNITCLEAR(7); IF IORESULT = ORD(INOERROR) THEN UNITABLE[7].UVID := 'SPEAKER'; UNITCLEAR(8); IF IORESULT = ORD(INOERROR) THEN UNITABLE[8].UVID := 'NETWORK'; END (*BUILDUNITABLE*) ; PROCEDURE INITCHARSET; TYPE CHARSET= ARRAY [32..127] OF PACKED ARRAY [0..9] OF 0..255; VAR I: INTEGER; TRIX: RECORD CASE BOOLEAN OF TRUE: (CHARADDR: INTEGER); FALSE: (CHARBUFP: ^ CHAR) END; CHARBUF: RECORD SET1: CHARSET; FILLER1: PACKED ARRAY [0..63] OF CHAR; SET2: CHARSET; FILLER2: PACKED ARRAY [0..63] OF CHAR; TRITON: ARRAY [0..63,0..3] OF INTEGER END (*CHARBUF*) ; LFIB: FIB; BEGIN FINIT(LFIB,NIL,-1); LTITLE := '*SYSTEM.CHARSET'; FOPEN(LFIB,LTITLE,TRUE,NIL); IF LFIB.FISOPEN THEN BEGIN UNITWRITE(3,TRIX,128); IF IORESULT = ORD(INOERROR) THEN BEGIN WITH LFIB.FHEADER DO BEGIN DOTRITON := DLASTBLK-DFIRSTBLK > 4; UNITREAD(LFIB.FUNIT,CHARBUF,SIZEOF(CHARBUF),DFIRSTBLK) END; TRIX.CHARADDR := 512-8192; (*UNIBUS TRICKYNESS!*) FOR I := 32 TO 127 DO BEGIN MOVELEFT(CHARBUF.SET1[I],TRIX.CHARBUFP^,10); TRIX.CHARADDR := TRIX.CHARADDR+16 END; TRIX.CHARADDR := 512-6144; FOR I := 32 TO 127 DO BEGIN MOVELEFT(CHARBUF.SET2[I],TRIX.CHARBUFP^,10); TRIX.CHARADDR := TRIX.CHARADDR+16 END; UNITABLE[3].UVID := 'GRAPHIC'; UNITWRITE(3,I,0) END END ELSE SYSCOM^.MISCINFO.HAS8510A := FALSE; IF DOTRITON THEN BEGIN (*INITIALIZE DISPLAY ARRAY*) FILLCHAR(DISPLAY,SIZEOF(DISPLAY),0); FOR I := 0 TO 63 DO MOVELEFT(CHARBUF.TRITON[I],DISPLAY[I,10],8) END; FCLOSE(LFIB,CNORMAL) END (*INITCHARSET*) ; BEGIN JUSTBOOTED := EMPTYHEAP = NIL; IF JUSTBOOTED THEN BEGIN (*BASIC FILE AND HEAP SETTUP*) NEW(INPUTFIB,TRUE,FALSE); FINIT(INPUTFIB^,NIL,0); NEW(OUTPUTFIB,TRUE,FALSE); FINIT(OUTPUTFIB^,NIL,0); NEW(SYSTERM,TRUE,FALSE); FINIT(SYSTERM^,NIL,0); NEW(INPUTFIB^.FWINDOW); NEW(OUTPUTFIB^.FWINDOW); NEW(SYSTERM^.FWINDOW); WITH USERINFO DO BEGIN NEW(SYMFIBP,TRUE,FALSE); FINIT(SYMFIBP^,NIL,-1); NEW(CODEFIBP,TRUE,FALSE); FINIT(CODEFIBP^,NIL,-1) END; MARK(EMPTYHEAP) END ELSE (*ALREADY UNDERWAY*) BEGIN FCLOSE(USERINFO.SYMFIBP^,CNORMAL); FCLOSE(USERINFO.CODEFIBP^,CNORMAL); RELEASE(EMPTYHEAP) END; DEBUGINFO := NIL; DOTRITON := FALSE; IPOT[0] := 1; IPOT[1] := 10; IPOT[2] := 100; IPOT[3] := 1000; IPOT[4] := 10000; WITH SYSCOM^ DO BEGIN FILLER[0] := CHR(CRTCTRL.FILLCOUNT); FILLCHAR(FILLER[1],CRTCTRL.FILLCOUNT,CHR(0)); XEQERR := 0; IORSLT := INOERROR; BUGSTATE := 0; GDIRP := NIL END; BUILDUNITABLE; IF JUSTBOOTED THEN BEGIN DKVID := SYVID; WITH THEDATE DO BEGIN MONTH := 0; DAY := 0; YEAR := 0 END; LTITLE := 'CONSOLE:'; FOPEN(INPUTFIB^,LTITLE,TRUE,NIL); FOPEN(OUTPUTFIB^,LTITLE,TRUE,NIL); LTITLE := 'SYSTERM:'; FOPEN(SYSTERM^,LTITLE,TRUE,NIL); WITH USERINFO DO BEGIN (*INITIALIZE WORK FILES ETC*) SYMTID := ''; CODETID := ''; WORKTID := ''; SYMVID := SYVID; CODEVID := SYVID; WORKVID := SYVID; LTITLE := '*SYSTEM.WRK.TEXT'; FOPEN(SYMFIBP^,LTITLE,TRUE,NIL); GOTSYM := SYMFIBP^.FISOPEN; IF GOTSYM THEN SYMTID := SYMFIBP^.FHEADER.DTID; FCLOSE(SYMFIBP^,CNORMAL); LTITLE := '*SYSTEM.WRK.CODE'; FOPEN(CODEFIBP^,LTITLE,TRUE,NIL); GOTCODE := CODEFIBP^.FISOPEN; IF GOTCODE THEN CODETID := CODEFIBP^.FHEADER.DTID; FCLOSE(CODEFIBP^,CNORMAL); STUPID := SYSCOM^.MISCINFO.STUPID END END; FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^); IF NOT JUSTBOOTED THEN IF GFILES[0] <> INPUTFIB THEN FCLOSE(GFILES[0]^,CNORMAL); GFILES[0] := INPUTFIB; GFILES[1] := OUTPUTFIB; GFILES[2] := SYSTERM; GFILES[3] := NIL; GFILES[4] := NIL; GFILES[5] := NIL; IF SYSCOM^.MISCINFO.HAS8510A THEN INITCHARSET; CLEARSCREEN; WRITELN(OUTPUT); IF JUSTBOOTED THEN BEGIN IF DOTRITON THEN BEGIN (*ASSUME DATA MEDIA SCREEN*) WRITE(OUTPUT,CHR(30),CHR(32),CHR(42)); UNITWRITE(3,DISPLAY[-80],23) END; WRITELN(OUTPUT,'Welcome ',SYVID,', to'); IF DOTRITON THEN WRITELN(OUTPUT); WRITE(OUTPUT,'U.C.S.D. Pascal System I.3') END ELSE WRITE(OUTPUT,'System re-initialized') END (*INITIALIZE*) ; PROCEDURE EXECERROR; BEGIN WITH SYSCOM^ DO BEGIN IF XEQERR = 4 THEN BEGIN RELEASE(EMPTYHEAP); PL := '**** STACK OVERFLOW!!'; UNITWRITE(2,PL[1],LENGTH(PL)); EXIT(COMMAND) END; BOMBP^.MSIPC := BOMBIPC; IF BUGSTATE <> 0 THEN BEGIN DEBUGGER; XEQERR := 0 END ELSE BEGIN FWRITELN(SYSTERM^); WRITELN(OUTPUT,'Run time error # ',ORD(XEQERR)); WRITE(OUTPUT,'S# ',BOMBP^.MSSEG^[0] MOD 256); WRITE(OUTPUT,', P# ',BOMBP^.MSJTAB^[0] MOD 256); WRITE(OUTPUT,', I# ', BOMBIPC-ORD(BOMBP^.MSJTAB)+2+BOMBP^.MSJTAB^[-1]); IF NOT SPACEWAIT THEN EXIT(COMMAND) END END END (*EXECERROR*) ; FUNCTION CHECKDEL(CH: CHAR; VAR SINX: INTEGER): BOOLEAN; BEGIN CHECKDEL := FALSE; WITH SYSCOM^,CRTCTRL,CRTINFO DO BEGIN IF CH = LINEDEL THEN BEGIN CHECKDEL := TRUE; IF (BACKSPACE = CHR(0)) OR (ERASEEOL = CHR(0)) THEN BEGIN SINX := 1; WRITELN(OUTPUT,' 1 DO BEGIN SINX := SINX-1; WRITE(OUTPUT,BACKSPACE) END; WRITE(OUTPUT,ESCAPE,ERASEEOL) END END; IF CH = CHARDEL THEN BEGIN CHECKDEL := TRUE; IF SINX > 1 THEN BEGIN SINX := SINX-1; IF BACKSPACE = CHR(0) THEN IF CHARDEL < ' ' THEN WRITE(OUTPUT,'_') ELSE (*ASSUME PRINTABLE*) ELSE BEGIN IF CHARDEL <> BACKSPACE THEN WRITE(OUTPUT,BACKSPACE); WRITE(OUTPUT,' ',BACKSPACE) END END ELSE IF CHARDEL = BACKSPACE THEN WRITE(OUTPUT,' ') END END END (*CHECKDEL*) ; PROCEDURE HOMECURSOR; BEGIN WITH SYSCOM^,CRTCTRL DO BEGIN IF ESCAPE <> CHR(0) THEN FWRITECHAR(SYSTERM^,ESCAPE,1); FWRITECHAR(SYSTERM^,HOME,1); IF (LENGTH(FILLER) > 0) AND (HOME <> CHR(EOL)) THEN FWRITESTRING(SYSTERM^,FILLER,0) END END (*HOMECURSOR*) ; PROCEDURE CLEARSCREEN; BEGIN HOMECURSOR; WITH SYSCOM^,CRTCTRL DO BEGIN IF MISCINFO.HAS8510A THEN UNITCLEAR(3); IF ERASEEOS <> CHR(0) THEN BEGIN IF ESCAPE <> CHR(0) THEN WRITE(OUTPUT,ESCAPE); WRITE(OUTPUT,ERASEEOS); IF LENGTH(FILLER) > 0 THEN WRITE(OUTPUT,FILLER) END END END (*CLEARSCREEN*) ; PROCEDURE PROMPT; VAR I: INTEGER; BEGIN HOMECURSOR; WITH SYSCOM^,CRTCTRL DO BEGIN IF ERASEEOL <> CHR(0) THEN BEGIN IF ESCAPE <> CHR(0) THEN WRITE(OUTPUT,ESCAPE); WRITE(OUTPUT,ERASEEOL); IF LENGTH(FILLER) > 0 THEN WRITE(OUTPUT,FILLER) END; IF MISCINFO.SLOWTERM THEN BEGIN I := SCAN(LENGTH(PL),=':',PL[1]); IF I <> LENGTH(PL) THEN PL[0] := CHR(I+1) END END; WRITE(OUTPUT,PL) END (*PROMPT*) ; FUNCTION GETCHAR(*FLUSH: BOOLEAN*); VAR CH: CHAR; BEGIN IF FLUSH THEN UNITCLEAR(1); INPUTFIB^.FGOTACHAR := FALSE; READ(INPUT,CH); IF (CH >= 'a') AND (CH <= 'z') THEN CH := CHR(ORD(CH)-ORD('a')+ORD('A')); GETCHAR := CH END (*GETCHAR*) ; FUNCTION SPACEWAIT; VAR CH: CHAR; BEGIN PL := 'Type a to continue'; REPEAT PROMPT; CH := GETCHAR(TRUE) UNTIL (CH = ' ') OR (CH = SYSCOM^.CRTINFO.ALTMODE); SPACEWAIT := CH <> ' ' END (*SPACEWAIT*) ; FUNCTION SCANTITLE(*FTITLE: STRING; VAR FVID: VID; VAR FTID: TID; VAR FSEGS: INTEGER; VAR FKIND: FILEKIND*); VAR I,RBRACK: INTEGER; CH: CHAR; OK: BOOLEAN; BEGIN FVID := ''; FTID := ''; FSEGS := 0; FKIND := UNTYPEDFILE; SCANTITLE := FALSE; I := 1; WHILE I <= LENGTH(FTITLE) DO BEGIN CH := FTITLE[I]; IF CH <= ' ' THEN DELETE(FTITLE,I,1) ELSE BEGIN IF (CH >= 'a') AND (CH <= 'z') THEN FTITLE[I] := CHR(ORD(CH)-ORD('a')+ORD('A')); I := I+1 END END; IF LENGTH(FTITLE) > 0 THEN BEGIN IF FTITLE[1] = '*' THEN BEGIN FVID := SYVID; DELETE(FTITLE,1,1) END; I := POS(':',FTITLE); IF I <= 1 THEN BEGIN IF LENGTH(FVID) = 0 THEN FVID := DKVID; IF I = 1 THEN DELETE(FTITLE,1,1) END ELSE IF I-1 <= VIDLENG THEN BEGIN FVID := COPY(FTITLE,1,I-1); DELETE(FTITLE,1,I) END; IF LENGTH(FVID) > 0 THEN BEGIN I := POS('[',FTITLE); IF I > 0 THEN I := I-1 ELSE I := LENGTH(FTITLE); IF I <= TIDLENG THEN BEGIN IF I > 0 THEN BEGIN FTID := COPY(FTITLE,1,I); DELETE(FTITLE,1,I) END; IF LENGTH(FTITLE) = 0 THEN OK := TRUE ELSE BEGIN OK := FALSE; RBRACK := POS(']',FTITLE); IF RBRACK = 2 THEN OK := TRUE ELSE IF RBRACK > 2 THEN BEGIN OK := TRUE; I := 2; REPEAT CH := FTITLE[I]; IF (CH >= '0') AND (CH <= '9') THEN FSEGS := FSEGS*10+ORD(CH)-ORD('0') ELSE OK := FALSE; I := I+1 UNTIL (I = RBRACK) OR NOT OK END END; SCANTITLE := OK; IF OK AND (LENGTH(FTID) > 5) THEN BEGIN FTITLE := COPY(FTID,LENGTH(FTID)-4,5); IF FTITLE = '.TEXT' THEN FKIND := TEXTFILE ELSE IF FTITLE = '.CODE' THEN FKIND := CODEFILE ELSE IF FTITLE = '.DATA' THEN FKIND := DATAFILE ELSE IF FTITLE = '.INFO' THEN FKIND := INFOFILE ELSE IF FTITLE = '.GRAF' THEN FKIND := GRAFFILE ELSE IF FTITLE = '.FOTO' THEN FKIND := FOTOFILE END END END END END (*SCANTITLE*) ; (* VOLUME AND DIRECTORY HANDLERS *) FUNCTION FETCHDIR(FUNIT: UNITNUM): BOOLEAN; VAR LINX: DIRRANGE; OK: BOOLEAN; HNOW: INTEGER; BEGIN FETCHDIR := FALSE; WITH SYSCOM^,UNITABLE[FUNIT] DO BEGIN (*READ IN AND VALIDATE DIR*) IF GDIRP = NIL THEN NEW(GDIRP); UNITREAD(FUNIT,GDIRP^,SIZEOF(DIRECTORY),DIRBLK); OK := IORSLT = INOERROR; IF OK THEN WITH GDIRP^[0] DO BEGIN OK := FALSE; (*CHECK OUT DIR*) IF (DFIRSTBLK = 0) AND (DFKIND = UNTYPEDFILE) THEN IF (LENGTH(DVID) > 0) AND (LENGTH(DVID) <= VIDLENG) AND (DNUMFILES >= 0) AND (DNUMFILES <= MAXDIR) THEN BEGIN OK := TRUE; (*SO FAR SO GOOD*) IF DVID <> UVID THEN BEGIN (*NEW VOLUME IN UNIT...CAREFUL*) LINX := 1; WHILE LINX <= DNUMFILES DO WITH GDIRP^[LINX] DO IF (DFKIND <= UNTYPEDFILE) OR (DFKIND > FOTOFILE) OR (LENGTH(DTID) <= 0) OR (LENGTH(DTID) > TIDLENG) OR (DLASTBLK < DFIRSTBLK) OR (DLASTBYTE > FBLKSIZE) OR (DLASTBYTE <= 0) OR (DACCESS.YEAR >= 100) THEN BEGIN OK := FALSE; DELENTRY(LINX,GDIRP) END ELSE LINX := LINX+1; IF NOT OK THEN BEGIN (*MUST HAVE BEEN CHANGED...WRITEIT*) UNITWRITE(FUNIT,GDIRP^, (DNUMFILES+1)*SIZEOF(DIRENTRY),DIRBLK); OK := IORSLT = INOERROR END END END; IF OK THEN BEGIN UVID := DVID; UEOVBLK := DEOVBLK; TIME(HNOW,DLOADTIME) END END; FETCHDIR := OK; IF NOT OK THEN BEGIN UVID := ''; UEOVBLK := 0; RELEASE(GDIRP); GDIRP := NIL END END END (*FETCHDIR*) ; PROCEDURE WRITEDIR(*FUNIT: UNITNUM; FDIR: DIRP*); VAR HNOW,LNOW: INTEGER; OK: BOOLEAN; LDE: DIRENTRY; BEGIN WITH UNITABLE[FUNIT],FDIR^[0] DO BEGIN OK := UVID = DVID; IF OK THEN BEGIN TIME(HNOW,LNOW); OK := (LNOW-DLOADTIME <= AGELIMIT) AND SYSCOM^.MISCINFO.HASCLOCK; IF NOT OK THEN BEGIN (*NO CLOCK OR TOO OLD*) UNITREAD(FUNIT,LDE,SIZEOF(DIRENTRY),DIRBLK); IF IORESULT = ORD(INOERROR) THEN OK := DVID = LDE.DVID; END; IF OK THEN BEGIN (*WE GUESS ALL IS SAFE...WRITEIT*) UNITWRITE(FUNIT,FDIR^, (DNUMFILES+1)*SIZEOF(DIRENTRY),DIRBLK); OK := IORESULT = ORD(INOERROR); IF OK THEN TIME(HNOW,DLOADTIME) END END; IF NOT OK THEN BEGIN SYSCOM^.IORSLT := ILOSTUNIT; UVID := ''; UEOVBLK := 0 END END END (*WRITEDIR*) ; FUNCTION VOLSEARCH(*VAR FVID: VID; LOOKHARD: BOOLEAN; VAR FDIR: DIRP*); VAR LUNIT: UNITNUM; OK: BOOLEAN; HNOW,LNOW: INTEGER; BEGIN VOLSEARCH := 0; FDIR := NIL; OK := FALSE; LUNIT := MAXUNIT; IF LENGTH(FVID) > 0 THEN REPEAT (*FIRST PASS THRU TABLE*) OK := FVID = UNITABLE[LUNIT].UVID; IF NOT OK THEN LUNIT := LUNIT-1 UNTIL OK OR (LUNIT = 0); IF OK THEN IF UNITABLE[LUNIT].UISBLKD THEN WITH SYSCOM^ DO BEGIN OK := FALSE; (*SEE IF GDIRP IS GOOD*) IF GDIRP <> NIL THEN IF FVID = GDIRP^[0].DVID THEN BEGIN TIME(HNOW,LNOW); OK := LNOW-GDIRP^[0].DLOADTIME <= AGELIMIT END; IF NOT OK THEN IF FETCHDIR(LUNIT) THEN OK := FVID = GDIRP^[0].DVID END; IF NOT OK AND LOOKHARD THEN BEGIN LUNIT := MAXUNIT; (*CHECK EACH DISK UNIT*) REPEAT WITH UNITABLE[LUNIT] DO IF UISBLKD THEN IF FETCHDIR(LUNIT) THEN OK := FVID = UVID; IF NOT OK THEN LUNIT := LUNIT-1 UNTIL OK OR (LUNIT = 0) END; IF OK THEN BEGIN VOLSEARCH := LUNIT; IF UNITABLE[LUNIT].UISBLKD THEN BEGIN FDIR := SYSCOM^.GDIRP; TIME(HNOW,FDIR^[0].DLOADTIME) END END END (*VOLSEARCH*) ; FUNCTION DIRSEARCH(*VAR FTID: TID; FINDPERM: BOOLEAN; FDIR: DIRP*); VAR I: DIRRANGE; FOUND: BOOLEAN; BEGIN DIRSEARCH := 0; FOUND := FALSE; I := 1; WHILE (I <= FDIR^[0].DNUMFILES) AND NOT FOUND DO BEGIN WITH FDIR^[I] DO IF DTID = FTID THEN IF FINDPERM = (DACCESS.YEAR <> 100) THEN BEGIN DIRSEARCH := I; FOUND := TRUE END; I := I+1 END END (*DIRSEARCH*) ; PROCEDURE DELENTRY(*FINX: DIRRANGE; FDIR: DIRP*); VAR I: DIRRANGE; BEGIN WITH FDIR^[0] DO BEGIN FOR I := FINX TO DNUMFILES-1 DO FDIR^[I] := FDIR^[I+1]; FDIR^[DNUMFILES].DTID := ''; DNUMFILES := DNUMFILES-1 END END (*DELENTRY*) ; PROCEDURE INSENTRY(*VAR FENTRY: DIRENTRY; FINX: DIRRANGE; FDIR: DIRP*); VAR I: DIRRANGE; BEGIN WITH FDIR^[0] DO BEGIN FOR I := DNUMFILES DOWNTO FINX DO FDIR^[I+1] := FDIR^[I]; FDIR^[FINX] := FENTRY; DNUMFILES := DNUMFILES+1 END END (*INSENTRY*) ; FUNCTION ENTERTEMP(VAR FTID: TID; FSEGS: INTEGER; FKIND: FILEKIND; FDIR: DIRP): DIRRANGE; VAR I,LASTI,DINX: DIRRANGE; LDE: DIRENTRY; PROCEDURE FINDMAX(CURINX: DIRRANGE; FIRSTOPEN,NEXTUSED: INTEGER); VAR FREEAREA: INTEGER; BEGIN FREEAREA := NEXTUSED-FIRSTOPEN; IF FREEAREA > FSEGS THEN BEGIN DINX := CURINX; FSEGS := FREEAREA END END (*FINDMAX*) ; BEGIN (*ENTERTEMP*) DINX := 0; LASTI := FDIR^[0].DNUMFILES; IF FSEGS = 0 THEN BEGIN FOR I := 1 TO LASTI DO FINDMAX(I,FDIR^[I-1].DLASTBLK,FDIR^[I].DFIRSTBLK); FINDMAX(LASTI+1,FDIR^[LASTI].DLASTBLK,FDIR^[0].DEOVBLK) END ELSE BEGIN I := 1; WHILE I <= LASTI DO BEGIN IF FDIR^[I].DFIRSTBLK-FDIR^[I-1].DLASTBLK >= FSEGS THEN BEGIN DINX := I; I := LASTI END; I := I+1 END; IF DINX = 0 THEN IF FDIR^[0].DEOVBLK-FDIR^[LASTI].DLASTBLK >= FSEGS THEN DINX := LASTI+1 END; IF LASTI = MAXDIR THEN DINX := 0 ELSE IF DINX > 0 THEN BEGIN WITH LDE DO BEGIN DFIRSTBLK := FDIR^[DINX-1].DLASTBLK; DLASTBLK := DFIRSTBLK+FSEGS; DFKIND := FKIND; DTID := FTID; DLASTBYTE := FBLKSIZE; WITH DACCESS DO BEGIN MONTH := 0; DAY := 0; YEAR := 100 END END; INSENTRY(LDE,DINX,FDIR) END; ENTERTEMP := DINX END (*ENTERTEMP*) ; (* FILE STATE HANDLERS *) PROCEDURE FINIT(*VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER*); BEGIN WITH F DO BEGIN FISOPEN := FALSE; FEOF := TRUE; FEOLN := TRUE; FWINDOW := WINDOW; IF RECWORDS = 0 THEN FRECSIZE := 1 ELSE IF RECWORDS < 0 THEN FRECSIZE := 0 ELSE FRECSIZE := RECWORDS+RECWORDS END END (*FINIT*) ; PROCEDURE FOPEN(*VAR F: FIB; VAR FTITLE: STRING; FOPENOLD: BOOLEAN; JUNK PARAM*); LABEL 1; VAR LDIR: DIRP; LUNIT: UNITNUM; LINX: DIRRANGE; LSEGS: INTEGER; LKIND: FILEKIND; LVID: VID; LTID: TID; BEGIN SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN THEN SYSCOM^.IORSLT := INOTCLOSED ELSE IF SCANTITLE(FTITLE,LVID,LTID,LSEGS,LKIND) THEN BEGIN (*GOT AN OK TITLE*) IF ORD(FOPENOLD) > 1 THEN (*OLD CODE FILE*) FOPENOLD := (ORD(FOPENOLD) = 2) OR (ORD(FOPENOLD) = 4); LUNIT := VOLSEARCH(LVID,TRUE,LDIR); IF LUNIT = 0 THEN SYSCOM^.IORSLT := INOUNIT ELSE WITH UNITABLE[LUNIT] DO BEGIN (*OK...OPEN UP FILE*) FISOPEN := TRUE; FEOF := FALSE; FEOLN := FALSE; FMODIFIED := FALSE; FUNIT := LUNIT; FVID := LVID; FNXTBLK := 0; FISBLKD := UISBLKD; FGOTACHAR := FALSE; FSOFTBUF := FISBLKD AND (FRECSIZE <> 0); IF (LENGTH(LTID) = 0) OR NOT UISBLKD THEN WITH FHEADER DO BEGIN (*DIRECT UNIT OPEN, SET UP DUMMY FHEADER*) DFIRSTBLK := 0; DLASTBLK := 0; IF UISBLKD THEN DLASTBLK := UEOVBLK; DFKIND := LKIND; DTID := ''; DLASTBYTE := FBLKSIZE; WITH DACCESS DO BEGIN MONTH := 0; DAY := 0; YEAR := 0 END END ELSE BEGIN (*LOOKUP OR ENTER FHEADER IN DIRECTORY*) LINX := DIRSEARCH(LTID,FOPENOLD,LDIR); IF FOPENOLD THEN IF LINX = 0 THEN BEGIN SYSCOM^.IORSLT := INOFILE; GOTO 1 END ELSE FHEADER := LDIR^[LINX] ELSE (*OPEN NEW FILE*) IF LINX > 0 THEN BEGIN SYSCOM^.IORSLT := IDUPFILE; GOTO 1 END ELSE BEGIN (*MAKE A TEMP ENTRY*) IF LKIND = UNTYPEDFILE THEN LKIND := DATAFILE; LINX := ENTERTEMP(LTID,LSEGS,LKIND,LDIR); IF LINX = 0 THEN BEGIN SYSCOM^.IORSLT := INOROOM; GOTO 1 END; FHEADER := LDIR^[LINX]; FMODIFIED := TRUE; WRITEDIR(LUNIT,LDIR) END END; IF FOPENOLD THEN FMAXBLK := FHEADER.DLASTBLK-FHEADER.DFIRSTBLK ELSE FMAXBLK := 0; IF FSOFTBUF THEN BEGIN FNXTBYTE := FBLKSIZE; FBUFCHNGD := FALSE; IF FOPENOLD THEN FMAXBYTE := FHEADER.DLASTBYTE ELSE FMAXBYTE := FBLKSIZE; WITH FHEADER DO IF (FRECSIZE = 1) AND (DFKIND = TEXTFILE) THEN BEGIN FNXTBLK := 2; IF NOT FOPENOLD THEN BEGIN (*NEW TEXT...NULLS IN FIRST PAGE*) FILLCHAR(FBUFFER,SIZEOF(FBUFFER),0); UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK); UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+1) END END END; 1: IF IORESULT <> ORD(INOERROR) THEN BEGIN FISOPEN := FALSE; FEOF := TRUE; FEOLN := TRUE END END END ELSE SYSCOM^.IORSLT := IBADTITLE END (*FOPEN*) ; PROCEDURE FCLOSE(*VAR F: FIB; FTYPE: CLOSETYPE*); LABEL 1; VAR LINX,DUPINX: DIRRANGE; LDIR: DIRP; FOUND: BOOLEAN; BEGIN SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN AND (FWINDOW <> INPUTFIB^.FWINDOW) AND (FWINDOW <> SYSTERM^.FWINDOW) THEN BEGIN IF FISBLKD THEN WITH FHEADER DO IF LENGTH(DTID) > 0 THEN BEGIN (*FILE IN A DISK DIRECTORY...FIXUP MAYBE*) IF FTYPE = CCRUNCH THEN BEGIN FMAXBLK := FNXTBLK; DACCESS.YEAR := 100; FTYPE := CLOCK; IF FSOFTBUF THEN FMAXBYTE := FNXTBYTE END; IF FTYPE <> CPURGE THEN FRESET(F); IF FMODIFIED OR (DACCESS.YEAR = 100) OR (FTYPE = CPURGE) THEN BEGIN (*HAVE TO CHANGE DIRECTORY ENTRY*) IF FUNIT <> VOLSEARCH(FVID,FALSE,LDIR) THEN BEGIN SYSCOM^.IORSLT := ILOSTUNIT; GOTO 1 END; LINX := 1; FOUND := FALSE; WHILE (LINX <= LDIR^[0].DNUMFILES) AND NOT FOUND DO BEGIN (*LOOK FOR FIRST BLOCK MATCH*) FOUND := (LDIR^[LINX].DFIRSTBLK = DFIRSTBLK) AND (LDIR^[LINX].DLASTBLK = DLASTBLK); LINX := LINX + 1 END; IF NOT FOUND THEN BEGIN SYSCOM^.IORSLT := ILOSTFILE; GOTO 1 END; LINX := LINX - 1; (*CORRECT OVERRUN*) IF ((FTYPE = CNORMAL) AND (LDIR^[LINX].DACCESS.YEAR = 100)) OR (FTYPE = CPURGE) THEN DELENTRY(LINX,LDIR) (*ZAP FILE OUT OF EXISTANCE*) ELSE BEGIN (*WELL...LOCK IN A PERM DIR ENTRY*) DUPINX := DIRSEARCH(DTID,TRUE,LDIR); IF (DUPINX <> 0) AND (DUPINX <> LINX) THEN BEGIN (*A DUPLICATE PERM ENTRY...ZAP OLD ONE*) DELENTRY(DUPINX,LDIR); IF DUPINX < LINX THEN LINX := LINX-1 END; IF LDIR^[LINX].DACCESS.YEAR = 100 THEN IF DACCESS.YEAR = 100 THEN DACCESS := THEDATE ELSE (*LEAVE ALONE...FILER SPECIAL CASE*) ELSE IF FMODIFIED AND (THEDATE.MONTH <> 0) THEN DACCESS := THEDATE ELSE DACCESS := LDIR^[LINX].DACCESS; DLASTBLK := DFIRSTBLK+FMAXBLK; IF FSOFTBUF THEN DLASTBYTE := FMAXBYTE; FMODIFIED := FALSE; LDIR^[LINX] := FHEADER END; WRITEDIR(FUNIT,LDIR) END END; IF FTYPE = CPURGE THEN IF LENGTH(FHEADER.DTID) = 0 THEN UNITABLE[FUNIT].UVID := ''; 1: FEOF := TRUE; FEOLN := TRUE; FISOPEN := FALSE END END (*FCLOSE*) ; PROCEDURE FSEEK(*F: FIB; RECNUM: INTEGER*); BEGIN END (*FSEEK*) ; ======================================================================================== DOCUMENT :usus Folder:VOL17:system.b.text ======================================================================================== (* INPUT-OUTPUT PRIMITIVES *) FUNCTION CANTSTRETCH(VAR F: FIB): BOOLEAN; LABEL 1; VAR LINX: DIRRANGE; FOUND: BOOLEAN; LAVAILBLK: INTEGER; LDIR: DIRP; BEGIN CANTSTRETCH := TRUE; WITH F,FHEADER DO IF LENGTH(DTID) > 0 THEN BEGIN (*IN A DIRECTORY FOR SURE*) IF FUNIT <> VOLSEARCH(FVID,FALSE,LDIR) THEN BEGIN SYSCOM^.IORSLT := ILOSTUNIT; GOTO 1 END; FOUND := FALSE; LINX := 1; WHILE (LINX <= LDIR^[0].DNUMFILES) AND NOT FOUND DO BEGIN FOUND := (LDIR^[LINX].DFIRSTBLK = DFIRSTBLK) AND (LDIR^[LINX].DLASTBLK = DLASTBLK); LINX := LINX+1 END; IF NOT FOUND THEN BEGIN SYSCOM^.IORSLT := ILOSTFILE; GOTO 1 END; IF LINX > LDIR^[0].DNUMFILES THEN LAVAILBLK := LDIR^[0].DEOVBLK ELSE LAVAILBLK := LDIR^[LINX].DFIRSTBLK; IF (DLASTBLK < LAVAILBLK) OR (DLASTBYTE < FBLKSIZE) THEN BEGIN WITH LDIR^[LINX-1] DO BEGIN DLASTBLK := LAVAILBLK; DLASTBYTE := FBLKSIZE; WRITEDIR(FUNIT,LDIR); IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END; FEOF := FALSE; FEOLN := FALSE; FGOTACHAR := FALSE; DLASTBLK := LAVAILBLK; DLASTBYTE := FBLKSIZE; DACCESS.YEAR := 100; CANTSTRETCH := FALSE END END; IF FALSE THEN 1: BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END END (*CANTSTRETCH*) ; PROCEDURE FRESET(*VAR F: FIB*); VAR BIGGER: BOOLEAN; BEGIN SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN THEN BEGIN FGOTACHAR := FALSE; FEOLN := FALSE; FEOF := FALSE; IF FISBLKD THEN BEGIN BIGGER := FNXTBLK > FMAXBLK; IF BIGGER THEN FMAXBLK := FNXTBLK; IF FSOFTBUF THEN BEGIN IF BIGGER THEN FMAXBYTE := FNXTBYTE ELSE IF FNXTBLK = FMAXBLK THEN IF FNXTBYTE > FMAXBYTE THEN FMAXBYTE := FNXTBYTE; IF FBUFCHNGD THEN BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE; UNITWRITE(FUNIT,FBUFFER,FBLKSIZE, FHEADER.DFIRSTBLK+FNXTBLK-1) END; FNXTBYTE := FBLKSIZE END; FNXTBLK := 0; IF FSOFTBUF THEN IF (FRECSIZE = 1) AND (FHEADER.DFKIND = TEXTFILE) THEN FNXTBLK := 2 END END END (*FRESET*) ; FUNCTION FBLOCKIO(*VAR F: FIB; VAR A: WINDOW; NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN*); LABEL 1; BEGIN FBLOCKIO := 0; SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN AND (NBLOCKS >= 0) THEN IF FISBLKD THEN WITH FHEADER DO BEGIN IF RBLOCK < 0 THEN RBLOCK := FNXTBLK; RBLOCK := DFIRSTBLK+RBLOCK; IF RBLOCK+NBLOCKS > DLASTBLK THEN IF DOREAD THEN NBLOCKS := DLASTBLK-RBLOCK ELSE IF CANTSTRETCH(F) THEN NBLOCKS := DLASTBLK-RBLOCK ELSE IF RBLOCK+NBLOCKS > DLASTBLK THEN NBLOCKS := DLASTBLK-RBLOCK; FEOF := RBLOCK >= DLASTBLK; IF NOT FEOF THEN BEGIN IF DOREAD THEN UNITREAD(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK) ELSE BEGIN FMODIFIED := TRUE; UNITWRITE(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK) END; IF IORESULT <> ORD(INOERROR) THEN GOTO 1; FBLOCKIO := NBLOCKS; RBLOCK := RBLOCK+NBLOCKS; FEOF := RBLOCK = DLASTBLK; FNXTBLK := RBLOCK-DFIRSTBLK; FMAXBYTE := FBLKSIZE; IF FNXTBLK > FMAXBLK THEN FMAXBLK := FNXTBLK END END ELSE BEGIN FBLOCKIO := NBLOCKS; IF DOREAD THEN UNITREAD(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK) ELSE UNITWRITE(FUNIT,A,NBLOCKS*FBLKSIZE,RBLOCK); IF IORESULT = ORD(INOERROR) THEN IF DOREAD THEN BEGIN RBLOCK := NBLOCKS*FBLKSIZE; RBLOCK := RBLOCK+SCAN(-RBLOCK,<>CHR(0),A[RBLOCK-1]); RBLOCK := (RBLOCK+FBLKSIZE-1) DIV FBLKSIZE; FBLOCKIO := RBLOCK; FEOF := RBLOCK < NBLOCKS END ELSE ELSE FBLOCKIO := 0 END ELSE SYSCOM^.IORSLT := INOTOPEN; 1: END (*FBLOCKIO*) ; PROCEDURE FGET(*VAR F: FIB*); LABEL 1; VAR LEFTOGET,WININX,LEFTINBUF,AMOUNT: INTEGER; DONE: BOOLEAN; BEGIN SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN THEN BEGIN IF FSOFTBUF THEN WITH FHEADER DO BEGIN LEFTOGET := FRECSIZE; WININX := 0; REPEAT IF FNXTBLK = FMAXBLK THEN IF FNXTBYTE+LEFTOGET > FMAXBYTE THEN GOTO 1 ELSE LEFTINBUF := DLASTBYTE-FNXTBYTE ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE; AMOUNT := LEFTOGET; IF AMOUNT > LEFTINBUF THEN AMOUNT := LEFTINBUF; IF AMOUNT > 0 THEN BEGIN MOVELEFT(FBUFFER[FNXTBYTE],FWINDOW^[WININX],AMOUNT); FNXTBYTE := FNXTBYTE+AMOUNT; WININX := WININX+AMOUNT; LEFTOGET := LEFTOGET-AMOUNT END; DONE := LEFTOGET = 0; IF NOT DONE THEN BEGIN FNXTBYTE := 0; (*GET NEXT BLOCK*) IF FBUFCHNGD THEN BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE; UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1) END; IF IORESULT <> ORD(INOERROR) THEN GOTO 1; UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK); FNXTBLK := FNXTBLK+1; IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END UNTIL DONE END ELSE BEGIN UNITREAD(FUNIT,FWINDOW^,FRECSIZE); IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END; IF FRECSIZE = 1 THEN (*FILE OF CHAR*) BEGIN FEOLN := FALSE; FGOTACHAR := TRUE; IF FWINDOW^[0] = CHR(EOL) THEN BEGIN FWINDOW^[0] := ' '; FEOLN := TRUE END; IF FWINDOW^[0] = CHR(0) THEN BEGIN (*EOF HANDLING*) IF FSOFTBUF AND (FHEADER.DFKIND = TEXTFILE) THEN BEGIN (*END OF 2 BLOCK PAGE*) IF ODD(FNXTBLK) THEN FNXTBLK := FNXTBLK+1; FNXTBYTE := FBLKSIZE; FGET(F) END ELSE BEGIN FWINDOW^[0] := ' '; GOTO 1 END END END END ELSE SYSCOM^.IORSLT := INOTOPEN; IF FALSE THEN 1: BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END END (*FGET*) ; PROCEDURE FPUT(*VAR F: FIB*); LABEL 1; VAR LEFTOPUT,WININX,LEFTINBUF,AMOUNT: INTEGER; DONE: BOOLEAN; BEGIN SYSCOM^.IORSLT := INOERROR; WITH F DO IF FISOPEN THEN BEGIN IF FSOFTBUF THEN WITH FHEADER DO BEGIN LEFTOPUT := FRECSIZE; WININX := 0; REPEAT IF DFIRSTBLK+FNXTBLK = DLASTBLK THEN IF FNXTBYTE+LEFTOPUT > DLASTBYTE THEN IF CANTSTRETCH(F) THEN GOTO 1 ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE ELSE LEFTINBUF := DLASTBYTE-FNXTBYTE ELSE LEFTINBUF := FBLKSIZE-FNXTBYTE; AMOUNT := LEFTOPUT; IF AMOUNT > LEFTINBUF THEN AMOUNT := LEFTINBUF; IF AMOUNT > 0 THEN BEGIN FBUFCHNGD := TRUE; MOVELEFT(FWINDOW^[WININX],FBUFFER[FNXTBYTE],AMOUNT); FNXTBYTE := FNXTBYTE+AMOUNT; WININX := WININX+AMOUNT; LEFTOPUT := LEFTOPUT-AMOUNT END; DONE := LEFTOPUT = 0; IF NOT DONE THEN BEGIN FNXTBYTE := 0; (*WRITE BUFFER...MAYBE GET NEXT*) IF FBUFCHNGD THEN BEGIN FBUFCHNGD := FALSE; FMODIFIED := TRUE; UNITWRITE(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK-1) END; IF IORESULT <> ORD(INOERROR) THEN GOTO 1; IF FNXTBLK < FMAXBLK THEN UNITREAD(FUNIT,FBUFFER,FBLKSIZE,DFIRSTBLK+FNXTBLK) ELSE IF FRECSIZE = 1 THEN FILLCHAR(FBUFFER,FBLKSIZE,CHR(0)); FNXTBLK := FNXTBLK+1; IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END UNTIL DONE; IF FRECSIZE = 1 THEN IF FWINDOW^[0] = CHR(EOL) THEN IF DFKIND = TEXTFILE THEN IF (FNXTBYTE >= FBLKSIZE-80) AND NOT ODD(FNXTBLK) THEN BEGIN FNXTBYTE := FBLKSIZE-1; FWINDOW^[0] := CHR(0); FPUT(F) END END ELSE BEGIN UNITWRITE(FUNIT,FWINDOW^,FRECSIZE); IF IORESULT <> ORD(INOERROR) THEN GOTO 1 END END ELSE SYSCOM^.IORSLT := INOTOPEN; IF FALSE THEN 1: BEGIN F.FEOF := TRUE; F.FEOLN := TRUE END END (*FPUT*) ; FUNCTION FEOF(*VAR F: FIB*); BEGIN FEOF := F.FEOF END; (* TEXT FILE INTRINSICS *) FUNCTION FEOLN(*VAR F: FIB*); BEGIN FEOLN := F.FEOLN END; PROCEDURE FWRITELN(*VAR F: FIB*); BEGIN F.FWINDOW^[0] := CHR(EOL); FPUT(F) END (*FWRITELN*) ; PROCEDURE FWRITECHAR(*VAR F: FIB; CH: CHAR; RLENG: INTEGER*); LABEL 1; BEGIN WITH F DO IF FISOPEN THEN IF FSOFTBUF THEN BEGIN WHILE RLENG > 1 DO BEGIN FWINDOW^[0] := ' '; FPUT(F); RLENG := RLENG-1 END; FWINDOW^[0] := CH; FPUT(F) END ELSE BEGIN WHILE RLENG > 1 DO BEGIN FWINDOW^[0] := ' '; UNITWRITE(FUNIT,FWINDOW^,1); RLENG := RLENG-1 END; FWINDOW^[0] := CH; UNITWRITE(FUNIT,FWINDOW^,1) END ELSE SYSCOM^.IORSLT := INOTOPEN; 1: END (*FWRITECHAR*) ; PROCEDURE FWRITEINT(*VAR F: FIB; I,RLENG: INTEGER*); VAR POT,COL: INTEGER; CH: CHAR; SUPPRESSING: BOOLEAN; S: STRING[10]; BEGIN COL := 1; SUPPRESSING := TRUE; IF I < 0 THEN BEGIN I := ABS(I); S[1] := '-'; COL := 2; IF I < 0 THEN I := 0 END; FOR POT := 4 DOWNTO 0 DO BEGIN CH := CHR(I DIV IPOT[POT] + ORD('0')); IF (CH = '0') AND (POT > 0) AND SUPPRESSING THEN ELSE (*FORMAT THE CHAR*) BEGIN SUPPRESSING := FALSE; S[COL] := CH; COL := COL+1; IF CH <> '0' THEN I := I MOD IPOT[POT] END END; S[0] := CHR(COL-1); FWRITESTRING(F,S,RLENG) END (*FWRITEINT*) ; PROCEDURE FWRITEREAL(*VAR F: FIB; X: REAL; W,D: INTEGER*); VAR I,J,TRUNCX,SINX: INTEGER; CH: CHAR; S: STRING[20]; PROCEDURE PUTCH(CH: CHAR); BEGIN S[SINX] := CH; SINX := SINX+1 END (*PUTCH*) ; BEGIN S[0] := CHR(20); SINX := 1; PUTCH(' '); IF (W < 0) OR (D < 0) OR (D > 6) THEN BEGIN D := 0; W := 0 END; IF X < 0 THEN BEGIN X := ABS(X); S[1] := '-' END; IF X = 0 THEN I := 0 ELSE I := TRUNC(LOG(X)); IF I > 0 THEN X := X/PWROFTEN(I) ELSE IF I < 0 THEN X := X*PWROFTEN(ABS(I)); IF X = 0 THEN BEGIN CH := '0'; TRUNCX := 0 END ELSE REPEAT TRUNCX := TRUNC(X); CH := CHR(TRUNCX+ORD('0')); IF TRUNCX = 0 THEN BEGIN I := I-1; X := X*10 END UNTIL TRUNCX <> 0; PUTCH(CH); PUTCH('.'); X := (X-TRUNCX)*10; J := 0; REPEAT TRUNCX := TRUNC(X); PUTCH(CHR(TRUNCX+ORD('0'))); X := (X-TRUNCX)*10; J := J+1 UNTIL J = 6; SINX := 3; IF (I > 0) AND (I < 6) THEN IF (6-I) >= D THEN BEGIN MOVELEFT(S[SINX+1],S[SINX],I); SINX := SINX+I; S[SINX] := '.'; I := 0 END; IF D = 0 THEN BEGIN D := 9; WHILE S[D] = '0' DO D := D-1; D := D-SINX; IF D = 0 THEN D := 1 END; SINX := SINX+D+1; IF SINX <= 9 THEN IF S[SINX] >= '5' THEN BEGIN FOR J := SINX-1 DOWNTO 2 DO IF S[J] <> '.' THEN BEGIN S[J] := SUCC(S[J]); IF S[J] > '9' THEN S[J] := '0' ELSE J := 0 END; IF J > 0 THEN BEGIN SINX := SINX+1; MOVERIGHT(S[2],S[3],12); S[2] := '1' END END; IF I <> 0 THEN BEGIN PUTCH('E'); IF I < 0 THEN BEGIN PUTCH('-'); I := ABS(I) END; IF I > 9 THEN BEGIN PUTCH(CHR(I DIV 10 + ORD('0'))); I := I MOD 10 END; PUTCH(CHR(I + ORD('0'))) END; S[0] := CHR(SINX-1); FWRITESTRING(F,S,W) END (*FWRITEREAL*) ; PROCEDURE FWRITESTRING(*VAR F: FIB; VAR S: STRING; RLENG: INTEGER*); VAR SINX: INTEGER; BEGIN WITH F DO IF FISOPEN THEN BEGIN IF RLENG <= 0 THEN RLENG := LENGTH(S); IF RLENG > LENGTH(S) THEN BEGIN FWRITECHAR(F,' ',RLENG-LENGTH(S)); RLENG := LENGTH(S) END; IF FSOFTBUF THEN BEGIN SINX := 1; WHILE (SINX <= RLENG) AND NOT FEOF DO BEGIN FWINDOW^[0] := S[SINX]; FPUT(F); SINX := SINX+1 END END ELSE UNITWRITE(FUNIT,S[1],RLENG) END ELSE SYSCOM^.IORSLT := INOTOPEN END (*FWRITESTRING*) ; PROCEDURE FWRITEBYTES(*VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER*); VAR AINX: INTEGER; BEGIN WITH F DO IF FISOPEN THEN BEGIN IF RLENG > ALENG THEN BEGIN FWRITECHAR(F,' ',RLENG-ALENG); RLENG := ALENG END; IF FSOFTBUF THEN BEGIN AINX := 0; WHILE (AINX < RLENG) AND NOT FEOF DO BEGIN FWINDOW^[0] := A[AINX]; FPUT(F); AINX := AINX+1 END END ELSE UNITWRITE(FUNIT,A,RLENG) END ELSE SYSCOM^.IORSLT := INOTOPEN END (*FWRITEBYTES*) ; PROCEDURE FREADLN(*VAR F: FIB*); BEGIN WHILE NOT F.FEOLN DO FGET(F); F.FGOTACHAR := FALSE; F.FEOLN := FALSE END (*FREADLN*) ; PROCEDURE FREADCHAR(*VAR F: FIB; VAR CH: CHAR*); BEGIN WITH F DO IF FISOPEN THEN BEGIN SYSCOM^.IORSLT := INOERROR; IF NOT FGOTACHAR THEN FGET(F); CH := FWINDOW^[0]; FGOTACHAR := FALSE END ELSE SYSCOM^.IORSLT := INOTOPEN END (*FREADCHAR*) ; PROCEDURE FREADINT(*VAR F: FIB; VAR I: INTEGER*); LABEL 1; VAR CH: CHAR; NEG,IVALID: BOOLEAN; BEGIN WITH F DO IF FISOPEN THEN BEGIN I := 0; NEG := FALSE; IVALID := FALSE; IF NOT FGOTACHAR THEN FGET(F); WHILE (FWINDOW^[0] = ' ') AND NOT FEOF DO FGET(F); IF FEOF THEN GOTO 1; CH := FWINDOW^[0]; IF (CH = '+') OR (CH = '-') THEN BEGIN NEG := CH = '-'; FGET(F); CH := FWINDOW^[0] END; WHILE (CH IN ['0'..'9']) AND NOT FEOF DO BEGIN IVALID := TRUE; I := I*10 + ORD(CH) - ORD('0'); FGET(F); CH := FWINDOW^[0] END; IF IVALID OR FEOF THEN IF NEG THEN I := -I ELSE (*NADA*) ELSE SYSCOM^.IORSLT := IBADFORMAT END ELSE SYSCOM^.IORSLT := INOTOPEN; 1: END (*FREADINT*) ; PROCEDURE FREADREAL(*VAR F: FIB; VAR X: REAL*); LABEL 1; VAR CH: CHAR; NEG,XVALID: BOOLEAN; IPOT: INTEGER; NUMBERS: SET OF '0'..'9'; BEGIN WITH F DO IF FISOPEN THEN BEGIN X := 0; NEG := FALSE; XVALID := FALSE; NUMBERS := ['0'..'9']; IF NOT FGOTACHAR THEN FGET(F); WHILE (FWINDOW^[0] = ' ') AND NOT FEOF DO FGET(F); IF FEOF THEN GOTO 1; CH := FWINDOW^[0]; IF (CH = '+') OR (CH = '-') THEN BEGIN NEG := CH = '-'; FGET(F); CH := FWINDOW^[0] END; WHILE (CH IN NUMBERS) AND NOT FEOF DO BEGIN XVALID := TRUE; X := X*10 + (ORD(CH)-ORD('0')); FGET(F); CH := FWINDOW^[0] END; IF FEOF THEN GOTO 1; IPOT := -1; IF CH = '.' THEN BEGIN IPOT := 0; REPEAT FGET(F); CH := FWINDOW^[0]; IF CH IN NUMBERS THEN BEGIN XVALID := TRUE; IPOT := IPOT + 1; X := X + (ORD(CH)-ORD('0'))/PWROFTEN(IPOT) END UNTIL FEOF OR NOT (CH IN NUMBERS); IF FEOF THEN GOTO 1 END; IF ((CH = 'e') OR (CH = 'E')) AND (XVALID OR (IPOT < 0)) THEN BEGIN FGOTACHAR := FALSE; FREADINT(F,IPOT); IF FEOF THEN GOTO 1; IF NOT XVALID THEN X := 1; XVALID := TRUE; IF IPOT < 0 THEN X := X/PWROFTEN(ABS(IPOT)) ELSE X := X*PWROFTEN(IPOT) END; IF XVALID THEN IF NEG THEN X := -X ELSE ELSE SYSCOM^.IORSLT := IBADFORMAT END ELSE SYSCOM^.IORSLT := INOTOPEN; 1: END (*FREADREAL*) ; PROCEDURE FREADSTRING(*VAR F: FIB; VAR S: STRING; SLENG: INTEGER*); VAR SINX: INTEGER; CH: CHAR; BEGIN WITH F DO IF FISOPEN THEN BEGIN SINX := 1; IF FEOLN THEN FREADLN(F); S[0] := CHR(SLENG); (*NO INV INDEX*) WHILE (SINX <= SLENG) AND NOT (FEOLN OR FEOF) DO BEGIN IF NOT FGOTACHAR THEN FGET(F); IF NOT FEOLN THEN BEGIN CH := FWINDOW^[0]; FGOTACHAR := FALSE; IF FUNIT = 1 THEN IF CHECKDEL(CH,SINX) THEN ELSE BEGIN S[SINX] := CH; SINX := SINX + 1 END ELSE BEGIN S[SINX] := CH; SINX := SINX + 1 END END END; S[0] := CHR(SINX - 1); WHILE NOT FEOLN DO FGET(F) END ELSE SYSCOM^.IORSLT := INOTOPEN END (*FREADSTRING*) ; (* STRING VARIABLE INTRINSICS *) PROCEDURE SCONCAT(*VAR SRC,DEST: STRING; DESTLENG: INTEGER*); BEGIN IF LENGTH(SRC)+LENGTH(DEST) <= DESTLENG THEN BEGIN MOVELEFT(SRC[1],DEST[LENGTH(DEST)+1],LENGTH(SRC)); DEST[0] := CHR(LENGTH(SRC)+LENGTH(DEST)) END END (*SCONCAT*) ; PROCEDURE SINSERT(*VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER*); VAR ONRIGHT: INTEGER; BEGIN IF (INSINX > 0) AND (LENGTH(SRC) > 0) AND (LENGTH(SRC)+LENGTH(DEST) <= DESTLENG) THEN BEGIN ONRIGHT := LENGTH(DEST)-INSINX+1; IF ONRIGHT > 0 THEN BEGIN MOVERIGHT(DEST[INSINX],DEST[INSINX+LENGTH(SRC)],ONRIGHT); ONRIGHT := 0 END; IF ONRIGHT = 0 THEN BEGIN MOVELEFT(SRC[1],DEST[INSINX],LENGTH(SRC)); DEST[0] := CHR(LENGTH(DEST)+LENGTH(SRC)) END END END (*SINSERT*) ; PROCEDURE SCOPY(*VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER*); BEGIN DEST := ''; IF (SRCINX > 0) AND (COPYLENG > 0) AND (SRCINX+COPYLENG-1 <= LENGTH(SRC)) THEN BEGIN MOVELEFT(SRC[SRCINX],DEST[1],COPYLENG); DEST[0] := CHR(COPYLENG) END END (*SCOPY*) ; PROCEDURE SDELETE(*VAR DEST: STRING; DELINX,DELLENG: INTEGER*); VAR ONRIGHT: INTEGER; BEGIN IF (DELINX > 0) AND (DELLENG > 0) THEN BEGIN ONRIGHT := LENGTH(DEST)-DELINX-DELLENG+1; IF ONRIGHT = 0 THEN DEST[0] := CHR(DELINX-1) ELSE IF ONRIGHT > 0 THEN BEGIN MOVELEFT(DEST[DELINX+DELLENG],DEST[DELINX],ONRIGHT); DEST[0] := CHR(LENGTH(DEST)-DELLENG) END END END (*SDELETE*) ; FUNCTION SPOS(*VAR TARGET,SRC: STRING*); LABEL 1; VAR I,LASTI: INTEGER; FIRSTCH: CHAR; TEMP: STRING; BEGIN SPOS := 0; IF LENGTH(TARGET) > 0 THEN BEGIN FIRSTCH := TARGET[1]; LASTI := LENGTH(SRC)-LENGTH(TARGET)+1; I := 1; TEMP[0] := TARGET[0]; WHILE I <= LASTI DO BEGIN IF SRC[I] = FIRSTCH THEN BEGIN MOVELEFT(SRC[I],TEMP[1],LENGTH(TARGET)); IF TEMP = TARGET THEN BEGIN SPOS := I; GOTO 1 END END; I := I+1 END END; 1: END (*SPOS*) ; (*MAIN STUFF OF SYSTEM*) PROCEDURE COMPILE; LABEL 1; VAR LTITLE: STRING[25]; BEGIN WITH USERINFO DO IF NOT GOTSYM THEN BEGIN WRITELN(OUTPUT); WRITE(OUTPUT,'No workfile') END ELSE BEGIN LTITLE := CONCAT(SYMVID,':',SYMTID); FOPEN(SYMFIBP^,LTITLE,TRUE,NIL); IF IORESULT <> ORD(INOERROR) THEN BEGIN WRITELN(OUTPUT); WRITE(OUTPUT,'Lost workfile!'); GOTSYM := FALSE; GOTO 1 END; LTITLE := '*SYSTEM.WRK.CODE'; FOPEN(CODEFIBP^,LTITLE,FALSE,NIL); ERRNUM := 0; ERRBLK := 0; ERRSYM := 0; WRITELN(OUTPUT,'Compiling...'); COMPILER(USERINFO); RELEASE(EMPTYHEAP); FCLOSE(SYMFIBP^,CNORMAL); IF SYSCOM^.MISCINFO.HAS8510A THEN UNITCLEAR(3); IF ERRNUM > 0 THEN BEGIN FCLOSE(CODEFIBP^,CPURGE); GOTCODE := FALSE; IF STUPID THEN EDITOR; ERRNUM := 0 END ELSE BEGIN CODEVID := CODEFIBP^.FVID; CODETID := CODEFIBP^.FHEADER.DTID; FCLOSE(CODEFIBP^,CLOCK); GOTCODE := TRUE END END; 1: END (*COMPILE*) ; PROCEDURE EXECUTE(*RUNWORKFILE: BOOLEAN*); LABEL 1; VAR LSEG: SEGRANGE; LTITLE: STRING[25]; LSEGTABLE: ARRAY [SEGRANGE] OF SEGDESC; BEGIN IF RUNWORKFILE THEN BEGIN WRITELN(OUTPUT); LTITLE := CONCAT(USERINFO.CODEVID,':',USERINFO.CODETID) END ELSE BEGIN PL := 'Execute? '; IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN INSERT(' what file',PL,8); PROMPT; READLN(INPUT,LTITLE); IF LENGTH(LTITLE) = 0 THEN GOTO 1; IF LTITLE[LENGTH(LTITLE)] = '.' THEN DELETE(LTITLE,LENGTH(LTITLE),1) ELSE LTITLE := CONCAT(LTITLE,'.CODE') END; FOPEN(USERINFO.CODEFIBP^,LTITLE,TRUE,NIL); IF IORESULT <> ORD(INOERROR) THEN BEGIN IF RUNWORKFILE THEN BEGIN USERINFO.GOTCODE := FALSE; WRITE(OUTPUT,'Lost workfile!') END ELSE IF IORESULT = ORD(IBADTITLE) THEN WRITE(OUTPUT,'Illegal title') ELSE WRITE(OUTPUT,'Can''t find file'); GOTO 1 END; IF USERINFO.CODEFIBP^.FHEADER.DFKIND <> CODEFILE THEN WRITE(OUTPUT,'Must be a code file') ELSE WITH SYSCOM^,USERINFO DO BEGIN UNITREAD(CODEFIBP^.FUNIT,LSEGTABLE,(MAXSEG+1)*4, CODEFIBP^.FHEADER.DFIRSTBLK); IF IORESULT <> ORD(INOERROR) THEN BEGIN IF RUNWORKFILE THEN WRITELN(OUTPUT); WRITE(OUTPUT,'Bad block # 0'); GOTO 1 END; FOR LSEG := 1 TO MAXSEG DO IF (LSEG = 1) OR (LSEG >= 10) THEN WITH SEGTABLE[LSEG],LSEGTABLE[LSEG] DO BEGIN CODEUNIT := CODEFIBP^.FUNIT; CODEDESC.CODELENG := CODELENG; CODEDESC.DISKADDR := DISKADDR + CODEFIBP^.FHEADER.DFIRSTBLK END; FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^); WRITELN(OUTPUT,'Running...'); USERPROGRAM(INPUTFIB^,OUTPUTFIB^); IF UNITBUSY(1) OR UNITBUSY(2) THEN UNITCLEAR(1); FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^) END; 1: FCLOSE(USERINFO.CODEFIBP^,CNORMAL) END (*EXECUTE*) ; PROCEDURE COMMAND; VAR CH: CHAR; BADCOMMAND: BOOLEAN; BEGIN BADCOMMAND := FALSE; REPEAT RELEASE(EMPTYHEAP); PL := 'Command: E(dit, R(un, F(ile, C(ompile, X(ecute, D(ebug, I(nit, H(alt'; PROMPT; CH := GETCHAR(BADCOMMAND); CLEARSCREEN; BADCOMMAND := NOT (CH IN ['E','D','R','F','C','X','U','I','H']); CASE CH OF 'E': EDITOR; 'D','R': BEGIN IF NOT USERINFO.GOTCODE THEN COMPILE; IF USERINFO.GOTCODE THEN BEGIN CLEARSCREEN; IF CH = 'R' THEN EXECUTE(TRUE) ELSE DEBUGGER END END; 'F': FILEHANDLER; 'C': COMPILE; 'X': EXECUTE(FALSE); 'U': BEGIN FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^); USERPROGRAM(INPUTFIB^,OUTPUTFIB^); UNITCLEAR(1); FRESET(INPUTFIB^); FRESET(OUTPUTFIB^); FRESET(SYSTERM^) END; 'I': INITIALIZE; 'H': EMPTYHEAP := NIL END UNTIL CH = 'H' END (*COMMAND*) ; BEGIN (*UCSD PASCAL SYSTEM*) EMPTYHEAP := NIL; INITIALIZE; REPEAT COMMAND; IF EMPTYHEAP <> NIL THEN INITIALIZE UNTIL EMPTYHEAP = NIL; CLEARSCREEN; PL := 'Open for business...'; PROMPT END (*PASCALSYSTEM*) . (*$I XOP:GLOBALS.TEXT *) (*$I XOP:SYSTEM.A.TEXT *) (*$I XOP:SYSTEM.B.TEXT *) (*$I XOP:GLOBALS.TEXT *) (*$I XOP:SYSTEM.A.TEXT *) (*$I XOP:SYSTEM.B.TEXT *) ======================================================================================== DOCUMENT :usus Folder:VOL17:vol17.doc.text ======================================================================================== USUS Library Volume 17 UCSD Version I.3 Sources SYSTEM.A.TEXT 48 The Operating System SYSTEM.B.TEXT 44 an include file of the operating system LINKER.TEXT 8 The Linker FILER.TEXT 50 The Filer YALOE.TEXT 44 Yaloe (I.3 didn't have a screen editor) GLOBALS.TEXT 22 Globals for the system COMP.A.TEXT 40 First file of the Compiler COMP.B.TEXT 34 an include file COMP.C.TEXT 44 ditto COMP.D.TEXT 52 ditto COMP.E.TEXT 46 ditto COMP.F.TEXT 34 ditto BOOTER.TEXT 4 The bootstrap copier XFER.TEXT 6 A single disk file transfer program VOL11.DOC.TEXT 6 You're reading it __________________________________________________________________________ Please transfer the text below to a disk label if you copy this volume. USUS Volume 17 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOL17:xfer.text ======================================================================================== (*$I-*) (*no bomb for errors in I/O*) PROGRAM LARGEFILESINGLEDISKTRANSFER; (* Keith *) CONST BLOCKS = 62; VAR LGTH: 0..BLOCKS; ITITLE,OTITLE: STRING[30]; BUF: PACKED ARRAY[0..32000] OF CHAR; IFILE,OFILE: FILE; PROCEDURE INDISK; BEGIN WRITE('Please insert disk containing source file and type '); READLN; END; PROCEDURE OUTDISK; BEGIN WRITE('Please insert disk onto which file is to be copied and type '); READLN; END; BEGIN IF EOLN THEN READLN; INDISK; REPEAT WRITE('Please type full input filename: '); READLN(ITITLE); IF LENGTH(ITITLE) = 0 THEN EXIT(PROGRAM); OPENOLD(IFILE,ITITLE); UNTIL IORESULT = 0; OUTDISK; REPEAT WRITE('Please type full output filename: '); READLN(OTITLE); IF LENGTH(OTITLE) = 0 THEN EXIT(PROGRAM); OPENNEW(OFILE,OTITLE); UNTIL IORESULT = 0; REPEAT INDISK; LGTH := BLOCKREAD(IFILE,BUF,BLOCKS); IF (IORESULT <> 0) THEN BEGIN WRITELN('Error encountered in reading'); EXIT(PROGRAM) END; OUTDISK; IF (BLOCKWRITE(OFILE,BUF,LGTH) <> LGTH) THEN BEGIN WRITELN('Error encountered in output'); EXIT(PROGRAM) END; UNTIL LGTH < BLOCKS; CLOSE(OFILE,LOCK); CLOSE(IFILE,NORMAL); WRITELN('Copy completed successfully'); END. ======================================================================================== DOCUMENT :usus Folder:VOL17:yaloe.text ======================================================================================== SEGMENT PROCEDURE USERPROGRAM(VAR I,O: TEXT); BEGIN END; SEGMENT PROCEDURE COMPILER; SEGMENT PROCEDURE COMPINIT; BEGIN END; BEGIN END; SEGMENT PROCEDURE EDITOR (* ADD THIS LINE FOR (VAR INN,OWWT: TEXT); DEBUGGING AND WORKING ON THIS SEGMENT *); (* YALOE * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE * * This text editor is based on the command structure * of the RT-11 system text editor. Initially structured * and writted by Richard Kaufmann and Greg Davidson. * Later modified, enhanced, and quickened by Keith Shillington. * Released continuously from early June 1977. * Latest fixes by Roger Sumner for I.3 8-AUG-77 * 11-AUG-77 Keith Shillington backspacing changes * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE * YALOE *) CONST RET = 13; TAB = 9; CTRLX = (*030o*) 24; DC1 = (*021o*) 17; EXECSIZE = 1000; MAXMAC = 9; (* CHANGING THIS HAS IMPACT ON THE CODE... *) SHIFT = 15; TYPE FILEBUF = PACKED ARRAY[0..1023] OF CHAR; COMARRAY = PACKED ARRAY[0..99] OF CHAR; BUFCHUNK = PACKED ARRAY[0..999] OF CHAR; VAR I,J,ENDPOS,CURSOR: INTEGER; BUFSIZE,BUFEND: INTEGER; EQUALLENGTH: INTEGER; ESC: CHAR; CTRLU: INTEGER; BACK,ACR: CHAR; EXEC: ^COMARRAY; BUF: ^BUFCHUNK; MACROS: ARRAY[0..MAXMAC] OF RECORD LGTH: INTEGER; EXEC: ^COMARRAY END; OPTION: PACKED RECORD LISTSIZE: 0..100; ONOFF: BOOLEAN END; IOFILE: FILE; FUNCTION COMMAND: BOOLEAN; FORWARD; FUNCTION MIN(A,B:INTEGER): INTEGER; BEGIN IF A>B THEN MIN := B ELSE MIN := A END; FUNCTION NEWFIN: BOOLEAN; (* TRUE IF ERROR OCCURS *) LABEL 1; VAR NBLOCKS,STASHSIZE,STASHEDAT: INTEGER; STASHCURSOR,NPAGES,I,NEXT: INTEGER; DIDDLED: BOOLEAN; BEGIN NEWFIN := FALSE; IF BLOCKREAD(IOFILE,I,0,2) = 0 THEN BEGIN (* OK *) STASHCURSOR := CURSOR; STASHSIZE := ENDPOS - CURSOR; STASHEDAT := BUFEND-STASHSIZE; IF (STASHEDAT > CURSOR) THEN (* THERE IS ROOM *) MOVERIGHT(BUF^[CURSOR],BUF^[STASHEDAT],STASHSIZE) ELSE BEGIN WRITELN(OUTPUT,'not enough space'); NEWFIN := TRUE; GOTO 1; END; DIDDLED := FALSE; IF ODD(CURSOR) THEN BEGIN DIDDLED := TRUE; CURSOR := CURSOR +1; END; NBLOCKS := (STASHEDAT - CURSOR) DIV 512; NBLOCKS := BLOCKREAD(IOFILE,BUF^[CURSOR],NBLOCKS); IF (NOT EOF(IOFILE)) OR (IORESULT <> 0) OR (ODD(NBLOCKS)) THEN BEGIN CLOSE(IOFILE); WRITELN(OUTPUT,'not enough space'); CURSOR := STASHCURSOR; NEWFIN := TRUE; GOTO 1; END; NPAGES := NBLOCKS DIV 2; IF DIDDLED THEN (* UGH *) BEGIN CURSOR := CURSOR -1; MOVELEFT(BUF^[CURSOR+1],BUF^[CURSOR],NPAGES*1024); END; NEXT := CURSOR; WHILE NPAGES > 0 DO BEGIN NPAGES := NPAGES -1; CURSOR := CURSOR +1023; NEXT := NEXT +1024; I := SCAN(-1024,<>CHR(0),BUF^[CURSOR]); CURSOR := CURSOR +I +1; (* POINT AT FIRST NUL *) IF NPAGES > 0 THEN MOVELEFT(BUF^[NEXT],BUF^[CURSOR],1024); END; 1: (* THIS IS WHERE THE WOUND IS CLOSED AND HEALED *) CLOSE(IOFILE); MOVELEFT(BUF^[STASHEDAT],BUF^[CURSOR],STASHSIZE); ENDPOS := STASHSIZE +CURSOR; BUF^[ENDPOS] := CHR(0); CURSOR := STASHCURSOR; END; END; PROCEDURE INITIALIZE; VAR BUFMAKER: ^BUFCHUNK; SPACEMAKER: ^COMARRAY; HERE: ^INTEGER; LIMIT: INTEGER; TEST: BOOLEAN; BEGIN WRITE(OUTPUT,'YALOE:'); IF NOT SYSCOM^.MISCINFO.SLOWTERM THEN WRITE(OUTPUT, ' - ? for details'); WRITELN(OUTPUT); NEW(BUF); (* BASE OF THE BUFFER *) BUFSIZE := SIZEOF(BUFCHUNK); LIMIT := ORD(SYSCOM^.LASTMP); REPEAT MARK(HERE); TEST := ((LIMIT - ORD(HERE))<5000) AND ((LIMIT - ORD(HERE))>0); IF NOT TEST THEN BEGIN NEW(BUFMAKER); BUFSIZE := BUFSIZE +SIZEOF(BUFCHUNK) END; UNTIL TEST; NEW(EXEC); FOR I := 1 TO 9 DO NEW(SPACEMAKER); (* CREATE SPACE FOR BASIC COMMAND *) FOR I := 0 TO MAXMAC DO MACROS[I].EXEC := NIL; CURSOR := 0; ENDPOS := 0; OPTION.ONOFF := FALSE; BUFEND := BUFSIZE; I := 0; ACR := CHR(RET); BACK := SYSCOM^.CRTCTRL.BACKSPACE; ESC := SYSCOM^.CRTINFO.ALTMODE; CTRLU := ORD(SYSCOM^.CRTINFO.LINEDEL); WITH USERINFO DO IF GOTSYM THEN BEGIN OPENOLD(IOFILE,CONCAT(SYMVID,':',SYMTID)); IF NEWFIN THEN BEGIN WRITELN(OUTPUT,'Lost workfile source'); GOTSYM := FALSE END ELSE BEGIN WRITE(OUTPUT,'Workfile '); IF LENGTH(WORKTID) > 0 THEN WRITE(OUTPUT,WORKTID,' '); WRITELN(OUTPUT,'read in'); END END ELSE BEGIN ENDPOS := 0; BUF^[0] := CHR(0); WRITELN(OUTPUT,'No workfile to read'); END; CURSOR := 0; EQUALLENGTH := 0; END; PROCEDURE NEWOUTLOOK; VAR I:INTEGER; STASHCURSOR: INTEGER; P: ^INTEGER; COM: ^FILEBUF; BEGIN STASHCURSOR := CURSOR; MARK(P); NEW(COM); FILLCHAR(COM^[0],1024,CHR(0)); CURSOR := 0; IF BLOCKWRITE(IOFILE,COM^,2) = 2 THEN WHILE (CURSOR + 1023) < ENDPOS DO BEGIN I := SCAN(-1022, = CHR(RET), BUF^[CURSOR +1022]); MOVELEFT(BUF^[CURSOR],COM^,1023+I); FILLCHAR(COM^[1023+I],ABS(I)+1,CHR(0)); IF BLOCKWRITE(IOFILE,COM^,2) <>2 THEN BEGIN RELEASE(P); WRITELN(OUTPUT, 'Output file error: Help'); CLOSE(IOFILE); EXIT(COMMAND); END; CURSOR := CURSOR+1023+I; END; IF (CURSOR < ENDPOS) THEN BEGIN FILLCHAR(BUF^[ENDPOS],1024-(ENDPOS-CURSOR),CHR(0)); MOVELEFT(BUF^[CURSOR],COM^,1024); IF BLOCKWRITE(IOFILE,COM^,2) <>2 THEN BEGIN RELEASE(P); WRITELN(OUTPUT,'Output file error. HELP!'); CLOSE(IOFILE); EXIT(COMMAND); END; END; RELEASE(P); CLOSE(IOFILE,LOCK); CURSOR := STASHCURSOR; END; PROCEDURE CLOSETHEWORLD(VAR CH: CHAR); VAR LTITLE : STRING[29]; EXITSET: SET OF 'A'..'z'; BEGIN EXITSET := ['E','e','U','u','R','r']; REPEAT IF NOT (CH IN EXITSET) THEN BEGIN CLEARSCREEN; WRITELN(OUTPUT,'Output options are:'); WRITELN(OUTPUT,' (U) - output to workfile'); WRITELN(OUTPUT,' (E) - exit with no output'); WRITELN(OUTPUT,' (R) - return to the editor'); READ(INPUT,CH); END; IF (CH='U') OR (CH='u') THEN WITH USERINFO DO BEGIN LTITLE := '*SYSTEM.WRK.TEXT'; OPENNEW(IOFILE,LTITLE); NEWOUTLOOK; (*IF WE GET HERE THEN FILE IS LOCKED ON DISK OK*) SYMVID := SYVID; SYMTID := 'SYSTEM.WRK.TEXT'; GOTSYM := TRUE; LTITLE := '*SYSTEM.WRK.CODE'; OPENOLD(IOFILE,LTITLE); CLOSE(IOFILE,PURGE); GOTCODE := FALSE; CODETID := '' END UNTIL CH IN EXITSET; END; PROCEDURE PROMPTS; VAR HERE: ^INTEGER; BEGIN MARK(HERE); CLEARSCREEN; WRITELN(OUTPUT,'Yet Another Line Oriented Editor.'); WRITELN(OUTPUT); WRITELN(OUTPUT, 'Advance Beginning Change Delete Get Insert Jump'); WRITELN(OUTPUT,'Kill List Macro Now '); WRITELN(OUTPUT,'Quit Read Save Unsave Verify'); WRITELN(OUTPUT,'Write eXchange ?elp'); WRITELN(OUTPUT,'Ctrl-X (can) to cancel command input.'); WRITELN(OUTPUT); WRITELN(OUTPUT,'The macros you have defined are:'); WRITE(OUTPUT,' - '); FOR I := 0 TO MAXMAC DO IF MACROS[I].EXEC <> NIL THEN WRITE(OUTPUT,I,' - '); WRITELN(OUTPUT); WRITE(OUTPUT,'Your text buffer is ',BUFSIZE,' bytes, ',ENDPOS); WRITELN(OUTPUT,' of which are filled, leaving ',BUFSIZE-ENDPOS); WRITE(OUTPUT,'Your ''save'' text is ',BUFSIZE-BUFEND,' bytes'); END; PROCEDURE INCOMMAND; LABEL 1,2; VAR ONEESC,WARNED: BOOLEAN; CH: CHAR; FACTOR,T: INTEGER; CHDEL: CHAR; CRTESC,UP,EEOL,BELL: CHAR; SLOW,WASBS: BOOLEAN; BEGIN FILLCHAR(EXEC^,EXECSIZE,ESC); FACTOR := 0; WITH SYSCOM^,CRTCTRL,MISCINFO DO BEGIN BELL := CRTINFO.BADCH; SLOW := (BACKSPACE = CHR(0)); (* NO CONTROL *) CHDEL := CRTINFO.CHARDEL; CRTESC := ESCAPE; UP := RLF; EEOL := ERASEEOL END; WASBS := FALSE; CH := ' '; I := 0; WARNED := FALSE; ONEESC := FALSE; READ(KEYBOARD,CH); IF EOLN(KEYBOARD) THEN CH := ACR; WHILE (CH <> ESC) OR NOT ONEESC DO BEGIN IF CH = CHR(SHIFT) THEN IF SYSCOM^.MISCINFO.HAS8510A THEN (*KAS 8/15*) IF FACTOR = 128 THEN FACTOR := 0 ELSE FACTOR := 128; ONEESC := (CH = ESC); IF ONEESC THEN GOTO 1; IF CH = CHDEL THEN IF (I > 0) THEN BEGIN I := PRED(I); IF SLOW THEN IF WASBS THEN WRITE(OUTPUT,EXEC^[I]) ELSE WRITE(OUTPUT,'%',EXEC^[I]) ELSE IF EXEC^[I] = CHR(TAB) THEN FOR T := 1 TO 8 DO WRITE(OUTPUT,BACK) ELSE WRITE(OUTPUT,BACK,' ',BACK); END; IF (CH = CHR(CTRLU)) THEN BEGIN IF SLOW THEN WRITELN(OUTPUT,' 0) AND (EXEC^[I] <> ACR) DO I := PRED(I); IF I <> 0 THEN I := SUCC(I) ELSE WRITE(OUTPUT,'*') END ELSE IF (CH < ' ') THEN BEGIN IF ORD(CH) IN [RET,TAB,DC1] THEN BEGIN 1: EXEC^[I] := CH; I := SUCC(I); IF ONEESC THEN WRITE(OUTPUT,'$') ELSE IF ORD(CH) = DC1 THEN WRITE(OUTPUT,BELL) ELSE WRITE(OUTPUT,CH) END; IF CH = CHR(CTRLX) THEN BEGIN I := 0; WRITELN(OUTPUT); EXIT(INCOMMAND) END END ELSE BEGIN IF WASBS AND SLOW THEN WRITE(OUTPUT,'%',CH) ELSE WRITE(OUTPUT,CH); EXEC^[I] := CH; I := SUCC(I) END; WASBS := (CH = CHDEL); IF I >= (EXECSIZE - 80 (*WARNING*)) THEN IF I > (EXECSIZE - 2) THEN REPEAT WRITELN(OUTPUT,'Command buffer full. Type or (^X).'); READ(KEYBOARD,CH); IF CH=CHR(CTRLX) THEN BEGIN I := 0; EXIT(INCOMMAND) END ELSE IF CH = ESC THEN BEGIN READ(KEYBOARD,CH); IF CH = ESC THEN EXIT(INCOMMAND); END; UNTIL FALSE ELSE IF NOT WARNED AND (CH = ACR) THEN BEGIN WRITELN(OUTPUT,'please finish',CHR(7)(* BELL *)); WARNED:=TRUE; END; READ(KEYBOARD,CH); IF EOLN(KEYBOARD) THEN CH := ACR; IF CH >= ' ' THEN CH := CHR(ORD(CH)+FACTOR) END; WRITELN(OUTPUT,'$'); I:=I-1; END; FUNCTION COMMAND(*: BOOLEAN *); VAR RCOUNT:INTEGER; THISCH: CHAR; NEG:BOOLEAN; NUMBER: SET OF '0'..'9'; PROCEDURE SYNTAX(ERRCH: CHAR); BEGIN WRITELN(OUTPUT,ERRCH,' : IS IN ERROR, COMMAND STOPPED.'); EXIT(COMMAND); END; PROCEDURE LINEPLACE(VAR PTR: INTEGER; N: INTEGER); VAR I: INTEGER; BEGIN PTR := CURSOR; (* A NICE PLACE TO START *) IF (N <= 0) THEN (* LOOK BACK *) BEGIN REPEAT PTR := PTR -1; I := SCAN(-(PTR+1),=ACR,BUF^[PTR]); PTR := PTR +I; N := SUCC(N); UNTIL (N > 0) OR (PTR < 0); PTR := SUCC(PTR); END ELSE REPEAT I := SCAN(ENDPOS-PTR-1,=ACR,BUF^[PTR]); PTR := PTR+I+1; N := N -1; UNTIL (N=0) OR (PTR = ENDPOS); END; PROCEDURE DELETESTUFF; VAR COUNT: INTEGER; BEGIN IF (RCOUNT = 0) THEN BEGIN LINEPLACE(COUNT,0); RCOUNT := COUNT - CURSOR; END; COUNT:=CURSOR+RCOUNT; IF RCOUNT<0 THEN BEGIN IF COUNT<0 THEN COUNT := 0; MOVELEFT(BUF^[CURSOR],BUF^[COUNT],ENDPOS-CURSOR+1); ENDPOS:=ENDPOS-(CURSOR-COUNT); CURSOR:=COUNT; END ELSE IF (COUNT >= ENDPOS) OR (COUNT < 0) THEN BEGIN ENDPOS := CURSOR; BUF^[CURSOR] := CHR(0); END ELSE BEGIN MOVELEFT(BUF^[COUNT],BUF^[CURSOR],ENDPOS-COUNT+1); ENDPOS:=ENDPOS-(COUNT-CURSOR); END; END; PROCEDURE GETTER; VAR DIR,SIZE: INTEGER; FOUND,HARDEND: BOOLEAN; FIRST: CHAR; PATTERN,QUESTION: STRING[100]; PROCEDURE FINDIT; BEGIN REPEAT IF DIR < 0 THEN BEGIN CURSOR := CURSOR + SCAN(-CURSOR,=FIRST,BUF^[CURSOR]); IF CURSOR <= 0 THEN BEGIN HARDEND := TRUE; CURSOR := 0; EXIT(FINDIT) END END ELSE BEGIN CURSOR := CURSOR + SCAN(ENDPOS-CURSOR+1,=FIRST,BUF^[CURSOR]); IF CURSOR >= ENDPOS THEN BEGIN HARDEND := TRUE; CURSOR := ENDPOS; EXIT(FINDIT) END END; MOVELEFT(BUF^[CURSOR],QUESTION[1],SIZE); FOUND := (QUESTION = PATTERN); CURSOR := CURSOR + DIR UNTIL FOUND END (* FINDIT *); BEGIN IF RCOUNT < 0 THEN BEGIN RCOUNT := -RCOUNT; DIR := -1 END ELSE DIR := 1; J := J+1; SIZE := 0; FIRST := EXEC^[J]; WHILE EXEC^[J +SIZE] <> ESC DO SIZE := SIZE +1; MOVELEFT(EXEC^[J],PATTERN[1],SIZE); PATTERN[0] := CHR(SIZE); QUESTION[0] := CHR(SIZE); HARDEND := FALSE; FOUND := FALSE; REPEAT FINDIT; RCOUNT := RCOUNT -1 UNTIL (RCOUNT <= 0) OR HARDEND; IF HARDEND THEN BEGIN WRITELN(OUTPUT,PATTERN,' not found'); EXIT(COMMAND) END; IF DIR < 0 THEN CURSOR := CURSOR +1 ELSE CURSOR := CURSOR +SIZE -1; J := J +SIZE; EQUALLENGTH := SIZE END (* GETTER *); PROCEDURE INSERTTEXT; VAR SIZEOVER: BOOLEAN; LENGTH,TEMP: INTEGER; BEGIN SIZEOVER := FALSE; J := J+1; LENGTH := SCAN(I-J,=(ESC),EXEC^[J]); TEMP := ENDPOS+LENGTH; IF (TEMP > BUFSIZE) THEN BEGIN WRITELN(OUTPUT,'insertion truncated, not enough space'); SIZEOVER := TRUE; LENGTH := BUFSIZE-ENDPOS; TEMP := BUFSIZE; END; IF (TEMP > BUFEND) THEN BEGIN WRITELN(OUTPUT,'''save'' area deleted.'); BUFEND := BUFSIZE; END; MOVERIGHT(BUF^[CURSOR],BUF^[CURSOR+LENGTH],BUFEND-(CURSOR+LENGTH)); MOVELEFT(EXEC^[J],BUF^[CURSOR],LENGTH); ENDPOS := ENDPOS +LENGTH; CURSOR := CURSOR +LENGTH; EQUALLENGTH := LENGTH; IF SIZEOVER THEN EXIT(COMMAND); J := J +LENGTH; END (* INSERT NEW TEXT *); PROCEDURE JUMP; BEGIN IF RCOUNT = 0 THEN LINEPLACE(CURSOR,0) ELSE CURSOR := CURSOR + RCOUNT; IF (CURSOR<0) AND (RCOUNT<0) THEN CURSOR := 0 ELSE IF (CURSOR<0) OR (CURSOR>ENDPOS) THEN CURSOR := ENDPOS; END; PROCEDURE KILL; VAR POSITION:INTEGER; BEGIN LINEPLACE(POSITION,RCOUNT); IF RCOUNT<=0 THEN BEGIN MOVELEFT(BUF^[CURSOR],BUF^[POSITION],(ENDPOS-CURSOR+1)); ENDPOS := ENDPOS - (CURSOR - POSITION); CURSOR := CURSOR - (CURSOR - POSITION); END ELSE BEGIN MOVELEFT(BUF^[POSITION],BUF^[CURSOR],(ENDPOS-POSITION+1)); ENDPOS := ENDPOS - (POSITION - CURSOR); END; END; PROCEDURE LIST; VAR POSITION: INTEGER; BEGIN LINEPLACE(POSITION,RCOUNT); IF RCOUNT<=0 THEN UNITWRITE(1(* CONSOLE: *),BUF^[POSITION],CURSOR-POSITION) ELSE UNITWRITE(1(* CONSOLE: *),BUF^[CURSOR],POSITION-CURSOR) END; PROCEDURE MACRODEFINITION; VAR STOPCH: CHAR; LGTH: INTEGER; BEGIN IF (RCOUNT<0) OR (RCOUNT>MAXMAC) THEN SYNTAX('#'); IF MACROS[RCOUNT].EXEC = NIL THEN NEW(MACROS[RCOUNT].EXEC); STOPCH := EXEC^[J+1]; LGTH := SCAN(I-J,=STOPCH,EXEC^[J+2]); IF (LGTH = (I-J)) OR (LGTH > SIZEOF(COMARRAY)) OR (LGTH = 0) THEN BEGIN WRITELN(OUTPUT,'Error in macro definition'); EXIT(COMMAND); END; MOVELEFT(EXEC^[J+2],MACROS[RCOUNT].EXEC^[0],LGTH); FILLCHAR(MACROS[RCOUNT].EXEC^[LGTH+1],SIZEOF(COMARRAY)-LGTH,ESC); MACROS[RCOUNT].LGTH := LGTH; J := J+LGTH+2; END (* DEFINE MACRO *); PROCEDURE NOWEXECUTEMACRO; VAR SAVE: RECORD EXEC: ^COMARRAY; I,J: INTEGER END; MACNUM: INTEGER; ERROR: BOOLEAN; BEGIN J := J +1; SAVE.EXEC := EXEC; SAVE.I := I; SAVE.J := J; IF EXEC^[J] = ESC THEN MACNUM := 1 ELSE MACNUM := ORD(EXEC^[J])-ORD('0'); IF (MACROS[MACNUM].EXEC = NIL) THEN BEGIN WRITELN(OUTPUT,'ILLEGAL MACRO...Try again'); EXIT(COMMAND) END; IF (MACNUM<0) OR (MACNUM > MAXMAC) THEN SYNTAX('#'); EXEC := MACROS[MACNUM].EXEC; I := MACROS[MACNUM].LGTH; WHILE RCOUNT > 0 DO BEGIN RCOUNT := RCOUNT -1; IF COMMAND THEN BEGIN COMMAND := TRUE; EXIT(COMMAND) END; ERROR := (J 1 THEN LISTSIZE := RCOUNT ELSE LISTSIZE := HEIGHT DIV 2 -1 END END; PROCEDURE READFILE; VAR LGTH: INTEGER; TITLE: STRING[40]; BEGIN J := J +1; LGTH := SCAN(30,=ESC,EXEC^[J]); IF (LGTH <= 30) AND (LGTH > 0) THEN BEGIN TITLE[0] := CHR(LGTH); MOVELEFT(EXEC^[J],TITLE[1],LGTH); OPENOLD(IOFILE,TITLE); IF IORESULT = 0 THEN BEGIN IF NEWFIN THEN EXIT(COMMAND) END ELSE BEGIN OPENOLD(IOFILE,CONCAT(TITLE,'.TEXT')); IF IORESULT = 0 THEN BEGIN IF NEWFIN THEN EXIT(COMMAND) END ELSE BEGIN WRITELN(OUTPUT,'File: ',TITLE,' is in error. Not read'); EXIT(COMMAND); END; END END ELSE BEGIN WRITELN(OUTPUT,'File name error.'); EXIT(COMMAND); END; J := J +LGTH; END; PROCEDURE SAVE; VAR POS,DELTA: INTEGER; BEGIN LINEPLACE(POS,RCOUNT); IF RCOUNT <= 0 THEN DELTA := CURSOR -POS ELSE DELTA := POS -CURSOR; BUFEND := BUFSIZE -DELTA; IF BUFEND <= ENDPOS THEN BEGIN BUFEND := BUFSIZE; WRITELN(OUTPUT,'Not enough room to save in'); EXIT(COMMAND); END; IF RCOUNT <= 0 THEN MOVELEFT(BUF^[POS],BUF^[BUFEND],DELTA) ELSE MOVELEFT(BUF^[CURSOR],BUF^[BUFEND],DELTA) END (* SAVE *); PROCEDURE UNSAVE; VAR STASHSIZE,STASHEDAT,DELTA: INTEGER; BEGIN IF RCOUNT = 0 THEN BUFEND := BUFSIZE ELSE BEGIN STASHSIZE := ENDPOS -CURSOR; DELTA := BUFSIZE -BUFEND; STASHEDAT := CURSOR +DELTA; IF ((STASHEDAT +STASHSIZE) < BUFEND) THEN BEGIN MOVERIGHT(BUF^[CURSOR],BUF^[STASHEDAT],STASHSIZE); MOVELEFT(BUF^[BUFEND],BUF^[CURSOR],DELTA); ENDPOS := ENDPOS +DELTA; BUF^[ENDPOS] := CHR(0) END ELSE BEGIN WRITELN(OUTPUT,'not enough space'); EXIT(COMMAND) END END (* ~=0 *) END (* UNSAVE *); PROCEDURE VIEW; BEGIN RCOUNT := 0; LIST; RCOUNT := 1; LIST END; PROCEDURE WRITEFILE; VAR LGTH: INTEGER; TITLE: STRING[40]; BEGIN J := J +1; LGTH := SCAN(30,=ESC,EXEC^[J]); IF (LGTH > 0) AND (LGTH <= 30) THEN BEGIN TITLE[0] := CHR(LGTH); MOVELEFT(EXEC^[J],TITLE[1],LGTH); IF (TITLE[LGTH] <> '.') AND (TITLE[LGTH] <> ']') AND (POS('.TEXT',TITLE) = 0) THEN TITLE := CONCAT(TITLE,'.TEXT'); IF (TITLE[LGTH] = '.') THEN DELETE(TITLE,LGTH,1); OPENNEW(IOFILE,TITLE); IF IORESULT = 0 THEN NEWOUTLOOK ELSE BEGIN WRITELN(OUTPUT,CONCAT('File: ',TITLE,' is in error. Write not done.')); EXIT(COMMAND); END; END ELSE BEGIN WRITELN(OUTPUT,'Illegal title'); EXIT(COMMAND); END; J := J +LGTH; END; BEGIN (*COMMAND*) COMMAND := FALSE; NUMBER := ['0'..'9']; J := 0; WHILE (J 3200)); THISCH := EXEC^[J]; END(* IN NUMBER *) ELSE RCOUNT := 1; IF (THISCH IN ['=','/']) THEN IF (RCOUNT <> 1) THEN SYNTAX(THISCH) ELSE BEGIN IF (THISCH = '=') THEN RCOUNT := -EQUALLENGTH ELSE (* = '/' *) RCOUNT := 32700; J := J +1; THISCH := EXEC^[J] END; IF NEG THEN RCOUNT := -RCOUNT; IF (J >= I) THEN EXIT(COMMAND); IF (THISCH IN ['?','A'..'Z','a'..'z']) THEN CASE THISCH OF '?' : PROMPTS; 'a','A':LINEPLACE(CURSOR,RCOUNT); 'b','B':CURSOR:=0; (*DA END*) 'c','C':BEGIN DELETESTUFF; INSERTTEXT END; 'd','D':DELETESTUFF; 'e','E':CLEARSCREEN; 'G','F','f','g':GETTER; 'H','h':WRITELN(OUTPUT,'Unimplemented'); 'I','i': INSERTTEXT; 'J','j':JUMP; 'K','k':KILL; 'L','l':LIST; 'M','m': MACRODEFINITION; 'N','n': NOWEXECUTEMACRO; 'O','o': OPTIONMOD; 'p','t','y','z', 'P','T','Y','Z': SYNTAX(THISCH); 'Q','q': BEGIN THISCH := EXEC^[J+1]; CLOSETHEWORLD(THISCH); COMMAND := (THISCH IN ['E','e','U','u']); EXIT(COMMAND) END; 'R','r':READFILE; 'S','s':SAVE; 'U','u':UNSAVE; 'V','v':VIEW; 'W','w':WRITEFILE; 'X','x':BEGIN KILL; INSERTTEXT END END ELSE SYNTAX(THISCH); J:=J+1; END (* WHILE J <= I *); IF OPTION.ONOFF THEN BEGIN CLEARSCREEN; RCOUNT := -OPTION.LISTSIZE; LIST; WRITE(OUTPUT,CHR(10 (* LF *))); RCOUNT := OPTION.LISTSIZE; LIST END; END (* COMMAND *); BEGIN (*EDITOR*) INITIALIZE; REPEAT WRITE(KEYBOARD,'*'); (*CLEARS ^F AND ^S FLAGS!*) (* this line is for the havaheart command * MOVELEFT(EXEC^,BUF^[ENDPOS+1],MIN(I,BUFEND-ENDPOS)); * which some day may be implemented *) INCOMMAND UNTIL COMMAND; END; BEGIN (* JUST A DUMMY *) END. ======================================================================================== DOCUMENT :usus Folder:VOL18:8queens.text ======================================================================================== {$R-,F-}(* This program finds all 92 positions of 8 queens on a cherssboard *) (* such that no queen checks another queen. The backtracking *) (* algorithmn is recursive. *) (* Run-time on the CDC 6400: 1017 msec. (679 msec without range checking)*) PROGRAM EIGHTQUEENS(OUTPUT); VAR I, q, iterations : INTEGER; SAFE: BOOLEAN; A : ARRAY[1..8] OF BOOLEAN; B : ARRAY[2..16] OF BOOLEAN; C : ARRAY[-7..7] OF BOOLEAN; X : ARRAY[1..8] OF INTEGER; SHITIME ,SLOWTIME, EHITIME, ELOWTIME: INTEGER; Procedure Print; Var k: integer; Begin for k := 1 to 8 do (* Write (x[k]: 2); Writeln; *) End; PROCEDURE TRYCOL(J : INTEGER); VAR I : INTEGER; PROCEDURE SETQUEEN; BEGIN A[I] := FALSE; B[I+J] := FALSE; C[I-J] := FALSE; END; PROCEDURE REMOVEQUEEN; BEGIN A[I] := TRUE; B[I+J] := TRUE; C[I-J] := TRUE END; BEGIN I:=0; REPEAT I := I+1; SAFE := A[I] AND B[I+J] AND C[I-J]; IF SAFE THEN BEGIN SETQUEEN; X[J] := I; IF J < 8 THEN TRYCOL(J+1) ELSE PRINT; REMOVEQUEEN END UNTIL I = 8 END; BEGIN FOR I := 1 TO 8 DO A[I] := TRUE; FOR I := 2 TO 16 DO B[I] := TRUE; FOR I := -7 TO 7 DO C[I] := TRUE; Writeln; Writeln ('8 queens (R-)'); WRITE('Iterations ? ( starts benchmark) '); READLN (iterations); for q := 1 to iterations do begin (* Page (output); *) TRYCOL(1); end; WRITELN('DONE', CHR (7)); END. ======================================================================================== DOCUMENT :usus Folder:VOL18:ancest.s.text ======================================================================================== {$R-,F-} { Ancestor matrix. Set version. } (* A SECOND VERSION OF THE ALGORITHM USES THE PASCAL SET STRUCTURE *) (* INSTEAD OF A BOOLEAN MATRIX. tHE RELATION R[I,J] IS EXPRESSED AS *) (* "J IN R[I]". SINCE THE PASCAL 6000-3.4 COMPILER RESTRICST SETS *) (* TO HAVE AT MOST 59 ELEMENTS, THE FOLLOWING PERFORMANCE COMPARISON *) (* IS BASED ON THE CASE N = 50. *) (* ON THE CDC6400 THIS PROGRAM REQUIRES ON 50 MSEC TO COMPUTE THE ANCESTOR *) (* MATRIX, COMPARED TO 341 MSEC FOR THE VERSION USING A PACKED ARRAY. *) (* tHIS IS A GAIN BY A FACTOR OF 5.9 *) PROGRAM ANCESTOR(OUTPUT); (*ANCESTOR ALGORITHM USING SETS INSTEAD OF BOOLEAN MATRIX*) CONST N = 50; VAR I,J,HI,LOW, q, iterations: INTEGER; R: ARRAY[1..N] OF SET OF 1..N; BEGIN (* J IN R[I] = "I IS A PARENT OF J"*) Writeln; Writeln ('Ancestor matrix (sets, R-)'); Writeln; Write ('Iterations ? ( starts benchmark) '); Readln (iterations); for q := 1 to iterations do begin (* Page (output); *) FOR I := 1 TO N DO IF I MOD 10 <> 0 THEN R[I] := [I+1] ELSE R[I] := []; FOR I := 1 TO N DO FOR J := 1 TO N DO IF I IN R[J] THEN R[J] := R[I]+R[J]; (* FOR I := 1 TO N DO BEGIN WRITE(' '); FOR J := 1 TO N DO IF J IN R[I] THEN WRITE('1') ELSE WRITE('.'); WRITELN END; *) end {for q}; WRITELN('DONE',CHR(7)); END. ======================================================================================== DOCUMENT :usus Folder:VOL18:bench.usus.text ======================================================================================== program benchusus; (* Self timed version of Jon Bondy's benchmark See USUS News #4*) type rec2_type = record next : ^rec2_type; end; var num_loops : integer; i,j,k,l, test : integer; r,s,t : real; starth,startl,endh,endl : integer; a : array[1..100] of integer; b : array[1..100] of real; ch : char; rec1 : record firsti, secondi : integer; firstr, secondr : real; end; root, ptr : ^rec2_type; cset : set of char; overhead,xt,xs,xe : real; fudge_loop : boolean; (* printr : interactive; *) procedure prompt; procedure prompt1; { too big for 1200 bytes otherwise... } var line:integer; begin gotoxy(0,23); for line:=1 to 24 do writeln; gotoxy(0,0); writeln('Select a test or enter "0" for all tests.'); writeln('Enter a negative number to quit.'); writeln; end; begin prompt1; writeln(' 1. null for loops (to). 2. null for loops (downto).'); writeln(' 3. integer increments (for loop). 4. null while loops.'); writeln(' 5. null repeat loops. 6. integer adds.'); writeln(' 7. integer multiplys. 8. integer divides.'); writeln(' 9. real increments. 10. real adds.'); writeln('11. real multiplies. 12. real divides.'); writeln('13. integer transfers. 14. integer array transfers.'); writeln('15. real transfers. 16. real array transfers.'); writeln('17. integer record transfers. 18. real record transfers.'); writeln('19. integer if comparisons. 20. real if comparisons.'); writeln('21. case statements. 22. procedure calls.'); writeln('23. proc calls with integer param.24. proc calls with real param.'); writeln('25. proc calls with a local var. 26. set unions.'); writeln('27. set differences. 28. set IN''s.'); writeln('29. pointer transfers. 30. NOOP''s.'); write('Test:'); end; { prompt } procedure doneit; begin writeln( chr ( 7 ), 'Done.'); xs:=ABS(startl); xe:=ABS(endl); xt:=ABS(xe-xs)/60; if xt <> 0.0 then begin write('Time = ',xt:5:2,' seconds ' ); if fudge_loop then writeln ((((xt/numloops ) * 1000 ) - ( overhead )):7:3,' ms per loop ') else writeln ((( xt/numloops ) * 1000 ):7:3, ' ms per loop' ); end; (*writeln(printr,t);*) end; procedure dummy1; begin end; procedure dummy2(i : integer); begin end; procedure dummy3(r: real); begin end; procedure dummy4; var i : integer; begin end; procedure test1; begin fudge_loop := false; write('1 . ',numloops,' null for loops (to).'); time(starth,startl); for i := 1 to num_loops do begin end; time(endh,endl); end; procedure test2; begin fudge_loop := false; write('2. ',numloops, ' null for loops (downto).'); time(starth,startl); for i := num_loops downto 1 do begin end; time(endh,endl); doneit; end; procedure test3; begin fudge_loop := false; write('3. ',numloops, ' integer increments (for loop).'); time(starth,startl); for i := 1 to num_loops do begin j := j + 1; end; time(endh,endl); doneit; end; procedure test4; begin fudge_loop := false; write('4. ',numloops,' null while loops.'); j := 0; time(starth,startl); while (j < num_loops) do begin j := j + 1; end; time(endh,endl); doneit; end; procedure test5; begin fudge_loop := false; write('5. ',numloops,' null repeat loops.'); j := 0; time(starth,startl); repeat j := j + 1 until (j = num_loops); time(endh,endl); doneit; end; procedure test6; begin fudge_loop := true; write('6. ',numloops,' integer adds.'); time(starth,startl); for i := 1 to num_loops do begin j := j + k; end; time(endh,endl); doneit; end; procedure test7; begin fudge_loop := true; write('7. ',numloops,' integer multiplys.'); time(starth,startl); for i := 1 to num_loops do begin j := k * l; end; time(endh,endl); doneit; end; procedure test8; begin fudge_loop := true; write('8. ',numloops,' integer divides.'); time(starth,startl); for i := 1 to num_loops do begin j := k div l; end; time(endh,endl); doneit; end; procedure test9; begin fudge_loop := true; write('9. ',numloops,' real increments.'); time(starth,startl); for i := 1 to num_loops do begin r := r + 1.0 end; time(endh,endl); doneit; end; procedure test10; begin fudge_loop := true; write('10. ',numloops,' real adds.'); time(starth,startl); for i := 1 to num_loops do begin r := r + s; end; time(endh,endl); doneit; end; procedure test11; begin fudge_loop := true; write('11. ',numloops,' real multiplies.'); time(starth,startl); for i := 1 to num_loops do begin r := s * t; end; time(endh,endl); doneit; end; procedure test12; begin fudge_loop := true; write('12. ',numloops,' real divides.'); time(starth,startl); for i := 1 to num_loops do begin r := s / t; end; time(endh,endl); doneit; end; procedure test13; begin fudge_loop := true; write('13. ',numloops,' integer transfers.'); time(starth,startl); for i := 1 to num_loops do begin j := k; end; time(endh,endl); doneit; end; procedure test14; begin fudge_loop := true; j := 5; k := 12; write('14. ',numloops, ' integer array transfers.'); time(starth,startl); for i := 1 to num_loops do begin a[j] := a[k]; end; time(endh,endl); doneit; end; procedure test15; begin fudge_loop := true; write('15. ',numloops,' real transfers.'); time(starth,startl); for i := 1 to num_loops do begin r := s; end; time(endh,endl); doneit; end; procedure test16; begin fudge_loop := true; j := 5; k := 12; write('16. ',numloops,' real array transfers.'); time(starth,startl); for i := 1 to num_loops do begin b[j] := b[k]; end; time(endh,endl); doneit; end; procedure test17; begin fudge_loop := true; write('17. ',numloops, ' integer record transfers.'); time(starth,startl); for i := 1 to num_loops do begin rec1.firsti := rec1.secondi; end; time(endh,endl); doneit; end; procedure test18; begin fudge_loop := true; write('18. ',numloops, ' real record transfers.'); time(starth,startl); for i := 1 to num_loops do begin rec1.firstr := rec1.secondr; end; time(endh,endl); doneit; end; procedure test19; begin fudge_loop := true; j := 5; k := 12; write('19. ',numloops, ' integer if comparisons.'); time(starth,startl); for i := 1 to num_loops do if (j < k) then begin end; time(endh,endl); doneit; end; procedure test20; begin fudge_loop := true; r := 5.0; s := 12.0; write('20. ',numloops,' real if comparisons.'); time(starth,startl); for i := 1 to num_loops do if (r < s) then begin end; time(endh,endl); doneit; end; procedure test21; begin fudge_loop := true; j := 2; write('21. ',numloops,' case statements.'); time(starth,startl); for i := 1 to num_loops do case j of 1 : begin end; 2 : begin end; 3 : begin end; 4 : begin end; end; time(endh,endl); doneit; end; procedure test22; begin fudge_loop := true; write('22. ',numloops,' procedure calls.'); time(starth,startl); for i := 1 to num_loops do dummy1; time(endh,endl); doneit; end; procedure test23; begin fudge_loop := true; write('23. ',numloops, ' procedure calls with integer parameter.'); time(starth,startl); for i := 1 to num_loops do dummy2(i); time(endh,endl); doneit; end; procedure test24; begin fudge_loop := true; write('24. ',numloops, ' procedure calls with real parameter.'); time(starth,startl); for i := 1 to num_loops do dummy3(r); time(endh,endl); doneit; end; procedure test25; begin fudge_loop := true; write('25. ',numloops, ' procedure calls with a local variable.'); time(starth,startl); for i := 1 to num_loops do dummy4; time(endh,endl); doneit; end; procedure test26; begin fudge_loop := true; write('26. ',numloops,' set unions.'); time(starth,startl); for i := 1 to num_loops do cset := cset + ['a','b']; time(endh,endl); doneit; end; procedure test27; begin fudge_loop := true; write('27. ',numloops,' set differences.'); time(starth,startl); for i := 1 to num_loops do cset := cset - ['a','b']; time(endh,endl); doneit; end; procedure test28; begin fudge_loop := true; write('28. ',numloops,' set IN''s.'); time(starth,startl); for i := 1 to num_loops do if (ch in cset) then begin end; time(endh,endl); doneit; end; procedure test29; begin fudge_loop := true; new(root); { create a loop of list elements } new(root^.next); root^.next^.next := root; ptr := root; write('29. ',numloops,' pointer transfers.'); time(starth,startl); for i := 1 to num_loops do ptr := ptr^.next; time(endh,endl); doneit; end; procedure test30; begin fudge_loop := true; write('30. ',numloops,' NOOP''s.'); time(starth,startl); for i := 1 to num_loops do begin pmachine(156); end; time(endh,endl); doneit; end; begin { main } j := 100; k := 200; l := 300; r := 400; s := 500; t := 600; (*rewrite(printr,'printer:');*) write('Enter number of loops per test : '); readln(num_loops); test1; xs:=ABS(startl); xe:=ABS(endl); xt:=ABS(xe-xs)/60; overhead := (xt/numloops) * 1000; repeat prompt; readln(test); if (test >= 0) then case test of 0 : begin test1; doneit; test2; test3; test4; test5; test6; test7; test8; test9; test10; test11; test12; test13; test14; test15; test16; test17; test18; test19; test20; test21; test22; test23; test24; test25; test26; test27; test28; test29; test30; end; 1 : begin test1; doneit end; 2 : test2; 3 : test3; 4 : test4; 5 : test5; 6 : test6; 7 : test7; 8 : test8; 9 : test9; 10 : test10; 11 : test11; 12 : test12; 13 : test13; 14 : test14; 15 : test15; 16 : test16; 17 : test17; 18 : test18; 19 : test19; 20 : test20; 21 : test21; 22 : test22; 23 : test23; 24 : test24; 25 : test25; 26 : test26; 27 : test27; 28 : test28; 29 : test29; 30 : test30; end; if test>=0 then begin write('Type to continue'); readln; end; until (test < 0); end. ======================================================================================== DOCUMENT :usus Folder:VOL18:benchmarks.text ======================================================================================== Benchmarks There are a bunch of benchmarks on this disk. They serve various purposes and some overlap in what they are designed to test. Some (such as the Byte benchmark) are included only because there is an existing database of results already so that you can get an immediate (although rough) idea of the performance of your iron in comparison to other popular types. If you should feel so inclined, you may run some or all of the benchmarks and report (on the forms provided, please) the results to me (preferably by US Mail). George Schreyer 412 North Maria Avenue Redondo Beach, Ca. 90277 I will try to condense the results that I receive into some form of digestable format. Presenting tables of performance numbers will be too cumbersome, so I will probably rank the speed of various computers based on a few of the pertanent benchmarks and note any hardware which is particularly fast or slow at some particular operation, such as reals or somesuch. I will describe the purpose of each of them (if I know it) and what it is primarily designed to test. PWROF2. This benchmark test integer arithmetic exclusively. It computes the first 90 powers of 2. QUICKSORT. This is the conventional recursive quicksort algorithm which sorts 10000 integers. It tests integer arithmetic and it uses recursion and array indexing heavily. NUMBERIO. This one writes a file of 25,000 real numbers and then reads them back. It tests file I/O speed but is not particularly sensitive to disk access time as only a few blocks are read and written, and no long head seeks are involved. UCSD Pascal I/O is generally slow. 8QUEENS. This benchmark is another test of recursion and iterive constructs such as IF-THEN and FOR loops. PRIMES. This one finds the first 1000 primes. It is more computationally intensive than PWROF2. ANCEST.S. This one manipulates sets. WHETSTONE. This is a pascal implementation (from the original ALGOL) of the "magic" WHETSTONE benchmark. It is a collection of weighted procedures which exercise the numerical capabilities of a machine. It is often quoted in performance comparisons of various mainframes. It is written to foil optimizing compilers and force execution of all of its constructs. It is rather heavily biased to test real numbers. SIEVE. This is the infamous Byte Benchmark, modified to compile under UCSD. It is NOT modified to run the fastest under UCSD as a considerable database has been accumlated with the version supplied. Within the file, you will find the results of several types of computers. BENCH.USUS. This is the benchmark published in NL#4 by Jon Bondy. It is a series of short loops which test specific constructs of UCSD Pascal. This one (and the similar following ones) will probably be my best basis for machine and UCSD version comparison. LONG_INT. This is similar to BENCH.USUS except that it specifically tests the performance of long interger operations. Long integers are implemented differently in different UCSD implementations, and I am interested if there are any significant differences in the performance between versions. INTRINSICS. This one tests the results of several of the system intrinsics such as SIN and COS. Again, I expect a wide variance of results from different UCSD systems. QUR. This simple test indicates the general response of the operating system and disk system. Its result changes radically for different disk systems and very radically between versions II.0 and IV.0. COMPKILLER. This one is designed to crash your computer. It indicates, in a simple minded way, how big a program your system can compile by measuring the available size of the compiler symbol table. Version IV.0 isn't nice enough to tell you this. STARS. This one measures the speed of single character I/O. It produced some suprising results under the LSI-11 extended memory implementation of IV.1. SEGMASHER. Segmasher tests the speed of segment swaps. Further instructions are given in the file. If this is all too much work to consider, then please just run two of the easist, SIEVE and QUR and submit just that data ALONG WITH YOUR SYSTEM CONFIGURATION AND p-SYSTEM VERSION! SIEVE will more or less indicate your system's processor speed and QUR will evaluate (among other things) your disk system speed. regards - gws ======================================================================================== DOCUMENT :usus Folder:VOL18:black.doc1.text ======================================================================================== Blackbox is aa game where one or more players guess the position of marbles inside an 8 * 8 grid. Information about the position of marbles in the grid is deduced by the player firing raays at any row or column in the grid. A ray fired at the black box can cause one of three possible outcomes. The outcome is indicated by a marker where the ray was fired. A '*' marker means a ray fired from this location has hit a marble in the grid ( i.e. the ray hits a marble straight on and is absorbed and does not exit the board). A '^' marker means a ray has been reflected ( the ray has approached two marbles one grid apart and has bounced back and emerged from the grid at its entry point). A special case for reflection occurs at the grid boundary. If a ray hits the corner of a marble at the ray entering boundary, it is reflected back without entering the grid. A ray that passes through the grid without absorption or reflection is marked by a lower case letter. The first ray to pass through is marked 'a', the second 'b', each subsequent marble labelled by an ascending letter. A ray turns 90 degrees if it does not hit a marble straight on, but hits the marble at a corner. One ray fired at the grid may undergo zero or more 90 degree turns while in the black box, so that a straight forward analysis of the marble path may not indicate the true path. Type to continue. ======================================================================================== DOCUMENT :usus Folder:VOL18:black.doc2.text ======================================================================================== The Blackbox program may be played in two modes. In mode 1, the program places the hidden marbles in the 8 * 8 grid using a random number generator. In mode 2, a player may place marbles for an opponent to guess in the 8 * 8 grid. In either mode, the player may select either 4 or 5 marbles to be hidden in the grid. The score of the game is the sum of the markers denoting the number of rays needed to deduce the position of the marbles in the board. The commands to Blackbox are S(hoot, which fires a ray from a player selected row or column; M(anipulate Marbles, where the player may place marbles to indicate a tentative guess; and G(uess when a player decides that his tentatively placed marbles represent a correct guess. If the guess is correct, the game ends and the score is displayed. The score is the sum of the markers '*','^', and 'a','b',etc. If a guess is incorrect, a 5 marker penalty is added and the game continues. Type to start the game. ======================================================================================== DOCUMENT :usus Folder:VOL18:blackbox.text ======================================================================================== program blackbox; { (C) Copyright 1980 Robert C. Hutchins } {screen control is "universal" although somewhat slow. change it if you wish - gws} const Version = '[x4]'; xboardbase = 21; yboardbase = 3; xmarkerbase = 24; ymarkerbase = 4; debug = false; type direction = (toeast,towest,tonorth,tosouth); okset = set of char; var occupied: packed array[9..16,1..8] of boolean; table: array[17..32] of integer; opposite,left,right: array[direction] of direction; startpos,endpos: array[direction] of integer; onboard,raydead: boolean; guesspenalty: integer; numguessed,numberballs,nummarkers: integer; raypos,rayline,startrayline: integer; letter: char; inc: -1..1; dir,startdir: direction; turned90: boolean; guess: array[1..5] of record xpos, ypos: integer; aguessmade: boolean; end; markers: packed array[1..32] of char; procedure cleartopline; var line : packed array [ 1..79 ] of char; begin fillchar ( line, sizeof ( line ) , ' ' ); gotoxy(0,0); unitwrite ( 2, line, sizeof ( line ) ); gotoxy ( 0, 0 ); end; procedure clearscreen; var buf : packed array [ 1 .. 24 ] of char; begin gotoxy ( 0, 23 ); fillchar ( buf, sizeof ( buf ), chr ( 10 ) ); unitwrite ( 2, buf, sizeof ( buf ) ); gotoxy ( 0, 0 ); end; function getcommand(ok: okset): char; var tempch: char; begin repeat read(keyboard,tempch); if tempch in ['a'..'z'] then tempch := chr(ord(tempch) - ord('a') + ord('A')); until tempch in ok; getcommand := tempch; writeln; end; procedure needhelp; var ch: char; f: text; s: string; procedure printhelp; begin while not eof(f) do begin (*while not eoln(f) do begin read(f,ch); write(ch); end; readln(f); writeln; *) readln(f,s); writeln(s); end; end; begin write('Need help (Y or N) '); read(ch); clearscreen; if ch in ['Y','y'] then begin reset(f,'black.doc1.text'); printhelp; close(f); readln; reset(f,'black.doc2.text'); printhelp; readln; clearscreen; end; end; procedure initialize; var i: integer; begin table[17] := 8; table[18] := 7; table[19] := 6; table[20] := 5; table[21] := 4; table[22] := 3; table[23] := 2; table[24] := 1; table[25] := 16; table[26] := 15; table[27] := 14; table[28] := 13; table[29] := 12; table[30] := 11; table[31] := 10; table[32] := 9; opposite[toeast] := towest; opposite[towest] := toeast; opposite[tonorth] := tosouth; opposite[tosouth] := tonorth; right[toeast] := tosouth; right[towest] := tonorth; right[tonorth] := toeast; right[tosouth] := towest; left[toeast] := tonorth; left[towest] := tosouth; left[tonorth] := towest; left[tosouth] := toeast; startpos[toeast] := 8; startpos[towest] := 17; startpos[tonorth] := 9; startpos[tosouth] := 0; endpos[toeast] := 17; endpos[towest] := 8; endpos[tonorth] := 0; endpos[tosouth] := 9; for i := 1 to 32 do markers[i] := ' '; for i := 1 to 5 do guess[i].aguessmade := false; raydead := false; numguessed := 0; nummarkers := 0; letter := 'a'; guesspenalty := 0; clearscreen; needhelp; end; function convert(coord: integer): integer; begin if coord <= 16 then convert := coord else convert := -table[coord]; end; function unconvert(internal: integer): integer; var i: integer; begin if internal >= 17 then unconvert := internal else begin i := 16; repeat i := i + 1; until table[i] = internal; unconvert := i; end; if debug then begin gotoxy(0,0); writeln('unconvert i = ',i,' table[i] = ',table[i]); end; end; procedure getcoord(var xcoord,ycoord: integer); var error: boolean; coord1,coord2: integer; begin {$I-} repeat cleartopline; write('Enter first coordinate (1..32) '); readln(coord1); until (ioresult = 0) and (coord1 in [1..32]); repeat repeat cleartopline; write('Enter second coordinate (1..32) '); readln(coord2); until (ioresult = 0) and (coord2 in [1..32]); coord1 := abs(convert(coord1)); coord2 := abs(convert(coord2)); {Check if legal} error := ((abs(coord1) in [9..16]) and not(abs(coord2) in [1..8])) or ((abs(coord1) in [1..8]) and not(abs(coord2) in [9..16])); until (ioresult = 0) and not error and (coord1 in [1..32]); {$I+} if coord1 in [1..8] then begin xcoord := coord2; ycoord := coord1 end else begin xcoord := coord1; ycoord := coord2 end; end; function poccupied(x,y: integer): boolean; begin if not(x in [9..16]) then poccupied := false else if not(y in [1..8] ) then poccupied := false else poccupied := occupied[x,y]; end; procedure markerdisplay; var i: integer; begin { Display top markers } for i := 32 downto 25 do begin gotoxy(xmarkerbase + (33 - i) * 4,ymarkerbase); write(markers[i]); end; { Display bottom markers } for i := 9 to 16 do begin gotoxy(xmarkerbase + (i - 8)* 4,ymarkerbase + 18); write(markers[i]); end; { Display left side markers } for i := 1 to 8 do begin gotoxy(xmarkerbase,ymarkerbase + i * 2); write(markers[i]); end; { Display right side markers } for i := 17 to 24 do begin gotoxy(xmarkerbase + 9*4,ymarkerbase + (25 - i) * 2); write(markers[i]); end; end; procedure boarddisplay; begin {12345678901234567890123456789012345678901234567890} gotoxy(xboardbase,yboardbase); write(' 32 31 30 29 28 27 26 25 ',nummarkers,' Markers'); gotoxy(xboardbase,yboardbase + 1); if guesspenalty > 0 then write(' | | | | | | | | | ',guesspenalty * 5,' as Penalty') else write(' | | | | | | | | | '); gotoxy(xboardbase,yboardbase + 2); write('-----+---+---+---+---+---+---+---+---+------ '); gotoxy(xboardbase,yboardbase + 3); write('1 | | | | | | | | | 24 '); gotoxy(xboardbase,yboardbase + 4); write('-----+---+---+---+---+---+---+---+---+------ '); gotoxy(xboardbase,yboardbase + 5); write('2 | | | | | | | | | 23 '); gotoxy(xboardbase,yboardbase + 6); write('-----+---+---+---+---+---+---+---+---+------ '); gotoxy(xboardbase,yboardbase + 7); write('3 | | | | | | | | | 22 '); gotoxy(xboardbase,yboardbase + 8); write('-----+---+---+---+---+---+---+---+---+------ '); gotoxy(xboardbase,yboardbase + 9); write('4 | | | | | | | | | 21 '); gotoxy(xboardbase,yboardbase +10); write('-----+---+---+---+---+---+---+---+---+------ '); gotoxy(xboardbase,yboardbase +11); write('5 | | | | | | | | | 20 '); gotoxy(xboardbase,yboardbase +12); write('-----+---+---+---+---+---+---+---+---+------ '); gotoxy(xboardbase,yboardbase +13); write('6 | | | | | | | | | 19 '); gotoxy(xboardbase,yboardbase +14); write('-----+---+---+---+---+---+---+---+---+------ '); gotoxy(xboardbase,yboardbase +15); write('7 | | | | | | | | | 18 '); gotoxy(xboardbase,yboardbase +16); write('-----+---+---+---+---+---+---+---+---+------ '); gotoxy(xboardbase,yboardbase +17); write('8 | | | | | | | | | 17 '); gotoxy(xboardbase,yboardbase +18); write('-----+---+---+---+---+---+---+---+---+------ '); gotoxy(xboardbase,yboardbase +19); write(' | | | | | | | | | '); gotoxy(xboardbase,yboardbase +20); write(' 9 10 11 12 13 14 15 16 '); gotoxy(0,4); write('''*'' = hit'); gotoxy(0,5); write('''^'' = reflection'); gotoxy(0,6); write('''a'',''b'' ...'); gotoxy(0,7); write(' pass through grid'); end; procedure marbledisplay(x,y: integer; mark: char); begin gotoxy(xmarkerbase + (x - 8) * 4,ymarkerbase + y * 2); write(mark); end; procedure removemarble(x,y: integer); begin gotoxy(xmarkerbase + (x - 8) * 4,ymarkerbase + y * 2); write(' '); end; procedure displayall; var i,x,y: integer; begin clearscreen; boarddisplay; markerdisplay; if debug then for y := 1 to 8 do for x := 9 to 16 do if occupied[x,y] then marbledisplay(x,y,'O') ; if not debug then for i := 1 to numberballs do with guess[i] do if aguessmade then marbledisplay(xpos,ypos,'O'); end; procedure setupmarbles; var xcoord, ycoord: integer; i,j: integer; seed: integer; tempch: char; function random(var fseed: integer; range: integer): integer; begin fseed := (fseed * 25 + 1009) mod 1048; random := (fseed div 100) mod range; end; begin for i := 9 to 16 do for j := 1 to 8 do occupied[i,j] := false; {$I-} repeat cleartopline; write('Enter number of balls (4 or 5) '); readln(numberballs); until (ioresult = 0) and (numberballs in [4,5]); {$I+} cleartopline; write('Do you want to place the balls? (Y or N)'); read(keyboard,tempch); writeln; if tempch in ['n','N'] then begin repeat cleartopline; write('Enter random number seed (0..999) '); readln(seed); until (seed >= 0) and (seed <= 999); i := 0; repeat i := i + 1; xcoord := random(seed,8) + 1 + 8; ycoord := random(seed,8) + 1; if occupied[xcoord,ycoord] then i := i -1 else occupied[xcoord,ycoord] := true; until i >= numberballs; end else begin i := 0; repeat i := i + 1; getcoord(xcoord,ycoord); if occupied[xcoord,ycoord] then i := i -1 else occupied[xcoord,ycoord] := true; until i >= numberballs; end; end; procedure UserRayShot; var tempch: char; begin {$I-} repeat cleartopline; write('Enter ray start column '); readln(startrayline); until (ioresult = 0) and (startrayline in [1..32]); rayline := convert(startrayline); if rayline in [1..8] then dir := toeast else if rayline in [9..16] then dir := tonorth else if -rayline in [1..8] then dir := towest else if -rayline in [9..16] then dir := tosouth; rayline := abs(rayline); if dir in [toeast,tosouth] then inc := 1 else inc := -1; raypos := startpos[dir]; startdir := dir; turned90 := false; onboard := false; end; function marble: boolean; begin if dir in [toeast,towest] then marble := poccupied(raypos+inc,rayline) else marble := poccupied(rayline,raypos+inc); end; procedure hit; begin raydead := true; markers[startrayline] := '*'; nummarkers := nummarkers + 1; end; function corner: boolean; begin if dir in [toeast,towest] then corner := (poccupied(raypos+inc,rayline-1) or poccupied(raypos+inc,rayline+1)) else corner := (poccupied(rayline-1,raypos+inc) or poccupied(rayline+1,raypos+inc)); end; function bothcorners: boolean; begin if dir in [toeast,towest] then bothcorners := (poccupied(raypos+inc,rayline-1) and poccupied(raypos+inc,rayline+1)) else bothcorners := (poccupied(rayline-1,raypos+inc) and poccupied(rayline+1,raypos+inc)); end; procedure turn90; var temp: integer; begin if dir in [toeast,towest] then begin if poccupied(raypos+inc,rayline-1) then dir := tosouth else dir := tonorth end else { dir in [tonorth,tosouth] } begin if poccupied(rayline-1,raypos+inc) then dir := toeast else dir := towest end; if dir in [toeast,tosouth] then inc := 1 else inc := -1; temp := rayline; rayline := raypos; raypos := temp; turned90 := true; end; procedure reflect; begin dir := opposite[dir]; inc := -inc; end; procedure terminateray; var reflection: boolean; realcolumn: integer; begin reflection := false; if startdir <> dir then reflection := (rayline = abs(convert(startrayline))) and (dir = opposite[startdir]); if reflection then begin markers[startrayline] := '^'; nummarkers := nummarkers + 1; end else begin { pass thru } markers[startrayline] := letter; if (rayline in [1..8]) and (dir = toeast) then rayline := unconvert(rayline) else if (rayline in [9..16]) and (dir = tonorth) then rayline := unconvert(rayline); markers[rayline] := letter; nummarkers := nummarkers + 2; letter := succ(letter); end; end; procedure raydisplay; begin if debug then begin if dir in [toeast,towest] then gotoxy(xmarkerbase + (raypos - 8) * 4, ymarkerbase + rayline * 2) else gotoxy(xmarkerbase + (rayline - 8) * 4, ymarkerbase + raypos * 2); write('.'); end; end; procedure moveray; var reflection : boolean; begin if debug then begin gotoxy(0,1); writeln(' raypos = ',raypos,' rayline = ',rayline,' dir = ', ord(dir)); end; if turned90 then turned90 := false else begin raypos := raypos + inc; raydisplay; raydead := ((inc > 0) and (raypos >= endpos[dir])) or ((inc < 0) and (raypos <= endpos[dir])); if raydead then terminateray; end; onboard := true; end; procedure endgame; var ch: char; i,x,y: integer; begin cleartopline; write('Do you want to end the game? (Y or N)'); ch := getcommand(['Y','N']); if ch = 'Y' then begin displayall; for y := 1 to 8 do for x := 9 to 16 do if occupied[x,y] then marbledisplay(x,y,'X') ; for i := 1 to numberballs do with guess[i] do if aguessmade then if occupied[xpos,ypos] then marbledisplay(xpos,ypos,'C') else marbledisplay(xpos,ypos,'O'); exit(program); end; end; procedure AskIfaGuess; var ch: char; i: integer; ok: boolean; begin cleartopline; write('Does this represent your guess? (Y or N)'); ch := getcommand(['Y','N']); if ch = 'N' then endgame; ok := true; for i := 1 to numberballs do if not poccupied(guess[i].xpos,guess[i].ypos) then ok := false; if not ok then begin nummarkers := nummarkers + 5; guesspenalty := guesspenalty + 1; displayall; endgame; end else begin displayall; cleartopline; gotoxy(2,2); writeln('You are correct ',nummarkers, ' used.'); exit(program); end; end; procedure insert; var i, guessindex: integer; begin if numguessed < numberballs then begin numguessed := numguessed + 1; guessindex := 0; for i := 1 to numberballs do if not guess[i].aguessmade then guessindex := i; with guess[guessindex] do begin getcoord(xpos,ypos); aguessmade := true; end; end; end; procedure delete; var i: integer; x,y: integer; found: boolean; begin if numguessed > 0 then begin i := 0; getcoord(x,y); repeat i := i + 1; with guess[i] do begin if aguessmade then found := (xpos = x) and (ypos = y) ; end; until found or (i = numberballs); if found then begin guess[i].aguessmade := false; numguessed := numguessed - 1; end; end; end; procedure marblemanipulate; var mchar: char; x,y: integer; endmanipulating : boolean; begin endmanipulating := false; cleartopline; write('P(lace a marble D(elete a marble N(o move '); mchar := getcommand(['P','D','N']); case mchar of 'P','p': insert; 'D','d': delete; 'n','N': endmanipulating := true; end; displayall; end; function Command: boolean; var mchar : char; endmoving : boolean; begin { placeaball } displayall; command := true; endmoving := false; repeat cleartopline; write('M(arble manipulate S(hoot ray G(uess game'); mchar := getcommand(['M','S','G']); case mchar of 'M','m': marblemanipulate; 'S','s': begin endmoving := true; UserRayShot; end; 'G','g': AskIfaGuess; end; until endmoving; end { placeaball }; begin {outerblock} initialize; setupmarbles; clearscreen; while command do begin repeat if marble then hit else begin if corner then if onboard then begin if bothcorners then reflect else turn90 end else { Not on the board so } reflect; moveray; end; until raydead; end; end. ======================================================================================== DOCUMENT :usus Folder:VOL18:bondy_form.text ======================================================================================== Bondy's Benchmark Report Form Use this form to report on the result of Jon Bondy's benchmark from USUS NewsLetter #4. There is a version of it on this disk, called BENCH.USUS.TEXT. It is self timing if you have a clock. Tests with real operations should be benchmarked with 2 and 4 word reals when they are available. Test 30 is for version IV.x only. Please report on the compilation time of the program. If you use version II.0 it is important that you specify if you used S+ or S-. Please report in milli-seconds per loop with the loop overhead of test 1 removed for tests 6 thru 30. Test time ( ms/loop ) 1 for loop ( to ) __________ 2 for loop ( downto ) __________ 3 integer increment __________ 4 while loop __________ 5 repeat loop __________ remember to subtract the result of test 1 from the following results 6 integer add __________ 7 integer multiply __________ 8 integer divide __________ 9 real increment (2 word) __________ (4 word) _________ 10 read add (2 word) __________ (4 word) _________ 11 real multiply (2 word) __________ (4 word) _________ 12 real divide (2 word) __________ (4 word) _________ 13 integer transfer __________ 14 integer array transfer __________ 15 real transfer (2 word) __________ (4 word) _________ 16 real array transfer (2 word) __________ (4 word) _________ 17 integer record transfer __________ 18 real record transfer (2 word) __________ (4 word) _________ 19 integer if compare __________ 20 real if compare (2 word) __________ (4 word) _________ 21 case statement __________ 22 procedure call __________ 23 procedure w/integer __________ 24 procedure w/real (2 word) __________ (4 word) _________ 25 procedure w/local var __________ 26 set union __________ 27 set difference __________ 28 set "in" __________ 29 pointer transfer __________ 30 call to pmachine ( IV.x only ) __________ Compilation time _____________ lines per minute _____________ ======================================================================================== DOCUMENT :usus Folder:VOL18:compkiller.text ======================================================================================== program stack_death; {this program writes a file with a bunch of declarations, so many in fact that the resultant file should not compile, it will crash of a stack overflow. If it does, make 'big_number' even bigger so that the program will just compile. When the program becomes too large, it is easist to comment out lines until it does compile. Then remove any commented-out lines and re-run it, time it if you wish. Please note the number of lines displayed by the compiler. This indicates the actual amount of symbol table space which you have available, with enough room for the compiler to still continue to operate. Version II.0 kept you nicely informed about how much room was available in the symbol table, but not so IV.x, it just goes slower and slower until it dies. If you are using something earlier than IV.0, try it both with $S- and $S+. II.0 will compile the declarations at a fairly constant rate. If there are too many declarations, the compiler will crash with a stack overflow. The compiler may still crash when it tries to compile the main body if there is not enough room to swap into memory a new code segment. When it finally displays the program name, you may have to eliminate several hundered lines of declarations before will finished. IV.x will compile at a greatly fluctuating rate. It will go for a while and then stop for a while, go a little further and stop again. What is happening is that the system is suffering heap faults as a bigger and bigger symbol table is generated. The code pool is then moved halfway between the stack and the heap, and the system can go again until it suffers another heap fault and must manage memory again. This happens a shorter and shorter intervals until the code pool can no longer be moved. The system will then throw out a segment, and go through the same sequence until it has to throw out another segment. Finally, when the compiler gets really desperate, it begins swapping code segments in and out of memory for every line! At this point, you are scraping the bottom of the bucket. In the case of this test program, certain death is not far away, as when the main body is reached, a large segment must be loaded, and there is no room. A stack overflow results, and the system will require rebooting. As in II.0, reduce the number of lines of declarations until the compilation completes and record the number of lines and the elapsed time from envoking the compiler to returning to the system prompt. IV.1 systems with extended memory will behave differently. Code segments do not reside between the stack and the heap so movement of the code pool is not necessary. Segment references are all to memory, so they happen very fast. The compiler will continue at a fairly constant, if not leasurely, rate until the main body is reached. The segment load here is not deadly, as it does not affect the heap space. As before, note the time and number of lines for the run. With a hard disk, IV.1 will be just a little faster than IV.0 on large programs. With floppy, the difference should be significant. On most extended memory systems, the size of the compilable file will be much larger in IV.1. On the PDP-11 and probably the 9900, the size will be about the same. - gws } const big_number = 1500; var i : integer; disk : text; begin rewrite ( disk, 'stackdeath.text' ); writeln ( disk, 'program stackdeath;' ); writeln ( disk, 'var' ); for i := 1 to big_number do begin write ( '.' ); if ( i mod 50 ) = 0 then writeln; writeln ( disk, 'a', i, ',' ); end; writeln ( disk, 'b : integer;' ); writeln ( disk, 'begin' ); writeln ( disk, 'end.' ); close ( disk, lock ); end. ======================================================================================== DOCUMENT :usus Folder:VOL18:debug.a.text ======================================================================================== (*$U-*) PROGRAM PASCALSYSTEM; (************************************************) (* *) (* UCSD PASCAL OPERATING SYSTEM *) (* *) (* RELEASE LEVEL: I.3 *) (* *) (* WRITTEN BY ROGER T. SUMNER *) (* WINTER 1977 *) (* *) (* INSTITUTE FOR INFORMATION SYSTEMS *) (* UC SAN DIEGO, LA JOLLA, CA *) (* *) (* KENNETH L. BOWLES, DIRECTOR *) (* *) (* THIS SOFTWARE IS THE PROPERTY OF THE *) (* REGENTS OF THE UNIVERSITY OF CALIFORNIA. *) (* *) (************************************************) CONST MAXUNIT = 8; (*MAXIMUM PHYSICAL UNIT # FOR UREAD*) MAXDIR = 77; (*MAX NUMBER OF ENTRIES IN A DIRECTORY*) VIDLENG = 7; (*NUMBER OF CHARS IN A VOLUME ID*) TIDLENG = 15; (*NUMBER OF CHARS IN TITLE ID*) MAXSEG = 15; (*MAX CODE SEGMENT NUMBER*) FBLKSIZE = 512; (*STANDARD DISK BLOCK LENGTH*) DIRBLK = 2; (*DISK ADDR OF DIRECTORY*) AGELIMIT = 600; (*MAX AGE FOR GDIRP...IN TICKS*) EOL = 13; (*END-OF-LINE...ASCII CR*) TYPE IORSLTWD = INTEGER; (*ARCHIVAL INFO...THE DATE*) DATEREC = INTEGER; (*VOLUME TABLES*) UNITNUM = 0..MAXUNIT; VID = STRING[VIDLENG]; (*DISK DIRECTORIES*) DIRRANGE = 0..MAXDIR; TID = STRING[TIDLENG]; FILEKIND = INTEGER; DIRENTRY = INTEGER; DIRP = ^DIRECTORY; DIRECTORY = ARRAY [DIRRANGE] OF DIRENTRY; (*FILE INFORMATION*) CLOSETYPE = INTEGER; WINDOWP = ^WINDOW; WINDOW = PACKED ARRAY [0..0] OF CHAR; FIBP = ^FIB; FIB = INTEGER; (*USER WORKFILE STUFF*) (*CODE SEGMENT LAYOUTS*) SEGRANGE = 0..MAXSEG; SEGDESC = INTEGER; (*DEBUGGER STUFF*) BYTERANGE = 0..255; MSCWP = ^ MSCW; (*MARK STACK RECORD POINTER*) MSCW = INTEGER; (*SYSTEM COMMUNICATION AREA*) (*SEE INTERPRETERS...NOTE *) (*THAT WE ASSUME BACKWARD *) (*FIELD ALLOCATION IS DONE *) SYSCOMREC = RECORD IORSLT: IORSLTWD; (*RESULT OF LAST IO CALL*) XEQERR: INTEGER; (*REASON FOR EXECERROR CALL*) SYSUNIT: UNITNUM; (*PHYSICAL UNIT OF BOOTLOAD*) BUGSTATE: INTEGER;(*DEBUGGER INFO*) GDIRP: DIRP; (*GLOBAL DIR POINTER,SEE VOLSEARCH*) LASTMP,STKBASE,BOMBP: MSCWP; MEMTOP,SEG,JTAB: INTEGER; BOMBIPC: INTEGER; (*WHERE XEQERR BLOWUP WAS*) EXPANSION: ARRAY [0..14] OF INTEGER; HIGHTIME,LOWTIME: INTEGER; MISCINFO: PACKED RECORD NOBREAK,STUPID,SLOWTERM, HASXYCRT,HASLCCRT,HAS8510A,HASCLOCK: BOOLEAN END; CRTTYPE: INTEGER; CRTCTRL: PACKED RECORD RLF,NDFS,ERASEEOL,ERASEEOS,HOME,ESCAPE: CHAR; BACKSPACE: CHAR; FILLCOUNT: 0..255; EXPANSION: PACKED ARRAY [0..3] OF CHAR END; CRTINFO: PACKED RECORD WIDTH,HEIGHT: INTEGER; RIGHT,LEFT,DOWN,UP: CHAR; BADCH,CHARDEL,STOP,BREAK,FLUSH,EOF: CHAR; ALTMODE,LINEDEL: CHAR; EXPANSION: PACKED ARRAY [0..5] OF CHAR END; SEGTABLE: ARRAY [SEGRANGE] OF RECORD CODEUNIT: UNITNUM; CODEDESC: SEGDESC END END (*SYSCOM*); VAR SYSCOM: ^SYSCOMREC; (*MAGIC PARAM...SET UP IN BOOT*) GFILES: ARRAY [0..5] OF FIBP; (*GLOBAL FILES, 0=INPUT, 1=OUTPUT*) EMPTYHEAP: ^INTEGER; (*HEAP MARK FOR MEM MANAGING*) INPUTFIB,OUTPUTFIB,SYSTERM: FIBP; (*ACTUAL FILES...GFILES ARE COPIES*) SYVID,DKVID: VID; (*SYSUNIT VOLID & DEFAULT VOLID*) THEDATE: DATEREC; (*TODAY...SET IN FILER OR SIGN ON*) DEBUGINFO: ^INTEGER; (*DEBUGGERS GLOBAL INFO WHILE RUNIN*) PL: STRING; (*PROMPTLINE STRING...SEE PROMPT*) (*-------------------------------------------------------------------------*) (* SYSTEM PROCEDURE FORWARD DECLARATIONS *) (* THESE ARE ADDRESSED BY OBJECT CODE... *) (* DO NOT MOVE WITHOUT CAREFUL THOUGHT *) PROCEDURE EXECERROR; FORWARD; PROCEDURE FINIT(VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER); FORWARD; PROCEDURE FRESET(VAR F: FIB); FORWARD; PROCEDURE FOPEN(VAR F: FIB; VAR FTITLE: STRING; FOPENOLD: BOOLEAN; JUNK: FIBP); FORWARD; PROCEDURE FCLOSE(VAR F: FIB; FTYPE: CLOSETYPE); FORWARD; PROCEDURE FGET(VAR F: FIB); FORWARD; PROCEDURE FPUT(VAR F: FIB); FORWARD; PROCEDURE FSEEK(VAR F: FIB); FORWARD; FUNCTION FEOF(VAR F: FIB): BOOLEAN; FORWARD; FUNCTION FEOLN(VAR F: FIB): BOOLEAN; FORWARD; PROCEDURE FREADINT(VAR F: FIB; VAR I: INTEGER); FORWARD; PROCEDURE FWRITEINT(VAR F: FIB; I,RLENG: INTEGER); FORWARD; PROCEDURE FREADREAL(VAR F: FIB; VAR X: REAL); FORWARD; PROCEDURE FWRITEREAL(VAR F: FIB; X: REAL; W,D: INTEGER); FORWARD; PROCEDURE FREADCHAR(VAR F: FIB; VAR CH: CHAR); FORWARD; PROCEDURE FWRITECHAR(VAR F: FIB; CH: CHAR; RLENG: INTEGER); FORWARD; PROCEDURE FREADSTRING(VAR F: FIB; VAR S: STRING; SLENG: INTEGER); FORWARD; PROCEDURE FWRITESTRING(VAR F: FIB; VAR S: STRING; RLENG: INTEGER); FORWARD; PROCEDURE FWRITEBYTES(VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER); FORWARD; PROCEDURE FREADLN(VAR F: FIB); FORWARD; PROCEDURE FWRITELN(VAR F: FIB); FORWARD; PROCEDURE SCONCAT(VAR DEST,SRC: STRING; DESTLENG: INTEGER); FORWARD; PROCEDURE SINSERT(VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER); FORWARD; PROCEDURE SCOPY(VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER); FORWARD; PROCEDURE SDELETE(VAR DEST: STRING; DELINX,DELLENG: INTEGER); FORWARD; FUNCTION SPOS(VAR TARGET,SRC: STRING): INTEGER; FORWARD; FUNCTION FBLOCKIO(VAR F: FIB; VAR A: WINDOW; NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN): INTEGER; FORWARD; (* NON FIXED FORWARD DECLARATIONS *) FUNCTION VOLSEARCH(VAR FVID: VID; LOOKHARD: BOOLEAN; VAR FDIR: DIRP): UNITNUM; FORWARD; PROCEDURE WRITEDIR(FUNIT: UNITNUM; FDIR: DIRP); FORWARD; FUNCTION DIRSEARCH(VAR FTID: TID; FINDPERM: BOOLEAN; FDIR: DIRP): DIRRANGE; FORWARD; FUNCTION SCANTITLE(FTITLE: STRING; VAR FVID: VID; VAR FTID: TID; VAR FSEGS: INTEGER; VAR FKIND: FILEKIND): BOOLEAN; FORWARD; PROCEDURE DELENTRY(FINX: DIRRANGE; FDIR: DIRP); FORWARD; PROCEDURE INSENTRY(VAR FENTRY: DIRENTRY; FINX: DIRRANGE; FDIR: DIRP); FORWARD; PROCEDURE CLEARSCREEN; FORWARD; PROCEDURE PROMPT; FORWARD; FUNCTION SPACEWAIT: BOOLEAN; FORWARD; FUNCTION GETCHAR(FLUSH: BOOLEAN): CHAR; FORWARD; PROCEDURE EXECUTE(RUNWORKFILE: BOOLEAN); FORWARD; PROCEDURE COMMAND; FORWARD; (* Interactive Pascal Debugger*) (* Version I.3 Released 7/21/77 *) (* Written Summer 1977 *) (* Author Joel McCormack *) (* Assistant authors Dave Wollner, Chip Chapin, Lucia Bennett *) SEGMENT PROCEDURE USERPROGRAM(VAR INPUT, OUTPUT: TEXT); BEGIN END; (* USERPROGRAM *) SEGMENT PROCEDURE COMPILER; SEGMENT PROCEDURE COMPINIT; BEGIN END; (* COMPINIT *) BEGIN END; (* COMPILER *) SEGMENT PROCEDURE EDITOR; BEGIN END; (* EDITOR *) SEGMENT PROCEDURE FILEHANDLER; BEGIN END; (* FILEHANDLER *) SEGMENT PROCEDURE DEBUGGER; CONST (* Special Characters *) ORDALT = 27; ORDCR = 13; ORD0 = 48; (* Positioning of info on screen *) PROMPTLINE = 0; INFOLINE = 3; HEADINGLINE = 7; FIRSTDATALINE = 8; LINKCOLUMN = 54; (* Information about the hardware and implementation *) DELTAMSCW = 12; DATAOFFSET = 1; (* The first data offset *) WORDSZ = 2; BYTESPERWORD = 2; LOBYTE = 1; HIBYTE = 2; HEXPERWORD = 4; MAXBREAKPNTS = 9; JTABPROCANDLL = 0; (* The offsets by words in the JUMPTABLE. Indexed off of @JTAB *) JTABENTRIC = -1; JTABEXITIC = -2; JTABPARMSZ = -3; JTABDATASZ = -4; (* BUGSTATES *) ASLEEP = 0; WAKINGUP = 1; CRAWLING = 2; WALKING = 3; RUNNING = 4; EXAMINING = 5; TYPE DEBUGLINE = (EMPTYLINE,DATALINE,STACKLINE,POINTERLINE); BUGINFOREC = RECORD BUFFEREMPTY: BOOLEAN; DATAPLACE: INTEGER; SCREENINFO: ARRAY [8..22] OF RECORD CASE LINETYPE: DEBUGLINE OF DATALINE,STACKLINE: (SEG: SEGRANGE; PROC: BYTERANGE; DISP: INTEGER); POINTERLINE: (HEAPPOINTER: INTEGER) END END (*BUGINFOREC*) ; OCTRANGE = 0..7; HEXRANGE = 0..15; MEMTYPE = RECORD CASE INTEGER OF (* Used to get at memory in various and convenient ways *) 0: (INTVAL: INTEGER); 1: (HEXVAL: PACKED ARRAY[1..HEXPERWORD] OF HEXRANGE); 2: (BYTEVAL: PACKED ARRAY[1..BYTESPERWORD] OF BYTERANGE); 3: (CHARVAL: PACKED ARRAY[1..BYTESPERWORD] OF CHAR); 4: (OCTVAL: PACKED RECORD FD0, FD1, FD2, FD3, FD4: OCTRANGE; FIRSTDIGIT: 0..1 END); 5: (BYTEOCTVAL: PACKED RECORD LD1, LD2: OCTRANGE; LD0: 0..3; HD1, HD2: OCTRANGE; HD0: 0..3 END); 6: (PTVAL: ^MEMTYPE) END;(* RECORD MEMTYPE *) MEMARRAY = ARRAY [0..0] OF MEMTYPE; DMSCWP = ^DMSCW; DMSCW = RECORD (* MSCW in convenient format *) MSSTAT: DMSCWP; MSDYN: DMSCWP; MSJTAB: ^MEMARRAY; MSSEG: ^MEMTYPE; MSIPC: INTEGER; MSSP: ^MEMARRAY; MSDATA: ARRAY [DATAOFFSET..DATAOFFSET] OF MEMTYPE END; (* Debug Mark Stack Control Word *) DIRECTYPE = (UP,DOWN); LINKTYPE = (STATIC,DYNAMIC); VAR LASTDATALINE, COMLINE: INTEGER; BUGDEBUGINFO: ^BUGINFOREC; JEXERRP: DMSCWP; (*Pointer to EXECERROR *) PPROCINFO, PLINKINFO: DMSCWP; (* Pointers to current proc *) DATOFF, STOFF, (* Default offsets for stack and data *) LNGTH, (* Default length to use *) SEGNUM, PROCNUM, (* Info about current proc *) LINKLEVEL: INTEGER; (* Number of DYNAMIC links above bombed proc *) LINKDEFAULT: LINKTYPE; DIRECTION: DIRECTYPE; DELAYCNT, (* Used to wait while in WALKING mode *) DIGITSET: SET OF '0'..'9'; DOWNCHARS: STRING[31]; ACROSSCHARS: STRING[79]; ======================================================================================== DOCUMENT :usus Folder:VOL18:debug.b.text ======================================================================================== FUNCTION INTREAD(VAR N: INTEGER): BOOLEAN; VAR CH: CHAR; BEGIN REPEAT READ(KEYBOARD, CH) UNTIL (CH <> ' ') OR EOLN(KEYBOARD); IF CH IN DIGITSET THEN BEGIN N := 0; INTREAD := TRUE; REPEAT N := 10*N+ORD(CH)-ORD0; WRITE(OUTPUT, CH); READ(KEYBOARD, CH); UNTIL (NOT (CH IN DIGITSET)) OR (N >= 3276); END ELSE INTREAD := FALSE; END; (* INTREAD *) FUNCTION FINDPROC(SEGNUM, PROCNUM: BYTERANGE; STRTPLACE: DMSCWP; VAR PPROCINFO, PLINKINFO: DMSCWP; VAR LEVELSUP: INTEGER): BOOLEAN; VAR FOUND: BOOLEAN; BEGIN LEVELSUP := 0; PPROCINFO := STRTPLACE; PLINKINFO := PPROCINFO^.MSDYN; FOUND := (PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE] = PROCNUM) AND (PPROCINFO^.MSSEG^.BYTEVAL[LOBYTE] = SEGNUM); WHILE (NOT FOUND) AND (PLINKINFO^.MSDYN <> PLINKINFO) DO BEGIN LEVELSUP := LEVELSUP + 1; PPROCINFO := PLINKINFO; PLINKINFO := PPROCINFO^.MSDYN; FOUND := (PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE] = PROCNUM) AND (PPROCINFO^.MSSEG^.BYTEVAL[LOBYTE] = SEGNUM); END; FINDPROC := FOUND; END; (* FINDPROC *) PROCEDURE PUTCURSOR(LINE, COLUMN: INTEGER); VAR I: INTEGER; BEGIN WITH SYSCOM^, CRTCTRL, CRTINFO DO BEGIN IF ESCAPE = CHR(0) THEN WRITE(OUTPUT, HOME) ELSE WRITE(OUTPUT, ESCAPE, HOME); WRITE(OUTPUT, COPY(ACROSSCHARS, 1, COLUMN), COPY(DOWNCHARS, 1, LINE)); END END; (*PUTCURSOR*) PROCEDURE CLEARLINE(LINE: INTEGER); BEGIN PUTCURSOR(LINE, 0); WITH SYSCOM^.CRTCTRL DO IF ESCAPE = CHR(0) THEN WRITE(OUTPUT, ERASEEOL) ELSE WRITE(OUTPUT, ESCAPE, ERASEEOL) END; (* CLEARLINE *) PROCEDURE CLEARTHISLINE; BEGIN WITH SYSCOM^.CRTCTRL DO IF ESCAPE =CHR(0) THEN WRITELN(OUTPUT, ERASEEOL) ELSE WRITELN(OUTPUT, ESCAPE, ERASEEOL); END; PROCEDURE SPACEWAIT; VAR CH: CHAR; BEGIN REPEAT CLEARLINE(COMLINE); WRITE(OUTPUT, '......Hit [space] to continue......'); READ(KEYBOARD, CH); UNTIL CH = ' '; END; PROCEDURE ERRORINDEBUGGER; BEGIN CLEARLINE(PROMPTLINE+1); WRITELN(OUTPUT, 'I seem to have made a serious error and if you don''t mind,'); WRITELN(OUTPUT, 'I am going to die peacefully. .....AARGHHHHHH !!!!!!'); EXIT(USERPROGRAM); END; (* ERRORINDEBUGGER *) FUNCTION GETPARAMS(VAR DSEGNUM: SEGRANGE; VAR DPROCNUM: BYTERANGE; VAR OFFSET, DLNGTH: INTEGER; VAR TPPROCINFO, TPLINKINFO: DMSCWP): BOOLEAN; VAR JUNK: INTEGER; BEGIN GETPARAMS := TRUE; DSEGNUM := SEGNUM; DPROCNUM := PROCNUM; OFFSET := -1; DLNGTH := LNGTH; TPPROCINFO := PPROCINFO; TPLINKINFO := PPROCINFO^.MSDYN; CLEARLINE(PROMPTLINE); WRITE(OUTPUT, 'Offset: '); IF INTREAD(OFFSET) THEN IF NOT EOLN(KEYBOARD) THEN BEGIN WRITE(OUTPUT, ' Length: '); IF INTREAD(DLNGTH) THEN BEGIN LNGTH := DLNGTH; IF NOT EOLN(KEYBOARD) THEN BEGIN WRITE(OUTPUT, ' Proc: '); IF INTREAD(DPROCNUM) THEN BEGIN IF NOT EOLN(KEYBOARD) THEN BEGIN WRITE(OUTPUT, ' Seg: '); IF INTREAD(DSEGNUM) THEN; END; IF NOT FINDPROC(DSEGNUM, DPROCNUM, PPROCINFO, TPPROCINFO, TPLINKINFO, JUNK) THEN BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT, 'Proc not found'); GETPARAMS := FALSE END END END END END END; (* GETPARAMS *) PROCEDURE INITDEBUG; VAR I: INTEGER; BUGTOSYS: RECORD CASE INTEGER OF 0: (SYSDEBUG: ^INTEGER); 1: (BUGDEBUG: ^BUGINFOREC) END; BEGIN IF DEBUGINFO = NIL THEN NEW(BUGDEBUGINFO); BUGTOSYS.BUGDEBUG := BUGDEBUGINFO; DEBUGINFO := BUGTOSYS.SYSDEBUG; FOR I := FIRSTDATALINE TO SYSCOM^.CRTINFO.HEIGHT-2 DO BUGDEBUGINFO^.SCREENINFO[I].LINETYPE := EMPTYLINE; BUGDEBUGINFO^.DATAPLACE := FIRSTDATALINE; BUGDEBUGINFO^.BUFFEREMPTY := TRUE; SYSCOM^.BUGSTATE := RUNNING; WRITELN(OUTPUT, 'PASCAL INTERACTIVE DEBUGGER - July 21, 1977'); END; (* INITDEBUG *) PROCEDURE DISPLYSYSERROR; VAR MSGNUM: INTEGER; MSG: STRING; BEGIN MSGNUM := 0; PUTCURSOR(COMLINE, 0); CASE SYSCOM^.XEQERR OF 1: MSG := 'INVALID INDEX - Subrange limits exceeded'; 3: MSG := 'Exitting from procedure never called'; 5: MSG := 'INTEGER OVERFLOW - ABS() > maxint'; 6: MSG := 'DIVIDE BY ZERO'; 7: MSG := 'BAD MEMORY ADDRESS - Attempted access to a nil pointer'; 8: MSG := 'USER BREAK - Break character received'; 9: MSG := 'SYSTEM I/O ERROR'; 10: BEGIN MSGNUM := ORD(SYSCOM^.IORSLT); MSG := 'USER I/O ERROR - IORESULT ='; END; 11: MSG := 'INTERPRETER ERROR - Instruction not implemented'; 12: MSG := 'FLOATING POINT ERROR - Overflow, underflow, or divide by zero'; 13: MSG := 'STRING TOO LONG'; 14: MSG := 'USER BREAK POINT OR HALT - Unconditional HALT executed' END; (* CASE *) WRITE(OUTPUT, MSG); IF MSGNUM > 0 THEN WRITE(OUTPUT, MSGNUM); END; (* DISPLYSYSERROR *) PROCEDURE DISPLYMEM(WHAT: MEMTYPE; ADDR: INTEGER); VAR I: INTEGER; OUTSTRING: PACKED ARRAY [0..27] OF CHAR; TRICKSTUFF: MEMTYPE; ADDRSTRING: PACKED ARRAY [0..8] OF CHAR; BEGIN WITH TRICKSTUFF, OCTVAL DO BEGIN INTVAL := ADDR; FILLCHAR(ADDRSTRING, 3, ' '); ADDRSTRING[3+0] := CHR(FIRSTDIGIT+ORD0); ADDRSTRING[3+1] := CHR(FD0+ORD0); ADDRSTRING[3+2] := CHR(FD1+ORD0); ADDRSTRING[3+3] := CHR(FD2+ORD0); ADDRSTRING[3+4] := CHR(FD3+ORD0); ADDRSTRING[3+5] := CHR(FD4+ORD0); END; WITH WHAT DO BEGIN WRITE(OUTPUT, ADDRSTRING, INTVAL: 9); FILLCHAR(OUTSTRING, 28, ' '); WITH OCTVAL DO BEGIN OUTSTRING[2+0] := CHR(FIRSTDIGIT+ORD0); OUTSTRING[2+1] := CHR(FD0+ORD0); OUTSTRING[2+2] := CHR(FD1+ORD0); OUTSTRING[2+3] := CHR(FD2+ORD0); OUTSTRING[2+4] := CHR(FD3+ORD0); OUTSTRING[2+5] := CHR(FD4+ORD0); END; FOR I := HEXPERWORD DOWNTO 1 DO IF HEXVAL[I] < 10 THEN OUTSTRING[9+I] := CHR(HEXVAL[I]+ORD0) ELSE OUTSTRING[9+I] := CHR(HEXVAL[I]-10+ORD('A')); WITH BYTEOCTVAL DO BEGIN OUTSTRING[15+1] := CHR(LD0+ORD0); OUTSTRING[15+2] := CHR(LD1+ORD0); OUTSTRING[15+3] := CHR(LD2+ORD0); OUTSTRING[15+5] := CHR(HD0+ORD0); OUTSTRING[15+6] := CHR(HD1+ORD0); OUTSTRING[15+7] := CHR(HD2+ORD0); END; FOR I := 1 TO BYTESPERWORD DO IF CHARVAL[I] IN [' '..'~', ' '..'þ'] THEN OUTSTRING[25+I] := CHARVAL[I] ELSE OUTSTRING[25+I] := SYSCOM^.CRTINFO.BADCH; WRITELN(OUTPUT, OUTSTRING); END END; (* DISPLYMEM *) PROCEDURE DISPLYHEADING; BEGIN PUTCURSOR(HEADINGLINE, 0); WRITE(OUTPUT, 'TYPE ID PROC# OFFSET ADDR INTEGER'); WRITE(OUTPUT, ' OCTAL HEX LO HI CHAR'); END; (* DISPLYHEADING *) PROCEDURE DISPLYINFO; VAR DATASZ, PARMSZ, STACKSZ, LL, IPC, PARENTNUM, PARENTLL, PARENTSEG, CALLER, CALLERLL, CALLSEG: INTEGER; TPPROCINFO, TPLINKINFO: DMSCWP; BEGIN (* Info about current proc *) PROCNUM := PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE]; LL := PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[HIBYTE]; SEGNUM := PPROCINFO^.MSSEG^.BYTEVAL[LOBYTE]; (* Info about parent *) TPLINKINFO := PLINKINFO^.MSSTAT; TPPROCINFO := PPROCINFO; WHILE TPPROCINFO^.MSDYN <> TPLINKINFO DO TPPROCINFO := TPPROCINFO^.MSDYN; PARENTNUM := TPPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE]; PARENTLL := TPPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[HIBYTE]; PARENTSEG := TPPROCINFO^.MSSEG^.BYTEVAL[LOBYTE]; (* Info about caller *) CALLER := PLINKINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE]; CALLERLL := PLINKINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[HIBYTE]; CALLSEG := PLINKINFO^.MSSEG^.BYTEVAL[LOBYTE]; (* More info on current proc *) STACKSZ := (ORD(PLINKINFO)-ORD(PPROCINFO^.MSSP)) DIV WORDSZ; DATASZ := (PPROCINFO^.MSJTAB^[JTABDATASZ].INTVAL) DIV BYTESPERWORD; PARMSZ := (PPROCINFO^.MSJTAB^[JTABPARMSZ].INTVAL) DIV BYTESPERWORD; IPC := PPROCINFO^.MSIPC - (ORD(PPROCINFO^.MSJTAB)+WORDSZ*JTABENTRIC -PPROCINFO^.MSJTAB^[JTABENTRIC].INTVAL); PUTCURSOR(INFOLINE, 0); WRITELN(OUTPUT, 'PROC', PROCNUM: 4, ' CALLER', CALLER: 4, ' PARENT', PARENTNUM: 4, ' PARAM', PARMSZ: 4, ' DATA', DATASZ: 6); WRITELN(OUTPUT, ' SEG', SEGNUM: 4, ' SEG', CALLSEG: 4, ' SEG', PARENTSEG: 4, ' STACK', STACKSZ: 4, ' IPC', IPC: 6, ' DEPTH', LINKLEVEL: 3); WRITE(OUTPUT, ' LL', LL: 4, ' LL', CALLERLL: 4, ' LL', PARENTLL: 4, ' DEFAULTLINK = '); PUTCURSOR(INFOLINE+2, LINKCOLUMN); IF LINKDEFAULT = DYNAMIC THEN WRITE(OUTPUT, 'DYNAMIC') ELSE WRITE(OUTPUT, 'STATIC'); END; (* DISPLYINFO *) PROCEDURE UPDATE; VAR I, JUNK: INTEGER; TRICKSTUFF: MEMTYPE; TPPROCINFO, TPLINKINFO: DMSCWP; BEGIN CLEARSCREEN; DISPLYSYSERROR; DISPLYINFO; DISPLYHEADING; PUTCURSOR(FIRSTDATALINE, 0); FOR I := FIRSTDATALINE TO LASTDATALINE DO WITH BUGDEBUGINFO^.SCREENINFO[I] DO BEGIN CASE LINETYPE OF EMPTYLINE: WRITELN(OUTPUT); DATALINE: BEGIN WRITE(OUTPUT, 'Data', PROC: 15, DISP: 7); IF FINDPROC(SEG, PROC, PPROCINFO, TPPROCINFO, TPLINKINFO, JUNK) THEN DISPLYMEM(TPLINKINFO^.MSDATA[DISP], ORD(TPLINKINFO)+DELTAMSCW +(DISP-DATAOFFSET)*WORDSZ) ELSE WRITELN(OUTPUT, ' Proc not found') END; STACKLINE: BEGIN WRITE(OUTPUT, 'Stack', PROC: 14, DISP: 7); IF FINDPROC(SEG, PROC, PPROCINFO, TPPROCINFO, TPLINKINFO, JUNK) THEN DISPLYMEM(TPPROCINFO^.MSSP^[DISP], ORD(TPPROCINFO^.MSSP)+DISP*WORDSZ) ELSE WRITELN(OUTPUT, ' Proc not found') END; POINTERLINE: BEGIN WRITE(OUTPUT, 'Pntr', ' ': 22); TRICKSTUFF.INTVAL := HEAPPOINTER; DISPLYMEM(TRICKSTUFF.PTVAL^, HEAPPOINTER) END END; (*CASE*) END; (*WITH*) END; (*UPDATE*) PROCEDURE DISPLYSTEPPINGINFO; BEGIN UPDATE; END;(* DISPLYSTEPPINGINFO *) PROCEDURE DOEXAMINING; VAR ENDCOMMAND: BOOLEAN; CH: CHAR; PROCEDURE TRAVERSELINKS(LINK: LINKTYPE; NLINKS: INTEGER; DIRECTION: DIRECTYPE); BEGIN IF LINKDEFAULT = STATIC THEN IF DIRECTION = DOWN THEN BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT,'Can only traverse UP Static links'); END ELSE BEGIN (* So lets travel up the static links *) WHILE (NLINKS>0) AND (PLINKINFO^.MSDYN<>PLINKINFO) DO BEGIN NLINKS := NLINKS-1; PLINKINFO := PLINKINFO^.MSSTAT; END; IF PLINKINFO^.MSDYN = PLINKINFO THEN BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT,'Top of link chain'); END; LINKLEVEL := 0; PPROCINFO := JEXERRP; WHILE PPROCINFO^.MSDYN <> PLINKINFO DO BEGIN PPROCINFO := PPROCINFO^.MSDYN; LINKLEVEL := LINKLEVEL+1; END; END (* of traveling up the Static links *) ELSE IF DIRECTION = DOWN THEN BEGIN (* traveling down the Dynamic links *) PPROCINFO := JEXERRP; PLINKINFO := PPROCINFO^.MSDYN; NLINKS := LINKLEVEL-NLINKS; LINKLEVEL := 0; IF NLINKS<=0 THEN BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT,'Bottom of link chain'); END ELSE TRAVERSELINKS(DYNAMIC, NLINKS, UP); (* We have now made it look like it is going up the Dynamic links *) END (*of going down the Dynamic links *) ELSE BEGIN (* going up the Dynamic links *) WHILE (NLINKS>0) AND (PLINKINFO^.MSDYN<>PLINKINFO) DO BEGIN LINKLEVEL := LINKLEVEL+1; NLINKS := NLINKS-1; PPROCINFO := PLINKINFO; PLINKINFO := PPROCINFO^.MSDYN; END; IF PLINKINFO^.MSDYN = PLINKINFO THEN BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT, 'Top of link chain'); END; END; (*of traveling up the dynamic links *) END;(*TRAVERSELINKS*) PROCEDURE COMD; VAR DSEG, DPROC, OFFSET, LEN, DATANDPARMSZ, I, LINE: INTEGER; TPPROCINFO, TPLINKINFO: DMSCWP; BEGIN IF GETPARAMS (DSEG, DPROC, OFFSET, LEN, TPPROCINFO, TPLINKINFO) THEN BEGIN DATANDPARMSZ := (TPPROCINFO^.MSJTAB^[JTABDATASZ].INTVAL + TPPROCINFO^.MSJTAB^[JTABPARMSZ].INTVAL) DIV BYTESPERWORD; IF OFFSET = -1 THEN OFFSET := DATOFF; DATOFF := OFFSET + LEN; IF OFFSET-DATAOFFSET+1 > DATANDPARMSZ THEN BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT, 'Warning - offset too large'); END ELSE IF OFFSET-DATAOFFSET+LEN > DATANDPARMSZ THEN BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT, 'Warning - length too large'); END; BUGDEBUGINFO^.BUFFEREMPTY := FALSE; LINE := BUGDEBUGINFO^.DATAPLACE; PUTCURSOR(LINE, 0); FOR I := OFFSET TO DATOFF-1 DO WITH BUGDEBUGINFO^.SCREENINFO[LINE] DO BEGIN LINETYPE := DATALINE; SEG := DSEG; PROC := DPROC; DISP := I; WRITE(OUTPUT, 'Data', DPROC: 15, I: 7); DISPLYMEM(TPLINKINFO^.MSDATA[I], ORD(TPLINKINFO)+DELTAMSCW+(I-DATAOFFSET)*WORDSZ); IF LINE=LASTDATALINE THEN BEGIN LINE := FIRSTDATALINE; PUTCURSOR(LINE, 0) END ELSE LINE := LINE + 1; END; BUGDEBUGINFO^.DATAPLACE := LINE; END END; (* PROCEDURE COMD *) PROCEDURE COMS; VAR DSEG, DPROC, OFFSET, LEN, STACKSZ, I, LINE: INTEGER; TPPROCINFO, TPLINKINFO: DMSCWP; BEGIN IF GETPARAMS (DSEG, DPROC, OFFSET, LEN, TPPROCINFO, TPLINKINFO) THEN BEGIN STACKSZ := (ORD(TPLINKINFO) - ORD(TPPROCINFO^.MSSP)) DIV WORDSZ; IF OFFSET = -1 THEN OFFSET := STOFF; STOFF := OFFSET + LEN; IF OFFSET + 1 > STACKSZ THEN BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT, 'Warning - offset too large'); END ELSE IF OFFSET + LEN > STACKSZ THEN BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT, 'Warning - length too large'); END; BUGDEBUGINFO^.BUFFEREMPTY := FALSE; LINE := BUGDEBUGINFO^.DATAPLACE; PUTCURSOR(LINE, 0); FOR I := OFFSET TO STOFF-1 DO WITH BUGDEBUGINFO^.SCREENINFO[LINE] DO BEGIN LINETYPE := STACKLINE; SEG := DSEG; PROC := DPROC; DISP := I; WRITE(OUTPUT, 'Stack', DPROC: 14, I: 7); DISPLYMEM(TPPROCINFO^.MSSP^[I], ORD(TPPROCINFO^.MSSP)+I*WORDSZ); IF LINE = LASTDATALINE THEN BEGIN LINE := FIRSTDATALINE; PUTCURSOR(FIRSTDATALINE, 0) END ELSE LINE := LINE + 1; END; BUGDEBUGINFO^.DATAPLACE := LINE; END END; (* PROCEDURE COMS *) PROCEDURE COMT; BEGIN END; (*COMT*) PROCEDURE COMB; BEGIN END; (*COMB*) PROCEDURE COME; VAR I: INTEGER; BEGIN BUGDEBUGINFO^.BUFFEREMPTY := TRUE; PUTCURSOR(FIRSTDATALINE, 0); FOR I := FIRSTDATALINE TO LASTDATALINE DO BEGIN BUGDEBUGINFO^.SCREENINFO[I].LINETYPE := EMPTYLINE; CLEARTHISLINE END; BUGDEBUGINFO^.DATAPLACE := FIRSTDATALINE; END; (* COME *) PROCEDURE COMH; BEGIN END; PROCEDURE MOVETOPROC; VAR PROC, SEG, LEVELS: INTEGER; CH: CHAR; TPLINKINFO, TPPROCINFO: DMSCWP; BEGIN SEG := SEGNUM; CLEARLINE(PROMPTLINE); WRITE(OUTPUT, 'Proc: '); IF NOT INTREAD(PROC) THEN BEGIN PPROCINFO := JEXERRP; PLINKINFO := PPROCINFO^.MSDYN; LINKLEVEL := 0; DISPLYINFO END ELSE BEGIN IF NOT EOLN(KEYBOARD) THEN BEGIN WRITE(OUTPUT, ' Seg: '); IF INTREAD(SEG) THEN; END; IF FINDPROC(SEG, PROC, PLINKINFO, TPPROCINFO, TPLINKINFO, LEVELS) THEN BEGIN LINKLEVEL := LINKLEVEL + LEVELS +1; PPROCINFO := TPPROCINFO; PLINKINFO := TPLINKINFO; DISPLYINFO END ELSE BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT, 'Proc not found') END; END; END;(*MOVETOPROC*) PROCEDURE INITEXAMINE; VAR CH: CHAR; BEGIN SYSCOM^.BUGSTATE := EXAMINING; DIRECTION := UP; STOFF := 0; LNGTH := LASTDATALINE-FIRSTDATALINE+1; ENDCOMMAND := FALSE; WRITE(OUTPUT, 'Hit [space] when ready'); CH := GETCHAR(TRUE); UPDATE; END; (* INITEXAMINE *) BEGIN (* DOEXAMINING *) INITEXAMINE; REPEAT CLEARLINE(PROMPTLINE); IF DIRECTION = DOWN THEN WRITE(OUTPUT, '<') ELSE WRITE(OUTPUT, '>'); WRITELN(OUTPUT, 'EXAMINE: # links, , L(ink, D(ata, S(tack, M(ove, R(esume, C(rawl, W(alk'); WRITE(OUTPUT, 'U(pdate, E(rase, <, >, H(eap '); CH := GETCHAR(FALSE); CLEARLINE(COMLINE); IF CH IN ['<', '>', ',', '.', '0'..'9', 'B', 'C', 'D', 'E', 'H', 'L', 'M', 'R', 'S', 'T', 'U'] THEN CASE CH OF '>', '.': DIRECTION := UP; '<', ',': DIRECTION := DOWN; '0','1','2','3','4','5','6','7','8','9': BEGIN TRAVERSELINKS(LINKDEFAULT,ORD(CH)-ORD0,DIRECTION); DISPLYINFO; END; 'L': BEGIN PUTCURSOR(INFOLINE+2, LINKCOLUMN); IF LINKDEFAULT = DYNAMIC THEN BEGIN LINKDEFAULT := STATIC; WRITE(OUTPUT, 'STATIC ') END ELSE BEGIN LINKDEFAULT := DYNAMIC; WRITE(OUTPUT, 'DYNAMIC') END; END; 'D': COMD; 'H': COMH; 'S': COMS; 'T': COMT; 'W': BEGIN SYSCOM^.BUGSTATE := WALKING; ENDCOMMAND := TRUE; END; 'C': BEGIN SYSCOM^.BUGSTATE := CRAWLING; ENDCOMMAND := TRUE; END; 'B': COMB; 'U': UPDATE;(* Display *) 'R': BEGIN SYSCOM^.BUGSTATE := RUNNING; ENDCOMMAND:=TRUE;(* Resume Program *) END; 'M': MOVETOPROC; 'E': COME (* Erase *) END (*CASE*) ELSE IF ORD(CH) = ORDALT THEN BEGIN CLEARSCREEN; EXIT(USERPROGRAM) END ELSE IF EOLN(KEYBOARD) THEN WITH BUGDEBUGINFO^ DO BEGIN CLEARLINE(DATAPLACE); IF DATAPLACE = LASTDATALINE THEN DATAPLACE := FIRSTDATALINE ELSE DATAPLACE := DATAPLACE + 1; END ELSE BEGIN PUTCURSOR(COMLINE, 0); WRITE(OUTPUT, 'Not a command') END; UNTIL ENDCOMMAND; CLEARSCREEN; END; (* DOEXAMINE *) PROCEDURE HANDLESTEPPING; BEGIN IF SYSCOM^.XEQERR = 14 THEN (* A HALT WAS EXECUTED *) DISPLYSTEPPINGINFO ELSE DOEXAMINING; END; PROCEDURE INITIALIZE; VAR SYSTOBUG: RECORD CASE INTEGER OF 0: (SYSMSCWP: MSCWP); 1: (BUGMSCWP: DMSCWP); 2: (SYSDEBUGINFO: ^INTEGER); 3: (BUGDEBUGINFO: ^BUGINFOREC) END; (* OLD TO NEW POINTER CONVERSION *) I, SIZE, DPROC, DSEG: INTEGER; BEGIN DIGITSET := ['0'..'9']; SYSTOBUG.SYSMSCWP := SYSCOM^.BOMBP; JEXERRP := SYSTOBUG.BUGMSCWP; SYSTOBUG.SYSDEBUGINFO := DEBUGINFO; BUGDEBUGINFO := SYSTOBUG.BUGDEBUGINFO; PPROCINFO := JEXERRP; PLINKINFO := PPROCINFO^.MSDYN; LINKLEVEL := 0; LINKDEFAULT := DYNAMIC; COMLINE := SYSCOM^.CRTINFO.HEIGHT-1; LASTDATALINE := COMLINE-1; DATOFF := FIRSTDATAOFFSET; DOWNCHARS[0] := CHR(31); ACROSSCHARS[0] := CHR(79); (* SET STRING LENGTHS *) FILLCHAR(DOWNCHARS[1], 31, CHR(10)); FILLCHAR(ACROSSCHARS[1], 79, SYSCOM^.CRTCTRL.NDFS); IF BUGDEBUGINFO^.BUFFEREMPTY THEN BEGIN DPROC := PPROCINFO^.MSJTAB^[JTABPROCANDLL].BYTEVAL[LOBYTE]; DSEG := PPROCINFO^.MSSEG^.BYTEVAL[LOBYTE]; SIZE := (PPROCINFO^.MSJTAB^[JTABDATASZ].INTVAL +PPROCINFO^.MSJTAB^[JTABPARMSZ].INTVAL) DIV BYTESPERWORD; IF SIZE > LASTDATALINE-FIRSTDATALINE+1 THEN SIZE := LASTDATALINE-FIRSTDATALINE+1; DATOFF := SIZE+DATAOFFSET; BUGDEBUGINFO^.DATAPLACE := FIRSTDATALINE+SIZE; IF BUGDEBUGINFO^.DATAPLACE>LASTDATALINE THEN BUGDEBUGINFO^.DATAPLACE := FIRSTDATALINE; FOR I := 0 TO SIZE-1 DO WITH BUGDEBUGINFO^.SCREENINFO[I+FIRSTDATALINE] DO BEGIN LINETYPE := DATALINE; PROC := DPROC; SEG := DSEG; DISP := I+DATAOFFSET; END; FOR I := SIZE+FIRSTDATALINE TO LASTDATALINE DO BUGDEBUGINFO^.SCREENINFO[I].LINETYPE := EMPTYLINE; END; END; (* INITIALIZE *) BEGIN (*SEGMENT PROCEDURE DEBUGGER *) IF SYSCOM^.BUGSTATE = ASLEEP THEN (*Lets wake up *) BEGIN INITDEBUG; EXECUTE(TRUE); SYSCOM^.BUGSTATE := ASLEEP END ELSE BEGIN INITIALIZE; IF SYSCOM^.XEQERR = 8 THEN (* he hit a break *) CASE SYSCOM^.BUGSTATE OF EXAMINING: BEGIN CLEARLINE(COMLINE); WRITE(OUTPUT, 'The key does not accomplish anything while in EXAMINE mode'); END; CRAWLING, WALKING, RUNNING: DOEXAMINING END (* CASE *) ELSE IF SYSCOM^.BUGSTATE = EXAMINING THEN ERRORINDEBUGGER ELSE CASE SYSCOM^.BUGSTATE OF CRAWLING: BEGIN HANDLESTEPPING; SPACEWAIT; END; WALKING: HANDLESTEPPING; RUNNING: DOEXAMING END; (* CASE *) CLEARSCREEN; END; (* IF *) END; (* SEGMENT PROCEDURE DEBUGGER *) BEGIN (* PASCAL SYSTEM *) END. ======================================================================================== DOCUMENT :usus Folder:VOL18:intrinsics.text ======================================================================================== program benchusus; (* a benchmark of system intrinsics using the structure of bench.usus from volume 12 - gws *) (* If you have a real time clock, the program will time itself. If you don't, than don't fret, just get a stopwatch. The timer code will detect the lack of a clock and not do anything. *) var i, j, k, l, test : integer; starth,startl,endh,endl : integer; num_loops : integer; arg, result,overhead,t,s,e : real; fudge_loop : boolean; procedure prompt; procedure prompt1; { too big for 1200 bytes otherwise... } var line:integer; begin gotoxy(0,23); for line:=1 to 24 do writeln; gotoxy(0,0); writeln('Select a test or enter "0" for all tests.'); writeln('Enter a negative number to quit.'); writeln; end; begin prompt1; writeln(' 1. null for loops (to). 2. sin'); writeln(' 3. cos 4. exp'); writeln(' 5. atan 6. ln'); writeln(' 7. log 8. pwroften'); writeln(' 9. trunc 10. round'); writeln('11. fillchar a small array 12. fillchar a large array'); writeln('13. moveleft a small array 14. moveleft a large array'); writeln('15. scan a small array 16. scan a large array'); writeln('17. sizeof'); writeln; write('Test number ? '); end; { prompt } procedure doneit; begin writeln( chr ( 7 ), 'Done.'); s:=ABS(startl); e:=ABS(endl); t:=ABS(e-s)/60; if t <> 0.0 then begin write('Time = ',t:5:2,' seconds ' ); if fudge_loop then writeln ((((t/numloops ) * 1000 ) - ( overhead )):7:3,' ms per loop ') else writeln ((( t/numloops ) * 1000 ):7:3, ' ms per loop' ); end; end; procedure test1; begin fudge_loop := false; write('1 . ',numloops,' null for loops (to).'); time(starth,startl); for i := 1 to num_loops do begin end; time(endh,endl); doneit; end; procedure test2; begin arg := 45.0; fudge_loop := true; write('2 . ',numloops,' sin.'); time(starth,startl); for i := 1 to num_loops do begin result := sin ( arg ) end; time(endh,endl); doneit; end; procedure test3; begin fudge_loop := true; arg := 45.0; write('3 . ',numloops,' cos.'); time(starth,startl); for i := 1 to num_loops do begin result := cos ( arg ) end; time(endh,endl); doneit; end; procedure test4; begin fudge_loop := true; arg := 3.14159; write('4 . ',numloops,' exp.'); time(starth,startl); for i := 1 to num_loops do begin result := exp ( arg ); end; time(endh,endl); doneit; end; procedure test5; begin fudge_loop := true; arg := 0.0; write('5 . ',numloops,' atan' ); time(starth,startl); for i := 1 to num_loops do begin result := atan ( arg ) end; time(endh,endl); doneit; end; procedure test6; begin fudge_loop := true; arg := 5.0; write('6 . ',numloops,' ln.'); time(starth,startl); for i := 1 to num_loops do begin result := ln ( arg ) end; time(endh,endl); doneit; end; procedure test7; begin fudge_loop := true; arg := 5.0; write('7 . ',numloops,' log.'); time(starth,startl); for i := 1 to num_loops do begin result := log ( arg ) end; time(endh,endl); doneit; end; procedure test8; begin fudge_loop := true; l := 5; write('8 . ',numloops,' pwroften.'); time(starth,startl); for i := 1 to num_loops do begin result := pwroften ( l ) end; time(endh,endl); doneit; end; procedure test9; begin fudge_loop := true; arg := 5.6; write('9 . ',numloops,' trunc.'); time(starth,startl); for i := 1 to num_loops do begin j := trunc ( arg ) end; time(endh,endl); doneit; end; procedure test10; begin fudge_loop := true; arg := 5.6; write('10. ',numloops,' round.'); time(starth,startl); for i := 1 to num_loops do begin j := round ( arg ) end; time(endh,endl); doneit; end; procedure test11; var ary : packed array [ 0..1 ] of char; begin fudge_loop := true; write('11. ',numloops,' fillchar a small array.'); time(starth,startl); for i := 1 to num_loops do begin fillchar ( ary, sizeof ( ary ), chr ( 0 ) ) end; time(endh,endl); doneit; end; procedure test12; var ary : packed array [ 0..10000 ] of char; begin fudge_loop := true; write('12. ',numloops,' fillchar a large array.'); time(starth,startl); for i := 1 to num_loops do begin fillchar ( ary, sizeof ( ary ), chr ( 0 ) ) end; time(endh,endl); doneit; end; procedure test13; var ary,ary1 : packed array [ 0..1 ] of char; begin fudge_loop := true; write('13. ',numloops,' moveleft a small array.'); time(starth,startl); for i := 1 to num_loops do begin moveleft ( ary, ary1, sizeof ( ary ) ) end; time(endh,endl); doneit; end; procedure test14; var ary,ary1 : packed array [ 0..10000 ] of char; begin fudge_loop := true; write('14. ',numloops,' moveleft a large array.'); time(starth,startl); for i := 1 to num_loops do begin moveleft ( ary, ary1, sizeof ( ary ) ) end; time(endh,endl); doneit; end; procedure test15; var ary : packed array [ 0..1 ] of char; j : integer; begin fillchar ( ary, sizeof ( ary ), chr ( 0 ) ); fudge_loop := true; write('15. ',numloops,' scan a small array'); time(starth,startl); for i := 1 to num_loops do begin j := scan ( sizeof ( ary ), =chr(1), ary ) end; time(endh,endl); doneit; end; procedure test16; var ary : packed array [ 0..10000 ] of char; j : integer; begin fillchar ( ary, sizeof ( ary ), chr ( 0 ) ); fudge_loop := true; write('16. ',numloops,' scan a large array'); time(starth,startl); for i := 1 to num_loops do begin j := scan ( sizeof ( ary ), =chr(1), ary ) end; time(endh,endl); doneit; end; procedure test17; var ary : packed array [ 0..10000 ] of char; j : integer; begin fudge_loop := true; write('17. ',numloops,' sizeofs.'); time(starth,startl); for i := 1 to num_loops do begin j := sizeof ( ary ) end; time(endh,endl); doneit; end; begin { main } writeln ( 'initializing ... ' ); numloops := 10000; test1; s:=ABS(startl); e:=ABS(endl); t:=ABS(e-s)/60; overhead := ( t/numloops ) * 1000; writeln; write('Enter number of loops per test : '); readln(num_loops); repeat prompt; readln(test); if (test >= 0) then case test of 0 : begin test1; test2; test3; test4; test5; test6; test7; test8; test9; test10; test11; test12; test13; test14; test15; test16; test17; end; 1 : test1; 2 : test2; 3 : test3; 4 : test4; 5 : test5; 6 : test6; 7 : test7; 8 : test8; 9 : test9; 10 : test10; 11 : test11; 12 : test12; 13 : test13; 14 : test14; 15 : test15; 16 : test16; 17 : test17; end; if test>=0 then begin write('Type to continue'); readln; end; until (test < 0); end. ======================================================================================== DOCUMENT :usus Folder:VOL18:life.inc.text ======================================================================================== procedure write_prompt(prompt:string); begin gotoxy(2,0); clear_line; write(prompt,' ',copy(border,1,76-length(prompt)),'+'); gotoxy(length(prompt)+2,0) end {write_prompt}; function read_int(low_lim,hi_lim,digits_allowed:integer):integer; var ch:char; result,digits,i:integer; ok:boolean; begin ok:=FALSE; repeat result := 0; digits := 0; repeat read(keyboard,ch); while not(ch in ['0'..'9',chr(SP),chr(BS)]) do read(keyboard,ch); if ch=chr(BS) then begin if digits>0 then begin {erase last character} write(chr(BS),chr(SP),chr(BS)); result := result div 10; digits := digits-1 end end else if ch<>chr(SP) then if digitsalive[x,y] then begin {change cell at x,y} alive[x,y] := live; population := population+amnt; cur_neighbors[x-1,y-1]:=cur_neighbors[x-1,y-1]+amnt; cur_neighbors[x-1,y]:=cur_neighbors[x-1,y]+amnt; cur_neighbors[x-1,y+1]:=cur_neighbors[x-1,y+1]+amnt; cur_neighbors[x,y-1]:=cur_neighbors[x,y-1]+amnt; cur_neighbors[x,y+1]:=cur_neighbors[x,y+1]+amnt; cur_neighbors[x+1,y-1]:=cur_neighbors[x+1,y-1]+amnt; cur_neighbors[x+1,y]:=cur_neighbors[x+1,y]+amnt; cur_neighbors[x+1,y+1]:=cur_neighbors[x+1,y+1]+amnt end {change cell at x,y} end {set_cell}; procedure change_pattern; const change_prompt= 'arrows (plain writes, caps erases, CNTL moves) CR (ESC aborts, ETX accepts)'; var x:col; y:row; begin {change_pattern} write_prompt(change_prompt); x := middlex; y := middley; gotoxy(x,y); repeat read(keyboard,ch); if EOF(keyboard) then ch := chr(ETX) else if EOLN(keyboard) then ch := chr(CR); if ord(ch) in [ESC,ETX,RT,LT,UP,DN,WRITE_RT,WRITE_LT,WRITE_UP,WRITE_DN, ERASE_RT,ERASE_LT,ERASE_UP,ERASE_DN,CR] then begin if ch>='a' then begin {write} set_cell(x,y,TRUE); gotoxy(36,23); write(population:4); ch := chr(ord(ch)-ord('a')+1) end {write} else if ch>='A' then begin {erase} set_cell(x,y,FALSE); gotoxy(36,23); write(population:4); ch := chr(ord(ch)-ord('A')+1) end {erase}; case ord(ch) of ESC: exit(change_pattern); ETX: ; RT: x := x+1; LT: x := x-1; UP: y := y-1; DN: y := y+1; CR: begin y := y+1; x := 1 end; end {case}; {perform wraparound} if x=0 then begin x := 78; y := y-1 end else if x=79 then begin x := 1; y := y+1 end; if y=0 then y := 22 else if y=23 then y :=1; {move cursor} gotoxy(x,y) end until ord(ch)=ETX; {set up regular prompt} write_prompt(prompt); {set ch to indicate we just did a "change_pattern"} ch := 'c' end {change_pattern}; function key_pressed:boolean; var status_rec : array [ 1..30 ] of integer; begin unitstatus ( 2, status_rec, 1 ); key_pressed := status_rec [ 1 ] > 0; end {key_pressed}; function read_title(var title:string):boolean; var ch:char; chstr:string[1]; begin chstr := ' '; title := ''; repeat read(keyboard,ch); if ord(ch)=BS then begin if length(title)>0 then begin {erase last character} write(chr(BS),chr(SP),chr(BS)); delete(title,length(title),1) end {erase last character} end else if not (ord(ch) in [ESC,SP]) then begin {add character to title} write(ch); if (ch>='a') and (ch<='z') then ch := chr(ord(ch)+ord('A')-ord('a')); chstr[1] := ch; title := concat(title,chstr) end {add character to title} until (ord(ch) in [ESC,SP]); read_title := ord(ch)=SP; if ord(ch)=SP then if length(title)<5 then title := concat(title,'.LIFE') else if copy(title,length(title)-4,5)<>'.LIFE' then title := concat(title,'.LIFE') end {read_title}; function move_cursor(var x:col; var y:row):boolean; var ch:char; begin repeat gotoxy(x,y); read(keyboard,ch); if EOF(keyboard) then ch := chr(ETX) else if EOLN(keyboard) then ch := chr(CR); case ord(ch) of RT: x := x+1; LT: x := x-1; UP: y := y-1; DN: y := y+1; CR: begin x:=1; y:=y+1 end end {case}; {perform wraparound} if x=0 then begin x := 78; y := y-1 end else if x=79 then begin x := 1; y := y+1 end; if y=0 then y := 22 else if y=23 then y :=1; until (ord(ch) in [ESC,ETX]); move_cursor := ord(ch)=ETX end {move_cursor}; procedure ioerror(n:integer); var ch:char; begin write_prompt('I/O ERROR '); write(n,'. Type anything to continue:'); read(ch) end {ioerror}; procedure save_pattern; const prompt1= 'Move cursor=>upper left corner of area to be saved(ESC aborts,ETX accepts)'; prompt2= 'Move cursor=>lower right corner of area to be saved(ESC aborts,ETX accepts)'; var title:string; startx,endx:col; starty,endy:row; ch:char; ok:boolean; begin ok := FALSE; write_prompt('Save as what file? (ESC escapes):'); if read_title(title) then begin {got title} {$I-} rewrite(life_file,title); {$I+} if IORESULT=0 then begin {file opened OK} write_prompt(prompt1); startx:=middlex; starty:=middley; if move_cursor(startx,starty) then begin {first move cursor ok} write_prompt(prompt2); endx:=startx; endy:=starty; repeat gotoxy(endx,endy); read(keyboard,ch); case ord(ch) of RT: endx:=endx+1; LT: endx := endx-1; UP: endy := endy-1; DN: endy := endy+1; CR: begin endx:=1; endy:=endy+1 end end {case}; if endx=rows) and (maxx-startx>=cols) then begin {enough room - read in pattern} ok := TRUE; write_prompt('Reading'); for y:=starty to starty+rows-1 do begin {do a row} gotoxy(startx,y); for x:=startx to startx+cols-1 do begin {set cell at x,y} read(life_file,ch); if ch='1' then set_cell(x,y,TRUE) else set_cell(x,y,FALSE) end {set cell at x,y} end {do a row}; gotoxy(36,23); write(population:4) end {enough room} else begin {not enough room allowed for pattern} ok := FALSE; write_prompt(room_prompt) end {not enough room} else ok := TRUE {didn't move cursor -ESCape} until ok; close(life_file,normal) end {file opened ok} else {file didn't open ok} ioerror(IORESULT) end {got title}; write_prompt(prompt) {restore prompt} end {get_pattern}; procedure read_key; var title:string; begin if ch<>'r' then begin {not 'run'ning - read from keyboard} repeat gotoxy(length(prompt)+2,0); read(keyboard,ch); {map to lower case} if ('A'<=ch) and (ch<='Z') then ch := chr(ord(ch)+ord('a')-ord('A')); case ch of 'i': begin {handle i(nterval} gotoxy(50,23); write(' ',chr(BS),chr(BS)); interval := read_int(1,99,2) end; 'c': change_pattern; 's': save_pattern; 'g': get_pattern; end {case} until not (ch in ['i','c','s','g']); if ch='r' then begin {got a 'run' request} gotoxy(2,0); clear_line; write(chr(ESC),'RD','Running: hit any key to stop.', chr(ESC),'R@',copy(border,1,46),'+') end {'run' request} end {not 'run'ning} else {'run'ning - see if a key has been pressed} if key_pressed then begin {a key was pressed - cancel 'run' request} read(keyboard,ch); {read the character} ch := 'x'; {and throw it away } gotoxy(1,0); write(chr(ESC),'S',chr(ESC),'S'); {restore prompt} write_prompt(prompt); read_key {see what user wants to do now} end {a key was pressed} end {read_key}; procedure initialize; var line:integer; begin generation :=0; population :=0; interval :=1; for x:=0 to maxx do for y:=0 to maxy do alive[x,y]:=FALSE; cur_neighbors:=zeros; next_neighbors:=zeros; {set up screen} clear_screen; write(chr(ESC),'W'); {disable scrolling} gotoxy(79,22); {last position of next to last line} write('|+---------generation ',generation:3,' population=', population:4,' interval=',interval:2,copy(border,1,27),'+'); write(chr(ESC),'X'); {reenable scrolling} write('+-'); gotoxy(0,1); write('|'); for line:=1 to 21 do begin gotoxy(79,line); write('||') end; {get initial pattern} change_pattern; {allow for initial option setting} if ch<>chr(ESC) then begin ch := 'x'; read_key end end {initialize}; procedure get_next_gen; begin population := 0; next_neighbors := zeros; for x:=1 to maxx-1 do for y:=1 to maxy-1 do begin {calculate new alive[x,y] & next_neighbors[x,y]} if (cur_neighbors[x,y]=3) or (alive[x,y] and (cur_neighbors[x,y]=2)) then begin alive[x,y] := TRUE; population := population+1; next_neighbors[x-1,y-1]:=next_neighbors[x-1,y-1]+1; next_neighbors[x-1,y]:=next_neighbors[x-1,y]+1; next_neighbors[x-1,y+1]:=next_neighbors[x-1,y+1]+1; next_neighbors[x,y-1]:=next_neighbors[x,y-1]+1; next_neighbors[x,y+1]:=next_neighbors[x,y+1]+1; next_neighbors[x+1,y-1]:=next_neighbors[x+1,y-1]+1; next_neighbors[x+1,y]:=next_neighbors[x+1,y]+1; next_neighbors[x+1,y+1]:=next_neighbors[x+1,y+1]+1 end else alive[x,y] := FALSE end {calculate}; cur_neighbors := next_neighbors; generation := generation+1 end {get_next_gen}; procedure print_gen; begin for y:=1 to 22 do for x:=1 to 78 do if alive[x,y]<>prev_alive[x,y] then begin gotoxy(x,y); if alive[x,y] then write(screen_char) else write(' ') end; gotoxy(21,23); write(generation:3); gotoxy(36,23); write(population:4) end {print_gen}; begin {life} fillchar(zeros,sizeof(zeros),chr(0)); print_intro; repeat initialize; while ch<>chr(ESC) do begin gotoxy(0,0); {give some indication that something is happening} prev_alive := alive; for i:=1 to interval do get_next_gen; print_gen; if population=0 then begin gotoxy(30,12); write('In generation ',generation,' population=0'); ch := chr(ESC) end else begin if prev_alive=alive then begin gotoxy(55,23); write('PATTERN IS REPEATING') end; read_key end end; gotoxy(0,0); clear_line; write('Type ''r'' to repeat, anything else to quit:'); read(keyboard,ch) until not(ch='r') end. {life} ======================================================================================== DOCUMENT :usus Folder:VOL18:long_int.text ======================================================================================== program benchusus; (* a long integer benchmark using the structure of bench.usus from volume 12 - gws *) (* I suggest that you run test 1 with 10,000 loops and the rest of the tests with 100 or 1000 loops *) (* There appears to be some sort of problem with divides on my H-89. If I run with more than about 250 loops on the 12 and 36 digit divied, the processor hangs. If you run into similar trouble, PLEASE let me know. This might be a general Z-80 system problem.*) (* If you have a real time clock, the program will time itself. If you don't, then fret not, just get a stopwatch. The timer code will detect the lack of a clock and not do anything. *) type int4 = integer [ 4 ]; int12 = integer [ 12 ]; int36 = integer [ 36 ]; var i, j, k, l, test : integer; starth,startl,endh,endl : integer; num_loops : integer; long_a4, long_b4, long_c4 : int4; long_a12, long_b12, long_c12 : int12; long_a36, long_b36, long_c36 : int36; overhead,t,s,e : real; fudge_loop : boolean; procedure prompt; procedure prompt1; var line:integer; begin gotoxy(0,23); for line:=1 to 24 do writeln; gotoxy(0,0); writeln('Select a test or enter "0" for all tests.'); writeln('Enter a negative number to quit.'); writeln; end; begin prompt1; writeln(' 1. null for loops (to). 2. integer [ 4 ] adds.'); writeln(' 3. integer [ 12 ] adds 4. integer [ 36 ] adds.'); writeln(' 5. integer [ 12 ] multiplies. 6. integer [ 12 ] divides.'); writeln(' 7. integer [ 36 ] multiplies. 8. integer [ 36 ] divides.'); writeln; write('Test number ? '); end; { prompt } procedure doneit; begin writeln( chr ( 7 ), 'Done.'); s:=ABS(startl); e:=ABS(endl); t:=ABS(e-s)/60; if t <> 0.0 then begin write('Time = ',t:5:2,' seconds ' ); if fudge_loop then writeln ((((t/numloops ) * 1000 ) - ( overhead )):7:3,' ms per loop ') else writeln ((( t/numloops ) * 1000 ):7:3, ' ms per loop' ); end; end; procedure test1; begin fudge_loop := false; write('1 . ',numloops,' null for loops (to).'); time(starth,startl); for i := 1 to num_loops do begin end; time(endh,endl); doneit; end; procedure test2; begin fudge_loop := true; long_a4 := 1234; long_b4 := 5678; write('2 . ',numloops,' integer [ 4 ] adds.'); time(starth,startl); for i := 1 to num_loops do begin long_c4 := long_a4 + long_b4 end; time(endh,endl); doneit; end; procedure test3; begin fudge_loop := true; long_a12 := 123456789012; long_b12 := 012345678901; write('3 . ',numloops,' integer [ 12 ] adds.'); time(starth,startl); for i := 1 to num_loops do begin long_c12 := long_a12 + long_b12 end; time(endh,endl); doneit; end; procedure test4; begin fudge_loop := true; long_a36 := 123456789012345678901234567890123456; long_b36 := long_a36; write('4 . ',numloops,' integer [ 36 ] adds.'); time(starth,startl); for i := 1 to num_loops do begin long_c36 := long_a36 + long_b36 end; time(endh,endl); doneit; end; procedure test5; begin fudge_loop := true; long_a12 := 100000; long_b12 := 100000; write('5 . ',numloops,' integer [ 12 ] multiplies.'); time(starth,startl); for i := 1 to num_loops do begin long_c12 := long_a12 * long_b12 end; time(endh,endl); doneit; end; procedure test6; begin fudge_loop := true; long_a12 := 300000000000; long_b12 := 100000000000; write('6 . ',numloops,' integer [ 12 ] divides.'); time(starth,startl); for i := 1 to num_loops do begin long_c12 := long_a12 div long_b12 end; time(endh,endl); doneit; end; procedure test7; begin fudge_loop := true; long_a36 := 10000000000000000; long_b36 := long_a36; write('7 . ',numloops,' integer [ 36 ] multiplies.'); time(starth,startl); for i := 1 to num_loops do begin long_c36 := long_a36 * long_b36 end; time(endh,endl); doneit; end; procedure test8; begin fudge_loop := true; long_a36 := 300000000000000000000000000000000000; long_b36 := 100000000000000000000000000000000000; write('8 . ',numloops,' integer [ 36 ] divides.'); time(starth,startl); for i := 1 to num_loops do begin long_c36 := long_a36 div long_b36 end; time(endh,endl); doneit; end; begin { main } writeln ( 'initializing ... ' ); numloops := 10000; test1; s:=ABS(startl); e:=ABS(endl); t:=ABS(e-s)/60; overhead := ( t/numloops ) * 1000; writeln; write('Enter number of loops per test : '); readln(num_loops); repeat prompt; readln(test); if (test >= 0) then case test of 0 : begin test1; test2; test3; test4; test5; test6; test7; test8; end; 1 : test1; 2 : test2; 3 : test3; 4 : test4; 5 : test5; 6 : test6; 7 : test7; 8 : test8; end; if test>=0 then begin write('Type to continue'); readln; end; until (test < 0); end. ======================================================================================== DOCUMENT :usus Folder:VOL18:numberio.text ======================================================================================== {$R-,$F-}(* GENERATES A FILE OF 25000 REAL NUMBERS, AND COMPUTES THEIR *) (* SUM S. THEN THE FILE IS RESET AND READ, AND A CHECKSUM IS COMPUTED. *) (* IT TOOK 1230 MSEC (ON THE CDC 6400) TO GENERATE THE FILE, AND 980 MSEC *) (* TO READ IT. THIS CORRESPONDS TO 49 USEC TO WRITE AND 39 USEC TO READ *) (* PER NUMBER. *) (* THE AMOUNT OF TIME INCREASES DRASTICALLY, IF A DECIMAL REPRESENTATION *) (* OF THE NUMBERS ON THE FILE IS REQUESTED. THIS IS EASILY ACCOMPLISHED, *) (* NAMELY BY DECLARING THE FILE TO CONSIST OF CHARACTERS INSTEAD OF REAL *) (* NUMBERS: *) (* F: FILE OF CHAR *) (* IN THIS CASE, THE READ AND WRITE STATEMENTS INCLUDE A CONVERSION *) (* OPERATION FROM DECIMAL TO BINARY AND VICE-VERSA. GENERATING THE FILE *) (* THEN TAKES 28185 MSEC (ON THE CDC 6400), READING TAKES 30313 MSEC (ON *) (* CDC 6400). THIS CORRESPONDS TO AN INCREASE BY A FACTOR OF 23 IN *) (* WRITING AND 31 IN READING. (EACH NUMBER IS REPRESENTED BY 22 *) (* CHARACTERS ON THE FILE). *) (* THE ORIGINAL PROGRAM HAS BEEN MODIFIED TO BE UCSD PASCAL COMPATIBLE, *) (* INCLUDING THE USE OF GET/PUT INSTEAD OF READ/WRITE FOR FILES OF REALS. *) PROGRAM NUMERICIO(F,OUTPUT); (* INPUT AND OUTPUT OF NUMBERS *) CONST N = 25000; D = 0.12345; VAR I: INTEGER; X,S: REAL; F: FILE OF REAL; BEGIN Writeln; Writeln ('Write and read reals (R-)'); Writeln; Write (' starts benchmark (create file part)'); Readln; X := 1.0; S := 0; REWRITE(F, 'REALTEMP' ); FOR I := 1 TO N DO BEGIN F^ := X; PUT(F); S := S+X; X := X+D END; WRITELN('DONE',CHR(7)); WRITELN('CHECKSUM= ', S ); CLOSE(F,LOCK); WRITELN(' continues benchmark (read part)'); READLN; RESET(F, 'REALTEMP'); S := 0; WHILE NOT EOF(F) DO BEGIN X:= F^; GET(F); S := S+X; END; WRITELN('DONE',CHR(7)); WRITELN('CHECKSUM = ',S); CLOSE(F, PURGE); END. ======================================================================================== DOCUMENT :usus Folder:VOL18:odmscu.text ======================================================================================== { One D****d More Screen Control Unit 24 Dec 82 } {|xjm$d0|nx|f8|ejm$d1|nx|f8|ejf|.} {$S++} { Enable as much swapping as you need } UNIT ScreenUnit ; {$C Copyright 1982, Volition Systems. All rights reserved.} {--- change log 21 Dec 82 [acd] Had to move var Disk to interface, no private files in II.x } INTERFACE CONST SCU_Version = '0.0a' ; SCU_Date = '24 Dec 82' ; TYPE Phyle = FILE ; CrtCommand = (ClrToEos, ClrToEoL , Up, Down, Right, Left ) ; VAR Disk : Phyle ; FUNCTION InitSCU : BOOLEAN ; FUNCTION ScrWidth : INTEGER ; FUNCTION ScrHeight: INTEGER ; PROCEDURE CrtControl( C : CrtCommand ); IMPLEMENTATION TYPE CrtRec = RECORD Unused0 : PACKED ARRAY [0..61] OF CHAR ; CrtCtrl : PACKED RECORD Escape : CHAR; Home : CHAR; EraseEoS : CHAR; EraseEoL : CHAR; NDFS : CHAR; RLF : CHAR; BackSpace : CHAR; FillCount : 0..11; ClearLine : CHAR; ClearScreen: CHAR; Prefixed : PACKED ARRAY [0..8] OF BOOLEAN END; CrtInfo : PACKED RECORD Height : INTEGER; Width : INTEGER; Up : CHAR; Down : CHAR; Left : CHAR; Right : CHAR; EoF : CHAR; Flush : CHAR; Break : CHAR; Stop : CHAR; CharDel : CHAR; BadCh : CHAR; LineDel : CHAR; AltMode : CHAR; Prefix : CHAR; ETx : CHAR; BackSpace : CHAR; Prefixed : PACKED ARRAY [0..13] OF BOOLEAN END; Unused1 : ARRAY [0..47] OF INTEGER ; Unused2 : ARRAY [0..31] OF INTEGER ; Block2 : ARRAY [0..127] OF INTEGER ; END ; { CrtRec } VAR InfoRec : CrtRec ; Filler : STRING[12] ; FUNCTION InitSCU ; { Use blockread because using a structured file would require putting } { the record declaration in the interface, since private files are not } { allowed in II.x units. } CONST MiscInfoName = '*SYSTEM.MISCINFO' ; VAR k : INTEGER ; BEGIN { InitSCU } {$I-} RESET( Disk, MiscInfoName ) ; IF IORESULT = 0 THEN BEGIN k := BLOCKREAD( Disk, InfoRec, 1 ) ; IF (IORESULT = 0) AND (k = 1) THEN BEGIN {$R-} FILLCHAR( Filler[1], InfoRec.CrtCtrl.FillCount, CHR(0) ) ; Filler[0] := CHR( InfoRec.CrtCtrl.FillCount ) ; {$R+} InitSCU := TRUE END ELSE InitSCU := FALSE END ELSE InitSCU := FALSE ; CLOSE( Disk ) {$I+} END { InitSCU } ; FUNCTION ScrWidth {: INTEGER} ; BEGIN { ScrWidth } ScrWidth := InfoRec.CrtInfo.Width END { ScrWidth } ; FUNCTION ScrHeight {: INTEGER} ; BEGIN { ScrHeight } ScrHeight := InfoRec.CrtInfo.Height END { ScrHeight } ; PROCEDURE CrtControl { c : CrtCommand } ; { Call InitSCU before using this procedure. } CONST CrtUnit = 1 ; NoSpec = 12 ; LineFeed = 10 ; VAR ca : PACKED ARRAY [0..0] OF CHAR ; PROCEDURE PutCrt ( Inx : INTEGER ; Ch : CHAR ) ; VAR i : INTEGER ; c : PACKED ARRAY [0..0] OF CHAR ; BEGIN { PutCrt } IF Ch <> CHR(0) THEN WITH InfoRec.CrtCtrl DO BEGIN IF Prefixed[Inx] THEN WRITE( Escape ) ; c[0] := Ch ; UNITWRITE( CrtUnit, c[0], 1, 0, NoSpec ) ; IF LENGTH( Filler ) > 0 THEN WRITE( Filler ) END END { PutCrt } ; BEGIN { CrtControl } WITH InfoRec DO CASE c OF ClrToEoS: BEGIN PutCrt( 2, CrtCtrl.EraseEoS ) ; END ; ClrToEoL: BEGIN PutCrt( 3, CrtCtrl.EraseEoL ) ; END ; Up: BEGIN PutCrt( 5, CrtCtrl.RLF ) ; END ; Down: BEGIN ca[0] := CHR(LineFeed) ; UNITWRITE( CrtUnit, ca[0], 1, 0, NoSpec ) END ; Left: BEGIN PutCrt( 6, CrtCtrl.BackSpace ) ; END ; Right: BEGIN PutCrt( 4, CrtCtrl.NDFS ) ; END ; END ; { case } END { CrtControl } ; BEGIN { ScreenUnit } { remove the BEGIN above if you are running II.0. If you are running II.1 } { or later you may place a call to InitSCU here, relieving your program of } { that burden. } END. { One D****d More Screen Control Unit } ======================================================================================== DOCUMENT :usus Folder:VOL18:primes.text ======================================================================================== {$R-,F-} (* Program "primes" computes the first 1000 prime numbers, and *) (* writes them in a table with 20 numbers per line. This takes 1347 *) (* msec. on the CDC 6400 (1061 msec. without the range checking) *) (* Modified to 10 numbers per line. *) PROGRAM PRIMES(OUTPUT); CONST N = 1000; N1 = 33; (*N1 = SQUARE ROOT OF N*) VAR I,K,X,INC,LIM,SQUARE,L,HI,LOW, q, iterations: INTEGER; PRIM: BOOLEAN; P,V: ARRAY[1..N1] OF INTEGER; SHITIME ,SLOWTIME, EHITIME, ELOWTIME: INTEGER; BEGIN Writeln; Writeln ('First 1000 primes. No IO. (R-)'); Writeln; Write ('Iterations ? ( starts benchmark)'); Readln (iterations); for q := 1 to iterations do begin (* WRITE(2:6, 3:6); *) L := 2; X := 1; INC := 4; LIM := 1; SQUARE := 9; FOR I := 3 TO N DO BEGIN (*FIND NEXT PRIME*) REPEAT X := X+INC; INC := 6-INC; IF SQUARE <=X THEN BEGIN LIM := LIM +1; V[LIM] := SQUARE; SQUARE := SQR(P[LIM+1]) END; K := 2; PRIM := TRUE; WHILE PRIM AND (K V[K] END UNTIL PRIM; IF I <= N1 THEN P[I] := X; (* WRITE(X:6); *) L := L+1; IF L = 10 THEN BEGIN (* WRITELN; *) L := 0; END END; (* WRITELN; *) end {for q}; WRITELN('DONE', CHR (7)); END. ======================================================================================== DOCUMENT :usus Folder:VOL18:pwrof2.text ======================================================================================== {$R-,F-}(* This program computes the exact values of 2^k and 2^(-k) for *) (* k=1...n, and prints them in the form *) (* 2 1 .5 *) (* 4 2 .25 *) (* 8 3 .125 *) (* 16 4 .0625 *) (* .............. *) (* *) (* This program uses integer arithmetic exclusively. Execution time *) (* for computing the powers of 2 (n=90) was measured as 916 (813) *) (* msec. The figure in parentheses is obtained when run-time index *) (* bound checks are disabled. *) PROGRAM POWERSOFTWO(OUTPUT); (*GENERATE A TABLE OF POWERS OF 2 *) CONST M = 30; N = 90; (* M >= N*LOG(2) *) VAR EXP,I,J,L: INTEGER; C,R,T, q, iterations: INTEGER; D: ARRAY[0..M] OF INTEGER; (*POSITIVE POWERS*) F: ARRAY[1..N] OF INTEGER; (*NEGATIVE POWERS*) SHITIME ,SLOWTIME, EHITIME, ELOWTIME: INTEGER; BEGIN Writeln; Writeln ('Powers of two. No IO. (R-)'); Writeln; WRITE('Iterations ? (test starts with ) '); READLN (iterations); for q := 1 to iterations do begin (* Page (output); *) L := 0; R := 1; D[0] := 1; FOR EXP := 1 TO N DO BEGIN (*COMPUTE AND PRINT 2**EXP *) C := 0; FOR I := 0 TO L DO BEGIN T := 2*D[I] + C; IF T >= 10 THEN BEGIN D[I] := T-10; C := 1; END ELSE BEGIN D[I] := T; C := 0; END END; IF C > 0 THEN BEGIN L := L + 1; D[L] := 1; END; FOR I := M DOWNTO L DO (* WRITE(' ') *); FOR I := L DOWNTO 0 DO (*WRITE(D[I]:1); WRITE(EXP:5, ' .') *); (* COMPUTE AND PRINT 2**(-EXP) *) FOR J := 1 TO EXP-1 DO BEGIN R := 10*R + F[J]; F[J] := R DIV 2; R := R - 2*F[J]; (* WRITE(F[J]:1) *) END; F[EXP] := 5; (* WRITELN('5'); *) R := 0 END; end {for q}; WRITELN('DONE',CHR(7)); END. ======================================================================================== DOCUMENT :usus Folder:VOL18:quicksort.text ======================================================================================== {$R-,$F-}(* THIS PROGRAM SORTS AN ARRAY OF 10000 INTEGERS ACCORDING TO THE *) (* METHOD CALLED QUICKSORT. IT USES A RECURSIVE PROCEDURE. THE *) (* THE MAXIMUM DEPTH OF RECURSION IS LN(10000). *) (* EXECUTION TIME ON THE CDC 6400 WAS 4098 MSEC. (2861 MSEC WITHOUT *) (* RANGE CHECKING). *) { Note CDC times did not include initializing array. } (* THE TEXT OF THIS PROGRAM WAS MODIFIED TO ACCOMODATE 16 BIT MACHINES *) PROGRAM QUICKSORT(OUTPUT); CONST N = 10000; VAR I,Z, q, iterations: INTEGER; A: ARRAY[1..N] OF INTEGER; SHITIME ,SLOWTIME, EHITIME, ELOWTIME: INTEGER; PROCEDURE SORT(L,R: INTEGER); VAR I,J,X,W: INTEGER; BEGIN (*QUICKSORT WITH RECURSION ON BOTH PARTITIONS*) I := L; J := R; X := A[ (I+J) DIV 2]; REPEAT WHILE A[I] < X DO I := I+1; WHILE X < A[J] DO J := J-1; IF I <= J THEN BEGIN W := A[I]; A[I] := A[J]; A[J] := W; I := I+1; J := J-1; END UNTIL I > J; IF L < J THEN SORT(L,J); IF I < R THEN SORT(I,R) END; (*SORT*) BEGIN Writeln; Writeln ('Quicksort 10000 integers (R-)'); Writeln; WRITE('Iterations? ( starts benchmark) '); READLN (iterations); for q := 1 to iterations do begin {$R-} Z := 257; (*GENERATE RANDOM SEQUENCE*) FOR I := 1 TO N DO BEGIN Z := (251*Z) MOD 255; A[I] := Z END; {$R+} SORT(1,N); end {for}; WRITELN('DONE',CHR(7)); END. ======================================================================================== DOCUMENT :usus Folder:VOL18:qur.text ======================================================================================== program qur; {This may seem to be a fairly trivial benchmark, but it actually has a fair amount of significance. It indicates the minimal response time of the system to update, compile and execute a trivial program. The preferred test method is to load this program into the editor using the G(et command. Update the file once to place it on your system disk as *SYSTEM.WRK.TEXT, and then re-enter the E(ditor. The compiler should be on your system disk. Start timing when your type the "Q" of the "QUR" command sequence to update the workfile and run the program. Stop timing when the 'hi there' message appears on the screen. The actual performance being measured is the system's ability to shuffle around data in a often used sequence. This test will not show much sensitivity to faster processors, and will be very much influenced by both the speed of your disk system and the type of software that you are using. Version II.0 type systems will respond much faster than IV.0 systems. ASE will hurt a little. Extended memory will help, as the system won't have to mash memory as much. If you wish to contribute your results, please include all of the information on the data collection form on this disk. It is very important to know which version of the p-system you are running and what type of disk subsystem that you use. regards - gws} begin writeln ( 'hi there' ); end. ======================================================================================== DOCUMENT :usus Folder:VOL18:report.doc.text ======================================================================================== Use the form in the file REPORTFORM.TEXT to report the results of the benchmarks on this disk for your particular iron. If you run the tests under different versions of the p-system, or with different hardware configurations, fill out the pertanent parts on a new form and attach it to the first one. You should not modify the sources of any of the benchmarks to optimize performance, it is realized that there may be faster ( or slower ) ways to do whatever the benchmarks do, but the goal is to obtain comparative data on many different types of computers to see which has the better or worse performance. We also wish to see if particular computers do particular things especially poorly or well. For example, the IV.03 release for the IBM PC is unusually slow when working with reals. When you are given an option on the number of loops to run, please pick a number which causes the benchmark to run at least 60 seconds. This will allow reasonable accuracy when timing with a stopwatch or wall clock. Please provide some sort of information on your hardware in the space provided. It is important that we know the processor type, the clock speed, and the version of the p-system that you use. It would also be helpful if you could supply information on the speed of your disks and whether or not that you have some sort of floating point hardware or perpherial data processor installed. regards - gws ======================================================================================== DOCUMENT :usus Folder:VOL18:reportform.text ======================================================================================== Benchmark Report Form ---> PLEASE READ THE INSTRUCTIONS IN REPORT.DOC.TEXT <--- Your Name ( optional ) __________________________________________________ Processor type ________________________________________ Clock ___________ RAM Available _________________ Speed if known ______________ P-System version ________________ Floating Point Hardware _______________ Floppy Disk Model _______________ Capacity _______________ DMA ? ____ Hard disk Model _______________ Capacity _______________ DMA ? ____ +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Timing results ( seconds ) PWROF2.TEXT _____ 8QUEENS.TEXT _______ NUMBERIO.TEXT _______/________ QUICKSORT.TEXT _____ ANCEST.S.TEXT ______ SIEVE.TEXT _____ QUR.TEXT _______ COMPKILLER number of lines compiled _________ elapsed time __________ STARS ______(ms/loop) SEGMASHER large seg _____ small seg ____ (ms/swap) LONG_INT.TEXT ( please normalize results to milli-seconds per loop with the overhead of test 1 subtracted from result ) Test 1 null for loop ______ Test 2 integer [ 4 ] adds _______ Test 3 integer [12] adds ______ Test 4 integer [ 36 ] adds _______ Test 5 integer [12] multiplies______ Test 6 integer [ 12 ] divides _______ Test 7 integer [36] multiplies______ Test 8 integer [ 36 ] divides _______ INTRINSICS.TEXT ( please normalize results to milli-seconds per loop with the overhead of test 1 subtracted from result ) Test 1 null for loop ______ Test 2 sin _______ Test 3 cos ______ Test 4 exp _______ Test 5 atan ______ Test 6 ln _______ Test 7 log ______ Test 8 pwroften _______ Test 9 trunc ______ Test 10 round _______ Test 11 fillchar a small array ______ Test 12 fillchar a large array _______ Test 13 moveleft a small array ______ Test 14 moveleft a large array _______ Test 15 scan a small array ______ Test 16 scan a large array _______ Test 17 sizeof ______ ======================================================================================== DOCUMENT :usus Folder:VOL18:segmap.1.text ======================================================================================== { SegMap: A quick & dirty segment map utility 17 Apr 83 } { L PRINTER: }{$L-} {$S++} { enable as much swapping as you need } {$V-} { turn off var string length verification on Apples } PROGRAM SegMap ; {========================================================================} { File : SegMap Author: Arley C. Dealey } { Date : 14 Dec 82 Time : 10:00 } {------------------------------------------------------------------------} { Revision: 0.1f Author: Arley C. Dealey } { Date : 17 Apr 83 Time : 15:15 } {========================================================================} { } { SegMap is a quick and dirty utility to display the information found } { the segment dictionary of a UCSD code file. It was developed hastily } { when a new and undocumented restriction was added to the system (no } { code segment may be over 8192 words long under IV.1 on the DEC - 11 } { systems) in the middle of a major project. The most important } { information it displays is available via the standard LIBRARY utility, } { but in a much less convenient form. } { } { This program was developed hastily and is not terribly well written. } { Several expedient, but questionable, programming practices are } { evident. As an example, most functions in this program exhibit one or } { more side effects, whether they be modifying the value of parameters } { or writing messages to the console. Global variables have been used } { rather heavily also. Be forwarned, it may not be the easiest program } { to modify! } { } { The segment dictionary is, of necessity, kludged together to deal with } { all known varieties of the UCSD system. The program has been compiled } { and tested under the II.0 and II.1 compilers and will work with all } { code files (yes, Virginia, even IV.x extended segment dictionaries). } { It is believed that some versions of the II.0 compiler may not have } { zeroed unused fields in the segment dictionary record. This will lead } { to erroneous reports of required intrinsics. If you are using a II.0 } { compiler and experience this, you should probably remove the intrinsic } { report code all together (they were not supported under II.0 anyway). } { Apple /// code files have not been tested and may act strangely } { because Apple chose to redefine the MajorVersion field to mean } { AppleVersion. This also causes Apple ][ release 1.0 segments to be } { reported as II.0 rather than II.1 } { } { Terminal screen control handling is hard-coded in procedure CrtControl } { for a TVI-950. A screen control unit was not used because the program } { was developed using a variant of the I.3 compiler which did not support} { units. It was hard-coded because the author is lazy, but it should be } { trivial to adapt it to use a generalized unit. } { } { This program was inspired by (and, in fact, based on) CodeMap by } { David N. Jones as published in Call-A.P.P.L.E. In Depth #2. } { } {========================================================================} {$C Copyright (C) 1982, Volition Systems. All rights reserved. } {========================================================================} {=== change log ============================================================= 16 Apr 83 gws broke it into two files for the benefit of non-ASE users 12 Feb 83 [acd] Fixed failure to clear screen reported by Schreyer/Willner 28 Dec 82 [acd] Added display of screen control unit version & date 28 Dec 82 [acd] SetOutput now clears line before putting status message 28 Dec 82 [acd] Fixed bug in SetPrefix that could bomb if null response 23 Dec 82 [acd] Converted to use One Damn More Screen Control Unit 22 Dec 82 [acd] Flips IntSegSet 21 Dec 82 [acd] Split procedure MapSofTech 21 Dec 82 [acd] Redefined ItIsFlipped (yet again) & hope it works correctly 20 Dec 82 [acd] Added further info to IV.= map 17 Dec 82 [acd] Paranoid double check of file gender & attendant restructuring 16 Dec 82 [acd] New test for ItIsFlipped. There must be a better way! 15 Dec 82 [acd] Added default capability to code file name prompt 15 Dec 82 [acd] New FlipIt. Should work correctly now. 15 Dec 82 [acd] Restructured sex-change stuff 14 Dec 82 [acd] Don't write any fields if seg length is zero 14 Dec 82 [acd] Major user interface & code restructuring 14 Dec 82 [acd] Added code to deal with IV.x linked segdicts 14 Dec 82 [acd] Turns off iochecking locally where needed instead of globally 14 Dec 82 [acd] Added code to flip integers if necessary 14 Dec 82 [acd] Added UCSD/SofTech dichotomy stuff {============================================================================} {--- profile ---------- |xstjm$d0|nx|f8|ejm$d1|nx|f8|ejm$d2|nx|f8|ejt|n|*|f1|. |"New Rev" stjm$r0|n dg |! |*c|f7 jm$r1|n x|f7|e jm$r2|n x|f7|e jt|. {--- end of profile ---} USES {$U odmscu.code} ScreenUnit ; CONST Title = 'SegMap[' ; Rev = '0.1f' ; T0 = ' Volition Systems'' SegMap utility' ; T1 = ' version 0.1f of 17 Apr 83' ; T2 = ' Copyright (C) 1982, Volition Systems. All rights reserved.'; MaxSeg = 63 ; { 15 for most, 31 for Apple ][, 63 for Apple /// } MaxDicSeg = 15 ; TYPE SegRange = 0..MaxSeg ; SegDicRange = 0..MaxDicSeg ; SegmentName = PACKED ARRAY[0..7] OF CHAR ; { I.x, II.x, III.x, VS } SegmentTypes = ( Linked, HostSeg, SegProc, UnitSeg, SeprtSeg, Unlinked_Intrins, Linked_Intrins, DataSeg ) ; MachineTypes = ( UnDefined, PCodeMost, PCodeLeast, PDP11, M8080, Z80, GA440, M6502, M6800, TI990 ) ; { IV.x } SegTypes = ( NoSeg, ProgSeg, xUnitSeg, ProcSeg, xSeprtSeg ) ; Versions = ( Unknown, II, II_1, III, IV, V, VI, VII ) ; { note on apples: } { Versions = ( Unknown, A2_10, A2_11, A3_10, A3_11, Bad1, Bad2, Bad3 ) } { therefore } { II implies Apple ][ 1.0 } { II_1 implies Apple ][ 1.1 } { III implies Apple /// 1.0 } { IV implies Apple /// 1.1 } { thanks a lot, you guys! sure would have been nice if you had used one } { of the unused words at the end of the record for the Apple version #. } SegSet = SET OF SegRange ; SegDict = RECORD DiskInfo : ARRAY[SegDicRange] OF RECORD CodeAddr : INTEGER ; CodeLeng : INTEGER END ; SegName : ARRAY[SegDicRange] OF SegmentName ; SegMisc : PACKED RECORD CASE BOOLEAN OF TRUE : { UCSD, Apple, WD, VS } ( SegType : ARRAY[SegDicRange] OF SegmentTypes ) ; FALSE : { SofTech } ( xSegMisc : ARRAY[SegDicRange] OF PACKED RECORD SegType : SegTypes ; Filler : 0..31 ; HasLinkInfo : BOOLEAN ; Relocatable : BOOLEAN END ) ; END ; SegText : ARRAY[SegDicRange] OF INTEGER ; SegInfo : ARRAY[SegDicRange] OF PACKED RECORD SegNum : 0..255 ; MType : MachineTypes ; { UCSD } Filler : 0..1 ; MajorVersion : Versions ; END ; CASE BOOLEAN OF TRUE : { UCSD, Apple, WD, VS } ( IntSegSet : SegSet ; { 1 word on most, 2 on A][, 4 on A/// } IntChkSum : PACKED ARRAY [0..MaxSeg] OF 0..255 ; {valid on A/// only} Filler2 : ARRAY[0..35] OF INTEGER ; Comment : PACKED ARRAY[0..79] OF CHAR ) ; FALSE : { SofTech } ( SegFamily : ARRAY[SegDicRange] OF RECORD CASE SegTypes OF xUnitSeg, ProgSeg: ( DataSize : INTEGER ; SegRefs : INTEGER ; MaxSegNum: INTEGER ; TextSize : INTEGER ) ; xSeprtSeg, ProcSeg: ( ProgName : SegmentName ) ; END ; NextDict : INTEGER ; Filler : ARRAY[0..6] OF INTEGER ; CopyNote : STRING[77] ; Sex : INTEGER ) ; END ; { SegDict } SegDicRec = RECORD Flipped : BOOLEAN ; Dict : SegDict END ; PathName = STRING[23] ; VAR f : Phyle ; o : INTERACTIVE ; CmdSet : SET OF CHAR ; OFileName : PathName ; CFileName : PathName ; Prefix : STRING[8] ; ConsoleOutput : BOOLEAN ; PROCEDURE Initialize ; BEGIN { Initialize } IF InitSCU = FALSE THEN BEGIN WRITE( 'Screen control unit failed initialization.' ) ; EXIT( SegMap ) END ; IF (ScrHeight < 24) OR (ScrWidth < 80) THEN BEGIN WRITE( 'Sorry, you must have at least a 24 x 80 terminal.' ) ; EXIT( SegMap ) END ; GOTOXY( 0, 0 ) ; CrtControl( ClrToEoS ) ; GOTOXY( 0, 8 ) ; WRITELN( T0 ) ; WRITELN ; WRITELN( T1 ) ; WRITELN ; WRITELN( T2 ) ; WRITELN ; GOTOXY( 0, 17 ) ; WRITE( '':14 ) ; WRITE( 'Using screen control unit version ' ) ; WRITE( SCU_Version, ' of ', SCU_Date, '.' ) ; CmdSet := [ 'm', 'M', 'o', 'O', 'p', 'P', 'q', 'Q' ] ; OFileName := 'CONSOLE:' ; CFileName := 'SYSTEM.WRK' ; Prefix := '' ; ConsoleOutput := TRUE ; REWRITE( o, OFileName ) ; END { Initialize } ; PROCEDURE CleanUp ; BEGIN { CleanUp } CLOSE( o, LOCK ) ; END { CleanUp } ; PROCEDURE SpaceWait ; CONST KbdUnit = 2 ; VAR JunkCh : CHAR ; BEGIN { SpaceWait } GOTOXY( 0, 0 ) ; CrtControl( ClrToEoL ) ; WRITE( '' ) ; UNITCLEAR( KbdUnit ) ; REPEAT READ( KEYBOARD, JunkCh ) UNTIL JunkCh = ' ' ; GOTOXY( 0, 0 ) ; CrtControl( ClrToEoL ) END { SpaceWait } ; { L+} PROCEDURE Sanitize ( VAR FileName : STRING ; Prefix : STRING ; Ext : STRING ) ; VAR i : INTEGER ; FNLen : INTEGER ; ExtLn : INTEGER ; BEGIN { Sanitize } ExtLn := LENGTH( Ext ) ; FOR i := LENGTH( FileName ) DOWNTO 1 DO IF FileName[i] IN [CHR(0)..CHR(31), ' '] THEN DELETE( FileName, i, 1 ) ELSE IF FileName[i] IN ['a'..'z'] THEN FileName[i] := CHR(ORD(FileName[i])-32) ; IF LENGTH( FileName ) > 0 THEN BEGIN IF (POS( ':', FileName ) = 0) AND (FileName[1] <> '*' ) THEN FileName := CONCAT( Prefix, FileName ) ; FNLen := LENGTH( FileName ) ; IF FileName[FNLen] = '.' THEN DELETE( FileName, FNLen, 1 ) ELSE IF COPY( FileName, SUCC(FNLen-ExtLn), ExtLn ) <> Ext THEN FileName := CONCAT( FileName, Ext ) ; IF LENGTH(FileName) > 23 THEN FileName := COPY( FileName, 1, 23 ) ; END { fnlen > 0 } END { Sanitize } ; PROCEDURE SplitName ( Name : STRING ; VAR VolName : STRING ; VAR FileName: STRING ) ; VAR ColonPos : INTEGER ; BEGIN { SplitPathName } IF LENGTH( Name ) > 0 THEN BEGIN ColonPos := POS( ':', Name ) ; IF ColonPos > 0 THEN BEGIN VolName := COPY( Name, 1, ColonPos ) ; FileName:= COPY( name, SUCC(ColonPos), LENGTH(name)-ColonPos ) ; END ELSE IF Name[1] = '*' THEN BEGIN VolName := '*' ; IF LENGTH( Name ) > 1 THEN FileName := COPY( Name, 2, LENGTH(Name)-1 ) ELSE FileName := '' ; END ELSE BEGIN VolName := '' ; FileName:= Name END END ELSE BEGIN VolName := '' ; FileName:= '' ; END ; END { SplitPathName } ; { L-} FUNCTION Menu : BOOLEAN ; VAR CmdCh : CHAR ; Done : BOOLEAN ; PROCEDURE PutPrompt ; BEGIN { PutPrompt } GOTOXY( 0, 23 ) ; CrtControl( ClrToEoL ) ; WRITE( 'Output file is ', OFileName ) ; IF (LENGTH( Prefix ) > 0) AND (Prefix <> ':') THEN WRITE( ', prefix volume is ', Prefix ) ; GOTOXY( 0, 0 ) ; CrtControl( ClrToEoL ) ; WRITE( Title, Rev, '] ' ) ; WRITE( 'M(ap, O(utput file, P(refix, Q(uit ' ) ; END { PutPrompt } ; PROCEDURE SetOutputFile ; VAR OFName : STRING ; BEGIN { SetOutputFile } GOTOXY( 0, 0 ) ; CrtControl( ClrToEoL ) ; WRITE( '[', OFileName, '] Enter new output file name: ' ) ; READLN( OFName ) ; Sanitize( OFName, Prefix, '' ) ; IF LENGTH( OFName ) > 0 THEN BEGIN {$I-} CrtControl( ClrToEoL ) ; CLOSE( o, LOCK ) ; REWRITE( o, OFName ) ; IF IORESULT = 0 THEN BEGIN WRITELN( 'Output file opened successfully' ) ; OFileName := OFName ; END ELSE BEGIN WRITELN( 'Open error on output file ', OFName ) ; REWRITE( o, OFileName ) END ; {$I+} IF (OFName = 'CONSOLE:') OR (OFName = '#1:') THEN ConsoleOutput := TRUE ELSE ConsoleOutput := FALSE END ; END { SetOutputFile } ; PROCEDURE SetPrefix ; VAR pf : STRING ; BEGIN { SetPrefix } GOTOXY( 0, 0 ) ; CrtControl( ClrToEoL ) ; IF LENGTH( Prefix ) > 0 THEN WRITE( '[', Prefix, '] ' ) ; WRITE( 'Enter new prefix: ' ) ; READLN( pf ) ; IF LENGTH( pf ) > 0 THEN Prefix := pf ; Sanitize( Prefix, '', '' ) ; IF LENGTH( Prefix ) > 0 THEN IF (Prefix <> '*') AND (Prefix[LENGTH(Prefix)] <> ':') THEN Prefix := CONCAT( Prefix, ':' ) ; END { SetPrefix } ; FUNCTION OpenCodeFile ( VAR CodeFile : Phyle ; VAR CFileName : PathName ) : BOOLEAN ; { Note that this returns the open status as a function result. This } { method of returning the status results in a function with side-effects } { on both of its parameters - questionable programming practice at best! } VAR fn : STRING ; JunkName : STRING ; BEGIN { OpenCodeFile } GOTOXY( 0, 0 ) ; CrtControl( ClrToEoL ) ; SplitName( CFileName, JunkName, CFileName ) ; IF LENGTH( CFileName ) > 0 THEN WRITE( '[', CFileName, '] ' ) ; WRITE( 'Enter name of file to be mapped: ' ) ; READLN( fn ) ; IF LENGTH( fn ) = 0 THEN fn := CFileName ; { try it first with no extension } Sanitize( fn, Prefix, '' ) ; {$I-} CLOSE( CodeFile ) ; RESET( CodeFile, fn ) ; IF IORESULT <> 0 THEN BEGIN { now try it with code extension } Sanitize( fn, '', '.CODE' ) ; RESET( CodeFile, fn ) ; END ; {$I+} IF IORESULT = 0 THEN BEGIN CFileName := fn ; OpenCodeFile := TRUE ; END ELSE BEGIN CrtControl( ClrToEoS ) ; WRITELN( 'Open error on file ', fn ) ; OpenCodeFile := FALSE ; END ; END { OpenCodeFile } ; BEGIN { Menu } REPEAT PutPrompt ; REPEAT READ( KEYBOARD, CmdCh ) UNTIL CmdCh IN CmdSet ; WRITELN ; CASE CmdCh OF 'm', 'M': BEGIN { M(ap } Done := OpenCodeFile( f, CFileName ) ; Menu := TRUE END ; { M(ap } 'o', 'O': BEGIN { O(utput } Done := FALSE ; SetOutputFile END ; { O(utput } 'p', 'P': BEGIN { P(refix } Done := FALSE ; SetPrefix END ; { P(refix } 'q', 'Q': BEGIN { Q(uit } Done := TRUE ; Menu := FALSE END ; { Q(uit } END ; { case } UNTIL Done END { Menu } ; (*$I segmap.2.text*) ======================================================================================== DOCUMENT :usus Folder:VOL18:segmap.2.text ======================================================================================== (* included from segmap.1.text*) PROCEDURE Map ( VAR f : Phyle ) ; VAR SegDic : SegDicRec ; SegDicNum : INTEGER ; BlockNum : INTEGER ; FUNCTION ReadSegDic ( VAR f : PHYLE ; Block : INTEGER ; VAR SegDic: SegDicRec ) : BOOLEAN ; FUNCTION ItIsFlipped ( SegDic : SegDict ) : BOOLEAN ; { Note (with some frustration) that we can't use the IV.x Sex byte } { to check for sex even on IV.x code files, because the MajorVersion } { field is in a sex-effected record and so cannot be checked until } { AFTER the sex is already determined! -acd 17 Dec 82 } { The test used is kludgy at best. We assume that all valid code } { (& library) files must have something beginning at block one. If } { we find no CodeAddr equal to 1 and no SegText equal to 1 we then } { assume that the file must be of the wrong sex. If someone can tell } { me of a less arbitrary way to test this, I would be very grateful! } { -acd 18 Dec 82 } { We now make the further assumption that if the IV.x sex word seems } { to contain the value <1> in either sex that the file is indeed IV.x } { This should be OK, since this word contained the last two bytes of } { the comment in pre-IV.x releases and if you put } { or into your comment you deserve anything you get. } { Of course, if your compiler didn't zero these bytes, 1 in every 128 } { files you SegMap will be reported erroneously as IV.x files. Sorry } { bout that, maybe someone will write a SegDictFix utility! All of } { this foolishness is necessary because my kludge test for sex won't } { work on IV.x where the segment that resides at block #1 will often } { be in a later block of the segment dictionary. -acd 21 Dec 82 } CONST NotFlipped = 1 ; Flipped = 256 ; VAR i : INTEGER ; Temp: BOOLEAN ; BEGIN { ItIsFlipped } IF SegDic.Sex IN [ Flipped, NotFlipped ] THEN BEGIN IF SegDic.Sex = Flipped THEN ItIsFlipped := TRUE ELSE ItIsFlipped := FALSE END ELSE BEGIN Temp := TRUE ; { assume it to be flipped } WITH SegDic DO BEGIN FOR i := 0 TO MaxDicSeg DO IF ( DiskInfo[i].CodeAddr = 1 ) OR ( SegText[i] = 1 ) THEN Temp := FALSE ; { must be ok (we hope) } END ; { with } ItIsFlipped := Temp END ; END { ItIsFlipped } ; PROCEDURE FlipSegDic ( VAR SegDic : SegDicRec ) ; VAR i : INTEGER ; Transfer: INTEGER ; XfrArray: ARRAY [0..3] OF INTEGER ; FUNCTION FlipIt ( Num : INTEGER ) : INTEGER ; VAR a, b : PACKED ARRAY [0..1] OF 0..255 ; BEGIN { FlipIt } MOVELEFT( Num, a[0], 2 ) ; b[0] := a[1] ; b[1] := a[0] ; MOVELEFT( b[0], Num, 2 ) ; FlipIt := Num END { FlipIt } ; BEGIN { FlipSegDic } IF ItIsFlipped( SegDic.Dict ) THEN BEGIN WITH SegDic, Dict DO BEGIN FOR i := 0 TO MaxDicSeg DO BEGIN { first the easy part... } WITH DiskInfo[i] DO BEGIN CodeAddr := FlipIt( CodeAddr ) ; CodeLeng := FlipIt( CodeLeng ) END ; { with DiskInfo } SegText[i] := FlipIt( SegText[i] ) ; { and now all the messy junk... } MOVELEFT( SegMisc.SegType[i], Transfer, 2 ) ; Transfer := FlipIt( Transfer ) ; MOVELEFT( Transfer, SegMisc.SegType[i], 2 ) ; MOVELEFT( SegInfo[i], Transfer, 2 ) ; Transfer := FlipIt( Transfer ) ; MOVELEFT( Transfer, SegInfo[i], 2 ) ; IF SegInfo[i].MajorVersion > III THEN BEGIN IF SegMisc.xSegMisc[I].SegType IN [ xUnitSeg, ProgSeg ] THEN BEGIN WITH SegFamily[i] DO BEGIN DataSize := FlipIt( DataSize ) ; SegRefs := FlipIt( SegRefs ) ; MaxSegNum := FlipIt( MaxSegNum ) ; TextSize := FlipIt( TextSize ) END ; { with segfamily } END ; { if } END ; { if } END ; { for } IF SegInfo[0].MajorVersion > III THEN BEGIN NextDict := FlipIt( NextDict ) ; { in an ideal world we'd leave Sex unflipped, but this thing is, } { as I said, quick and dirty so we need to go ahead and flip it. } Sex := FlipIt( Sex ) END { if } ELSE BEGIN MOVELEFT( IntSegSet, XfrArray[0], SIZEOF(IntSegSet) ) ; FOR i := 0 TO 3 DO XfrArray[i] := FlipIt( XfrArray[i] ) ; MOVELEFT( XfrArray[0], IntSegSet, SIZEOF(IntSegSet) ) ; END ; { else } END ; { with segdic.dict } END { if } END { FlipSegDic } ; BEGIN { ReadSegDic } {$I-} IF (BLOCKREAD(f, SegDic.Dict, 1, Block) = 1) AND (IORESULT = 0) THEN BEGIN {$I+} IF ItIsFlipped( SegDic.Dict ) THEN BEGIN SegDic.Flipped := TRUE ; FlipSegDic( SegDic ) END ELSE BEGIN SegDic.Flipped := FALSE ; END ; IF Block = 0 THEN BEGIN { only recheck gender in first seg of dictionary } IF ItIsFlipped( SegDic.Dict ) THEN BEGIN CrtControl( ClrToEoS ) ; WRITE( 'Unable to determine gender of ', CFileName ) ; ReadSegDic := FALSE END ELSE BEGIN ReadSegDic := TRUE END END { if block = 0 } ELSE ReadSegDic := TRUE { because we already know the gender is OK } END { if block read successfully } ELSE BEGIN CrtControl( ClrToEoS ) ; WRITE( 'Error reading segment dictionary of ', CFileName ) ; ReadSegDic := FALSE END END { ReadSegDic } ; PROCEDURE MapUCSD ( SegDic : SegDicRec ) ; VAR i : INTEGER ; j : SegRange ; IntrinsNeeded : BOOLEAN ; BEGIN { MapUCSD } IntrinsNeeded := FALSE ; WRITE( o, ' # Name Addr Len ' ) ; WRITE( o, 'Version Machine Kind ' ) ; WRITE( o, 'Seg Text' ) ; WRITELN( o ) ; WITH SegDic, Dict DO BEGIN FOR i := 0 TO MaxDicSeg DO BEGIN WRITE( o, i:3 ) ; IF SegDic.Dict.DiskInfo[i].CodeLeng <> 0 THEN BEGIN WRITE( o, ' ', SegName[i] ) ; WITH DiskInfo[i] DO BEGIN WRITE( o, CodeAddr:6 ) ; WRITE( o, CodeLeng DIV 2:7 ) ; END ; WITH SegInfo[i] DO BEGIN WRITE( o, ' ' ) ; CASE MajorVersion OF Unknown : WRITE( o, 'Volition' ) ; II : WRITE( o, 'II.0 ' ) ; II_1 : WRITE( o, 'II.1 ' ) ; III : WRITE( o, 'III.0 ' ) END ; { case } IF MajorVersion <> Unknown THEN BEGIN WRITE( o, ' ' ) ; CASE MType OF UnDefined : WRITE( o, 'Unknown' ) ; PCodeMost : WRITE( o, 'PCode+ ' ) ; PCodeLeast : WRITE( o, 'PCode- ' ) ; PDP11 : WRITE( o, 'PDP-11 ' ) ; M8080 : WRITE( o, '8080 ' ) ; Z80 : WRITE( o, 'Z80 ' ) ; GA440 : WRITE( o, 'GA440 ' ) ; M6502 : WRITE( o, '6502 ' ) ; M6800 : WRITE( o, '6800 ' ) ; TI990 : WRITE( o, 'TI990 ' ) ; END ; { case } WRITE( o, ' ' ) ; CASE SegMisc.SegType[i] OF Linked : WRITE( o, 'Linked excutable ' ) ; HostSeg : WRITE( o, 'Unlinked host ' ) ; SegProc : WRITE( o, 'Segment procedure ' ) ; UnitSeg : WRITE( o, 'Regular unit ' ) ; SeprtSeg : WRITE( o, 'Separate procedure' ) ; Unlinked_Intrins : WRITE( o, 'Unlinked intrinsic' ) ; Linked_Intrinsic : WRITE( o, 'Linked intrinsic ' ) ; DataSeg : WRITE( o, 'Data segment ' ) ; END ; { case } WRITE( o, ' ' ) ; WRITE( o, SegNum:3, ' ' ) ; WRITE( o, ' ' ) ; IF SegMisc.SegType[i] IN [ UnitSeg, UnLinkedIntrins, LinkedIntrins ] THEN WRITE( o, SegText[i]:4 ) ; END ; { if majorversion <> volition } END ; { with seginfo } END ; { if } WRITELN( o ) ; END ; { for } WRITE( o, 'Intrinsic segments required: ' ) ; FOR i := 0 TO MaxSeg DO BEGIN IF i IN IntSegSet THEN BEGIN WRITE( o, i:3 ) ; IntrinsNeeded := TRUE END ; { if } END ; { for } IF IntrinsNeeded = FALSE THEN WRITE( o, ' None' ) ; WRITELN( o ) END ; { with segdic, dict } END { MapUCSD } ; PROCEDURE MapSofTech ( VAR SegDic : SegDicRec ; SegDicNum : INTEGER ; BlockNum : INTEGER ) ; CONST { machine types kludge } xPsuedo = 0 ; x6809 = 1 ; xPDP11 = 2 ; x8080 = 3 ; xZ80 = 4 ; xGA440 = 5 ; x6502 = 6 ; x6800 = 7 ; x9900 = 8 ; x8086 = 9 ; xZ8000 = 10 ; x68000 = 11 ; VAR i : INTEGER ; j : SegRange ; BadSegs : SegSet ; TooBig : BOOLEAN ; PROCEDURE PutFamilyInfo ( Index : INTEGER ) ; { uses SegDic and the file o globally } BEGIN { PutFamilyInfo } WITH SegDic, Dict, SegFamily[Index] DO BEGIN CASE SegMisc.xSegMisc[Index].SegType OF xUnitSeg, ProgSeg: BEGIN WRITE( o, ' ' ) ; WRITE( o, DataSize:5 ) ; WRITE( o, ' ' ) ; WRITE( o, SegRefs:5 ) ; WRITE( o, ' ' ) ; WRITE( o, MaxSegNum:5 ) ; IF SegMisc.xSegMisc[Index].SegType = xUnitSeg THEN BEGIN WRITE( o, ' ' ) ; WRITE( o, SegText[Index]:5 ) ; WRITE( o, ' ' ) ; WRITE( o, TextSize:5 ) ; END ELSE WRITE( o, '':12 ) ; END ; xSeprtSeg, ProcSeg: BEGIN WRITE( o, ' ' ) ; WRITE( o, '':11, ProgName ) ; END ; NoSeg: BEGIN END ; END ; { case } END END { PutFamilyInfo } ; PROCEDURE PutOtherInfo ; { uses SegDic, output file o globally } VAR i : INTEGER ; BEGIN { PutOtherInfo } WITH SegDic, Dict DO BEGIN WRITE( o, 'pCode version ' ) ; CASE SegInfo[0].MajorVersion OF Unknown : WRITE( o, 'unknown' ) ; II,II_1,III : WRITE( o, '<>' ) ; IV : WRITE( o, 'IV' ) ; V,VI,VII : WRITE( o, 'unknown' ) ; END ; { case } WRITE( o, '. ' ) ; IF NextDict = 0 THEN WRITELN( o, 'Last dictionary segment in chain.' ) ELSE WRITELN( o, 'Next dictionary segment is at block #', NextDict, '.' ) ; WRITELN( o, '[', CopyNote, ']' ) END ; IF TooBig THEN BEGIN WRITE( o, '*** ERROR: The following segments are too large: ' ) ; FOR i := 0 TO MaxDicSeg DO IF i IN BadSegs THEN WRITE( o, i, ' ' ) ; WRITELN( o ) END END { PutOtherInfo } ; BEGIN { MapSofTech } BadSegs := [] ; TooBig := FALSE ; IF ReadSegDic( f, BlockNum, SegDic ) THEN BEGIN WRITE ( o, ', segment dictionary record #', SegDicNum ) ; WRITELN( o, ', block #', BlockNum ) ; WRITE( o, 'Seg Name Addr Len Mach. Kind ' ) ; WRITE( o, 'Lnk Rel ' ) ; WRITE( o, ' Data Refs MxSeg TxAdr TxLen' ) ; WRITELN( o ) ; FOR i := 0 TO MaxDicSeg DO BEGIN WRITE( o, i:3 ) ; IF SegDic.Dict.DiskInfo[i].CodeLeng <> 0 THEN WITH SegDic, Dict DO BEGIN WRITE( o, ' ', SegName[i] ) ; WITH DiskInfo[i] DO BEGIN WRITE( o, CodeAddr:6 ) ; WRITE( o, CodeLeng:7 ) ; IF CodeLeng > 8191 THEN BEGIN BadSegs := BadSegs + [ i ] ; TooBig := TRUE END END ; WITH SegInfo[i] DO BEGIN WRITE( o, ' ' ) ; IF ORD(MType) = xPsuedo THEN BEGIN WRITE( o, 'pCode' ) ; IF Flipped THEN WRITE( o, '~' ) ELSE WRITE( o, ' ' ) END ELSE CASE ORD(MType) OF x6809 : WRITE( o, '6809 ' ) ; xPDP11: WRITE( o, 'PDP11 ' ) ; x8080 : WRITE( o, '8080 ' ) ; xZ80 : WRITE( o, 'Z80 ' ) ; xGA440: WRITE( o, 'GA440 ' ) ; x6502 : WRITE( o, '6502 ' ) ; x6800 : WRITE( o, '6800 ' ) ; x9900 : WRITE( o, '9900 ' ) ; x8086 : WRITE( o, '8086 ' ) ; xZ8000: WRITE( o, 'Z8000 ' ) ; x68000: WRITE( o, '68000 ' ) ; END ; { case } WRITE( o, ' ' ) ; CASE SegMisc.xSegMisc[i].SegType OF NoSeg : WRITE( o, ' ' ) ; ProgSeg : WRITE( o, 'Program ' ) ; xUnitSeg : WRITE( o, 'Unit ' ) ; ProcSeg : WRITE( o, 'Segment ' ) ; xSeprtSeg : WRITE( o, 'Separate' ) ; END ; { case } END ; { with seginfo } WRITE( o, ' ' ) ; WITH SegMisc, xSegMisc[i] DO BEGIN IF HasLinkInfo THEN WRITE( o, ' T' ) ELSE WRITE( o, ' F' ) ; WRITE( o, ' ' ) ; IF Relocatable THEN WRITE( o, ' T' ) ELSE WRITE( o, ' F' ) ; END ; PutFamilyInfo( i ) ; END ; (* if, with segdic *) WRITELN( o ) ; END ; (* for *) PutOtherInfo ; END ELSE BEGIN { ReadSegDic has already written err msg, so set NextDict to quit } SegDic.Dict.NextDict := 0 END ; END { MapSofTech } ; BEGIN { Map } SegDicNum := 0 ; BlockNum := 0 ; IF ReadSegDic( f, BlockNum, SegDic ) THEN BEGIN IF SegDic.Dict.SegInfo[0].MajorVersion < IV THEN BEGIN IF ConsoleOutput THEN CrtControl( ClrToEoS ) ELSE Page( o ) ; WRITELN( o ) ; WRITELN( o, 'File: ', CFileName ) ; MapUCSD( SegDic ) END ELSE BEGIN REPEAT IF ConsoleOutput THEN CrtControl( ClrToEoS ) ELSE Page( o ) ; WRITELN( o ) ; WRITE( o, 'File: ', CFileName ) ; MapSofTech( SegDic, SegDicNum, BlockNum ) ; BlockNum := SegDic.Dict.NextDict ; SegDicNum := SUCC( SegDicNum ) ; IF (OFileName = 'CONSOLE:') AND (BlockNum <> 0) THEN SpaceWait ; UNTIL BlockNum = 0 END END ELSE BEGIN { ReadSegDic has already written error message, so do nothing! } END ; END { Map } ; BEGIN Initialize ; WHILE Menu = TRUE DO Map( f ) ; CleanUp END. ======================================================================================== DOCUMENT :usus Folder:VOL18:segmasher.text ======================================================================================== program segmasher; {This program tests the speed of segment swaps. It was originally written to test the swapping ability of the IV.1 LSI-11 extended memory p-system vs. the non-extended memory implementation of IV.0. The program causes successive segment swaps. If the value of "selector" is set to 2, then the segments are very small, and can co-reside in the IV.0 code pool. They can be called without causing stack or heap faults and should present very little overhead. If the value of "selector" is set to be very large, 8165 in this case, the compiler generates a huge jump table, and the segment will very large. In this case each segment is nearly 16k bytes, the maximum allowed under the LSI- 11 IV.1 implementation. Each of the two segments has this size. However, depending on how much memory you have, they may still be able to co-reside in the code pool. If this is the case, there will be very little difference in swapping speed. The global variable "buffer" is designed to eat up a lot of stack to cause the system to be forced to cause segment loads of each segment. When this happens, the segment swaps in IV.0 will be quite slow, depending on the speed of your disks. To cause the segments to swap, set "stack_filler" so that the varavail displayed is between about 9000 and 15,000 words, or enough room for one, but not both of the segments. Version IV.1 swaps from extended memory, so its swaps should be much quicker. The swapping speed should not be dependant on the size of the segments. The results I got on an 11/23 with IV.0 and IV.1 are shown below. IV.0 hard disk IV.0 floppy IV.1 small segment 0.8 ms/swap 0.8 ms/swap 1.7 ms/swap large segment 190 ms/swap 2000 ms/swap 1.7 ms/swap Swapping the small segment under IV.1 is slower than IV.0 as the system must massage some memory mapping registers to access the new segment in extended memory. However, if IV.0 must do a disk swap, IV.1 has a decided advantage. The disk swaps from floppy disk are so slow as not only is a seek performed, but 16k of code, or about 64 sectors, must be loaded. george w. schreyer} const stack_filler = 20000; selector = 8165; var i : integer; num_swaps : integer; buff : packed array [ 0..stack_filler ] of char; segment procedure big_seg1; var i : integer; begin case i of 1 : ; selector : ; end; end; segment procedure big_seg2; var i : integer; begin case i of 1 : ; selector : ; end; end; begin writeln ( varavail ( 'segmasher' ) ); write ( 'number of swaps ? ' ); readln ( num_swaps ); write ( chr ( 7 ) ); for i := 1 to ( num_swaps div 2 ) do begin bigseg1; bigseg2; end; write ( chr ( 7 ) ); end. ======================================================================================== DOCUMENT :usus Folder:VOL18:sieve.text ======================================================================================== (* Eratosthenes Sieve Prime Number Program in PASCAL *) PROGRAM PRIMES; {This is the original version from Byte, with only the modifications necessary to allow it to compile under UCSD and a bell at the end. If you choose to report your results, PLEASE RUN IT AS IS! It is a known fact that the speed of this version can be significantly improved by turning off range checking and re-ordering the declarations of the variables, but this is the version which has been used most and we desire consistantcy. Start timing by typing and stop at the bell. gws} {The results of this version on several systems have been reported on MUSUS. System UCSD version Time (sec) ------ ------------ ---------- Sage II IV.1 57 (68000 at 8 MHz) WD uEngine III.0 59 (fillchar is so slow on uE) LSI-11/23 IV.01 92-122 (depends on memory speed) LSI-11/23 II.0 105 (98 seconds under IV.01) LSI-11/23 IV.1 107 (non-extended memory) LSI-11/23 IV.1 128 (extended memory) NEC APC IV.1 144 8086 at 4.9 Mhz extended memory JONOS IV.03 ? 162 (pretty good for a 4 MHz Z-80A) NorthStar I.5 183 (Z-80 at 4 MHz) OSI C8P-DF II.0 ? 197 (6502 at 2 MHz) H-89 II.0 200 (4 MHz Z-80A) LSI-11/2 IV.0 202 IBM PC IV.03 203 (4.77 MHz 8088) LSI-11/2 II.0 220 Apple ][ II.1 390 (1 MHz 6502) H-89 II.0 455 (2 MHz Z-80) } CONST SIZE = 8190; VAR FLAGS : ARRAY [0..SIZE] OF BOOLEAN; I,PRIME,K,COUNT,ITER : INTEGER; BEGIN WRITE('10 iterations, to start'); readln; FOR ITER := 1 TO 10 DO BEGIN COUNT := 0; FILLCHAR(FLAGS,SIZEOF(FLAGS),CHR(1)); FOR I := 0 TO SIZE DO IF FLAGS[I] THEN BEGIN PRIME := I+I+3; K := I + PRIME; WHILE K <= SIZE DO BEGIN FLAGS[K] := FALSE; K := K + PRIME END; COUNT := COUNT + 1; (* WRITELN(PRIME) *) END; END; WRITELN( chr ( 7 ),COUNT,' primes') END. ======================================================================================== DOCUMENT :usus Folder:VOL18:sort2.text ======================================================================================== PROGRAM Sort; TYPE lrec = RECORD stpart : STRING; lpart : ^lrec; END; VAR optr, tptr, first, ptr : ^lrec; ifile, ofile : TEXT; nlines,temp : INTEGER; added : BOOLEAN; space,key1,key2,key3 : STRING; infile, outfile : STRING[30]; b1,l1,o1,b2,l2,o2,b3,l3,o3 : INTEGER; FUNCTION Atrectoaddat : BOOLEAN; VAR intb : BOOLEAN; tkey1,tkey2,tkey3 : STRING; BEGIN WITH tptr^ DO BEGIN tkey1 := COPY(CONCAT(stpart,space),b1,l1); tkey2 := COPY(CONCAT(stpart,space),b2,l2); tkey3 := COPY(CONCAT(stpart,space),b3,l3); END; intb := FALSE; CASE (o1*4) + (o2*2) + o3 OF 0 : IF tkey1key3) THEN intb := TRUE; 2 : IF tkey1key2) THEN intb := TRUE ELSE IF (tkey1=key1) AND (tkey2=key2) AND (tkey3key2) THEN intb := TRUE ELSE IF (tkey1=key1) AND (tkey2=key2) AND (tkey3>key3) THEN intb := TRUE; 4 : IF tkey1>key1 THEN intb := TRUE ELSE IF (tkey1=key1) AND (tkey2key1 THEN intb := TRUE ELSE IF (tkey1=key1) AND (tkey2key3) THEN intb := TRUE; 6 : IF tkey1>key1 THEN intb := TRUE ELSE IF (tkey1=key1) AND (tkey2>key2) THEN intb := TRUE ELSE IF (tkey1=key1) AND (tkey2=key2) AND (tkey3key1 THEN intb := TRUE ELSE IF (tkey1=key1) AND (tkey2>key2) THEN intb := TRUE ELSE IF (tkey1=key1) AND (tkey2=key2) AND (tkey3>key3) THEN intb := TRUE; END; Atrectoaddat := intb; END; PROCEDURE Putinlinkedlist; BEGIN IF tptr<>first THEN BEGIN optr^.lpart := ptr; ptr^.lpart := tptr; END ELSE BEGIN ptr^.lpart := first; first := ptr; END; added := TRUE; END; PROCEDURE Getitandputitinlinkedlist; BEGIN NEW(ptr); READLN(ifile,ptr^.stpart); WITH ptr^ DO BEGIN key1 := COPY(CONCAT(stpart,space),b1,l1); key2 := COPY(CONCAT(stpart,space),b2,l2); key3 := COPY(CONCAT(stpart,space),b3,l3); END; tptr := first; optr := NIL; added := FALSE; WHILE (NOT added) AND (tptr<>NIL) DO IF Atrectoaddat THEN Putinlinkedlist ELSE BEGIN optr := tptr; tptr := tptr^.lpart; END; IF NOT added THEN BEGIN optr^.lpart := ptr; ptr^.lpart := NIL; END END; BEGIN first := NIL; WRITE('enter input file name ---->'); READLN(infile); WRITE('enter output file name --->'); READLN(outfile); RESET(ifile,infile); REWRITE(ofile,outfile); WRITELN; WRITELN; WRITELN('enter sort specification: '); WRITELN; WRITE('beginnig byte of sortkey 1 --->'); READLN(b1); WRITE('length of sortkey1 ----------->'); READLN(l1); WRITE('order (0=asc, 1=desc) -------->'); READLN(o1); WRITELN; WRITE('beginnig byte of sortkey 2 --->'); READLN(b2); WRITE('length of sortkey2 ----------->'); READLN(l2); WRITE('order (0=asc, 1=desc) -------->'); READLN(o2); WRITELN; WRITE('beginnig byte of sortkey 3 --->'); READLN(b3); WRITE('length of sortkey3 ----------->'); READLN(l3); WRITE('order (0=asc, 1=desc) -------->'); READLN(o3); WRITELN; WRITELN; WRITE('enter the number of lines for header info --->'); READLN(nlines); NEW(ptr); FOR temp := 1 TO nlines DO BEGIN READLN(ifile,ptr^.stpart); WRITELN(ofile,ptr^.stpart); END; READLN(ifile,ptr^.stpart); space := ''; FOR temp := 1 TO 8 DO space := CONCAT(space,' '); first := ptr; ptr^.lpart := NIL; WHILE NOT EOF(ifile) DO Getitandputitinlinkedlist; ptr := first; WHILE ptr <> NIL DO BEGIN WRITELN(ofile,ptr^.stpart); ptr := ptr^.lpart; END; CLOSE(ofile,lock); CLOSE(ifile); END. ======================================================================================== DOCUMENT :usus Folder:VOL18:sortunit.text ======================================================================================== UNIT Sortunit; INTERFACE VAR disk : FILE; PROCEDURE pSort( fname : STRING; recsiz,numrecs, pos1,len1,ord1, pos2,len2,ord2, pos3,len3,ord3 : INTEGER); IMPLEMENTATION PROCEDURE pSort; TYPE lptr = ^lrec; lrec = RECORD key1,key2,key3 : STRING[30]; recfrom : INTEGER; link : lptr; END; VAR linkedrec : lrec; first,ptr,tptr,hptr : lptr; currentblock,rectoaddto,recat,temp,rnum : INTEGER; heaptr : ^INTEGER; frecord,tfrecord : PACKED ARRAY[1..512] OF CHAR; tdblock : PACKED ARRAY[1..512] OF CHAR; ch : CHAR; PROCEDURE Getlogrec(recnumber : INTEGER); VAR temp1,temp2,posinblock : INTEGER; BEGIN WRITE('+'); temp := currentblock; currentblock := 0; temp1 := 0;temp2 := 0; WHILE temp1 < recnumber DO BEGIN temp2 := temp2 + recsiz; IF temp2 >= 512 THEN BEGIN currentblock := currentblock + 1; temp2 := temp2 - 512; END; temp1 := temp1 + 1; END; posinblock := temp2; IF temp<>currentblock THEN temp := BLOCKREAD(disk,tdblock,1,currentblock); IF posinblock + recsiz <= 512 THEN BEGIN FOR temp := 1 TO recsiz DO frecord[temp] := tdblock[posinblock+temp]; END ELSE BEGIN FOR temp := posinblock + 1 TO 512 DO frecord[temp-posinblock] := tdblock[temp]; currentblock := currentblock + 1; temp := BLOCKREAD(disk,tdblock,1,currentblock); FOR temp := 1 TO posinblock + recsiz - 512 DO frecord[temp+512-posinblock] := tdblock[temp]; END; END; PROCEDURE Putlogrec(recnumber: INTEGER); VAR temp1,temp2,posinblock : INTEGER; BEGIN WRITE('-'); temp := currentblock; currentblock := 0; temp1 := 0;temp2 := 0; WHILE temp1 < recnumber DO BEGIN temp2 := temp2 + recsiz; IF temp2 >= 512 THEN BEGIN currentblock := currentblock + 1; temp2 := temp2 - 512; END; temp1 := temp1 + 1; END; posinblock := temp2; IF temp<>currentblock THEN temp := BLOCKREAD(disk,tdblock,1,currentblock); IF posinblock + recsiz <= 512 THEN BEGIN FOR temp := 1 TO recsiz DO tdblock[posinblock+temp] := frecord[temp]; temp := BLOCKWRITE(disk,tdblock,1,currentblock); END ELSE BEGIN FOR temp := posinblock + 1 TO 512 DO tdblock[temp] := frecord[temp-posinblock]; temp := BLOCKWRITE(disk,tdblock,1,currentblock); currentblock := currentblock + 1; temp := BLOCKREAD(disk,tdblock,1,currentblock); FOR temp := 1 TO posinblock + recsiz - 512 DO tdblock[temp] := frecord[temp+512-posinblock] ; temp := BLOCKWRITE(disk,tdblock,1,currentblock); END; END; PROCEDURE Getkeys(recnumber : INTEGER); BEGIN Getlogrec(recnumber); NEW(ptr); WITH ptr^ DO BEGIN key1 := ''; key2 := ''; key3 := ''; FOR temp := 1 TO len1 DO BEGIN key1 := CONCAT(key1,' '); key1[temp] := frecord[pos1+temp]; END; FOR temp := 1 TO len2 DO BEGIN key2 := CONCAT(key2,' '); key2[temp] := frecord[pos2+temp]; END; FOR temp := 1 TO len3 DO BEGIN key3 := CONCAT(key3,' '); key3[temp] := frecord[pos3+temp]; END; recfrom := recnumber; END; END; FUNCTION Atrecbelowtheonetobeadded: BOOLEAN; VAR intb : BOOLEAN; BEGIN intb := FALSE; CASE (ord1*4) + (ord2*2) + ord3 OF 0 : IF ptr^.key1tptr^.key3) THEN intb := TRUE; 2 : IF ptr^.key1tptr^.key2) THEN intb := TRUE ELSE IF (ptr^.key1=tptr^.key1) AND (ptr^.key2=tptr^.key2) AND (ptr^.key3tptr^.key2) THEN intb := TRUE ELSE IF (ptr^.key1=tptr^.key1) AND (ptr^.key2=tptr^.key2) AND (ptr^.key3>tptr^.key3) THEN intb := TRUE; 4 : IF ptr^.key1>tptr^.key1 THEN intb := TRUE ELSE IF (ptr^.key1=tptr^.key1) AND (ptr^.key2tptr^.key1 THEN intb := TRUE ELSE IF (ptr^.key1=tptr^.key1) AND (ptr^.key2tptr^.key3) THEN intb := TRUE; 6 : IF ptr^.key1>tptr^.key1 THEN intb := TRUE ELSE IF (ptr^.key1=tptr^.key1) AND (ptr^.key2>tptr^.key2) THEN intb := TRUE ELSE IF (ptr^.key1=tptr^.key1) AND (ptr^.key2=tptr^.key2) AND (ptr^.key3tptr^.key1 THEN intb := TRUE ELSE IF (ptr^.key1=tptr^.key1) AND (ptr^.key2>tptr^.key2) THEN intb := TRUE ELSE IF (ptr^.key1=tptr^.key1) AND (ptr^.key2=tptr^.key2) AND (ptr^.key3>tptr^.key3) THEN intb := TRUE; END; Atrecbelowtheonetobeadded := intb; END; PROCEDURE Addtolinkedlist; VAR intb : BOOLEAN; BEGIN tptr := first; intb := TRUE; WHILE (tptr<>NIL) AND intb DO IF Atrecbelowtheonetobeadded THEN intb := FALSE ELSE BEGIN hptr := tptr; tptr := tptr^.link; END; ptr^.link := tptr; IF tptr = first THEN first := ptr ELSE hptr^.link := ptr; tptr := first; END; FUNCTION Inrightplace : BOOLEAN; VAR intb : BOOLEAN; BEGIN intb := TRUE ; IF ptr^.recfrom <> rectoaddto THEN intb := FALSE; Inrightplace := intb; END; PROCEDURE Puttptratlinkedrecthatwillgototemp(temp : INTEGER); VAR temp1 : INTEGER; BEGIN tptr := first; temp1 := 0; WHILE (tptr<>NIL) AND (temp1rectoaddto DO BEGIN Getlogrec(tptr^.recfrom); Putlogrec(temp); temp2 := tptr^.recfrom; tptr^.recfrom := temp; temp := temp2; Puttptratlinkedrecthatwillgototemp(temp); END; tptr^.recfrom := temp; frecord := tfrecord; Putlogrec(temp); END; BEGIN (* Sort *) numrecs := numrecs - 1; pos1 := pos1 - 1; pos2 := pos2 - 1; pos3 :=pos3 - 1; temp := 0; currentblock := 32700; RESET(disk,fname); MARK(heaptr); first := nil; FOR recat := 0 TO numrecs DO BEGIN Getkeys(recat); Addtolinkedlist; END; ptr := first; rectoaddto := 0; REPEAT IF NOT Inrightplace THEN Putinrightplace; ptr := ptr^.link; rectoaddto := rectoaddto + 1; UNTIL ptr=nil; RELEASE(Heaptr); CLOSE(disk,lock); END; END. ======================================================================================== DOCUMENT :usus Folder:VOL18:stars.text ======================================================================================== program stars; { This is a simple test of console I/O speed with the slowest I/O method, single character writes. 1000 characters are written to the console, each with a separate WRITE statement and its attendant system overhead. The actual time it takes to write the character to a serial port at 9600 baud is about 1 ms (0.5 ms for 19,200 baud) and the loop overhead time will be processor dependant, but usually between about 0.05 ms for a Sage to about 0.4 ms for an Apple. You will probably find that the time necessary to execute this test is much longer than you would expect. For example, the loop overhead of my LSI- 11/23 is 0.14 ms and the I/O overhead is 0.5 ms (19.2k baud). One would expect that the test would take 0.64 ms/loop to complete. Not so under IV.1, with extended memory the test takes 6.2 ms/loop! Without extended memory the test runs at 4 ms/loop. IV.0 takes 2.3 ms/loop. II.0 takes 1.5 ms/loop. Using the UNITWRITE, version II.0 takes 0.8 ms/loop, much closer to what you would expect as UNIT I/O has very little system overhead. Version IV.0 takes 0.9 ms/loop, and version IV.1 (with extended memory and probably memory management overhead) takes 1.6 ms/loop. IV.1 without extended memory takes 1.2 ms/loop (IV.1 is about 15% slower than IV.0 anyway). As you may find, different versions of software can affect I/O speed as much as different hardware! - gws } var i,j : integer; ch : packed array [ 0..1 ] of char; begin ch [ 0 ] := '*'; write ( chr ( 7 ) ); for i := 1 to 20 do begin for j := 1 to 49 do write ( '*' ) {unitwrite ( 1, ch [ 0 ], 1 )}; writeln; end; write ( chr ( 7 ) ); end. ======================================================================================== DOCUMENT :usus Folder:VOL18:tele.text ======================================================================================== PROGRAM Telephone; TYPE Telrec = RECORD date : STRING[6]; time : STRING[4]; wfrom: STRING[15]; whoto: STRING[15]; who : STRING[5]; mins : INTEGER; cost : REAL; mode : STRING[1]; END; VAR telfile : FILE OF Telrec; numrecs : INTEGER; ch : CHAR; PROCEDURE Clear; FORWARD; PROCEDURE Wnewnrecs; FORWARD; SEGMENT PROCEDURE Initfile; BEGIN Clear; WRITE('are you sure you wish to initialize the file?'); READ(ch); IF ch IN ['Y','y'] THEN BEGIN telfile^.whoto := '#2:'; telfile^.mins := 0; SEEK(telfile,0); PUT(telfile); numrecs := 0; END; END; SEGMENT PROCEDURE Sortfile; VAR temp1,temp2 : INTEGER; trec1,trec2 : telrec; FUNCTION Necessary: BOOLEAN; BEGIN IF (trec2.date>trec1.date) OR ((trec2.date=trec1.date) AND (trec2.time>trec1.time)) OR ((trec2.date=trec1.date) AND (trec2.time=trec1.time) AND (trec2.wfrom>trec1.wfrom)) OR ((trec2.date=trec1.date) AND (trec2.time=trec1.time) AND (trec2.wfrom=trec1.wfrom) AND (trec2.whoto>trec1.whoto)) THEN Necessary := TRUE ELSE Necessary := FALSE; END; BEGIN WRITELN; WRITE('Sorting '); FOR temp1 := 2 TO numrecs DO BEGIN WRITE('.'); SEEK(telfile,temp1); GET(telfile); trec1 := telfile^; temp2 := temp1 - 1; SEEK(telfile,temp2); GET(telfile); trec2 := telfile^; WHILE Necessary and (temp2>0) DO BEGIN telfile^ := trec2; SEEK(telfile,temp2 + 1); PUT(telfile); temp2 := temp2 - 1; IF temp2 > 0 THEN BEGIN SEEK(telfile,temp2); GET(telfile); trec2 := telfile^; END END; telfile^ := trec1; SEEK(telfile,temp2 + 1); PUT(telfile); END; END; SEGMENT PROCEDURE Add; BEGIN WITH telfile^ DO BEGIN Clear; {$I-} WRITELN('date (mmddyy) ---> <'); WRITELN('time (hh:mm) ---> <'); WRITELN('who from ---> <'); WRITELN('who to ---> <'); WRITELN('who ---> <'); WRITELN('number of mins -->'); WRITELN('cost --->'); WRITELN('mode ---> <'); GOTOXY(18,0); READLN(date); GOTOXY(18,1); READLN(time); GOTOXY(18,2); READLN(wfrom); GOTOXY(18,3); READLN(whoto); GOTOXY(18,4); READLN(who); GOTOXY(18,5); READLN(mins); GOTOXY(18,6); READLN(cost); GOTOXY(18,7); READLN(mode); {$I+} END; numrecs := numrecs + 1; SEEK(telfile,numrecs); PUT(telfile); Wnewnrecs; END; SEGMENT PROCEDURE Report; VAR ofname : STRING; ofile : TEXT; temp : INTEGER; mwild : STRING[1]; wwild : STRING[5]; dwild : STRING[6]; fwild,twild : STRING[15]; rmode : CHAR; total : REAL; PROCEDURE Getwilds; BEGIN Clear; WRITE('enter date wildcard --->'); READLN(dwild); WRITE('enter from# wildcard --->'); READLN(fwild); WRITE('enter to# wildcard --->'); READLN(twild); WRITE('enter initials wildcard --->'); READLN(wwild); WRITE('enter mode --->'); READLN(mwild); END; FUNCTION Wildok : BOOLEAN; VAR intb : BOOLEAN; temp : INTEGER; FUNCTION Min(a,b : INTEGER): INTEGER; BEGIN IF aLENGTH(wfrom)) OR (LENGTH(twild)>LENGTH(whoto)) OR (LENGTH(dwild)>LENGTH(date )) OR (LENGTH(wwild)>LENGTH(who )) OR (LENGTH(mwild)>LENGTH(mode )) THEN intb := FALSE; FOR temp := 1 TO Min(LENGTH(fwild),LENGTH(wfrom)) DO IF (fwild[temp]<>'?') AND (fwild[temp]<>wfrom[temp]) THEN intb := FALSE; FOR temp := 1 TO Min(LENGTH(twild),LENGTH(whoto)) DO IF (twild[temp]<>'?') AND (twild[temp]<>whoto[temp]) THEN intb := FALSE; FOR temp := 1 TO Min(LENGTH(dwild),LENGTH(date)) DO IF (dwild[temp]<>'?') AND (dwild[temp]<>date[temp]) THEN intb := FALSE; FOR temp := 1 TO Min(LENGTH(wwild),LENGTH(who)) DO IF (wwild[temp]<>'?') AND (wwild[temp]<>who[temp]) THEN intb := FALSE; IF (LENGTH(mwild)<>0) AND (mwild<>'?') AND (mwild<>mode) THEN intb := FALSE; END; Wildok := intb; END; BEGIN REPEAT Clear; WRITE('Report :: W)ildcard, A)ll, C)hangeoutputdevice ::'); READ(rmode); WRITELN; WRITELN; IF rmode IN ['C','c'] THEN BEGIN WRITE('enter new output device --->'); READLN(ofname); SEEK(telfile,0); GET(telfile); telfile^.whoto := ofname; SEEK(telfile,0); PUT(telfile); END; UNTIL NOT (rmode IN ['C','c']); SEEK(telfile,0); GET(telfile); ofname := telfile^.whoto; REWRITE(ofile,ofname); WRITELN; WRITELN; IF rmode IN ['W','w'] THEN BEGIN Getwilds; rmode := 'W'; END; total := 0; WRITE(ofile, ' # date time who from '); WRITELN(ofile,' who to chgto mins cost m'); WRITE(ofile, '----------------------------------------'); WRITELN(ofile,'---------------------------------'); {$I-} FOR temp := 1 TO numrecs DO BEGIN SEEK(telfile,temp); GET(telfile); IF ((rmode='W') AND Wildok) OR (rmode<>'W') THEN WITH telfile^ DO BEGIN WRITE(ofile,temp:4,' '); WRITE(ofile,date:6,' '); WRITE(ofile,time:4,' '); WRITE(ofile,wfrom:15,' '); WRITE(ofile,whoto:15,' '); WRITE(ofile,who :5,' '); WRITE(ofile,mins:6,' '); total := total + cost; WRITE(ofile,'$',cost:8:2,' '); WRITELN(ofile,mode); END; END; {$I+} WRITE(ofile,' '); WRITELN(ofile,' total cost - ',total:8:2); CLOSE(ofile,lock); IF ofname = '#2:' THEN BEGIN WRITE(' to continue --->'); READLN(keyboard); END; END; PROCEDURE Delete; VAR todelete,recat : INTEGER; BEGIN Clear; WRITE('enter record number to be deleted --->'); READLN(todelete); WRITE('are you sure you want to delete record #',todelete,'? '); READ(ch); IF (ch IN ['Y','y']) AND (todelete>0) AND (todelete<=numrecs) THEN BEGIN FOR recat := todelete TO numrecs-1 DO BEGIN SEEK(telfile,recat+1); GET(telfile); SEEK(telfile,recat); PUT(telfile); END; numrecs := numrecs - 1; Wnewnrecs; END; END; PROCEDURE Initprog; BEGIN {$I-} RESET(telfile,'Tele.data'); {$I+} IF IORESULT <> 0 THEN BEGIN REWRITE(telfile,'Tele.data'); Initfile; END; SEEK(telfile,0); GET(telfile); numrecs := telfile^.mins; END; PROCEDURE Clear; BEGIN gotoxy ( 0, 0 ); WRITE(CHR(27),chr ( 69 )); {H-19 specific} END; PROCEDURE Wnewnrecs; BEGIN SEEK(telfile,0); GET(telfile); telfile^.mins := numrecs; SEEK(telfile,0); PUT(telfile); END; BEGIN Initprog; REPEAT Clear; WRITE('Telephone :: I)nit, A)dd, D)elete, S)ort, R)eport, Q)uit ::'); READ(ch); CASE ch OF 'I','i' : Initfile; 'A','a' : Add; 'S','s' : Sortfile; 'R','r' : Report; 'D','d' : Delete; END; UNTIL ch IN ['Q','q']; CLOSE(telfile,lock); END. ======================================================================================== DOCUMENT :usus Folder:VOL18:vol18.doc.text ======================================================================================== USUS Volume 18 SEGMAP.1.TEXT 34 Arley Dealey's version independant segment mapper SEGMAP.2.TEXT 28 an include file of segmap ODMSCU.TEXT 10 One Damn More Screen Control Unit (for Segmap) LIFE.TEXT 32 The game of LIFE LIFE.INC.TEXT 8 an include file for LIFE BLACKBOX.TEXT 38 A guessing game based on particle physics BLACK.DOC1.TEXT 6 a help file for BLACKBOX BLACK.DOC2.TEXT 6 ditto TELE.TEXT 18 Keeps a data base of telephone traffic SORTUNIT.TEXT 18 A three-way key sort unit SORT2.TEXT 12 A sort program DEBUG.A.TEXT 22 The UCSD I.3 debugger DEBUG.B.TEXT 44 an include file of the debugger BENCHMARKS.TEXT 10 An overview of the benchmarks on this disk PWROF2.TEXT 8 A Pascal benchmark program 8QUEENS.TEXT 6 ditto NUMBERIO.TEXT 8 ditto ANCEST.S.TEXT 6 ditto PRIMES.TEXT 6 ditto QUICKSORT.TEXT 6 ditto QUR.TEXT 6 A simple benchmark to measure "system" speed STARS.TEXT 6 A simple I/O benchmark COMPKILLER.TEXT 6 A benchmark designed especially to crash your compiler WHETSTONE.TEXT 12 The famous WHETSTONE benchmark WHET.DOC.TEXT 16 Some notes on WHETSTONE, taken from MUSUS SIEVE.TEXT 8 The infamous Byte Benchmark, as standard as possible LONG_INT.TEXT 12 Tests long integer operations INTRINSICS.TEXT 18 Tests system intrinsics SEGMASHER.TEXT 8 A segment swap speed tester REPORT.DOC.TEXT 6 Some simple instructions for running the benchmarks REPORTFORM.TEXT 8 A form for recording the results of the benchmarks. BENCH.USUS.TEXT 26 Jon Bondy's benchmark ( again ) BONDY_FORM.TEXT 8 A form for recording the results of BENCH.USUS VOL18.DOC.TEXT 12 You're reading it ----------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 18 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Some notes from the editor: LIFE This is the game of LIFE submitted by Pat Horton. It will require some form of KEY_PRESS routine. There is one in there which should work on many IV.0 systems. I haven't as yet figured out the meaning of this game, but after one watches it for a while, one wonders what life is all about. TELE TELE, submitted by Pat Horton, keeps a database of telephone transactions. It probably takes longer to enter the data than to complete the conversion, but it is fun. SORTUNIT This is a three-key sort, submitted by Pat Horton. I haven't used it, but it compiles and seems to be alive. SORT2 A program version of SORTUNIT. DEBUG This is the UCSD Pascal version I.3 debugger. It is reputed to have problems, but is is also reputed to work. Although I haven't tried it, I am willing to bet that it will be fairly easy to convert it to run as a separate program under any version of the p-system. BLACKBOX Blackbox is a game that simulates the work of a nuclear physicist. The player fires rays into an unknown 8 * 8 grid. The resultant interaction of the rays with the contents of the 8 * 8 grid allows deduction of its contents. SEGMAP Segmap displays a report the the contents of ANY UCSD segment from ANY version of the p-system. If you are having troubles and want to determine what's REALLY in that questionable segment, this will tell you. THE BENCHMARK PACKAGE There are several benchmark programs on this disk. These are intended to determine how fast a particular computer/software combo is in relation to others for reasonable "real-life" type computer tasks. Refer to the file BENCHMARKS.TEXT for more info. ======================================================================================== DOCUMENT :usus Folder:VOL18:whet.doc.text ======================================================================================== ****************************************************************************** #: 8590 Sec. 1 - Members Sb: Whetstone and Apple II 02-Oct-82 10:35:42 Fm: Keith McLaurin 71505,2035 To: Roger Peterson Roger, I compiled and ran the whetstone on an Apple II with Apple Pascal 1.1. The results are below. I added a time instruction to relate the time spent in the program initialized after the readln(I) and all times are relative to that point. The input/output to the screen and the disk file adds about 15 seconds. I added looping constructs to call each routine to allow running the program for more than 1 million (I=10) to reduce the I/O percentage and improve the 1 second resolution of the clock. To compile, I had to enable the goto compiler option, add Uses Transcend, and change ARCTAN to ATAN. I also ran it for IV.0... no Uses Transcend needed for iv.0 . Whetstone I = 10; Range Checking on. T: 0 MODULE 1 0 0 0 1.000 -1.000 -1.000 -1.000 T: 7 MODULE 2 120 140 120 -0.068 -0.463 -0.730 -1.124 T: 46 MODULE 3 140 120 120 -0.055 -0.447 -0.711 -1.103 T: 55 MODULE 4 3450 1 1 1.000 -1.000 -1.000 -1.000 T: 84 MODULE 6 2100 1 2 6.000 6.000 -0.711 -1.103 T: 231 MODULE 7 320 1 2 0.492 0.492 0.492 0.492 T: 355 MODULE 8 8990 1 2 1.000 1.000 1.000 1.000 T: 421 MODULE 9 6160 1 2 3.000 2.000 3.000 -1.103 T: 423 MODULE 10 0 2 3 1.000 -1.000 -1.000 -1.000 T: 515 MODULE 11 930 2 3 0.835 0.835 0.835 0.835 Apple Pascal 1.1 Apple Pascal 1.1 Apple Pascal 1.1 IV.0 - Apple Weight 1 million . Weight 100 Million . Weight 1 Million . Weight 1 Million (range chkg off) (range chkg on) (range chkg on) (range chkg on) T: 0 MODULE 1 T: 1 MODULE 1 T: 0 MODULE 1 T: 0 MODULE 1 T: 6 MODULE 2 T: 534 MODULE 2 T: 7 MODULE 2 T: 6 MODULE 2 T: 42 MODULE 3 T: 4269 MODULE 3 T: 46 MODULE 3 T: 41 MODULE 3 T: 52 MODULE 4 T: 5063 MODULE 4 T: 55 MODULE 4 T: 50 MODULE 4 T: 80 MODULE 6 T: 7826 MODULE 6 T: 84 MODULE 6 T: 75 MODULE 6 T: 226 MODULE 7 T: 22302 MODULE 7 T: 231 MODULE 7 T: 219 MODULE 7 T: 350 MODULE 8 T: 34553 MODULE 8 T: 355 MODULE 8 T: 342 MODULE 8 T: 410 MODULE 9 T: 40961 MODULE 9 T: 421 MODULE 9 T: 400 MODULE 9 T: 412 MODULE 10 T: 40962 MODULE 10 T: 423 MODULE 10 T: 401 MODULE 10 T: 504 MODULE 11 T: 50078 MODULE 11 T: 515 MODULE 11 T: 493 MODULE 11 Comments: Module 1 -- Simple identifiers, assignments Module 2 -- Array Elements Module 3 -- Array as Parameter Module 4 -- Conditional Jumps Module 5 -- Omitted ?? Why and What ?? Module 6 -- Integer (Array) arithmetic Module 7 -- Trig Functions Module 8 -- Procedure Calls Module 9 -- Array References Module 10 - Integer Arithmetic Module 11 - Standard Math Functions IV.0 is faster in excution than Apple Pascal 1.1. The time spent in any Module is calculated by subtracting the T: value above the module. e.g. time in module 11 is 50078 - 40962 = 9116 seconds. The values were calculated as long integers. - keith mclaurin ****************************************************************************** MODULE 5 was also omitted in the original reference. There was no reason given, nor any explanation of its original purpose. -Roger Peterson ****************************************************************************** #: 8732 Sec. 1 - Members Sb: #8685-Whetstone cont. Fm: Keith McLaurin 71505,2035 To: Roger Peterson 71565,411 Roger, I looked up the reference you listed for 'The Computer Journal' Volume 19, #1 p. 43-49 and see that Module 5 is ommited in the Appendix with no explanation as to why. So please disreguard my earlier question. The source file I downloaded from the MUSUS data base WHET.PAS has one very minor typo in MODULE 4. The conditional statement J<1 should read J<2. This has little impact on program execution time on the Apple II. I replaced the Var Temp in MODULE 7 with the source to match the Algol listing and the execution time of that module increased about 20%. The use of Temp variable optimizes the source sincethe Temp expression is evaluated only once in a pass rather than twice when it is in the denominator. Essentially equivalent times are obtained when the Temp expression is evaluated twice. I have often heard of 'Whetstones' and often wondered what they specifically were. The Whetstone program is a benchmark for evaluating scientific type programs based on analysis of about 1000 programs for frequencies of operations. The term 'Whetstones per second' is calculated by I * 100,000 / (Program execution in seconds). Thanks for sharing this program with the USUS group. -keith mclaurin ****************************************************************************** The temporary variable, TEMP, in MODULE 7 was added for the OMSI compiler. OMSI Pascal (versions 1.1 and really do NOT use the stack properly and thus have severe limits on nesting of expressions (especially floating point calculations). This is not a limitation in UCSD. I suggest that the original source of WHET.PAS be changed to read BEGIN TEMP:= COS(X+Y)+COS(X-Y)-1.0; X:=T*ATAN(T2*SIN(X)*COS(X)/TEMP); (* USE ARCTAN FOR OMSI *) TEMP:=COS(X+Y)+COS(X-Y)-1.0; Y:=T*ATAN(T2*SIN(Y)*COS(Y)/TEMP) END; Now the only difference from the original is that it has two additional floating point store and retrieve operations. -Roger Peterson ****************************************************************************** ======================================================================================== DOCUMENT :usus Folder:VOL18:whetstone.text ======================================================================================== (*$R-*) (*WHETSTONE BENCHMARK - - DIRECT TRANSLITERATION OF THE ORIGINAL ALGOL PROGRAM FROM: "A SYNTHETIC BENCKMARK" BY H. J. CURNOW & B. A. WICHMANN 'THE COMPUTER JOURNAL' VOL 19, NO. *) (*$G+*) (* TURN ON 'GOTO' -- FOR UCSD COMPILER *) (* UGLY, BUT THAT'S THE WAY IT WAS IN THE ORIGINAL VERSION *) PROGRAM WHETSTONE; CONST T=0.499975; T1=0.50025; T2=2.0; TYPE ARGARRAY = ARRAY[1..4] OF REAL; VAR E1 : ARRAY[1..4] OF REAL; X,Y,Z,X1,X2,X3,X4 : REAL; MODULE,I,J,K,L,N1,N2,N3,N4,N5,N6,N7,N8,N9,N10,N11 : INTEGER; PROCEDURE PA(VAR E:ARGARRAY); LABEL 1; VAR J : INTEGER; BEGIN J:=0; 1: E[1]:=(E[1]+E[2]+E[3]-E[4])*T; E[2]:=(E[1]+E[2]-E[3]+E[4])*T; E[3]:=(E[1]-E[2]+E[3]+E[4])*T; E[4]:=(-E[1]+E[2]+E[3]+E[4])/T2; J:=J+1; IF J<6 THEN GOTO 1 END; (* PROCEDURE PA*) PROCEDURE P0; BEGIN E1[J]:=E1[K]; E1[K]:=E1[L]; E1[L]:=E1[J] END; (* PROCEDURE P0 *) PROCEDURE P3(X,Y:REAL;VAR Z:REAL); BEGIN X:=T*(X+Y); Y:=T*(X+Y); Z:=(X+Y)/T2 END; (* PROCEDURE P3 *) PROCEDURE MODULE1; (* MODULE 1: SIMPLE IDENTIFIERS *) BEGIN X1:=1.0; X2:=-1.0; X3:=-1.0; X4:=-1.0; FOR I:=1 TO N1 DO BEGIN X1:=(X1+X2+X3-X4)*T; X2:=(X1+X2-X3+X4)*T; X3:=(X1-X2+X3+X4)*T; X4:=(-X1+X2+X3+X4)*T END; END; (* MODULE 1 *) PROCEDURE MODULE2; (* MODULE 2: ARRAY ELEMENTS *) BEGIN E1[1]:=1.0; E1[2]:=-1.0; E1[3]:=-1.0; E1[4]:=-1.0; FOR I:=1 TO N2 DO BEGIN E1[1]:=(E1[1]+E1[2]+E1[3]-E1[4])*T; E1[2]:=(E1[1]+E1[2]-E1[3]+E1[4])*T; E1[3]:=(E1[1]-E1[2]+E1[3]+E1[4])*T; E1[4]:=(-E1[1]+E1[2]+E1[3]+E1[4])*T END; END; (* MODULE 2 *) PROCEDURE MODULE4; (* MODULE 4: CONDITIONAL JUMPS *) BEGIN J:=1; FOR I:=1 TO N4 DO BEGIN IF J=1 THEN J:=2 ELSE J:=3; IF J>1 THEN J:=0 ELSE J:=1; IF J<2 THEN J:=1 ELSE J:=0 END; END; (* MODULE 4 *) PROCEDURE MODULE6; (* INTEGER ARITHMETIC *) BEGIN J:=1; K:=2; L:=3; FOR I:= 1 TO N6 DO BEGIN J:=J*(K-J)*(L-K); K:=L*K-(L-J)*K; L:=(L-K)*K+J; E1[L-1]:=J+K+L; E1[K-1]:=J*K*L END; END; (* MODULE 6 *) PROCEDURE MODULE7; (* MODULE 7: TRIG FUNCTIONS *) VAR TEMP : REAL; BEGIN X:=0.5; Y:=0.5; FOR I:=1 TO N7 DO BEGIN TEMP:=COS(X+Y)+COS(X-Y)-1.0; X:=T*ATAN(T2*SIN(X)*COS(X)/TEMP); (*USE ARCTAN FORM OMSI*) TEMP:=COS(X+Y)+COS(X-Y)-1.0; Y:=T*ATAN(T2*SIN(Y)*COS(Y)/TEMP); END; END; (* MODULE 7 *) PROCEDURE MODULE8; (* MODULE 8: PROCEDURE CALLS *) BEGIN X:=1.0; Y:=1.0; Z:=1.0; FOR I:=1 TO N8 DO P3(X,Y,Z) END; (* MODULE 8 *) PROCEDURE MODULE10; (* MODULE 10: INTEGER ARTIHMETIC *) BEGIN J:=2; K:=3; FOR I:=1 TO N10 DO BEGIN J:=J+K; K:=J+K; J:=K-J; K:=K-J-J END; END; (* MODULE 10 *) PROCEDURE MODULE11; (* MODULE 11: STANDARD FUNCTIONS *) BEGIN X:=0.75; FOR I:=1 TO N11 DO X:=SQRT(EXP(LN(X)/T1)); END; (* MODULE 11 *) PROCEDURE POUT(VAR N,J,K:INTEGER; VAR X1,X2,X3,X4:REAL); BEGIN WRITE('MODULE ',MODULE:2,N:5,J:5,K:5); WRITELN(X1:12:3,X2:12:3,X3:12:3,X4:12:3); END; (* PROCEDURE POUT *) BEGIN (* START WHETSTONE *) (* READ VALUE OF I, CONTROLLING TOTAL WEIGHT: IF I=10, THE TOTAL WEIGHT IS ONE MILLION WHETSTONE INSTRUCTIONS *); WRITELN; WRITE ('WEIGHTING FACTOR I = '); READLN(I); WRITELN; N1:=0; N2:=12*I; N3:=14*I; N4:=345*I; N5:=0; N6:=210*I; N7:=32*I; N8:=899*I; N9:=616*I; N10:=0; N11:=93*I; (* MODULAR PROGRAMMING IS USED TO REDUCE THE LENGTH OF MAIN CODE *) MODULE1; (* SIMPLE IDENTIFIERS *) MODULE:=1; POUT(N1,N1,N1,X1,X2,X3,X4); MODULE2; (* ARRAY ELEMENTS *) MODULE:=2; POUT(N2,N3,N2,E1[1],E1[2],E1[3],E1[4]); (* MODULE 3: ARRAY AS A PARAMETER *) FOR I:= 1 TO N3 DO PA(E1); MODULE:=3; POUT(N3,N2,N2,E1[1],E1[2],E1[3],E1[4]); (* END OF MODULE 3 *) MODULE4; (* CONDITIONAL JUMPS *) MODULE:=4; POUT(N4,J,J,X1,X2,X3,X4); WRITELN('MODULE 5 OMITTED '); MODULE6; (* INTEGER ARITHMETIC *) MODULE:=6; POUT(N6,J,K,E1[1],E1[2],E1[3],E1[4]); MODULE7; (* TRIG FUNCTIONS *) MODULE:=7; POUT(N7,J,K,X,X,Y,Y); MODULE8; (* PROCEDURE CALLS *) MODULE:=8; POUT(N8,J,K,X,Y,Z,Z); (* MODULE 9: ARRAY REFERENCES *) J:=1; K:=2; L:=3; E1[1]:=1.0; E1[2]:=2.0; E1[3]:=3.0; FOR I:=1 TO N9 DO P0; MODULE:=9; POUT(N9,J,K,E1[1],E1[2],E1[3],E1[4]); MODULE10; (* INTEGER ARITHMETIC *) MODULE:=10; POUT(N10,J,K,X1,X2,X3,X4); MODULE11; (* STANDARD FUNCTIONS *) MODULE:=11; POUT(N11,J,K,X,X,X,X); WRITELN('END OF WHETSTONE') END. (* END WHETSTONE *) ======================================================================================== DOCUMENT :usus Folder:VOL19:2k.key.text ======================================================================================== The 2K Key There is a ROM available from E&H Systems which replaces the H-27 boot ROM and allows you to obtain an extra 2K words (4k bytes) of RAM if your memory board can support a 2K word I/O page in addition to the standard 4K I/O page. The ROM moves boot and diagnostic code from below address 170000 (octal) to above 170000. If you have no other I/O devices which respond to address between 160000 and 167777 then this ROM can considerably help you, especially if you use version IV.0. The ROM uses a different boot procedure than the standard Heath ROM. Instead of letting you specify the device to boot, it tries to boot any bootable device on line. This allows the system to boot automatically on power-up with no console microcode necessary. This feature is neat in some circumstances and a pain in the a** in others. The ROM first tries to boot DL0..4: (RL01). If it doesn't find an RL01 it tries DK0..7: (RK05). If that fails it tries DX0..1: (RX01) and then DY0..1: (RX02). If all of the boots fail, it starts over at RL01. This sequence can cause problems. When the ROM tries to boot any of the four devices, it first looks at unit 0 of the device and then tries unit 1 and so on. This means that if, for example, DK0: and DK1: are both bootable, the ROM will always boot DK0 and never even try DK1:. To boot DK1: or higher, you will must (as I do) enter the DMA bootstrap instructions by hand into console microcode. Also if your hard disk and floppy come on with the same power switch, and you want to boot floppy, you had better plug in the floppy before you hard disk controller signals that it is ready or the system will boot the hard disk. Then in order to boot your floppy, you will have to enter the console microcode instructions (about 30 of them) by hand, or turn your hard disk off and start over. There ain't no free lunch. There is also a problem with the software bootstrap compatibility and the 2K key, but it can be easily fixed with a simple object patch to the bootstrap. When the LSI-11 processor generates an address above 160000, it also asserts bus line BBS7. This tells all I/O devices to decode the lower 13 bits of the address so the one being address can respond. I/O devices look at line BBS7 instead of the high order 3 bits (or 5 bits in the case of the 11/23). Memory on the bus also looks at line BBS7 except that to memory it means ignore this address. However, some memory boards such as the Mostek, Chrislin, Monolithic Memories and others allow a trick to occur. The standard Heath 16K boards and all standard DEC boards do not allow this special trick. When a switch or jumper on the memory board is properly set, the memory board will not ignore addresses between 160000 and 167777 when BBS7 is asserted. It will ignore address above 170000 if BBS7 is asserted. If BBS7 is asserted by the CPU and no I/O device responds to an address in the range of 160000 to 167777, then no address conflict occurs and memory can legally respond. So this "extra" address space, 2K words of it, can be reclaimed for system memory. There is a hitch however. The p-system boot code (located in block 0 of your system disk) sometimes does not allow the processor to access the memory which you have so carefully made free. This is because it only looks up to 157777 to find the top of memory, as it does not expect to find any in the I/O page. The version II.0 RX01 interpreter handles the memory sizing properly and the 2K Key works fine, but none of the other software bootstraps that I have tested do. There is a patch which is simple to do. You must use PATCH to view block 0 of your system disk (use a copy in case you screw it up). You must change a word which indicates to highest memory to search from 160000 (octal) to 170000. The byte flipped hex pattern which you are looking for is 00E0 and you want to change it to 00F0. The byte offsets (decimal per the PATCH display) are shown below for some of the p-system bootstraps. version II.0 RK05 offset 282 version IV.0 RK05 offset 282 version IV.0 RX01 offset 446 If you want to patch some other bootstrap such as RL01 or RX02, you will have to look through every word to find the appropriate pattern and change it. If your system won't boot, you found the wrong place. You should write a simple program BEFORE you make the change to display the available memory to see if you really got 2048 more words. program memtest; begin writeln; write ( memavail ); end. regards - gws ======================================================================================== DOCUMENT :usus Folder:VOL19:booter.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL19:dec.index.text ======================================================================================== USUS Library DEC specific Index The following is an index of the DEC specific programs which are already in the USUS Library. Volume #2A PUNCH.TAPE.TEXT These programs allow you to use your H-10 paper tape READ.TAPE.TEXT punch. SMARTREMOT.TEXT This is a terminal emulator which is very DEC specific. It is also H-19 (VT-52) specific. An improved version is found on Volume 15. Volume #5 FMT.2.0.CODE A code file of a fair text formatter. It works on DEC iron, but on nothing else. Source is N/A. SP.TEXT This is a utility needed to do underlining and boldface with FMT. It has a DEC specific routine to output a CR without a LF, but an easier way is just to send chr ( 141 ). Volume #8 MODEMV2.2.TEXT The worlds simplest terminal emulator. Requires UNITBUSY so it is DEC specific. Volume #15 SMARTREMOT.TEXT The reworked version of the terminal emulator on #2A. Requires an H-19 also. IOUNIT.TEXT A unit used by SMARTREMOT. It is a bunch of declarations which allow one to easily access hardware buffer for I/O dev devices. REMUNIT.L3.TEXT A DEC specific USUS Standard remote unit. CLR_BREAK.TEXT an external procedure for REMUNIT.L3 SET_BREAK.TEXT ditto ======================================================================================== DOCUMENT :usus Folder:VOL19:eis.text ======================================================================================== EIS=1 ======================================================================================== DOCUMENT :usus Folder:VOL19:lp11.text ======================================================================================== .TITLE LP-11 PRINTER HANDLER ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; SYSTEM TABLE CONTENTS ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; .ASECT ; INTERRUPT HANDLER LOCATION IN VECTORS .=200 LP$INT 200 .CSECT TABLES .BLKW 128. ; OPERATOR XFER TABLE .REPT 6 .BLKW 3 .ENDR .WORD OUTBIT,LPSTRT,LPABRT .PAGE .CSECT LPDRVR ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; PRINTER OUTPUT HANDLER ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; LPUNIT: .WORD 0 LPBUFA: .WORD LPLENG: .WORD LP.COL: .WORD 0 LPCSR: .WORD 177514 LPBUF: .WORD 177516 LPOFST = 4 LPSTRT: ; THIS CODE STARTS IO'S TO THE PRINTER DEVICE TST LPUNIT ; SEE IF AN IO ALREADY IN PROGRESS BNE LPSTRT ; IF SO LOOP UNTIL THE IO IS COMPLETE MTPS #200 ; NO INTERRUPTS PLEASE MOV R1,LPUNIT ; MARK HANDLER AS BUSY BIS #BSYBIT,(R1) ; MARK LOGICAL UNIT AS BUSY CLR (SP) ; SET UP RETURN STUFF ON STACK...PR-0 PS TST (R3)+ ; SKIP R3 OVER IO INFO WORD MOV R3,-(SP) ; NOW THE RETURN ADDRESS MOV (SP),LPBUFA ; GRAB USER BUFFER ADDR MOV (SP),LPLENG ; AND REQUESTED IO LENGTH LP$INT: BIC #100,@LPCSR ; DISABLE INTERRUPTS TST LPUNIT ; ANY IO'S IN PROGRESS BEQ LPEXIT ; IF NOT JUST FORGET IT TST LPLENG ; ANY CHARS LEFT TO BE SENT? BEQ LPQUIT ; IF NOT THEN FINISH UP IO MOV R0,-(SP) ; STASH REG CLR R0 BISB @LPBUFA,R0 ; GRAB CHAR FROM USER BUFFER BEQ 3$ ; A NULL? RESET TABS STOPS CMPB R0,#FF ; FORM - FEED? BEQ 3$ CMPB R0,#HT BNE 4$ JSR PC,LPTABR 4$: INC LP.COL CMPB R0,#CR ; AN END-OF-LINE CHAR? BNE 1$ MOVB #LF,R0 ; MAKE A PRINTRONIX EOL BR 3$ 1$: CMPB R0,#21 ; A DC1?? (USED TO DO UNDERLINING) BNE 2$ MOVB #CR,R0 ; MAKE A CR FOR PRINTRONIX BENEFIT 3$: CLR LP.COL 2$: TST @LPCSR ; TEST ERROR BIT BMI 2$ ; AND HANG TIL READY MOVB R0,@LPBUF ; SEND CHAR TO DL MOV (SP)+,R0 ; RESTORE TEMP REG BIS #100,@LPCSR ; ALLOW INTERRUPT INC LPBUFA ; BUMP BUFFER POINTER TO NEXT CHAR DEC LPLENG ; ALSO REFLECT ONE FEWER CHAR TO SEND JMP @#INTRTN ; THIS STRUCTURE IMPLIES AN IO IS NOT ; DONE UNTIL THE LAST INTERRUPT IS RECEIVED LPQUIT: BIC #BSYBIT,@LPUNIT ; CLEAR BUSY BIT IN IO UNIT TABLE CLR LPUNIT ; MARK HANDLER AS NOT BUSY NOW LPEXIT: JMP INTRTN ; AND BACK NOW TO WHEREVER LPTABR: ; LITTLE SUBROUTINE TO TAB MOV R1,-(SP) MOV #' ,R0 MOV LP.COL,R1 BIS #7,LP.COL SUB LP.COL,R1 BEQ 3$ 1$: MOVB R0,@LPBUF 2$: TSTB @LPCSR BPL 2$ INC R1 BNE 1$ 3$: MOV (SP)+,R1 RTS PC LPABRT: MTPS #200 TST LPUNIT BEQ 1$ BIC #BSYBIT,@LPUNIT CLR LPUNIT 1$: MTPS #0 RTS PC .END ======================================================================================== DOCUMENT :usus Folder:VOL19:macros.text ======================================================================================== .NLIST .NLIST CND .NLIST TTM .LIST ;************************************************; ;* *; ;* UCSD PASCAL INTERPRETER FOR PDP-11'S *; ;* *; ;* WRITTEN BY ROGER T. SUMNER *; ;* AND MARK OVERGAARD, 1977 *; ;* *; ;* INSTITUTE FOR INFORMATION SYSTEMS *; ;* UC SAN DIEGO, LA JOLLA, CA *; ;* *; ;* KENNETH L. BOWLES, DIRECTOR *; ;* *; ;* THIS SOFTWARE IS THE PROPERTY OF THE *; ;* REGENTS OF THE UNIVERSITY OF CALIFORNIA. *; ;* *; ;************************************************; .NLIST PC=%7 ;PDP-11 PROGRAM COUNTER SP=%6 ;PDP-11 AND P-11 STACK POINTER IPC=%4 ;P-11 PROGRAM COUNTER MP=%5 ;BASE OF LOCAL DATA SEGMENT BASE=%3 ;BASE OF GLOBAL DATA SEG BK=%2 ;USED TO GET TO BACK FOR NEXT OPCODE FETCH MAXUNT = 8. ; MAX LEGAL UNIT # IN SYSTEM MAXSEG = 15. ; MAX SEGMENT NUMBER ALLOWED NP = 50 ; INITIAL HEAP TOP...SET BY LINKER MAGICALLY .IF DF,TERAK LSI=1 EIS=1 FPI=1 .GLOBL DRAWLINE,DRAWBLOCK .ENDC .IF NDF,FPI .GLOBL $ADR,$SBR,$MLR,$DVR,$CMR .ENDC .GLOBL HLTLIN,BRKPTS,BUGSTA .GLOBL $IR,$RI,ALOG,ALOG10,EXP,SIN,COS,ATAN,SQRT .GLOBL ENTFP,XITFP,LOTIME,HITIME .GLOBL MEMTOP,CRTNFO,GDIRP,INTRTN .GLOBL BACK,SYIORQ,SYSUNT,DIV,MLI,STKBAS,IORSLT .GLOBL JTAB,SEGTBL,LASTMP,SEG,UNITBL,BITTER BLANK=40 BLANKS=20040 ;TWO ASCII BLNKS BS=10 ;BACKSPACE CR=15 LF=12 HT=11 EM=31 FS=34 US=37 FF=14 GS=35 VT=13 RS=36 DC1=21 DC2=22 ; TRAP PARAMETERS ( >=0 ARE EXECERR, <0 ARE SYSTEM REQUESTS) SYSERR=0 INVNDX=1 NOPROC=2 NOEXIT=3 STKOVR=4 INTOVR=5 DIVZER=6 BADMEM=7 UBREAK=10 SYIOER=11 UIOERR=12 NOTIMP=13 FPIERR=14 S2LONG=15 HLTBPT=16 BRKPNT=17 TTXREQ=-1 NIL = 1 ;;;; CODE SEGMENT FORMAT DEFINES ; R@JTAB IS PROC# (LOW BYTE) AND LL (HIGH BYTE) ENTRIC = -2 ; JTAB INDEX OF ENTRY OFFSET EXITIC = -4 ; " " " EXIT POINT PARMSZ = -6 ; " " " # WORDS OF PARAMS TO COPY AT ENTRY TIME DATASZ = -10 ; " " " # WORDS TO OPEN IN STACK ;;;; MARK STACK CONTROL WORD FORMAT ; THESE OFFSETS ARE RELATIVE TO THE STAT LINK WORD! MSSTAT = 0 ; STATIC LINK...POINTS TO PARENTS STAT LINK MSDYN = 2 ; DYNAMIC LINK...POINTS TO CALLERS STAT LINK MSIPC = 10 ; ABSOLUTE MEM ADDR OF NEXT OPCODE IN CALLER MSSEG = 6 ; " " " OF SEG TABLE OF CALLER (LIKELY = SEG) MSJTAB = 4 ; " " " OF CALLER JTAB (PROCEDURE CODE INFO ETC) MSSP = 12 ; VALUE TO SET SP TO UPON EXIT MSBASE = -2 ; BASE REG...ONLY IN BASE MSCW'S MSDLTA = 12 ; SIZE OF MSCW - 2 ;;;; IO SUBSYSTEM STUFF ; BIT FIELDS IN UNITBL ; IO RESULTS GIVEN BY IO ROUTINES PARERR = 1 UNTERR = 2 MODERR = 3 INBIT = 20000 OUTBIT = 40000 BSYBIT = 100000 UNOWAIT = 0 UBLOCK = 2 URLENG = 4 UBUFFR = 6 UUNIT = 10 .MACRO GETNEXT STUFF .IF B, MOVB (IPC)+,R0 ;GET A BYTE FROM CODE .IFF MOVB (IPC)+,STUFF ;AND PUT IT IN R0 OR .ENDC ;IN STUFF IF STUFF I S NON-BLANK .ENDM GETNEXT .MACRO GETBYTE STUFF .IF B, CLR R0 BISB (IPC)+,R0 .IFF CLR STUFF BISB (IPC)+,STUFF .ENDC .ENDM GETBYTE .MACRO GETBIG STUFF,?NOTBIG .IF B, GETNEXT BPL NOTBIG BIC #SIGNWIPE,R0 SWAB R0 BISB (IPC)+,R0 .IFF GETNEXT STUFF BPL NOTBIG BIC #SIGNWIPE,STUFF SWAB STUFF BISB (IPC)+,STUFF .ENDC NOTBIG: .ENDM GETBIG R0=%0 ; DEFINE WORKING REGISTERS R1=%1 R2=%2 R3=%3 R4=%4 R5=%5 .MACRO MORE MOV BK,PC ;SET PC TO BACK LABEL ADDR .ENDM MORE .MACRO WORDBOUND INC IPC ;BUMP IPC BIC #1,IPC ;THEN ROUND .ENDM WORDBOUND SIGNWIPE=177600 CLREXT=177400 .IF NDF,LSI .MACRO MTPS NEWPS,?L MOV NEWPS,-(SP) MOV #L,-(SP) RTI L: .ENDM MTPS .IF NDF,EIS .MACRO SOB REG,LABEL DEC REG ; THIS IS AN SOB OPERATOR BNE LABEL ; AS IN LSI-11 OR 11-40 .ENDM SOB .ENDC .ENDC .MACRO .TTYOUT .CHAR .IIF NB,<.CHAR>, MOVB .CHAR,R0 TRAP TTXREQ .ENDM .TTYOUT .MACRO UREAD UNIT,BUFR,LENG,BLOCK MOV UNIT,-(SP) MOV BUFR,-(SP) MOV LENG,-(SP) MOV BLOCK,-(SP) CLR -(SP) JSR R1,SYIORQ .WORD 1 .ENDM UREAD .LIST ======================================================================================== DOCUMENT :usus Folder:VOL19:mainop.text ======================================================================================== .TITLE MAIN OPERATORS .CSECT MAINOP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; MAIN OPERATORS ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; FIRST ARE THE SHORT FORM LDL,LDO, AND IND OPS. ; THESE ARE THE MOST COMMON OPS (EXCEPT LDCI) AND RUN ; VERY FAST. EACH DISP VALUE FOR THESE IS A NEW OPCODE ; SHORT LOCAL LOADS...16 OF THEM SLDLS: .IRP N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20> MOV +MSDLTA(MP),-(SP) BR BACK .ENDR ; SHORT LOAD GLOBALS...16 OF THEM SLDOS: .IRP N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20> MOV +MSDLTA(BASE),-(SP) BR BACK .ENDR ; SHORT IND OPS...8 OF THEM SINDS: MOV @(SP)+,-(SP) BR BACK .BLKW 2 ; FUNNY BUSINESS FOR EXTRA FAST IND 0 .IRP N,<1,2,3,4,5,6,7> ADD #,@SP MOV @(SP)+,-(SP) BR BACK .ENDR .PAGE ;;;;;;;;;;;;;;;;;;;;;;; ; MAIN INTERPRETER LOOP ; GO HERE FOR OPCODE ; FETCH SEQUENCE ;;;;;;;;;;;;;;;;;;;;;;;; SLDCI: MOV R0,-(SP) ; PUSH THE LIT VALUE AND FALL INTO NEXT OP BACK: GETNEXT ; GET NEXT INSTRUCTION BYTE BPL SLDCI ; IF POSITIVE THEN A SHORT LDCI ASL R0 ; DOUBLE FOR WORD INDEXING MOV XFRTBL(R0),PC ; TRANSFER CONTROL TO PROPER OP ABI: ; INTEGER ABSOLUTE VALUE TST @SP BPL 1$ NEG @SP BPL 1$ CLR @SP 1$: MORE ABR: ; REAL ABSOLUTE VALUE BIC #100000,@SP MORE ADI: ; ADD INTEGER ADD (SP)+,@SP MORE ADR: ; ADD REAL .IF DF,FPI FADD SP MORE .IFF JSR R4,ENTFP .WORD $ADR,XITFP .ENDC AND: ; LOGICAL AND COM @SP BIC (SP)+,@SP MORE BPT: ; CONDITIONAL HALT (BREAKPOINT) GETBIG ; LINE IN LIST FILE MOV R0,HLTLIN CMP BUGSTA,#3 BGE BPTTRP ; NOT IN STEPPING MODE, SO SEE IF MATCHES A BREAKPOINT MOV #BRKPTS,R1 CMP (R1)+,R0 BEQ BPTTRP CMP (R1)+,R0 BEQ BPTTRP CMP (R1)+,R0 BEQ BPTTRP CMP (R1),R0 BEQ BPTTRP MORE BPTTRP: TRAP BRKPNT DIF: ; SET DIFFERENCE JSR PC,SETADJ BEQ 2$ 1$: BIC (SP)+,(R0)+ SOB R1,1$ 2$: MORE DVI: ; INTEGER DIVIDE MOV (SP)+,R1 MOV (SP)+,R0 JSR PC,DIV MOV R0,-(SP) MORE DVR: ; REAL DIVIDE .IF DF,FPI FDIV SP MORE .IFF JSR R4,ENTFP .WORD $DVR,XITFP .ENDC CHK: ; CHECK INDEX OR RANGE CMP (SP)+,2(SP) ; CHECK MAXIMUM VALUE BLT CHKERR CMP (SP)+,@SP ; CHECK MINIMUM VALUE BGT CHKERR MORE CHKERR: TRAP INVNDX FLO: ; FLOAT NEXT TO TOP-OF-STACK MOV (SP)+,FLO1 ; SAVE REAL ON TOS MOV (SP)+,FLO0 JSR R4,ENTFP .WORD $IR,FIXTOS,XITFP FIXTOS: MOV (PC)+,-(SP) FLO0: .WORD MOV (PC)+,-(SP) FLO1: .WORD JMP @(R4)+ FLT: ; FLOAT TOP-OF-STACK JSR R4,ENTFP .WORD $IR,XITFP INN: ; SET INCLUSION MOV (SP)+,BK ; GET SET SIZE FROM STACK MOV SP,R0 ; NOW POINT R0 AT THE SCALAR VAL ADD BK,R0 ; BY SKIPPING IT ABOVE ADD BK,R0 ; THE SET MOV @R0,R1 ; R1 HAS THE VALUE TO TEST FOR NOW BMI NOTINN ; NO NEGATIVE SET INDEXES .IF DF,EIS ASH #-4,R1 .IFF ASR R1 ASR R1 ASR R1 ASR R1 .ENDC CMP R1,BK ; CHECK IF ENOUGH WORD ARE IN SET BGE NOTINN ; TO ACCOMODATE THE VALUE IN R1 ASL R1 ; IF THERE ARE, POINT R1 AT THE WORD ADD SP,R1 ; WHICH HAS THE BIT IN IT MOV @R1,BK ; PLACE THE WORD INTO BK FOR LATER MOV @R0,R1 ; GET THE SCALAR AGAIN BIC #177760,R1 ; CHUCK ALL BUT LOW 4 BITS ASL R1 ; MAKE A WORD INDEX INTO BITTER BIT BITTER(R1),BK ; TEST IF THE BIT IN QUESTION IS ON BEQ NOTINN MOV R0,SP ; FOUND IT...CUT BACK STACK MOV #1,@SP ; PUT A TRUE ON TOP XITINN: MOV #BACK,BK ; RESTORE REGISTER MORE NOTINN: MOV R0,SP ; CUT BACK HERE TOO CLR @SP ; EXCEPT PUSH A FALSE BR XITINN INT: ; SET INTERSECTION JSR PC,SETADJ MOV R1,TOPSIZ ; SAVE TOP SET SIZE BEQ 2$ 1$: COM @SP BIC (SP)+,(R0)+ SOB R1,1$ 2$: MOV @SP,R1 ; GET FINAL SET SIZE SUB TOPSIZ,R1 ; SUBTRACT THE TOP SIZE...R1 = DIFF BEQ 4$ ; IF NO LEFTOVER WORDS THEN EXIT 3$: CLR (R0)+ ; ELSE CLEAR EXTRA WORDS IN FINAL SET SOB R1,3$ 4$: MORE TOPSIZ: .WORD ; SIZE OF TOP SET (TEMP) IOR: ; LOGICAL OR BIS (SP)+,@SP MORE MOD: ; INTEGER REMAINDER DIVIDE MOV (SP)+,R1 MOV (SP)+,R0 JSR PC,DIV MOV R1,-(SP) MORE MPI: ; INTEGER MULTIPLY MOV (SP)+,R0 MOV (SP)+,R1 JSR PC,MLI MOV R0,-(SP) MORE MPR: ; REAL MULTIPLY .IF DF,FPI FMUL SP MORE .IFF JSR R4,ENTFP .WORD $MLR,XITFP .ENDC NGI: ; INTEGER NEGATION NEG @SP MORE NGR: ; REAL NEGATION TST @SP BEQ 1$ ADD #100000,@SP 1$: MORE NOT: ; LOGICAL NOT COM @SP MORE SRS: ; BUILD SUBRANGE SET MOV (SP)+,R0 ; GRAB HIGHER VALUE J OF I..J MOV (SP)+,R1 ; AND LOWER VALUE I BMI NULSET ; IF I IS NEG THEN NULL SET TIME CMP R1,R0 ; IF I > J THEN BGT NULSET ; ALSO A NULL SET MOV #1,SETWDS ; FINAL SET SIZE...START WITH 1 WORD MOV #177777,-(SP) ; OF ALL ONES MOV R0,BK ; CLEAR HIGH BITS 15 DOWNTO J BIC #177760,BK ; USE LOW BITS IN BK FOR CLRMSK INX ASL BK ; DOUBLE FOR WORDS INDEX BIC CLRMSK+2(BK),@SP ; HIGH ORDER BITS GONE NOW BIS #17,R0 ; FIND WORDS TO PUT BETWEEN I..J SUB R1,R0 ; HAVE DIFFERENCE NOW * 16 .IF DF,EIS ASH #-4,R0 ; DIV 16...NUMBER WORDS FROM I..J .IFF ASR R0 ASR R0 ASR R0 ASR R0 .ENDC BEQ 2$ ; IF ZERO, THEN 1 WORD IS ENOUDH ADD R0,SETWDS ; ELSE BUMP SET SIZE COUNTER 1$: MOV #177777,-(SP) ; AND PUSH ALL BIT SET WORDS SOB R0,1$ ; FOR NUMBER WORDS DIFFERENCE 2$: MOV R1,BK ; NOW ZAP LOW BITS ON TOS WORD BIC #177760,BK ; THAT ARE LESS THAN I VALUE ASL BK ; WORD INDEX MOV CLRMSK(BK),BK ; GRAB HIGH ORDER CLEARING BIT MASK COM BK ; CHANGE TO LOW ORDER MASK BIC BK,@SP ; NOW THE ON BITS IN SET ARE OK .IF DF,EIS ASH #-4,R1 ; DIV 16...# OF ZERO TO PUSH NOW .IFF ASR R1 ASR R1 ASR R1 ASR R1 .ENDC BEQ 4$ ; IF NO MORE ZEROES THEN SKIP ADD R1,SETWDS ; ELSE ADD ON ZERO COUNT TO SET SIZE 3$: CLR -(SP) ; AND LOOP ADDING ON ZEROES SOB R1,3$ 4$: MOV SETWDS,-(SP) ; PUSH SET SIZE...NOW GOOD, CLEAN SET ON STACK MOV #BACK,BK MORE SETWDS: .WORD ; SIZE OF SET BUILD ABOVE STUCK HERE SBI: ; INTEGER SUBTRACT SUB (SP)+,@SP MORE SBR: ; REAL SUBTRACT .IF DF,FPI FSUB SP MORE .IFF JSR R4,ENTFP .WORD $SBR,XITFP .ENDC ; SGS IS BELOW THE SQUARE OPS SQI: ; SQUARE INTEGER MOV @SP,-(SP) BR MPI SQR: ; SQUARE REAL MOV 2(SP),-(SP) MOV 2(SP),-(SP) BR MPR NULSET: CLR -(SP) ; ZERO WORD SET SIZE MORE SGS: ; MAKE SINGLETON SET MOV (SP)+,R0 ; GET THE SCALAR VALUE WANTED BMI NULSET ; IF NEGATIVE THEN GO BUILD A NULL SET CLR -(SP) ; PUT A WORD TO SET BIT INN MOV R0,R1 ; NOW SET PROPER BIT IN TOS BIC #177760,R1 ; ZAP ALL BUT LOW 4 BITS ASL R1 ; MAKE A WORD INDEX IN BITTER BIS BITTER(R1),@SP ; NOW WE HAVE PROPER BIT SET BIC #170017,R0 ; ZAP ALL BUT WORD BITS BEQ 2$ ; IF NO ZEROES NEEDED THEN DONE .IF DF,EIS ASH #-4,R0 .IFF ASR R0 ASR R0 ASR R0 ASR R0 .ENDC MOV R0,R1 ; SAVE WORD COUNT FOR LATER PUSH 1$: CLR -(SP) ; CLEAR A STACK WORD SOB R1,1$ 2$: INC R0 ; SET R0 TO TOTAL SET SIZE MOV R0,-(SP) ; AND PUSH IT FINALLY MORE STO: ; STORE INDIRECT MOV (SP)+,@(SP)+ MORE IXS: ; STRING INDEX...DYNAMIC RANGE CHECK MOV @SP,R0 ; GRAB INDEX VALOUE BEQ IXSERR ; ZERO INDEX IS AN ERROR CMP R0,#255. ; CHECK IF WAY TOO BIG BHI IXSERR ; BOMB IF SO CMPB R0,@2(SP) ; CHECK INDEX AGAINST STRING LENGTH BHI IXSERR ; AND BOMB FOR THAT TOO ADD (SP)+,@SP ; OK...ADD THE INDEX TO ADDR ON TOS MORE IXSERR: TRAP INVNDX UNI: ; SET UNION JSR PC,SETADJ BEQ 2$ 1$: BIS (SP)+,(R0)+ SOB R1,1$ 2$: MORE S2P: ; STRING TO PACKED ARRAY CONVERT INC 2(SP) MORE LDCN: ; LOAD CONSTANT NIL .IIF EQ,NIL, CLR -(SP) .IIF NE,NIL, MOV #NIL,-(SP) MORE ADJ: ; SET ADJUST GETBYTE ; GRAB REQUESTED SET SIZE MOV (SP)+,R1 ; GET SET SIZE FROM TOS CMP R1,R0 ; COMPARE SET SIZE TO REQ SIZE BLT EXPAND ; IF SET TOO SMALL THEN EXPAND IT BGT CRUNCH ; IF TOO BIG THEN CRUNCH THE SET MORE ; ELSE ALL'S OK...NEXT INSTRUCTION CRUNCH: MOV R0,BK ; SAVE REQUESTED LENGTH ASL R0 ; NOW POINT R0 AT TOP OF VALID PART OF SET ADD SP,R0 ASL R1 ; POINT R1 ABOVE ENTIRE SET...IS DEST ADD SP,R1 ; FOR FUTURE MOVES TO CRUNCH OUT JUNK 1$: MOV -(R0),-(R1) ; COPY THE WORDS OF GOOD SEOT PART SOB BK,1$ MOV R1,SP ; R1 IS NEW TOS...CUT BACK STUFF BR XITADJ EXPAND: MOV SP,BASE ; REMEMBER TOP OF SMALL SET SUB R1,R0 ; R0 HAS SET SIZE DIFFERENCE NOW MOV R0,BK ; SAVE DIFF FOR LATER ZEROING ASL R0 ; DOUBLE FOR WORD COUNT SUB R0,SP ; ADD JUNK ONTO STACK POINTER FOR ZERO FILL MOV SP,R0 ; NOW DEST FOR SET COPYING TST R1 ; CHECK IF OLD SET SIZE = 0!! BEQ 2$ ; IF SO THEN DONT DO LOOP...SYSBOMB! 1$: MOV (BASE)+,(R0)+ ; COPY THE SET NOW SOB R1,1$ 2$: CLR (R0)+ ; NOW ZERO IN THE REST OF SET SOB BK,2$ MOV STKBAS,BASE ; RESTORE SCRATCH REG XITADJ: MOV #BACK,BK ; RESTORE THIS TOO MORE ; FJP IS UP AHEAD WITH UJP INC: ; INCREMENT TOS BY PARAM GETBIG ADD R0,@SP MORE IND: ; INDIRECT LOAD GETBIG ASL R0 ADD R0,@SP MOV @(SP)+,-(SP) MORE IXA: ; INDEX ARRAY GETBIG R1 ; GET # WORDS PER ELEMENT MOV (SP)+,R0 ; GRAB USER'S INDEX VALUE BEQ 2$ ; IF ZERO, THEN DONE ALREADY! CMP R1,#1 ; CHECK IF 1 WORD ELS BEQ 1$ ; IF SO THEN NO MULTIPLY JSR PC,MLI 1$: ASL R0 ; NOW DOUBLE INDEX VALUE FOR WORDS ADD R0,@SP ; NEW ADDRESS OFO ARRAY ELEMENT NOW 2$: MORE LAO: ; LOAD GLOBAL ADDRESS GETBIG ASL R0 .IIF NE,MSDLTA, ADD #MSDLTA,R0 ADD BASE,R0 MOV R0,-(SP) MORE LCA: ; LOAD CONSTANT (STRING) ADDRESS MOV IPC,-(SP) GETBYTE ; GRAB STRING LENGTH ADD R0,IPC ; AND SKIP IPC PAST STRING MORE LDO: ; LOAD GLOBAL GETBIG ASL R0 .IIF NE,MSDLTA, ADD #MSDLTA,R0 ADD BASE,R0 MOV @R0,-(SP) MORE MOV: ; MOVE WORDS GETBIG BK ; GRAB # WORDS TO MOVE (ALWAYS > 0) MOV (SP)+,R0 ; SOURCE ADDRESS MOV (SP)+,R1 ; DESTINATION ADDRESS 1$: MOV (R0)+,(R1)+ ; COPY EACH WORD SOB BK,1$ MOV #BACK,BK MORE MVB: ; MOVE BYTES GETBIG BK ; GRAB # BYTES TO MOVE (ALWAYS > 0) MOV (SP)+,R0 ; SOURCE ADDRESS MOV (SP)+,R1 ; DESTINATION ADDRESS 1$: MOVB (R0)+,(R1)+ ; COPY EACH BYTE SOB BK,1$ MOV #BACK,BK MORE SAS: ; STRING ASSIGNMENT MOV (SP)+,R0 ; GET SOURCE STRING ADDRESS CMP R0,#255. ; CHECK IF ITS REALLY A CHAR BHI 1$ ; IF NOT THEN SKIP TRICKYNESS MOVB R0,LITCHR+1 ; LIT CHAR...MAKE IT A STRING MOV #LITCHR,R0 ; NOW R0 HAS GOOD ADDRESS 1$: CMPB @R0,(IPC)+ ; CHEOCK IF MAXLENG IS EXCEEDED BY SRC LENG BHI SASERR ; BOMB OUT IF SO MOV (SP)+,R1 ; GRAB DESTINATION ADDRESS CLR BK ; SET UP LOOP COUNTER WITH SOURCE LENGTH BISB @R0,BK ; NOW BK HAS LENGTH COUNT OF SOURCE INC BK ; INCLUDE LENGTH BYTE IN LOOP COUNT 2$: MOVB (R0)+,(R1)+ ; COPY EACH BYTE SOB BK,2$ ; LOOP FOR CHARS+LENGTH BYTE MOV #BACK,BK ; RESTORE MORE LITCHR: .WORD 1 ; DUMMY STRING OF LENGTH 1 SASERR: TRAP INVNDX SRO: ; STORE GLOBAL GETBIG ASL R0 .IIF NE,MSDLTA, ADD #MSDLTA,R0 ADD BASE,R0 MOV (SP)+,@R0 MORE XJP: ; INDEX JUMP WORDBOUND MOV (SP)+,R0 ; GRAB INDEX VALUE FROM TOS MOV (IPC)+,R1 ; GET MIN CASE INDEX FROM CODE CMP R0,R1 ; SEE IF INDEX IS TOO SMALL BLT MINERR ; SKIP OUT IF NOT IN RANGE CMP R0,(IPC)+ ; CHECK IF LEQ MAX VALUE BGT MAXERR ; SKIP OUT HERE TOO TST (IPC)+ ; SKIP OVER ELSE JUMP WORD SUB R1,R0 ; ADJUST INDEX TO 0..N ASL R0 ; DOUBLE INDEX FOR WORD STUFF ADD R0,IPC ; POINT IPC AT PROPER JUMP TABLE INDEX SUB @IPC,IPC ; NOW IPC POINTS AT STATEMENT SELECTED MORE MINERR: TST (IPC)+ ; SKIP IPC TO ELSE JUMP LOCATION MAXERR: MORE ; IPC POINTS AT ELSE JUMP...ONWARD COMPAR: ; COMPARE COMPLEX THINGS ; RELOPS EQU, GRT, GEQ, LEQ, LES, & NEQ GETNEXT R1 ; GRAB COMPARISON TYPE MOV CMPTBL(R1),PC ; NOW TRANSFER TO PROPER CODE REALCMP:; COMPARE REAL MOV SBROPS(R0),1$ .IF DF,FPI FSUB SP 1$: NOP BR 2$ TST (SP)+ MOV #1,@SP MORE 2$: TST (SP)+ CLR @SP MORE .IFF JSR R4,ENTFP .WORD $CMR,1$,XITFP 1$: NOP BR 2$ MOV #1,-(SP) JMP @(R4)+ 2$: CLR -(SP) JMP @(R4)+ .ENDC BYTECMP:; COMPARE BYTE STRING GETBIG BK CMP.IT: MOV UBROPS(R0),2$ ; PUT IN PROPER CMP OPERATOR MOV (SP)+,R1 ; RIGHT HAND EXPRESSION ADDR MOV (SP)+,R0 ; LEFT EXPRESSION 1$: CMPB (R0)+,(R1)+ ; COMPARE BYTES BNE 2$ ; ANY NEQ STOPS LOOP SOB BK,1$ 2$: NOP BR 4$ MOV #1,-(SP) 3$: MOV #BACK,BK MORE 4$: CLR -(SP) BR 3$ STRGCMP:; COMPARE STRING VARIABLES CLR BK BISB @2(SP),BK INC BK ; INCLUDE LENGTH BR CMP.IT WORDCMP:; COMPARE WORDS GETBIG BK ASL BK BR CMP.IT BOOLCMP:; COMPARE BOOLEAN OPERANDS BIC #177776,@SP BIC #177776,2(SP) MOV XFRTBL+40.(R0),PC ; DO INTEGER COMPARE POWRCMP:; COMPARE SETS JSR PC,SETADJ ; ENSURE SETS MAKE SENSE MOV -(R0),BK ; GET LOWER SET SIZE ADD (R0)+,BK ; DOUBLE FOR BYTE SIZE ADD R0,BK ; NOW BK POINTS AT FINAL TOP OF STACK MOV BK,NEWSP MOVB -2(IPC),BK ; GRAB ORIGINAL INSTRUCTION BYTE ASL BK ; DOUBLE IT!! WORD INDEX IN XFRSET MOV XFRSET(BK),-(SP) ; STASH TRANSFER ADDRESS... MOV -2(R0),BK ; ACTUAL OPS EXPECT BK=LOWER SET SIZE MOV (SP)+,PC ; TRANSFER NOW TO PROPER COMPARE OP EQUS: ; COMPARE SETS EQUAL TST R1 ; NUMBER OF WORDS IN TOP SERT BEQ CHKZER 1$: CMP (SP)+,(R0)+ BNE SFALSE DEC BK SOB R1,1$ CHKZER: TST BK BEQ STRUE 1$: TST (R0)+ BNE SFALSE SOB BK,1$ BR STRUE LEQS: ; LESS THAN OR EQUAL SET COMPARE TST R1 BEQ CHKZER 1$: BIC (SP)+,(R0)+ BNE SFALSE DEC BK SOB R1,1$ BR CHKZER GEQS: ; GREATER OR EQUAL SET COMPARE TST R1 BEQ STRUE 1$: BIC (R0)+,(SP)+ BNE SFALSE SOB R1,1$ BR STRUE NEQS: ; NOT EQUAL SET COMPARE TST R1 BEQ 2$ 1$: CMP (SP)+,(R0)+ BNE STRUE DEC BK SOB R1,1$ 2$: TST BK BEQ SFALSE 3$: TST (R0)+ BNE STRUE SOB BK,3$ SFALSE: MOV NEWSP,SP CLR -(SP) XITPWR: MOV #BACK,BK MORE STRUE: MOV NEWSP,SP MOV #1,-(SP) BR XITPWR NEWSP: .WORD LDA: ; LOAD INTERMEDIATE ADDRESS GETNEXT ; THE DELTA LEX LEVEL MOV MP,R1 ; POINT R1 AT STAT LINKS 1$: MOV @R1,R1 ; LINK DOWN NOW UNTIL SOB R0,1$ ; DELTA LL = 0 (NEVER START AT 0) GETBIG ; GET DISPLACMENT ASL R0 ; DOUBLE FOR WORD INDEXING .IIF NE,MSDLTA, ADD #MSDLTA,R0 ADD R1,R0 ; NOW R0 HAS ADDRESS MOV R0,-(SP) ; PUSH IT MORE LDC: ; LOAD MULTIWORD CONSTANT GETNEXT ; NUMBER OF WORDS TO LOAD (ALWAYS > 0) WORDBOUND 1$: MOV (IPC)+,-(SP) SOB R0,1$ MORE LOD: ; LOAD INTERMEDIATE VALUE GETNEXT ; THE DELTA LEX LEVEL MOV MP,R1 ; POINT R1 AT STAT LINKS 1$: MOV @R1,R1 ; LINK DOWN NOW UNTIL SOB R0,1$ ; DELTA LL = 0 (NEVER START AT 0) GETBIG ; GET DISPLACMENT ASL R0 ; DOUBLE FOR WORD INDEXING .IIF NE,MSDLTA, ADD #MSDLTA,R0 ADD R1,R0 ; NOW R0 HAS ADDRESS MOV @R0,-(SP) ; COPY VALUE FROM STACK MORE STR: ; STORE INTERMEDIATE VALUE GETNEXT ; THE DELTA LEX LEVEL MOV MP,R1 ; POINT R1 AT STAT LINKS 1$: MOV @R1,R1 ; LINK DOWN NOW UNTIL SOB R0,1$ ; DELTA LL = 0 (NEVER START AT 0) GETBIG ; GET DISPLACMENT ASL R0 ; DOUBLE FOR WORD INDEXING .IIF NE,MSDLTA, ADD #MSDLTA,R0 ADD R1,R0 ; NOW R0 HAS ADDRESS MOV (SP)+,@R0 ; SAVE VALUE INTO STACK MORE NOJUMP: INC IPC ; GO HERE IF A TRUE WAS ON STACK MORE EFJ: ; INTEGER = THEN FJP SUB (SP)+,(SP)+ BEQ NOJUMP BR UJP NFJ: ; INTEGER <> THEN FJP SUB (SP)+,(SP)+ BNE NOJUMP BR UJP FJP: ; BRANCH IF FALSE ON TOS ROR (SP)+ BCS NOJUMP ; NOW FALL INTO UJP UJP: ; BRANCH UNCONDITIONAL GETNEXT ; GET BRANCH PARAM BMI 1$ ; IF < 0 THEN A LONG JUMP ADD R0,IPC ; ELSE JUST A BYTE OFFSET FORWARD MORE 1$: MOV JTAB,IPC ; POINT IPC AT JTAB ENTRY SO OFFSET ADD R0,IPC ; IS GOOD...R0 IS < 0 REALLY A SUBTRACT SUB @IPC,IPC ; POINT IPC AT NEW OBJECT CODE MORE LDP: ; LOAD PACKED FIELD MOV @4(SP),R0 ; GET WORD WHICH HAS FIELD IN IT INTO R0 MOV (SP)+,R1 ; GET FIELD RIGHT-MOST BIT NUMBER .IF DF,EIS NEG R1 ASH R1,R0 .IFF BEQ NOASR ; IF ZERO THEN NO SHIFTS NEEDED 1$: ASR R0 ; SHIFT R0 UNTIL FIELD IN LOW BITS SOB R1,1$ NOASR: .ENDC MOV (SP)+,R1 ; GRAB FIELD WIDTH FROM STACK ASL R1 ; DOUBLE IT FOR WORD INDEXING BIC CLRMSK(R1),R0 ; CLEAR SHIT BITS IN WORD MOV R0,@SP ; NOW PUT FIELD ON STACK MORE STP: ; STORE PACKED FIELD MOV 4(SP),R1 ; GRAB FIELD WIDTH ASL R1 ; DOUBLE FOR WORD INDEX MOV CLRMSK(R1),R1 ; NOW WE HAVE A CLEARING MASK IN R1 MOV (SP)+,R0 ; GRAB INSERT VALUE FROM STACK BIC R1,R0 ; ZAP JUNK BITS IN INSERT VALUE COM R1 ; NOW R1 WILL ZAP THE FIELD ITSELF MOV (SP)+,BK ; GET FIELD RIGHT-MOST BIT .IF DF,EIS ASH BK,R0 ASH BK,R1 .IFF BEQ NOASL ; IF IN RIGHT-MOST BIT THEN NO SHIFT 1$: ASL R0 ; SHIFT INSERT VALUE BY ONE ASL R1 ; AND SHIFT CLEAR MASK SOB BK,1$ ; AND DO SO UNTIL LINED UP WITH FIELD NOASL: .ENDC TST (SP)+ ; FORGET THE OLD FIELD WIDTH MOV (SP)+,BK ; BK NOW HAS ADDRESS OF PACKED FIELD WORD BIC R1,@BK ; SET FIELD IN WORD TO ZEROES BIS R0,@BK ; NOW OR IN THE INSERT VALUE MOV #BACK,BK ; RESTORE SCRATCH REG MORE LDM: ; LOAD MULTIPLE WORDS MOV (SP)+,R1 ; GET WORD LIST ADDRESS GETBYTE ; AND GET WORD COUNT BEQ NOLOAD ; MAY HAPPEN SOMEDAY ADD R0,R1 ; SKIP LIST ADDRESS TO UPPER END ADD R0,R1 ; R1 NOW POINTS ABOVE DATA BLOCK 1$: MOV -(R1),-(SP) SOB R0,1$ NOLOAD: MORE STM: ; STORE MULTIPLE WORDS GETBYTE ; GET NUMBER OF WORDS BEQ NOSTOR MOV SP,R1 ; POINT R1 AT DATA BLOCK ON STACK ADD R0,R1 ; SKIP R1 PAST THE DATA TO GET THE ADD R0,R1 ; STORE ADDRESS BELOW IT MOV @R1,R1 ; GET STORE ADDRESS NOW 1$: MOV (SP)+,(R1)+ SOB R0,1$ NOSTOR: TST (SP)+ ; CHUCK ADDRESS WORD MORE LDB: ; LOAD BYTE MOV @SP,R0 CLR @SP BISB @R0,@SP MORE STB: ; STORE BYTE MOVB (SP)+,@(SP)+ MORE IXP: ; INDEX PACKED ARRAY GETNEXT R1 ; GET # ELEMENTS PER WORD MOV (SP)+,R0 ; GET USER'S INDEX VALUE JSR PC,DIV ; NOW DIVIDE OUT WORD INX AND BIT INX ADD R0,@SP ; ADD WORD INDEX TO BASE ADDR ON TOS ADD R0,@SP ; TO BUILD WORD ADDRESS FOR LDP GETNEXT ; GET ELEMENT WIDTH MOV R0,-(SP) ; NOW PUSH EL WIDTH FOR LDP STUFF CLR -(SP) ; NOW THE RIGHT-MOST BIT 1$: ASR R1 ; NOW A SHORT MULTIPLY FOR SMALL VALUES BCC 2$ ; SKIP IF THE MULTIPLICAND BIT IS OFF ADD R0,@SP 2$: ASL R0 ; DOUBLE ADDEND TST R1 ; ANY MULTIPLICATION AT ALL? BNE 1$ ; IF SO THEN KEEP LOOPING MORE EQUI: ; INTEGER EQUAL COMPARE SUB (SP)+,@SP BEQ PSHTRU PSHFLS: CLR @SP MORE PSHTRU: MOV #1,@SP MORE GEQI: ; INTEGER GREATER OR EQUAL COMPARE SUB (SP)+,@SP BGE PSHTRU BR PSHFLS GRTI: ; INTEGER GREATER THAN COMPARE SUB (SP)+,@SP BGT PSHTRU BR PSHFLS LLA: ; LOAD LOCAL ADDRESS GETBIG ASL R0 .IIF NE,MSDLTA, ADD #MSDLTA,R0 ADD MP,R0 MOV R0,-(SP) MORE LDCI: ; LOAD LONG INTEGER CONSTANT MOVB (IPC)+,-(SP) MOVB (IPC)+,1(SP) MORE LEQI: ; INTEGER LESS THAN OR EQUAL COMPARE SUB (SP)+,@SP BLE PSHTRU BR PSHFLS LESI: ; INTEGER LESS THAN COMPARE SUB (SP)+,@SP BLT PSHTRU BR PSHFLS LDL: ; LOAD LOCAL GETBIG ASL R0 .IIF NE,MSDLTA, ADD #MSDLTA,R0 ADD MP,R0 MOV @R0,-(SP) MORE NEQI: ; INTEGER NOT EQUAL COMPARE SUB (SP)+,@SP BNE PSHTRU BR PSHFLS STL: ; STORE LOCAL GETBIG ASL R0 .IIF NE,MSDLTA, ADD #MSDLTA,R0 ADD MP,R0 MOV (SP)+,@R0 MORE S1P: ; STRING TO PACKED ON TOS INC @SP MORE IXB: ; INDEX BYTE ARRAY ADD (SP)+,@SP MORE BYT: ; CONVERT WORD TO BYTE ADDR MORE ; EQUAL FJP AND NOT EQUAL FJP ARE AT FJP XIT: ; EXIT SYSTEM HALT TRAP SYSERR NOP: ; NO OPERATION MORE ENTFP: ; THIS SUBROUTINE STARTS THE THREADED CODE ; SEQUENCE A-LA FPMP $POLSH. THE DIFFERENCE IS ; WE SAVE IPC REGISTER (R4) MOV (SP)+,FPIPC ; IPC MUST BE R4!!! JMP @(R4)+ ; THREAD IT FPIPC: .WORD ; SAVE R4 (IPC) REG HERE XITFP: ; HERE IS WHERE WE EXIT FROM FPMP BUSINESS MOV LASTMP,MP MOV #BACK,BK MOV STKBAS,BASE MOV FPIPC,IPC MORE SETADJ: ; THIS IS A SUBROUTINE CALLED BY SET OPERATIONS ; TO MASSAGE SET SIZES AND REGISTERS...SEE THOSE OPS MOV (SP)+,RETADR ; SAVE RETURN ADDRESS TRYAGN: MOV (SP)+,R1 ; GRAB SET SIZE MOV SP,R0 ; NOW POINT R0 AT NEXT SET ADD R1,R0 ADD R1,R0 CMP (R0)+,R1 ; COMPARE FIRST SET SIZE WITH SECOND (TOP) SIZE BGE SETSOK ; QUIT IF SIZES ARE OK MOV R1,-(SP) ; ELSE EXPAND LOWER SET BY SHOVING IN 0-S MOV -(R0),BK ; GET SMALLER SET SIZE MOV R1,@R0 ; CHANGE IT TO FINAL SIZE AFTER EXPAND MOV R1,R0 ; CALCULATE NUMBER OF EXTRA ZEROES NEEDED SUB BK,R0 ; R0 = TOPSIZE-LOWERSIZE MOV R0,ZEROES ; STASH IT FOR LATER USE ADD BK,R1 ; NOW SET R1 TO TOTAL NUMBER OF WORDS TO COPY ADD #2,R1 ; BE SURE TO INCLUDE SIZE WORDS MOV SP,BK ; POINT BK AT OLD TOS ASL R0 ; DOUBLE SIZE DIF TO BYTES SUB R0,SP ; AND BUMP STACK TO MAKE ROOM MOV SP,R0 ; NOW R0 IS DEST POINTER FOR COPY 1$: MOV (BK)+,(R0)+ ; COPY EACH WORD IN STACK SOB R1,1$ ; LOOP FOR TOTAL SET SIZES MOV ZEROES,R1 ; NOW COPY IN ZEROES BELOW SETS 2$: CLR (R0)+ SOB R1,2$ MOV #BACK,BK ; RESTORE REG BR TRYAGN ; RESET REGISTERS AND EXIT ZEROES: .WORD ; TEMP FOR ABOVE EXPAND SETSOK: TST R1 ; LEAVE CC WITH R1 VALUE JMP @(PC)+ ; BACK TO CALLER...LEAVE CC ALONE RETADR: .WORD .PAGE .CSECT TABLES .GLOBL XFRTBL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; OPERATOR TRANSFER TABLES ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; XFRTBL = . + 400 ; USE NEGATIVE INDEXES TO GET TO OPS .WORD ABI .WORD ABR .WORD ADI .WORD ADR .WORD AND .WORD DIF .WORD DVI .WORD DVR .WORD CHK .WORD FLO .WORD FLT .WORD INN .WORD INT .WORD IOR .WORD MOD .WORD MPI .WORD MPR .WORD NGI .WORD NGR .WORD NOT .WORD SRS .WORD SBI .WORD SBR .WORD SGS .WORD SQI .WORD SQR .WORD STO .WORD IXS .WORD UNI .WORD S2P .BLKW 1 .WORD LDCN .WORD ADJ .WORD FJP .WORD INC .WORD IND .WORD IXA .WORD LAO .WORD LCA .WORD LDO .WORD MOV .WORD MVB .WORD SAS .WORD SRO .WORD XJP .BLKW 2 .WORD COMPAR .WORD COMPAR .WORD COMPAR .WORD LDA .WORD LDC .WORD COMPAR .WORD COMPAR .WORD LOD .WORD COMPAR .WORD STR .WORD UJP .WORD LDP .WORD STP .WORD LDM .WORD STM .WORD LDB .WORD STB .WORD IXP .WORD 0,0 .WORD EQUI .WORD GEQI .WORD GRTI .WORD LLA .WORD LDCI .WORD LEQI .WORD LESI .WORD LDL .WORD NEQI .WORD STL .BLKW 3. .WORD S1P .WORD IXB .WORD BYT .WORD EFJ .WORD NFJ .WORD BPT .WORD XIT .WORD NOP .LIST ME .IRP N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20> .WORD SLDLS+<6*> .ENDR .IRP N,<1,2,3,4,5,6,7,10,11,12,13,14,15,16,17,20> .WORD SLDOS+<6*> .ENDR .IRP N,<0,1,2,3,4,5,6,7> .WORD SINDS+<10*N> .ENDR .NLIST ME .BLKW 3* ; UNIT TABLE IN IOTRAP CMPTBL: .WORD 0 .WORD REALCMP .WORD STRGCMP .WORD BOOLCMP .WORD POWRCMP .WORD BYTECMP .WORD WORDCMP XFRSET = . + 242 .WORD EQUS .WORD GEQS .WORD 0,0,0 .WORD LEQS .WORD 0,0 .WORD NEQS SBROPS = . + 242 BEQ .+4 BGE .+4 BGT .+4 TRAP SYSERR TRAP SYSERR BLE .+4 BLT .+4 TRAP SYSERR BNE .+4 UBROPS = . + 242 BEQ .+4 BHIS .+4 BHI .+4 TRAP SYSERR TRAP SYSERR BLOS .+4 BLO .+4 TRAP SYSERR BNE .+4 .RADIX 2. BITTER: 0000000000000001 0000000000000010 0000000000000100 0000000000001000 0000000000010000 0000000000100000 0000000001000000 0000000010000000 0000000100000000 0000001000000000 0000010000000000 0000100000000000 0001000000000000 0010000000000000 0100000000000000 1000000000000000 CLRMSK: 1111111111111111 1111111111111110 1111111111111100 1111111111111000 1111111111110000 1111111111100000 1111111111000000 1111111110000000 1111111100000000 1111111000000000 1111110000000000 1111100000000000 1111000000000000 1110000000000000 1100000000000000 1000000000000000 0000000000000000 .END ======================================================================================== DOCUMENT :usus Folder:VOL19:make_i.3.text ======================================================================================== MACRO/OBJ:MAINOP EIS+MACROS+MAINOP MACRO/OBJ:PROCOP EIS+MACROS+PROCOP MACRO/OBJ:TRAPS EIS+MACROS+TRAPS MACRO/OBJ:LP11 EIS+MACROS+LP11 MACRO/OBJ:RX11 EIS+MACROS+RX11 LINK/EXEC:INTERP/PRO MAINOP PROCOP TRAPS LP11 RX11 FORLIB.OBJ // ======================================================================================== DOCUMENT :usus Folder:VOL19:modem.pas.text ======================================================================================== program modem; { Give control of the system to the MODEM } var i : integer; procedure gomodem ; external; begin gomodem end. .title "GOMODEM - Modem redirector" .proc gomodem ; This function will: ; 1) Find the console register map ; 2) Change it to relfect the -odem ; 3) Point the modem vectors to the console driver ; 4) Point the console vectors to nil ; This procedure will effectivly redirect control of the ; P-system to the modem device. clr r0 ; Point to bottom of memory search: mov (r0)+,r1 ; Get the word to test bic #7,r1 ; Mask off the register select field cmp #177560,r1 ; Test : is this a console pointer ? bne search ; Keep looking... sub #40,-(r0) ; Fix the register address tst (r0)+ ; Point to the next cell to continue inc count ; Found one... only 4 exsist cmp #4,count ; Was this the last ? bne search ; No...keep looking mov @#60,r0 ; Swap vectors mov @#120,@#60 mov r0,@#120 mov @#64,r0 mov @#124,@#64 mov r0,@#124 rts pc count .word 0 .end ======================================================================================== DOCUMENT :usus Folder:VOL19:patch.cont.text ======================================================================================== Problem #5: DLE expansion problems. This patch was supplied by Charles Rockwell and is also published in NewsLetter #7. The problem is the console driver software. For the benefit of those who speak assembly language, the section of code that sends characters to the screen looks like: 1$: MOV R0,-(SP) ;push R0 CLR R0 ;get the next character BISB @BUFPTR,R0 ; cleanly TST DFLAG ;was last char a DLE BEQ 3$ ; branch if no CLR DFLAG ; if yes, R0 has the count SUB #32.,R0 ;expansion count excess 32 BLE 4$ ;branch if too big ;DLE expansion MTPS #0 ;interrupts on 2$: TSTB @ITPS ;port busy? BPL 2$ ;branch if yes MOVB #' ,@ITPS ;send space to screen SOB R0,2$ ;decrement R0, branch if not equal ;done - R0=0 MTPS #200 ;interrupts off 3$: CMPB R0,#DLE ;is this character a DLE? BNE 5$ ;branch if not COM DFLAG ; set flag if yes CLR R0 ; ;send R0 to screen 5$: MOVB R0,@ITPB ;with no test for busy CMPB R0,#CR ;was it a carriage return? The DLE expansion loop beginning a 2$ sends the required number of spaces to the screen. It then falls through the branch to 5$. R0, (which is null at this point), is sent to the screen immediately, without a test for busy. This null usually wipes out the final space of the DLE expansion. However, there is a hardware FIFO buffer in the serial interface to the terminal. If this buffer is empty, it can grab the final space before the null gets there. This is why DLE expansions look good if they only require one or two spaces. The fix for the bug requires reassembly and relinking the the entire interpreter, and is not practical without DEC's RT-11 operating system. The fix looks like: 4$: CLR R0 ;check for done 5$: TSTB @ITPS ; and only then MOVB R0,@ITBP ;send R0 to the screen The patch for the bug can be made on any LSI/PDP-11 interpreter. It is installed in the loop that sends the spaces for the DLE expansion to the screen. The patch simply reverses the order of the test for busy and the sending of the space. This means that the first space of the DLE expansion will be sent without a check for busy. This shouldn't be a problem, because the existing code already sends most characters to the screen without checking for busy. (The implied assumption is that the serial interface generates an interrupt only if it is not busy). The patch changes the code at 2$ to: MTPS #0 ;interrupts on 2$: MOVB #' ,@ITPS ;send the first space 6$: TSTB @ITPS ; wait until not busy BPL 6$ ; before sending next SOB R0,2$ ;branch in not done Implementing the patch requires on operating version of PATCH, DISKREAD, or some similar program that can change selected words on a disk file. (The DEC Console ODT can be used to change the program in memory, but the change has to be made every time the system is booted.) STEP 1: Use the FILER to make a copy of yoyr system disk, and put your system disk in a safe place. Use only the copy to perform the following steps. After you are certain that all went well, you can call the unmodified copy of the system disk an archive copy if you wish, but leave it in a safe place. If all didn't go well, you can zero the new copy and start over. STEP 2: Boot the copy of the system disk, and execute PATCH or DISKREAD. Do whatever is necessary to display block 2 (or block 3 for IV.1) of SYSTEM.PDP-11. The result should be a screen full of hex words. Find your particular computer model and UCSD version in the table below, and make the indicated changes. If the sequence of hex characters is not EXACTLY as shown, quit immediatly. This section of the program is full of code sequences that are almost the same, but almost isn't good enough in this case. Note that offsets in the block are decimal, while the code is in hex, per PATCH convention. The presence or absence of the LSI EIS chip does not make a difference in the offset. PDP-11 LSI-11 LSI-11 LSI-11 UCSD I.4 UCSD I.4 UCSD IV.0 IV.1 (LS142B) UCSD I.5 UCSD I.5 UCSD II.0 UCSD II.0 BLOCK 3 OFFSET 244 200 462 302 DATA FROM TO FROM TO FROM TO FROM TO FF8B FF95 FF8B FF95 FF8B FF95 FF8B FF95 36FF 2000 4EFF 2000 F0FB 2000 98FA 2000 FD80 36FF FD80 4EFF FD80 F0FB FD80 98FA FF95 FF8B FF95 FF8B FF95 FF8B FF95 FF8B 2000 30FF 2000 48FF 2000 EAFB 2000 92FA 30FF FD80 48FF FD80 EAFB FD80 92FA FD80 STEP 3: When the changes are satisfactory, write the block back out to the disk. SYSTEM.PDP-11 is now either hopelessly corrupt, or successfully patched. Reboot the disk, and execute SCREENTEST to find out which. If the patch was successful, the screen patterns should be as advertised, although there may well be problems remaining in the character set copying routines. For those who prefer to try the patch in memory before changing the disk, and for those who wich to check the patch in memory, the octal numbers for the console ODT are: PDP,I.4 LSI,I.4/II.0 LSI,IV.0 ADDR FROM TO ADDR FROM TO ADDR FROM TO 2364 105777 112777 2310 105777 112777 2716 105777 112777 177466 40 177516 40 175760 40 100375 177466 100375 177516 100375 175760 112777 105777 112777 105777 112777 105777 40 177460 40 177510 40 175752 177460 100375 177510 100375 175752 100375 Patch #7, Tab Expansion The interp for the pdp-11 hasn't changed much since the days of I.3. At that time is was standard for the system to expand tabs to the printer as the printer used at that time wouldn't do it on its own. In newer implementations of the p-system, this convention was dropped, but the -11 was never changed. This doesn't cause any problems unless you MUST send CHR ( 11 ), a tab character to the printer as a control character. For example, a Diablo printer must be sent a tab character as part of a control sequence to make it do an absolute tab. This means that Diablo printer drivers which work on other p- systems don't work on the -11. However a simple fix is shown below. The actual printer detects the tab character and jumps to a subroutine to expand the tab, using a current column count to go the the next 8 column tab position. If the character is not a tab, a branch is performed around the subroutine call. The patch is to change this conditional branch to a non- conditional branch. This original code is: . . CMPB R0,#HT ; is it a tab BNE 4$ ; if not continue JSR PC,LPTABR ; if so, send some spaces 4$ INC LP.COL ; increment the column count . . We change the BNE to a BR and the patch is done. To do the patch, follow these instructions. 1) Make a backup copy of system.pdp-11. 2) Invoke PATCH and R(read SYSTEM.PDP-11. V(erify block 0. 3) Look at the contents of location 128 decimal (200 octal) and note it. This is the location of the beginning of the printer driver. If you have done the X-ON/X-OFF patch above, you will have to look at the contents of the last word of that patch instead. Convert this value to decimal (the program HEXDECOCT.TEXT on volume 5 helps a lot here but remember to flip the bytes as HEXDECOCT expects inputs non-flipped). Divide the value by 512 (decimal). The non-fractional part of the result is the block number of the block in which the patch will be made and the remainder multiplied by 512 is the offset into the block. Add 124 decimal to the offset to get the offset into the printer driver of the offending instruction. 4) At this location you should see 0202 (hex) or 001002 (octal). This is the BNE instruction. The previous word should be 0900 (byte flipped hex) or 11 octal. This is the value of a tab. Change the 0202 to 0201 (byte flipped hex for a BR) or 000402 (octal), a branch of two words. 5) Save the block and you are done. Test the patch by sending some tabs to your printer. If your printer does its own tabs, you will not see any difference. If your printer doesn't recognize tabs, it won't tab. ======================================================================================== DOCUMENT :usus Folder:VOL19:patches.text ======================================================================================== Patching Your LSI-11 Interpreter compiled by George Schreyer The LSI-11 implementation of the UCSD p-system has some bugs which make it act differently than most other implementations. The specific problems are described below. 1) The system comes preconfigured for parallel printers (the Printronix in particular). This will cause the system to crash if a serial interface is used at the printer port. This problem occurs ONLY in version II.0. 2) If a serial printer is used, the interpreter cannot recognize the standard X-ON/X-OFF protocol of typical serial (RS-232) printers. The symptom is the loss of printed data due to printer buffer overflows. 3) The interpreter strips the parity bit off incoming characters at the remote port, REMIN:. This prevents 8 bit data (such as found in code and data files) from being read from REMIN:. 4) Your remote port doesn't work and you are using a DLV-11J. The vectors of the printer and remote port are not contigious even though the addresses are. Since your DLV-11J requires that the three non-console devices have contigous addresses and vectors, you have a hardware/software mismatch. No one seems to know why it was done this way, but you can fix it. See Problem #4 for the general method of moving port addresses and vectors around. See Problem #4A for specific (easy) modifications to get your DLV-11J to work with the remote port. 5) DLE expansion problems. If you use UNITWRITES to the console you may find that the left margin of displayed text is shifted left by one character. This is a bug in the interpreter which can be fixed so that the - 11 system will work like any other. 6) The control code (5th parameter of UNITREAD and UNITWRITE) does not work as specified in the IV.0 internal archecture guide. You cannot suppress the automatic LF after a CR and you cannot suppress special character handling on input. There is no known object patch. 7) The printer driver expands tabs, it will not send chr ( 9 ). Instead it sends 8 spaces. This may be considered a "feature", but it is not done on any other version of the p-system that I know of and it causes real problems when you need an HT as a control character for your printer. You must send chr ( 128 + 9 ) instead or you may apply the patch listed below to fix the problem forever. These are the patches that you can make to the interpreter to solve some of these problems once and for all. Problem #1 System Crashes If your system crashes with an unimplemented instruction error anytime that you access the printer, you must patch the interpreter with a short Pascal program, shown below. Key this program into your computer, compile and execute it. This patch is necessary only in version II.0. {Printerfix modifies the interpreter so that the printer will work. This program was obtained from Softech Microsystems} {You must hard boot to bring in the new version of the interpreter} VAR F: FILE OF PACKED ARRAY [0..255] OF INTEGER; BEGIN RESET (F,'SYSTEM.PDP-11'); F^[66]:=F^[64]; F^[67]:=F^[65]; SEEK(F,0); PUT(F); CLOSE(F,LOCK); END. Problem #2 Printer Overflows If your printer goes berserk or loses data after a few lines or pages have been printed, then your interpreter and printer are not properly coordinating the transmission of data. One solution (the one most often used) is to set the baud rate of the serial printer port to a slow rate so that the computer cannot send data any faster than the printer can print it. However by doing this, you cannot run your printer at its maximum speed. Many serial printers will send an X-OFF character (most often a control- S) to the serial line when their internal buffers are nearly full. This character should be read by the computer and the computer should stop sending until the printer indicates that it is ready to receive more data by sending an X-ON character (most often a control-Q). The UCSD p-system ignores those control characters and keeps right on sending data to the printer. You can patch your interpreter to install a very short routine to cause your computer to respond to these characters. The patch is done with the UCSD utility PATCH. The patch can be done on both version II.0 and IV.0 interpreters. This patch was given to me by Eli Willner and is reproduced in part below (the original version is in NewsLetter #6). The patch described here was designed for the SYSTEM.PDP-11 configured for the EIS chip, using RX01 (distributed as LSI.EIS.RX). However, it will not be difficult to discover the appropriate addresses to patch in other versions on SYSTEM.PDP-11. The patch: 1) Make a backup copy of your entire system disk. Be sure to install the software bootstrap. (This is Very Important!). 2) Invoke the PATCH utility. G(et SYSTEM.PDP-11 and V(iew block 0 (which has already been read as a result of the G(et). 3) The assumption is made that the trap vector for the printer is at location 128 (decimal). Note the contents of location 128. In the version of SYSTEM.PDP-11 described above, the contents should be 4822. After noting the contents, change location 128 to C000. To do this, go to T(ype mode, position the cursor over location 128, enter H(ex mode and type C000. Type a control-c to accept the change. 4) Location 132 (decimal) should have the same original contents as 128. Change that location to C000 as well and Q(uit the type mode to re- enter the main command mode of PATCH. 5) You have just installed a jump to location 192 (decimal). This location contains the copyright message which you are going to overwrite with the routine to check for the X-ON/X-OFF characters. Make sure that location 192 really is the start of your copyright message. Do this by typing M(ixed and V(iewing the block. The first character of the copyright message should be visible at location 192. 6) Change the contents of locations 192-227 to the following: DFB5 8000 4CFF 0C03 DFA5 9300 4EFF 0802 DFB5 8000 4CFF FC03 DFA5 9100 4EFF F802 5F00 4822 7) Note the number that was formerly in locations 128 and 132 before they were changed. If is is NOT 4822 then change the last grouping of hex digits from 4822 to the number that you noted. This causes the patch to jump back to wherever the jump from 128 or 132 went. 8) The presumption is made that your printer sends the X-ON/X-OFF characters with the parity bit set. If your parity bit is cleared, then change the 9300 to 1300 and the 9100 to 1100. If your printer uses different handshake characters, install the approproate hex values instead the of the ones listed. 9) S(ave the block and re-boot your system. Your printer should not overflow any more. If the system crashes or your printer still overflows, carefully make sure that you typed the patch in correctly and make sure that your printer is sending the X-ON/X-OFF characters as control-Q/control-S. Problem #3 REMIN: troubles This patch was supplied by Peter A. Mason and is also published in newsletter #6. The remote port, REMIN:, strips the parity bit. If you just read ASCII data from REMIN: then you will never notice any trouble. But if you want to read 8 bit data from REMIN:, the loss of the 8th bit is a disaster. The patch to fix this is quite simple, you just have to locate and change only one byte in SYSTEM.PDP-11. 1) Make a backup copy of your entire system disk. Be sure to install the software bootstrap. (This is Very Important!). 2) Invoke the PATCH utility and G(et SYSTEM.PDP-11. R(read block 18 for version IV.0 or block 15 for version II.0. V(eiw the block. For IV.1 you may have to calculate the offset of the start of the REMOTE driver from the contents of the vector at 80 decimal (120 octal) in block 0, that is, unless that you have changed it. This value is the byte flipped hex address of the start of the REMIN: handler. Refer to the section on tab expansion for an explaintion on how to calculate the offset. 3) You are looking for the hex grouping FFC5 8000. Look through the block for this grouping. IF you calculate it from the value in the REMIN: vector, the offending word will be offset 14 bytes from the start of the handler. When you find it, enter T(ype mode and position the cursor over the 8 in 8000. Enter H(ex mode and type 00. Type control-C to make the change and the Q(uit type mode. S(ave the block and you are done. If you have any communications software which uses REMIN:, you should not notice any problems unless data is received with the parity bit set. Since the interpreter removed the parity bit, your communications software probably never assumed that the bit could be set. You may have to include a statement in your software to check if the ordinal value of received characters are above 127 and if they are you must subtract 128 from their ordinal value as shown below. if ord ( ch ) > 127 then ch := chr ( ord ( ch ) - 128 ) ); Problem #4 REMIN:/REMOUT: address and vector changes This patch was supplied by Eli Willner and is also published in NL#7. One of the consequences of the current unfortunate lack of an adaptable p- System for the LSI/PDP-11 computers, is the inablilty of the user to custom configure the device and vector addresses of the various Q-bus peripherals. Presently, the LSI/PDP-11 p-System has all vector and device addresses "hard-wired" to certain "standard" values. The user who requires different addresses (eg. the system may be running other operating systems >shudder< besides the p-System) has no recourse. This causes problems most frequently with the remote serial port, whose address are perhaps the least "standard" of Q-bus devices. Herewith, we describe a patch to SYSTEM.PDP-11 to allow the user to set the remote serial port device and vector addresses to whatever values are required. I am indebted to Walt Farrell for supplying this patch. We assume for purposes of illustration that the current device address is 177520 and the current vector address is 120 (the "standard" values) and it is desired to change the device address to 177570 and the vector address to 320. 1. Make a backup copy of your system disk, including SYSTEM.PDP-11. VERY IMPORTANT!!! 2. E(xecute the Patch utility, and G(et block 0 to the SYSTEM.PDP-11. 3. V(iew block 0. At the current vector location of 120 (octal), which is 80 (decimal), are 4 words containing the REMIN and REMOUT interrupt vectors. These consist of the REMIN interrupt address and its priority, followed by the REMOUT interrupt address and its priority. These values may differ from one version of SYSTEM.PDP-11 to another; in any case note them. For purposes of illustration, assume that these values to be 6424 8000 9C23 8000 in byte-flipped hex. 4. After noting the values, get into T(ype mode, and change all four words to zeros. 5. We are going to change the vector to 320 (octal), or 208 (decimal), so V(iew the value there in character mode. That location should be within the copyright notice. MAKE SURE THAT THE FOUR WORDS AT YOUR NEW VECTOR LOCATION ARE IN A "DEAD CODE" AREA OF THE INTERPRETER! If you neglect to do this, you may be wrecking some vital interpreter code. [Note that this patch location will interfere with the XON/XOFF patch described above. If you are using that patch, you will have to relocate it to some other "dead code" area, if you can find one. Good luck to you!] 6. Get into T(ype mode, and copy the four words you noted earlier to the area beginning at 203 (decimal) [in this example]. S(ave block 0 to disk. You have just completed the modification to the interrupt vector. 7. We must now modify the device address. Examine the first and third words of the four previously noted (the REMIN and REMOUT interrupt routine address, respectively) and find the lower of those two numbers. (This procedure is easiest if the values are first converted from byte-flipped hex to decimal.) In our example case, this value is 9C23, or 9116 (decimal). 8. This value must now be converted into a block number and offset into SYSTEM.PDP-11. Divide it by 512. The quotient is the block number; the remainder is the offset. In our example case we get block number 17, offset 412. 9. G(et block 17 and V(iew it. Subtract 44 from the remainder, yielding [in our example] 368. Examine byte 368 in block 17. It and the three words beyond it should contain 50FF 52FF 54FF 56FF in byte-flipped hex, which are 177520, 177522, 177524, 177526 (octal), the address of the REMOTE ports. 10. IF THESE ARE THE VALUES YOU GET (or the equivalent for your system) change the four words to 78FF 7AFF 7CFF 7EFF, which are 177570 177572 177574 177576 (octal) (or your equivalent). IF THESE ARE NOT THE VALUES YOU GET then you are at the wrong location in the interperter. Do NOT make any changes. If you did make a change and want to keep it, S(ave it to disk. Note: You must also change the jumpers or switches on your serial card to correspond to whatever vector and addresses you patch into your interpreter. Problem 4A. Getting your DLV-11J to work with the remote port. The problem with the DLV-11J is that three of the ports require contigous addresses and vectors. The "standard" UCSD printer address is 177510 and the "standard" remote address is 177520. These are already contigous so no problem occurs here. The problem is that the "standard" printer vector is 200 and the "standard" remote vector is 120. These are not contigous! The solution would seem easy, move the remote vector to 220, and all is well. Not so. DEC has done a number on you. If you investigate the problem in the Interfaces Handbook a little, you will realize that there are not enough pins available on the DLV-11J to put the address and vectors anywhere you want. The address must start on even 100's and the vectors must start on even 40's as the least significant bits of the fields are pre-set. However, the solution is still not too complicated. You must set port 0 of the DLV-11J at 177500 and the vector for that port at 200. Then port 1 comes at 177510 (for the printer) and port 2 comes at 177520 (for the remote). Port 3 is the independant port and is probably set at 177560, vector 60, for your console. The vector for port 1 is 210 (which will be your new printer vector) and the vector for port 2 is 220 (which will be your new remote vector). Note that if you have an RK05, you are out-of-luck at this point as the standard vector for the RK05 is also 220. Changing vectors is easy. It is all done in block 0 of your interpreter. First locate the printer vector at location 200 octal (128 decimal). Note the contents of the four words starting at 128 (decimal) and copy them into the four words immediatly following (starting at 136 decimal). This moves your printer vectors. Next, locate the contents of the four words starting at 120 octal (80 decimal). Copy these into the four locations starting at 144 decimal. This moves your remote vectors. If you have an RK05, this also wipes out its vectors, so don't expect it to work. You may also be able to move the vectors to 100, 110, and 120 octal without damaging anything. In this case you will only have to copy the printer vector as the remote vector is already in the right spot. Unfortunatly, 100 octal is your clock vector. This dissallows the use of port 0 of the DLV-11J as everytime it generates an interrupt, the clock will tick instead. If nothing is hooked to that port, you might get away with it, but I haven't tried it. (*$I patch.cont.text*) ======================================================================================== DOCUMENT :usus Folder:VOL19:procop.text ======================================================================================== .TITLE PROCEDURE OPERATORS .CSECT PROCOP .GLOBL CSPTBL ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; PROCEDURE OPERATORS ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; OLDSEG: .WORD ; SEG VALUE TO BE SAVED IN MSCW OLDSP: .WORD ; SP VALUE ABOVE LOADED CODE IN READIT READIT: ; END UP HERE IF SEGMENT IS NOT IN CORE...MAKE ROOM ; IN THE STACK AND READ IT. THEN FALL INTO CIP. MOV R0,R1 ASL R0 ; MULTIPLY BY 6 TO INDEX INTO SEGTBL ADD R1,R0 ASL R0 TST SEGTBL+4(R0) ; CHECK IF THERE IS CODE IN SEG BNE 1$ ; IF SO THEN WE CAN READ IT IN TRAP NOPROC ; ELSE BOMB FOR SYSTEM ERROR 1$: MOV SP,OLDSP ; SAVE TOP OF PARAM STACK FOR LATER SUB SEGTBL+4(R0),SP ; OPEN UP GAP LARGE ENOUGH FOR CODE MOV SP,R1 ; REMEMBER MEM ADDR FOR SYIORQ UREAD SEGTBL(R0),R1,SEGTBL+4(R0),SEGTBL+2(R0) MOV OLDSP,R1 ; RETRIEVE POINTER AT PARAM ON STACK MOV R1,R0 ; R0 MUST POINT AT THEM TST -(R1) ; NOW POINT R1 AT TOP WORD IN PROCTBL MOV R1,SEG ; WHICH IS THE NEW SEG POINTER VALUE CLR BK ; NOW OPEN EXTRA STACK SPACE FOR PARAMS... BISB @IPC,BK ; GET PROCEDURE NUMBER FROM CODE ASL BK ; DOUBLE FOR WORD INDEXING SUB BK,R1 ; R1 NOW POINTS AT PROCTBL(P#) SUB @R1,R1 ; R1 NOW POINTS AT JTAB FOR CALLED PROC SUB PARMSZ(R1),SP ; OPEN SOME SPACE FOR DUPLICATE PARAMS MOV #ENDCIP,BK ; AFTER XCLP...END UP IN CIP BR XCLP CXP: ; CALL EXTERNAL (OTHER SEGMENT) PROCEDURE GETNEXT ; GRAB SEGMENT # OF CALLED PROC BNE 4$ ; IF SEG 0 THEN FAST HANDLING MOV SEG,OLDSEG MOV @#MEMTOP,SEG BR 3$ 4$: CMPB @SEG,R0 ; ARE WE IN THAT SEGMENT ALREADY? BEQ CIP ; IF SO THEN DO A NORMAL CALL MOV SEG,OLDSEG ; HAVE TO FIND NEW SEG...SAVE OLD ONE MOV MP,R1 ; LOOK DOWN MSCW STAT LINKS FOR THE SEG 1$: CMPB @MSSEG(R1),R0 ; IS SEG IN MSCW THE ONE WE WANT? BEQ 2$ ; IF SO THEN GO CALL IT MOV MSDYN(R1),R1 ; ELSE LINK DOWN TO NEXT LEVEL CMP R1,@BASE ; HAVE WE REACHED THE OUTER BLOCK? BNE 1$ ; IF NOT THEN GO FOR NEXT LOOP BR READIT ; ELSE READ IN CODE FROM DISK 2$: MOV MSSEG(R1),SEG ; SET SEG POINTER TO REQUEST SEG 3$: MOV SP,R0 ; SET UP STUFF FOR CLP MOV #ENDCIP,BK ; RETURN TO CIP (VERY GENERAL PROC CALLS) BR XCLP ; AND CALL LOCAL PROC CLPERR: TSTB @SEG ; CHECK IF CALLING EXECERROR... BNE 1$ ; IF NOT SEG 0 THEN CANT BE CMPB @R1,#2 ; PROCEDURE # 2? BEQ NOCARE ; IF SO THEN DONT CARE ABOUT STCK OVER 1$: ADD DATASZ(R1),SP ; RESTORE STACK W/O DAMAGE HOPEFULLY TRAP STKOVR CLP: ; CALL LOCAL PROCEDURE MOV SEG,OLDSEG ; NO SEG CHANGE...SET UP TO SAVE CUR SEG MOV SP,R0 ; NO CODE...LEAVE R0 AT PARAM LIST XCLP: ; ENTER HERE FOR EXTERNAL CALLS...R0 AND OLDSEG DIFFERENT GETBYTE R1 ; GET PROCEDURE # ASL R1 ; CHANGE FOR WORD INDEXING NEG R1 ; ENSURE NEGATIVE SINCE SEGP IS ABOVE TABLE ADD SEG,R1 ; NOW R1 POINT AT SEGTABLE ENTRY FOR PROC SUB @R1,R1 ; NOW R1 POINTS AT JTAB FOR PROC SUB DATASZ(R1),SP ; OPEN UP HOLE IN STACK FOR LOCAL VARS CMP SP,NP ; SEE IF WE ARE OVERFLOWING INTO HEAP BLOS CLPERR ; AAAAUUUUGGGGHHH STACK OVERFLOW!!! NOCARE: TST -(SP) ; HOLE FOR FUTURE SP SAVE MOV IPC,-(SP) ; SAVE PROCESSOR STATE REGS MOV OLDSEG,-(SP) ; THUS BUILDING MSCW MOV JTAB,-(SP) MOV MP,-(SP) MOV MP,-(SP) MOV PARMSZ(R1),IPC ; NOW COPY PARAMS (IF ANY) BEQ 2$ ; IF NONE, THEN SKIP MESSINESS ASR IPC ; WAS NUMBER OF BYTES...NOW WORDS MOV SP,MP ; SET UP MP TO PARAM COPY PLACE ADD #MSDLTA+2,MP ; MP NOW POINTS ABOVE MSCW... 1$: MOV (R0)+,(MP)+ ; LOOP AND COPY EACH PARAM WORD SOB IPC,1$ 2$: MOV SP,MP ; NOW FINALLY POINT MP AT STAT LINK MOV MP,LASTMP ; SAVE THIS FOR EXECUTION ERROR MOV R0,MSSP(MP) ; STASH OLD SP VALUE MOV R1,JTAB ; NEW JUMP TABLE POINTER MOV R1,IPC ; SET UP CODE ENTRY POINT ADD #ENTRIC,IPC ; POINT IPC AT ENTRY OFFSET WORD SUB @IPC,IPC ; NOW IPC POINTS AT FIRST CODE BYTE MORE ; RETURN NOW CGP: ; CALL GLOBAL PROCEDURE MOV #ENDCGP,BK ; SET UP MAGIC RETURN BR CLP ; AND CALL LOCAL PROC ENDCGP: MOV BASE,@MP ; CHANGE STAT LINK TO BASE MOV #BACK,BK ; RESTORE REGS MORE CBP: ; CALL BASE PROCEDURE MOV #ENDCBP,BK BR CLP ENDCBP: MOV BASE,-(SP) ; ADD ON EXTRA MSCW WORD MOV @BASE,@MP ; POINT STAT LINK AT OUTER BLOCK MOV MP,BASE ; SET BASE REG TO THIS NEW PROC MOV BASE,STKBAS ; BE SURE TO UPDATE PERM BASE REG MOV #BACK,BK ; RESTORE MORE CIP: ; CALL INTERMEDIATE PROCEDURE MOV #ENDCIP,BK BR CLP ENDCIP: MOVB 1(R1),BK ; GRAB LEX LEVEL OF CALLED PROC BLE ENDCBP ; IF <= 0 THEN A BASE PROC CALL MOV MP,R0 ; NOW SEARCH DOWN DYN LINKS FOR PARENT 1$: MOV MSJTAB(R0),R1 ; GRAB JTAB SAVED IN MSCW CMPB 1(R1),BK ; COMPARE LEX LEVELS BLT 2$ ; IS IT LOWER? IF SO THEN FOUND PARENT MOV MSDYN(R0),R0 ; ELSE LINK DOWN TO CALLER OF CURRENT BR 1$ ; AND LOOP UNTIL FOUND 2$: MOV @R0,@MP ; SET UP FOUND STAT LINK MOV #BACK,BK ; RESTORE AND MORE RBP: ; RETURN FROM BASE LEVEL PROCEDURE MOV MSBASE(MP),BASE ; GET BASE FROM MSCW MOV BASE,STKBAS ; AND SAVE IN PERM WORD RNP: ; RETURN FROM NORMAL PROCEDURE MOV MSSP(MP),R0 ; POP OLD SP VALUE GETNEXT R1 ; GRAB # OF WORDS TO RETURN BEQ 2$ ; IF NONE THEN SKIP RETURN CODE ADD #MSDLTA+2,MP ADD R1,MP ; POINT MP ABOVE FUNCTION VALUE ADD R1,MP ; R1 IS WORDS 1$: MOV -(MP),-(R0) ; PUSH RETURN WORDS ONTO STACK SOB R1,1$ ; AND LOOP FOR TOTAL WORD COUNT MOV LASTMP,MP ; RESTORE OLD MP VALUE 2$: MOV MP,R1 ; NOW RESTORE STATE FROM MSCW TST (R1)+ ; CHUCK STAT LINK MOV (R1)+,MP ; DYNAMIC LINK MOV (R1)+,JTAB MOV (R1)+,SEG MOV (R1)+,IPC MOV MP,LASTMP MOV R0,SP ; NOW BACK IN STATE AT CALL TIME MORE CSP: ; CALL STANDARD PROCEDURE GETNEXT ; GET STANDARD PROC # ASL R0 ; SET FOR WORD INDEXING MOV CSPTBL(R0),PC ; TRANSFER TO PROPER SUBROUTINE IOC: ; IO CHECK TST @#IORSLT BEQ 1$ TRAP UIOERR 1$: MORE NEW: ; ALLOCATE DYNAMIC MEMORY CMP @#GDIRP,#NIL ; IS GLOB DIR NIL? BEQ 2$ MOV @#GDIRP,@#NP ; RELEASE ITS SPACE MOV #NIL,@#GDIRP ; ZAP CURRENT DIRECTORY BUFFER 2$: MOV (SP)+,R1 ; GET NUMBER OF WORDS INTO R1 MOV @#NP,R0 ; GET CURRENT HEAP TOP IN R0 MOV R0,@(SP)+ ; SET POINTER PARAM TO NEW MEM SPACE ADD R1,R0 ; POINT R0 ABOVE DYN MEM AREA ADD R1,R0 ; BYTE WISE MOV SP,R1 ; NOW CHECK FOR STK OVERFLOW SUB #40.,R1 ; GIVE A 20 WORD BUFFER ZONE CMP R0,R1 ; CHECK IF OVERLAPPING BLOS 1$ ; IF NEW HEAP TOP LOWER THEN OK TRAP STKOVR ; ELSE BOMB FOR STACK OVERFLOW 1$: MOV R0,@#NP ; SAVE NEW HEAP TOP MORE FLC: ; FILL CHAR INTRIN...KB GROSSNESS MOV (SP)+,R1 ; CHAR TO FILL WITH MOV @SP,BK ; # CHARS TO FILL BLE NOMOVE ; LEAVE TWO THINGS ON STACK IN THIS CASE TST (SP)+ ; NOW GET RID OF IT MOV (SP)+,R0 ; ADDRESS TO FILL INTO 1$: MOVB R1,(R0)+ ; FILL EACH CHAR W/ CHAR PARAM SOB BK,1$ BR XITMOV MVL: ; MOVE LEFT BYTES MOV (SP)+,BK ; GRAB # BYTES TO MOVE BLE NOMOVE ; QUIT IF LENGTH <= 0 MOV (SP)+,R1 ; GET DESTINATION ADDR MOV (SP)+,R0 ; GRAB SOURCE ADDRESS 1$: MOVB (R0)+,(R1)+ ; COPY BYTES SOB BK,1$ BR XITMOV NOMOVE: ; GO HERE FOR A BAD MOVE REQUEST CMP (SP)+,(SP)+ ; CHUCK ADDRESSES ON STACK XITMOV: MOV #BACK,BK MORE MVR: ; MOVE RIGHT BYTES MOV (SP)+,BK ; GRAB # BYTES TO MOVE RIGHT BLE NOMOVE ; QUIT IF <= 0 MOV (SP)+,R1 ; DESTATION ADDR MOV (SP)+,R0 ; SOURCE ADDR ADD BK,R0 ; POINT SOURCE AND DESTINATION ADD BK,R1 ; AT END OF THE ARRAYS 1$: MOVB -(R0),-(R1) ; BYTE COPY BACKWARDS SOB BK,1$ BR XITMOV XIT: ; EXIT PROCEDURE MOV JTAB,IPC ; FIRST SET IPC TO EXIT FROM CURRENT ADD #EXITIC,IPC ; PROC ... GET INFO FROM CUR JTAB SUB @IPC,IPC ; NOW IPC IS SET TO EXIT MY CALLER CMPB @JTAB,@SP ; IS IT THE PROC # TO EXIT ANYWAY? BNE XCHAIN ; IF NOT THEN CHAIN DYN LINKS TO FIND CMPB @SEG,2(SP) ; IF PROC OK, HOW ABOUT SEG#? BNE XCHAIN ; IF WRONG, THEN CHAIN DYN TOO CMP (SP)+,(SP)+ ; ELSE CHUCK STACK STUFF MORE ; AND DO THE RETURN CODE XCHAIN: MOV MP,R0 ; OK...START EXITING STACKED PROCS XLOOP: CMP R0,@BASE ; ARE WE ABOUT TO EXIT SYSTEM BLOCK? BEQ XBOMB ; IF SO THEN BIG BOOBOO MOV MSJTAB(R0),R1 ; ELSE OK...GRAB JTAB AND FUDGE MS IPC ADD #EXITIC,R1 ; TO EXIT CODE RATHER THAN NORMAL REENTRY SUB @R1,R1 ; R1 NOW HAS EXIT POINT IPC MOV R1,MSIPC(R0) ; SO PLACE IN STACK FRAME CMPB @MSJTAB(R0),@SP ; IS THIS THE PROC# TO EXIT FROM? BNE 1$ ; IF NOT THEN GO TO NEXT CALLED PROC CMPB @MSSEG(R0),2(SP); AND RIGHT SEG# BNE 1$ CMP (SP)+,(SP)+ ; WELL, FOUND IT...CHUCK PARAMS MORE ; AND FALL OUT OF PROC 1$: MOV MSDYN(R0),R0 ; CHAIN DOWN DYNAMIC LINKS! BR XLOOP XBOMB: TRAP NOEXIT ;TREESEARCH (TREEROOTP, VAR FOUNDP, VAR TARGETNAME) ;-SEARCHS A BINARY TREE, EACH OF WHOSE NODES CONTAIN ; AT LEAST THE FOLLOWING COMPONENTS, IN ORDER SHOWN: ; A) CODEWD: ALPHA (8 CHAR NODE NAME) ; B) RLINK: CTP (POINTER TO RIGHT SUBTREE) ; C) LLINK: CTP (POINTER TO LEFT SUBTREE) ;-RETURNS POINTER TO TARGET NODE THROUGH CALL BY NAME PARA- ; METER AND DESCRIPTION OF SEARCH RESULTS AS INTEGER FUNCTION ; VALUE WITH 3 POSSIBLE VALUES: ; A) 0: TARGET NAME WAS FOUND; FOUNDP POINTS TO IT ; B) 1: NO MATCH; TARGET > LEAF NODE; FOUNDP => LEAF ; C) -1: NO MATCH; TARGET < LEAF NODE; FOUNDP => LEAF ;-ROOT POINTER ASSUMED TO BE NON NIL. TRS: MOV (SP)+,R0 ; GET ADDR OF TARGET NAME MOV 2(SP),R1 ;GET ROOT OF TREE TRLOOP: CMP @R0,@R1 ;FIRST WORD COMPARE BNE TRNEXT CMP 2(R0),2(R1) BNE TRNEXT CMP 4(R0),4(R1) BNE TRNEXT CMP 6(R0),6(R1) BNE TRNEXT MOV R1,@(SP)+ ;FOUND IT! TELL USER WHERE CLR @SP ;RETURN ZERO VALUE MORE TRNEXT: BHI TRRIGHT ;WHICH SUBTREE NEXT? BIT #177776,12(R1) ;LEFT- IS IT NIL? BNE NEXTL ;NOPE, CARRY ON MOV R1,@(SP)+ ;YES- RETURN POINTER MOV #177777,(SP) ;AND FUNCTION VALUE MORE NEXTL: MOV 12(R1),R1 ;ON TO POSTERITY BR TRLOOP TRRIGHT:BIT #177776,10(R1) ;RIGHT TREE NIL? BNE NEXTR MOV R1,@(SP)+ ;POINTER MOV #1,(SP) ;AND FUNCTION VALUE MORE NEXTR: MOV 10(R1),R1 ;POSTERITY AGAIN... BR TRLOOP ;IDSEARCH(SYMCURSUR[START OF SYM INFO BUFF],SYMBUF[SOURCE BUF]) ;ORDER OF SYMBOL INFO BLOCK IS ; A) SYMCURSUR (POINTER IN SYMBOLIC BUFFER) ; B) SY (SYMBOL) ; C) OP (OPERATOR) ; D) IDCODE (8 CHAR ID NAME) ;IDSEARCH EXITS WITH SYMCURUSR UPDATED TO POINT TO THE END OF ;NEXT ID. SY AND OP DESCRIBE THE TOKEN FOUND, AND IDCODE CON- ;TAINS THE FIRST 8 CHARACTERS (BLANK FILLED) IF TOKEN WAS AN IDENT- ;TIFIER. ;ON ENTRY, SYMCURUSR POINTS TO FIRST CHARACTER OF ID, WHICH ;IS ASSUMED TO BE ALPHABETIC. ALSO ON ENTRY, TOS-1 IS ADDRESS OF ;SYMCURSUR AND TOS IS ADDR OF SYMBUF IDS: MOV (SP)+,R0 ;GET ADDR OF BUFFER ADD @(SP),R0 ;CALC INDEXED BUFFER ADDR MOVB (R0)+,R1 ;FIRST CHAR OF ID ASL R1 ; DOUBLE CHAR ORD FOR WORD INDEX MOV RWLOOK-'A-'A(R1),R1 ; POINTS R1 AT START OF RW'S MOV R0,-(SP) ; REMEMBER SECOND LETTER ADDRESS RWLOOP: MOVB (R1)+,BK ;GET LENGTH OF REWORD BEQ NORW ;0 SIGNALS END OF LIST 1$: CMPB (R0)+,(R1)+ ;COMPARE..STARING AT SECOND BYTE BNE NEXTRW ;EQUAL? SOB BK,1$ MOVB @R0,BK ; GRAB FOLLOWING CHAR IN SYMBUF CMPB BK,#'0 BLO GOTRW CMPB BK,#'Z BHI GOTRW CMPB BK,#'A BHIS 2$ CMPB BK,#'9 BHI GOTRW 2$: ADD #2,R1 ;NO--POINT TO START OF NEXT RW MOV @SP,R0 ;RESTORE SOURCE POINTER BR RWLOOP ;AND TRY NEXT GUY NEXTRW: ADD BK,R1 ;BUMP TO NEXT RW INC R1 ;EXACTLY MOV @SP,R0 ;RESTORE SOURCE POINTER BR RWLOOP GOTRW: SUB (SP)+,R0 ; R0 HAS LENGTH-1 OF RW NOW MOV (SP)+,BK ; BK HAS SYMCURSOR ADDR NOW ADD R0,(BK)+ ; BUMP SYMCURSOR...BK -> SY MOVB (R1)+,@BK ; PUT SY VALUE IN COMP STACK MOVB (R1)+,2(BK) ; AND OP VALUE TOO MOV #BACK,BK MORE NORW: MOV @SP,R0 ; ADDR OF SECOND LETTER IN SYMBUF AGAIN 1$: MOVB (R0)+,R1 ; GRAB EACH LETTER UNTIL DELIM FOUND CMPB R1,#'0 BLO 2$ CMPB R1,#'Z BHI 2$ CMPB R1,#'A BHIS 1$ CMPB R1,#'9 BLOS 1$ 2$: SUB #2,R0 ; POINT R0 AT LAST CHAR IN ID MOV (SP)+,R1 ; GRAB SECOND LETTER ADDR MOV (SP)+,BK ; AND SYMCURSORS ADDR DEC R1 ; POINT R1 @ FIRST CHAR IN SYMBUF ID SUB R1,R0 ; R0 IS # CHARS IN ID-1 ADD R0,(BK)+ ; BUMP SYMCURSOR TO LAST CH IN ID CLR (BK)+ ; SY := IDENT (A ZERO) MOV #15.,(BK)+ ; OP := NOOP INC R0 ; NOW R0 IS TOTAL # CHARS IN ID CMP R0,#8. ; IS ID TOO LONG? BLT 3$ MOV #8.,R0 ; IF SO THEN COPY MAX 8 CHARS BR 4$ 3$: MOV #" ,@BK ; ELSE BLANK ENTIRE ID FIELD MOV (BK)+,@BK MOV (BK)+,@BK MOV (BK)+,@BK SUB #6.,BK ; RESET BK TO ITS START AND 4$: MOVB (R1)+,(BK)+ ; COPY R0 COUNT OF CHARS INTO ID SOB R0,4$ MOV #BACK,BK MORE ;MACROS FOR RESERVED WORD TABLE .MACRO RW NAME,SY,OP .NCHR NUMCH,NAME .BYTE NUMCH .ASCII /NAME/ .BYTE SY .IF NB,OP .BYTE OP .IFF .BYTE 15. ;NOOP CHARACTER .ENDC .ENDM RW .MACRO RWENT CHAR .BYTE 0 ;TERMINATE PREVIOUS LIST OF IDS IDS.'CHAR = . .ENDM RWENT RWENT A RW ND,39.,2. RW RRAY,44. RWENT B RW EGIN,19. RWENT C RW ASE,21. RW ONST,28. RWENT D RW IV,39.,3. RW O,6. RW OWNTO,8. RWENT E RW LSE,13. RW ND,9. RWENT F RW OR,24. RW ILE,46. RW ORWARD,34. RW UNCTION,32. RWENT G RW OTO,26. RWENT I RW F,20. RW N,41.,14. RWENT L RW ABEL,27. RWENT M RW OD,39.,4. RWENT N RW OT,38. RWENT O RW F,11. RW R,40.,7. RWENT P RW ACKED,43. RW ROCEDURE,31. RW ROGRAM,33. RWENT R RW ECORD,45. RW EPEAT,22. RWENT S RW ET,42. RW EGMENT,33. RWENT T RW HEN,12. RW O,7. RW YPE,29. RWENT U RW NTIL,10. RWENT V RW AR,30. RWENT W RW HILE,23. RW ITH,25. RWENT Z .BYTE 0 ;FOR UNUSED LETTERS .EVEN RWLOOK: .IRPC X,ABCDEFGHIJKLMNOPQRSTUVWXYZ .IF DF,IDS.'X .WORD IDS.'X .IFF .WORD IDS.Z .ENDC .ENDR TIM: ; RETURN TIME OF DAY WORDS MOV LOTIME,@(SP)+ MOV HITIME,@(SP)+ MORE SCN: ; SCAN ARRAY TST (SP)+ ; EXTRA MASK PARAM...NOT USED YET MOV @SP,R0 ; GRAB ADDR TO START SCAN MOV 2(SP),BK ; CHAR TO SCAN FOR MOV 6(SP),R1 ; LENGTH TO SCAN FOR BEQ NOTFND ; IF NULL SCAN THEN RETURN 0 BMI BCKSCN ; IF NEGATIVE THEN BACKWARD SCAN TST 4(SP) ; ELSE FORWARD SCAN...CHECK RELOP BNE 2$ ; NEQ 0 MEANS NEQ SCAN 1$: CMPB (R0)+,BK ; ELSE EQUAL COMPARE BYTES BEQ 3$ ; UNTIL ONE IS EQUAL SOB R1,1$ BR NOTFND 2$: CMPB (R0)+,BK ; DO NEQ COMPARE BNE 3$ SOB R1,2$ BR NOTFND 3$: DEC R0 ; POINT R0 AT CHAR FOR FIX.R0 FIX.R0: SUB (SP)+,R0 ; MAKE R0 THE DISPLACEMENT FROM SCAN START CMP (SP)+,(SP)+ ; CHUCK CHAR & RELOP PARAMS MOV R0,@SP ; RETURN DISP ON TOS MOV #BACK,BK MORE BCKSCN: NEG R1 ; MAKE A NUMBER SUITABLE FOR SOB OP INC R0 ; PRE-DEC SETTUP TST 4(SP) ; CHECK OP TYPE BNE 2$ 1$: CMPB -(R0),BK ; SCAN BACKWARD EQUAL COMPARE BEQ FIX.R0 ; WHEN FOUND THEN RETURN DISP SOB R1,1$ BR NOTFND 2$: CMPB -(R0),BK BNE FIX.R0 SOB R1,2$ NOTFND: MOV 6(SP),R0 ; RETURN SCAN LENGTH IN THIS CASE ADD @SP,R0 ; THAT SIGNIFIES UNSUCCESSFUL SCAN BR FIX.R0 TRC: ; REAL TRUNCATE JSR R4,ENTFP .WORD $RI,XITFP RND: ; REAL ROUND MOV @SP,R0 ; GET SIGN WORD OF PARAM TO ADD + OR - .5 CLR -(SP) ; LOW ORDER REAL 0.5 MOV #100000,-(SP) ; HIGH ORDER SHIFTED ONE LEFT ROL R0 ; SHIFT SIGN OF PARAM INT.O C-BIT ROR @SP ; AND PLACE IN SIGN OF THE 0.5 .IF DF,FPI FADD SP .ENDC JSR R4,ENTFP .IF NDF,FPI .WORD $ADR .ENDC .WORD $RI,XITFP SINCSP: ; REAL SINE JSR R4,ENTFP .WORD CALJR5,SIN COSCSP: ; REAL COSINE JSR R4,ENTFP .WORD CALJR5,COS LOGCSP: ; BASE-10 LOGARITHM JSR R4,ENTFP .WORD CALJR5,ALOG10 ATNCSP: ; REAL ARCTANGENT JSR R4,ENTFP .WORD CALJR5,ATAN LNCSP: ; NATURAL LOGARITHM JSR R4,ENTFP .WORD CALJR5,ALOG EXPCSP: ; EXPONENTIAL FUNCTION JSR R4,ENTFP .WORD CALJR5,EXP SQTCSP: ; REAL SQUARE ROOT JSR R4,ENTFP .WORD CALJR5,SQRT CALJR5: ; THIS SUBROUTINE MAGICALLY CALLS FPMP STUFF MOV SP,1$ ; PUT REAL PARAM ADDR INTO CODE JSR R5,@(R4)+ ; ENTER THE ROUTINE DESIRED BR 2$ ; PLEASE SEE CALL SEQUENCE IN FPMP DOC 1$: .WORD ; ADDR OF PARAM GOES HERE 2$: MOV R1,2(SP) ; PUT LOW ORDER RESULT IN STACK MOV R0,@SP ; AND THEN HIGH ORDER JMP XITFP ; FINALLY EXIT MRK: ; MARK HEAP CMP @#GDIRP,#NIL ; IS THE GLOB DIR NIL? BEQ 1$ MOV @#GDIRP,@#NP MOV #NIL,@#GDIRP 1$: MOV @#NP,@(SP)+ ; SAVE TOP OF HEAP IN POINTER PARAM MORE RLS: ; RELEASE HEAP MOV @(SP)+,@#NP ; CUT BACK HEAP POINTER MOV #NIL,@#GDIRP ; ZAP GLOBAL DIR THING MORE IOR: ; RETURN IO RESULT MOV @#IORSLT,-(SP) MORE ;. BUILD A POWER OF TEN TABLE EXPON = 0 .MACRO PWR10 EXP .FLT2 1.0E'EXP .ENDM TENTBL: .REPT 38. PWR10 EXPON EXPON = EXPON+1 .ENDR POT: ; POWER OF TEN MOV (SP)+,R0 ; GET POWER DESIRED BMI BADPOT ; NO NEGATIVE POWER ALLOWED CMP R0,#EXPON ; SEE IF INDEX IS TOO BIG BGE BADPOT ; CROAK FOR THAT TOO ASL R0 ; ELSE MAKE A REAL ARRAY INDEX ASL R0 ; MULTIPLY BY 4 MOV TENTBL+2(R0),-(SP) ; LOW ORDER WORD MOV TENTBL(R0),-(SP) ; AND HIGH ORDER WORD MORE BADPOT: TRAP INVNDX HLT: ; HALT AND/OR BREAKPOINT...EXECERROR KNOWS MOV (PC)+,@BK ; STASH TRAP HLTBPT INTO OP FETCH TRAP HLTBPT MORE UBUSY: JSR R4,ENTFP .WORD BSYSTRT,IOSTRT,BSYTST,CHKERR,IODONE UWAIT: JSR R4,ENTFP .WORD WATSTRT,IOSTRT,BSYWAIT,CHKERR,IODONE UCLEAR: JSR R4,ENTFP .WORD WATSTRT,IOSTRT,CLRUNT,IODONE UREAD: JSR R4,ENTFP .WORD IOSTRT,INMODE,BSYWAIT,CHKERR,STRTIN .WORD CHKWAIT,BSYWAIT,CHKERR,IODONE UWRITE: JSR R4,ENTFP .WORD IOSTRT,OUTMODE,BSYWAIT,CHKERR,STRTOUT .WORD CHKWAIT,BSYWAIT,CHKERR,IODONE ; BELOW ARE THE THREAD MODULES FOR THE ABOVE ; OPERATIONS.. IT IS SUGGESTED THAT YOU LOOK ; HERE BEFORE TRYING TO FIGURE OUT THE INTERRUPT ; HANDLER INTERFACE TO THIS SECTION. BSYSTRT:MOV (SP),-(SP) ; DUPL UNIT# PARAM CLR 2(SP) ; SHOVE A FALSE INTO STACK FOR RETURN WATSTRT:SUB #8.,SP ; MAKE STACK LOOK OK FOR IODONE JMP @(R4)+ ; AND ONWARD WE GO BSYTST: TST (R1) ; SEE IF UNIT IS IN FACT BUSY BPL THRUR4 ; IF NOT, CONTINUE SEQUENCE INC (SP) ; SET RETURN VALUE TO 1 (TRUE) BR IODONE ; AND QUIT NOW CLRUNT: JSR PC,@4(R1) CLRB @R1 JMP @(R4)+ IOSTRT: CLR R5 ; ERROR REGISTER, NO ERROR YET MOV UUNIT(SP),R1 ; GRAB RAW UNIT # BLE 1$ ; IF <= ZERO, GIVE BADUNIT ERROR CMP R1,#MAXUNT ; SEE IF NUMBER IS TOO BIG BGT 1$ ; UNITBL INDEXED 1..MAXUNT ASL R1 ; ITS OK, MULTIPLY BY 6 ADD UUNIT(SP),R1 ASL R1 ; TO GET AN ACTUAL ADDR IN ADD #UNITBL,R1 ; UNITBL, R1 NOW IS ABS ADDR OF UNIT BIT #INBIT!OUTBIT,@R1 BEQ 1$ ; IF NOT IO ALLOWED AT ALL THEN ERROR JMP @(R4)+ ; SO CONTINUE WITH SEQUENCE 1$: MOV #UNTERR,R5 ; ERROR RESULT FOR JUNK UNIT # ; AND FALL INTO IO DONE IODONE: MOV R5,@#IORSLT ; GIVE ANY ERROR RESULTS TO SYSTEM ADD #10.,SP ; GET RID OF PARAMS ON STACK JMP XITFP ; AND RETURN TO PROGRAM INMODE: BIT #INBIT,(R1) ; SEE IF INPUT ALLOWED ON THE UNIT MODTST: BNE THRUR4 ; IF ONE BIT, THEN GO AHEAD MOV #MODERR,R5 ; ELSE GIVE BAD MODE ERROR BR IODONE OUTMODE:BIT #OUTBIT,(R1) ; SEE IF OUTPUT ALLOWED ON UNIT BR MODTST ; AND SKIP TO ACTUAL TEST CODE BSYHANG:MTPS #0 ; ENSURE LOW PRIORITY BEFORE WAIT WAIT ; WAIT UNTIL AN INTERRUPT OCCURS BSYWAIT:MTPS #340 ; NO INTERRUPTS IN HERE...TIMING PROBS TST (R1) ; HIGH ORDER BIT TELLS IF BUSY BMI BSYHANG ; SO WAIT AROUND UNTIL THE BIT IS OFF MTPS #0 ; OK...ALLOW INTERRUPTS THRUR4: JMP @(R4)+ ; CONVENIENT LOCATION FOR CONDITIONAL JMP CHKERR: TSTB (R1) ; LOW BYTE IS HARD IO RSLT BEQ THRUR4 ; IF NO ERROR, THEN KEEP GOING MOVB (R1),R5 ; ELSE GIVE TO IORSLT AND QUIT NOT CLRB (R1) ; BE SURE TO CLEAR UNIT OR SYSTEM BOMB BR IODONE CHKWAIT:BIT #1,UNOWAIT(SP) ; SEE IF USER WANTS TO WAIT FOR IO BNE IODONE ; IF PARAM IS TRUE, THEN GO BACK TO CALLER JMP @(R4)+ ; ELSE D.O BUSYWAIT ETC STRTIN: JSR R3,@2(R1) ; JUMP INTO INTERRUPT HANDLER TO START IO .WORD 1 ; ONE HERE SAYS READ OP JMP @(R4)+ STRTOUT:JSR R3,@2(R1) ; JUMP TO INTERRUPT HANDLER .WORD 0 ; ZERO MEANS WRITE OP JMP @(R4)+ ; AND CONTINUE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; SYIORQ: ; THIS CODE IS FOR SYSTEM IO REQUESTS VIA UREAD AND ; UWRITE MACROS...NO PARAM CHECKING IS DONE ; AND ALL IO'S MUST BE SYNCHRONOUS (I DIDNT WANT TO BOTHER) MOV (SP)+,SYIOR1 ; SAVE OLD R1 VALUE MOV R3,SYIOR3 ; AND R3 (ALL OTHERS SAVED BY CONVENTION) MOV (R1)+,IOTYPE ; SAVE THE READ OR WRITE WORD FOR HANDLERS MOV R1,XTSYIO ; SAVE RETURN ADDRESS MOV UUNIT(SP),R1 ; GET UNIT # ASL R1 ; MULTIPLY BY 6 ADD UUNIT(SP),R1 ASL R1 ; FOR UNIT(*) INDEX ADD #UNITBL,R1 ; R1 SHOULD BE ABS ADDR OF UNIT ENTRY JSR R3,@2(R1) ; ENTER HANDLER FOR PARTICULAR UNIT IOTYPE: .WORD 0 ; 0 OR 1 STORED HERE 1$: TST (R1) ; NOW WAIT UNTIL UNIT IS NOT BUSY BMI 1$ ; BUSY WAIT UNTIL IO IS COMPLETE TSTB @R1 ; CHECK IO RESULT FOR UNIT BEQ 2$ TRAP SYIOER ; BOMB SYSTEM IO ERROR 2$: MOV (PC)+,R1 ; RESTORE REGISTERS...FI.RST R1 SYIOR1: .WORD MOV (PC)+,R3 ; RESTORE R3 SYIOR3: .WORD ADD #12,SP ; CHUCK PARAMETERS MOV (PC),PC ; AND RETURN IN A KLUDGY MANNER XTSYIO: .WORD 0 ; RETURN ADDR STORED HERE ; HERE WE STICK A FEW MISCELLANEOS THINGS DIV: .IF DF,EIS MOV R1,DENOM ; STASH DENOM INTO OP FIELD ASHC #-16.,R0 ; SHIFT R0 INTO R1 WITH SIGN EXT DIV (PC)+,R0 ; PERFORM DIVID OP DENOM: .WORD 0 ; DENOMINTOR GOES HERE BCC 1$ ; C-BIT IS ON FOR DIV BY ZERO TRAP DIVZER 1$: RTS PC .IFF CLR -(SP) ;CLEAR SIGN FLAG TST R1 ;EXAMINE DENOMINATOR BGT 1$ ;PLUS BNE 3$ ;GIVE EXECERR IF DIV 0 TRAP DIVZER 3$: INC (SP) ;REMEMBER IF NEGATIVE NEG R1 ;AND MAKE IT POS 1$: TST R0 ;TEST NUMERATOR BGT 2$ ;PLUS? BNE 4$ ;NOT ZERO, THEN HAVE TO DO WORK CLR BK ;MAKE REMAINDER ZERO TST (SP)+ ;THROW AWAY SIGN INFORMATION BR DONED ;AND THEN JUMP TO END 4$: INC (SP) ;ELSE NEGATIVE NEG R0 2$: MOV #8.,-(SP) ;8 ITERATIONS CLR BK ;HIGH ORDER DIVIDEND SWAB R0 ;ANY HIGH ORDER NUMERATOR? BEQ DIVD ;NO, THEN PROCEED TO DIVIDE ASL @SP ;ELSE NEED 16 ITERATIONS SWAB R0 ;AND RESTORE NUMERATOR DIVD: ASL R0 ;DOUBLE DIVIDEND ROL BK BEQ LOP ;JUMP IF NO CHANCE THIS TIME INC R0 ;QUOTIENT BIT SUB R1,BK ;TRIAL STEP BHIS LOP ;OK ADD R1,BK ;DIVIDEND NOT BIG ENOUGH DEC R0 ;RETRACT QUOTIENT BIT LOP: DEC @SP ;COUNT THIS LOOP BGT DIVD ;CONTINUE TIL DONE NEG R0 ;NEGMAX CHECK TST (SP)+ ASR (SP)+ ;GET SIGN OF QUOTIENT BCS DONED ;JUMP IF NEG NEG R0 ;ANSWER POSITIVE BVS OVR ;GIVE OVERFLOW ERROR DONED: MOV BK,R1 ;REMAINDER IN R1 MOV #BACK,BK RTS PC .ENDC .IF DF,EIS MLI: MUL R0,R1 MOV R1,R0 ; EXPECTS RESULTS IN R0 RTS PC .IFF OVR: TRAP INTOVR MLI: CLR -(SP) ; SIGN STORAGE TST R1 ;CHECK MULTIPLICAND BGT 1$ ;SKIP FOLLOWING IF + BEQ ZEROM ;ANSWER IS ZERO INC @SP ;REMEMBER - NEG R1 1$: TST R0 ;TEST MULTIPLIER BGT 2$ BEQ ZEROM INC @SP NEG R0 2$: MOV #8.,-(SP) ; SET UP ITERATION COUNT CMP R1,R0 ;MAKE SURE BGE CLR ;MULTIPLIER MOV R1,BK ;IS MOV R0,R1 ;SMALLER MOV BK,R0 CLR: CLR BK ;CLEAR HIGH ORDER PRODUCT MUL: ROR BK ;SHIFT PRODUCT ROR R0 BCC CYC ;MULTIPLIER BIT = 0? ADD R1,BK ;NO,ADD IN MULTIPLICAND CYC: DEC @SP ;COUNT LOOP BGT MUL TST (SP)+ TSTB R0 ;TEST HIGH MULTI BNE OVR ;ERROR .IF MULTIPLIER NOT GONE BISB BK,R0 ;MOVE PRODECT RIGHT SWAB R0 CLRB BK SWAB BK ASR BK ;ONE MROE SHIFT BNE OVR ;PRODUCT EXCEEDED 15 BITS ROR R0 NEG R0 ;MAKE NEG BPL OVR ;TOO BIG ROR (SP)+ ;DETERMINE SIGN OF PRODUCT BCS OUTM NEG R0 ;SHOULD BE + BVS OVR OUTM: MOV #BACK,BK RTS PC ZEROM: CLR R0 TST (SP)+ BR OUTM ;AND CLEAN UP .ENDC CSPTBL: .WORD IOC .WORD NEW .WORD MVL .WORD MVR .WORD XIT .WORD UREAD .WORD UWRITE .WORD IDS .WORD TRS .WORD TIM .WORD FLC .WORD SCN .IF DF,TERAK .WORD DRAWLINE .WORD DRAWBLOCK .IFF .WORD 0,0 .ENDC .WORD 0,0,0,0,0,0,0,0,0 .WORD TRC .WORD RND .WORD SINCSP .WORD COSCSP .WORD LOGCSP .WORD ATNCSP .WORD LNCSP .WORD EXPCSP .WORD SQTCSP .WORD MRK .WORD RLS .WORD IOR .WORD UBUSY .WORD POT .WORD UWAIT .WORD UCLEAR .WORD HLT .CSECT TABLES .BLKW 30. .WORD CSP .BLKW 14. .WORD RNP .WORD CIP .BLKW 18. .WORD RBP .WORD CBP .BLKW 10. .WORD CXP .WORD CLP .WORD CGP .BLKW 48. .END ======================================================================================== DOCUMENT :usus Folder:VOL19:pvm.mac.text ======================================================================================== .TITLE VM p-System KT11 Disk Driver ; ; Submitted to the USUS Library by Eliakim Willner ; USUS DEC SIG Chairman ; .ENABL LC ; p-System KT11 Disk Driver ; For Version II.0 Interpreters ; .SBTTL General comments ; "Faster than a speeding bullet..." ; -Clark Kent ;+ ; VM.MAC is a handler to access extended memory on PDP 11's with the ; KT11 memory management unit as a disk device. ; ; This handler was originally written by DEC personnel and contributed ; by DEC to DECUS. It was adapted to the p-System by Eliakim Willner. ; ; Author: ; RB 01-May-75 ; With random assistance from A(C and HJ ; ; Edits: ; CG 15-Aug-79 V04 format and bootstrap ; EGW 31-Dec-82 p-System Version II.0 adaptation ;- .ASECT .=250 VMINT 340 .CSECT TABLES .BLKW 128. .REPT 11. .BLKW 3 .ENDR .WORD INBIT!OUTBIT,VMSTRT,VMABRT .CSECT VMDRVR VMUNIT: .WORD 0 VMOFST = 14 DUMCSW: .WORD .WORD DUMCSW DUMIOQ: .WORD .WORD .WORD .WORD .WORD 1 VMSTRT: TST VMUNIT BNE VMSTRT MOV R1,VMUNIT BIS #BSYBIT,@R1 TST (R3)+ MOV R3,@SP MOV R0,-(SP) MOV R1,-(SP) MOV R2,-(SP) MOV R4,-(SP) MOV R5,-(SP) CLR DUMCSW MOV #DUMIOQ,R5 MOV (SP),(R5)+ MOV @R1,(R5)+ MOV (SP),(R5)+ MOV (SP),R0 ROR R0 TST -(R3) BNE 1$ NEG R0 1$: MOV R0,(R5)+ JSR PC,QENTRY MOV (SP)+,R5 MOV (SP)+,R4 MOV (SP)+,R2 MOV (SP)+,R1 MOV (SP)+,R0 MOVB DUMCSW,@R1 JMP @(SP)+ $INTEN: MOV R4,-(SP) JSR PC,@R5 MOV (SP)+,R4 MOV (SP)+,R5 JMP @#INTRTN VMQUIT: MOVB DUMCSW,@VMUNIT BIC #BSYBIT,@VMUNIT CLR VMUNIT RTS PC VMABRT: TST VMUNIT BNE VMABRT RTS PC .SBTTL Macros and Definitions ; Memory management registers MMSR0 = 177572 ;STATUS REG 0 MMSR1 = 177574 ;STATUS REG 1 MMSR2 = 177576 ;STATUS REG 2 MMSR3 = 172516 ;STATUS REG 3 UISDR0 = 177600 ;USER I DESC REG 0 UISDR7 = 177616 ;USER I DESC REG 7 UISAR0 = 177640 ;USER I ADDR REG 0 UISAR7 = 177656 ;USER I ADDR REG 7 KISDR0 = 172300 ;KERNEL I DESC REG 0 KISDR7 = 172316 ;KERNEL I DESC REG 7 KISAR0 = 172340 ;KERNEL I ADDR REG 0 KISAR7 = 172356 ;KERNEL I ADDR REG 7 ; Miscellaneous definitions V.TRP4 = 4 ;Trap to 4 vector PS = 177776 ;PROCESSOR STATUS WORD UMODE = 140000 ;CURRENT MODE = USER (IN PS) ADRS22 = 000020 ;22-BIT ADDRESSING MODE FOR 11/70 PUMODE = 030000 ;PREVIOUS MODE = USER MODE (IN PS) .SBTTL Driver entry .ENABL LSB VMCQE: .WORD DUMIOQ QENTRY: MOV VMCQE,R3 ;R3 -> QUEUE ELEMENT MOV (R3)+,R2 ;R2 = BLOCK NUMBER ASL R2 ASL R2 ASL R2 ;R2 = VM MEMORY BLOCK # ADD #1600,R2 ; + 28K WORDS CLR R4 ;R4 = MEMORY BLK # MOV #UISAR0,R1 ;R1 -> USER I ADDRESS REGS MOV #8.,R0 ;8 REGS TO LOAD 1$: MOV #77406,UISDR0-UISAR0(R1) ;LOAD USER DESC REG MOV #77406,KISDR0-UISAR0(R1) ;LOAD KERNEL DESC REG MOV R4,KISAR0-UISAR0(R1) ;LOAD KERNEL I ADDR REG MOV R4,(R1)+ ;AND USER I ADDR REG ADD #200,R4 ;BUMP ADDR BY 4K SOB R0,1$ ;AND LOOP TO SET UP ALL 8 MOV R2,-(R1) ;MAP VM BLK OVER USER I/O PAGE MOV #37406,@#UISDR7 ;WITH A LENGTH OF 2K WORDS MOV #177600,@#KISAR7 ;MAP I/O PAGE TO KERNEL MOV #160000,R5 ;R5 -> BASE OF I/O PAGE VMHPAT: NOP ;NOMODE22 ;Filler NOP ;NOMODE22 NOP ;NOMODE22 ; BIS #ADRS22,@#MMSR3 ;MODE22 ;SET 22-BIT MODE FOR 11/70 BIS #UMODE,@#PS ;GO INTO USER MODE BIS #1,@#MMSR0 ;ENABLE MANAGEMENT TST (R3)+ ;SKIP UNIT NUMBER IN Q ELEMENT MOV (R3)+,R0 ;R0 = BUFFER ADDRESS MOV @R3,R4 ;R4 = WORD COUNT BMI VMWRT ;IF NEGATIVE, WRITE REQUEST BEQ VMTRAP ;IF SEEK THEN DONE IMMEDIATELY INC R4 ;FOLD WORD COUNT TO SPEED TRANSFER ASR R4 BCC 2$ VMREAD: MOV (R5)+,(R0)+ ;COPY TO USER BUFFER 2$: MOV (R5)+,(R0)+ SOB R4,VMREAD ;LOOP UNTIL TRANSFER COMPLETE BR VMTRAP ;THEN GO TO COMMON EXIT VMWRT: NEG R4 ;MAKE WORD COUNT POSITIVE INC R4 ;FOLD WORD COUNT TO SPEED TRANSFER ASR R4 BCC 4$ 3$: MOV (R0)+,(R5)+ ;MOVE A WORD FROM USER BUFFER 4$: MOV (R0)+,(R5)+ SOB R4,3$ ;LOOP UNTIL TRANSFER COMPLETE MOVB @R3,R4 ;CHECK IF ZERO-FILL REQ'D BEQ VMTRAP ;NOPE - MULTIPLE OF A BLOCK 5$: CLR (R5)+ ;ELSE CLEAR A WORD DECB R4 ;UNTIL REACH A BLOCK BOUNDARY BNE 5$ VMTRAP: CLR @#MMSR0 ;TRY TO TURN OFF MANAGEMENT MOV PC,R4 ;POINT TO Q ELEMENT AGAIN ADD #VMCQE-.,R4 ; MOV @#54,R0 ;GET BASE OF RMON ; JMP @270(R0) ;AND DISPATCH ELEMENT JMP VMQUIT ; ABORT ENTRY BR VMTRAP ;ABORT BY DISABLING MANAGEMENT ; INTERRUPT SERVICE VMINT: MOV #160000,R5 ;RESET TO POINT TO BASE OF I/O PAGE ADD #100,@#UISAR7 ;AND REMAP TO NEXT 2K CHUNK MOV @#MMSR2,R1 ;R1 = VIRTUAL PC OF ERROR CMP @R1,(PC)+ ;CHECK FOR R0 MODIFICATION MOV (R0)+,(R5)+ ; ON THIS INSTRUCTION ONLY! BNE 6$ ;NOT THIS ONE, SO SKIP CORRECTION TST -(R0) ;ELSE UPDATE 6$: BIC R5,@#MMSR0 ;CLEAR SEGMENT LENGTH FAULT MOV PC,R2 ;GET ADDR OF EXIT CODE ADD #VMTRAP-.,R2 ; IN R2 CMP R1,R2 ;TRYING TO EXIT? BNE 7$ ;NOPE BIC R5,2(SP) ;ELSE RETURN TO KERNEL MODE 7$: MOV R1,@SP ;RESTART INSTRUCTION RTI ;AND EXIT .DSABL LSB .END ======================================================================================== DOCUMENT :usus Folder:VOL19:rx11.text ======================================================================================== ;************************************************; ;* *; ;* UCSD PASCAL INTERPRETER FOR PDP-11'S *; ;* *; ;* WRITTEN BY ROGER T. SUMNER *; ;* AND MARK OVERGAARD, 1977 *; ;* *; ;* INSTITUTE FOR INFORMATION SYSTEMS *; ;* UC SAN DIEGO, LA JOLLA, CA *; ;* *; ;* KENNETH L. BOWLES, DIRECTOR *; ;* *; ;* THIS SOFTWARE IS THE PROPERTY OF THE *; ;* REGENTS OF THE UNIVERSITY OF CALIFORNIA. *; ;* *; ;************************************************; .TITLE RX-11 FLOPPY DRIVER .ASECT .=264 RX$INT ; RX FLOPPY INTERRUPT HANDLER 240 ; MAX PRIORITY .CSECT TABLES .BLKW 128. ; OPERATOR TRANSFER TABLES .REPT 4 .BLKW 3 .ENDR .WORD INBIT!OUTBIT,RXSTRT,RXABRT .WORD INBIT!OUTBIT!10000,RXSTRT,RXABRT .PAGE .CSECT RXDRVR ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; ; ; rx - 11 floppy handler ; ; ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; RXUNIT: .WORD 0 ; ADDRESS OF UNIT TABLE ENTRY FOR I/O RXBUFA: .WORD 0 ; ADDRESS OF CURRENT BYTE BUCKET RXSECT: .WORD 0 ; CURRENT LOGICAL SECTOR ON DISK RXTRYS: .WORD 0 ; RETRY COUNT FOR CRC ERRORS RXLENG: .WORD 0 ; NUMBER OF BYTE REMAINING TO BE MOVED RXCS = 177170 ; ADDRESS OF RX CONTROL AND STATUS REG RXDB = RXCS+2 ; ADDRESS OF RX DATA REGISTER RXGO = 1 ; GO BIT IN RXCS RXFILL = 0*2 ; FILL BUFFER COMMAND RXMPTY = 1*2 ; EMPTY BUFFER COMMAND RXRORW = 2*2 ; COMMAND FOR READ OR WRITE, LOW BIT DETERMINES RXERRF = 7*2 ; COMMAND FOR READ ERROR REGISTER RXINTS = 100 ; INTERRUPTS OK BIT RXOFST = 14 ; NUMBER OF WORDS OUR STACK DIFFERS ; FROM UNIT-IO STACK (CAUSE OF SAVED REGISTERS) RXSTRT: ;THIS IS THE ENTRY POINT OF THE ROUTINE TO START ; I/O'S TO FLOPPIES. THE CALLING SEQUENCE IS ; JSR R3,RXSTRT ; .WORD (1 FOR READ, 0 FOR WRITE) ; WE ASSUME THAT R1 CONTAINS THE ADDRESS OF THE UNIT TABLE ; ELEMENT AND THE FLOPPY IS NOT INTERRUPT ENABLED. GP REGISTERS ; ARE SAVED EXCEPT R3 WHICH WE ASSUME TO BE SCRATCH AT ENTRY. ; ALL EXITS ARE DONE VIA INTRTN INSTRUCTIONS. TST RXUNIT ; CAN'T DO TWO FLOPPY I/O'S AT ONCE BNE RXSTRT ; WAIT UNITL WE CAN TST IO UNIT AGAIN MOV R1,RXUNIT ; STASH UNIT TABLE ADDR, NOW BUSY BIS #BSYBIT,(R1) ; MARK UNIT AS BUSY CLR (SP) ; NEW PSW AT PR-0 WHEN WE RTI TST (R3)+ ; POINT R3 AT RETURN ADDR MOV R3,-(SP) ; SET UP FOR AN RTI AFTER FIRST TRANSFER START MOV -(R3),R3 ; GRAB I/O CODE.. 1 READ.. 0 WRITE IN R3 MOV R0,-(SP) ; SAVE ALL REGISTERS FOR EXIT MOV R2,-(SP) CLR -(SP) ; R3'S LOCATION.. CLEAR IT FOR NO REASON MOV R5,-(SP) ; ALL SET TO START UP MOV #RXCS,R0 ; R0 HAS RXCS ADDRESS IN IT (CONVENTION) ASL R3 ; REFORMAT INTO FLOPPY OPERATION BIS #,R3 BISB 1(R1),R3 ; SET UNIT BIT FROM TABLE BIC #177740,R3 ; GET RID OF JUNK INFO MOV R3,RXFUNC ; THE ACTUAL IO CONTROL WORD TO RXCS MOV (SP),RXBUFA ; STASH BUFFER ADDRESS MOV (SP),R3 ; GRAB USER BLOCK # FROM STACK ASL R3 ; MULTIPLY IT BY 4 TO GET ASL R3 ; A LOGICAL SECTOR NUMBER MOV R3,RXSECT ; AND SAVE IT FOR I/O LATER MOV (SP),R5 ; GRAB NUMBER OF BYTES BEQ RXQUIT ; IF NO BYTES, FORGET IT RXNEXT: ; THIS IS WHERE WE START THE I/O'S FROM MOV #5,RXTRYS ; RETRY CRC ERRS AT MOST 3 TIMES BIT #2,RXFUNC ; SEE IF DOING A WRITE SO FILL BUFF BNE RXRTRY ; SLIP OVER FILL IF READ.. START I/O MOV #,(R0) ; SEND FILL BUFF COMMAND TO FLOPPY JSR R2,RXMOVE ; TRANSFER IN 128 BYTES INTO RX BUFFER MOVB (R3)+,(R2) ; PARAM 1..INSTRUC IF BYTES>0 CLRB (R2) ; PARAM 2..DO THIS IF BYTES <= 0 RXRTRY: MOV RXSECT,R3 ; NOW PERFORM MAGIC ALGOTITHM FOR MOV #8.,R2 ; LOOP COUNT 1$: CMP #6400,R3 ; DOES 26 GO INTO DIVIDEND BHI 2$ ; BRANCH IF NOT, C CLEAR ADD #171400,R3 ; SUBTRACT 26 FROM DIVIDEND, SETS C 2$: ROL R3 ; SHIFT DIVIDEND AND QUOTIENT DEC R2 ; DEC BRANCH COUNT BGT 1$ ; BRANCH TILL DIVIDE DONE MOVB R3,R2 ; COPY TRACK NUMBER CLRB R3 ; REMOVE TRACK NUMBER FROM REMAINDER SWAB R3 ; GET REMAINDER CMP #12.,R3 ; C=1 OF 13<=R3<=26, ELSE C=0 ROL R3 ; DOUBLE FOR 2 TO 1 INTERLEAVE ; C-BIT COMES IN FOR SECTOR GROUP ASL R2 ; ADD TRACK TO TRACK SKEW TO SECTOR ADD R2,R3 ; SKEW BY 2* TRACK ADD R2,R3 ; SKEW BY 4* TRACK ADD R2,R3 ; SKEW BY 6* TRACK ASR R2 ; REFIX TRACK NUMBER INC R2 ; PUT TRACK # IN RANGE 1-76 TO HANDLE ; ANSI FLOPPY, TRACK 0 IS LEFT ALONE 3$: SUB #26.,R3 ; MODULO SECTOR INTO RANGE -26, -1 BGE 3$ ; LOOP TILL REMAINDER GOES NEGATIVE ADD #27.,R3 ; PUT SECTOR IN RANGE 1,26 MOV (PC)+,(R0) ; SEND ACTUAL IO OP TO RX-11 RXFUNC: .WORD 0 ; SET UP IN INITIALIZE 1$: TSTB (R0) ; NOW WAIT UNTIL TR FLAG BEQ 1$ ; LOOP UNTIL FLOPPY ANSWERS BPL RXERR ; WHOOPS..DONE BUT NOT TR MOV R3,@#RXDB ; SEND SECTOR NUMBER 2$: TSTB (R0) ; NOW WAIT UNTIL SECOND TR BEQ 2$ ; TO SEND TRACK # BPL RXERR ; ANOTHER SCREW UP MOV R2,@#RXDB ; NOW OPERATION BEGINS BIS #RXINTS,(R0) ; ALLOW INTERRUPT AT COMPLETION RXEXIT: ; GO BACK TO USER NOW..RESTORE RETISTERS MOV R5,RXLENG ; SAVE NUMBER OF BYTES FOR RE-ENTRY MOV (SP)+,R5 MOV (SP)+,R3 MOV (SP)+,R2 MOV (SP)+,R0 JMP INTRTN ; RETURN NOW RXQUIT: BIC #BSYBIT,@RXUNIT ; MARK UNIT AS NOT BUSY CLR RXUNIT ; AND RX INTERFACE NOT BUSY EITHER BR RXEXIT ; AND WE ARE DONE WITH IT ; HERE IS THE RE-ENTRY POINT THAT IS PLACED IN THE TRAP ; VECTOR FOR THE RX-11 RX$INT: MOV R0,-(SP) MOV R2,-(SP) MOV R3,-(SP) MOV R5,-(SP) MOV #RXCS,R0 ; SET UP STATE FOR CONTINUED OPERATION MOV RXLENG,R5 ; NOW SET TO GO ON BIC #RXINTS,(R0) ; NO UNEXPECTED INTERRUPTS PLEASE BMI RXERR ; HIGH BIT ON..GO TO ERROR THING BIT #2,RXFUNC ; SEE IF A READ..IF SO THEN BEQ RXISWT ; WE WANT TO EMPTY BUFFER MOV #,(R0) ; EMPTY COMMAND JSR R2,RXMOVE ; ENTER SUBROUTINE WHICH DOES MOVES MOVB (R2),(R3)+ ; OP FOR NUMBYTES > 0 TSTB (R2) ; OP FOR NUMBYTES <= 0 TST R5 ; IF READING AND NO MORE CHARS BEQ RXQUIT ; THEN QUIT READING NOW RXISWT: MOV RXSECT,R3 ; SET UP FOR NEXT LOGICAL SECTOR I/O INC R3 MOV R3,RXSECT ; FOR FUTURE REFERENCE BIT #3,R3 ; SEE IF AT BLOCK BOUNDERY BNE RXAHED ; IF NOT AT BLOCK, I/O ANYWAY TST R5 ; IF A BLOCK THOUGH, SEE FI ANY MORE BEQ RXQUIT ; BYTES..IF NOT, THEN TIME TO QUIT RXAHED: JMP RXNEXT ; NEXT SECTOR PLEASE RXERR: ; WE END UP HERE IF NAY PROBLEMS CAME UP DURING ; ANY OPERATION. WE MAY CHOOSE TO RETRY, BUT MORE LIKELY ; JUST QUIT AND RETURN THE ERROR MOV #,(R0) ; ASK FOR DETAILED ERROR INFO 1$: TSTB (R0) ; HANG UNTIL DONE BIT BEQ 1$ MOV @#RXDB,R2 ; GET DETAIL ERROR INFO CMP #040,R2 ; SEE OF BAD TRACK ADDRESS BEQ 4$ CMP #120,R2 ; SEE OF DISK SURFACE INACCESIBLE BEQ 4$ CMP #210,R2 ; SEE IF PARITY ERROR BEQ 4$ ; GIVE SAME ERROR AS CRC, NO RETRY DEC RXTRYS BLE 4$ JMP RXRTRY ; GIVE IT ANOTHER SHOT 4$: MOV #PARERR,R3 RXSPLT: MOVB R3,@RXUNIT JMP RXQUIT ; FORGET IT, UNIT RAUNCHY RXMOVE: ; THIS SUBROUTINE TRANSFERS 128 BYTES TO OR FROM THE ; RX-11 INTERFACE RXDB. THE TWO WORD PARAMETERS ; ARE THE INSTRUCTION I PERFORM FOR THE DATA MOVE ITSELF. ; R2 AND R3 ARE SCRATCH (R2 IS LINKAGE REGISTER THOUGH) MOV (R2)+,RXDOIT ; INSTRUCTION FOR BYTES > 0 MOV (R2)+,RXDONT ; INSTRUCTION FOR BYTES <=0 MOV R2,(SP) ; RETURN ADDRESS..RTS PC 1$: TSTB (R0) ; WAIT UNTIL TR IS UP BEQ 1$ ; LOOP UNTIL RX ANSWERS MOV #RXDB,R2 ; OUR PARAMS EXPECT R2=#RXDB MOV RXBUFA,R3 ; AND R3=CURRENT BYTE BUFFER TST R5 ; IF ALREADY ZERO, DONT MOVE BEQ RXDONT ; ANYTHING AT ALL RXDOIT: .WORD 0 ; USER INSTRUCTION GOES HERE 1$: TSTB (R0) ; WAIT UNTIL TR OR DONE BEQ 1$ BPL RXDNMV ; IF NOT TR, THEN MUST BE DONE SOB R5,RXDOIT ; DEC AND BNE UNTIL ALL BYTES TRANSFERED RXDONT: .WORD 0 ; USERS EAT CHAR INSTRUCTION 1$: TSTB (R0) ; WAIT UNTIL TR OR DONE BEQ 1$ ; LOOP HERE UNTIL SOME RESULT BMI RXDONT ; TR WAS STILL UP, EAT JUNK CHARS INC R5 ; TO FOOSET DEC DONE NEXT RXDNMV: DEC R5 ; BE SURE TO COUNT THE LAST BYTE TST (R0) ; SEE OF WE HAD AN ERROR INSIDE BPL 1$ ; SKIP ERROR RETURN FO BIT 15 IS FOO MOV #RXERR,(SP) ; NOW RTS WILL DUMP RIGHT INTO ERROR 1$: MOV R3,RXBUFA ; SAVE THE CURRENT BYTE BUCKET RTS PC ; GO BACK TO NEXT I/O OR ERROR EXIT RXABRT: CLR RXLENG 1$: TST RXUNIT BNE 1$ RTS PC .END ======================================================================================== DOCUMENT :usus Folder:VOL19:setup.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL19:system.interp ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL19:system.pascal ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL19:traps.text ======================================================================================== .TITLE INTERRUPT AND TRAP SUBSYSTEM ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; TRAP VECTOR CONTENTS ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; .ASECT ; INTERRUPT HANDLER LOCATION IN VECTORS .=0 TRAP SYSERR ; BAD BRANCH...MOST LIKELY BAD OBJECT CODE 0 T4$INT ; 4-TRAP HANDLER 0 T10$INT ; 10-TRAP HANDLER 0 .=24 173000 ; POWER UP LOCATION 0 .=34 TP$INT ; TRAP HANDLER 0 ; PR-0 BACK ; ENTRY POINT FOR BOOT LOADER .=60 TR$INT ; KEYBOARD INTERRUPT HANDLER 200 ; PR-4 TX$INT ; CONSOLE PRINTER HANDLER 200 ; PR-4 .=100 KW$INT ; KW-11 (MAYBE REFRESH HARDWARE!) CLOCK HANDLER 301 ; PR-6...CARRY SET FOR ADC OP .=244 FP$INT ; FLOATING POINT EXCEPTIONS 0 .PAGE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; SYSCOM CONTENTS ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; .=400 IORSLT: .WORD 0 XEQERR: .WORD 0 SYSUNT: .WORD 0 BUGSTA: .WORD 0 GDIRP: .WORD NIL BOMBP: .WORD NIL STKBAS: .WORD NIL LASTMP: .WORD NIL JTAB: .WORD NIL SEG: .WORD NIL MEMTOP: .WORD 157776 BOMBIPC:.WORD 0 HLTLIN: .WORD NIL BRKPTS: .BLKW 4 .BLKW 10. LOTIME: .WORD 0 HITIME: .WORD 0 NOBREAK=100 ;NO BREAK BIT IN MISCINFO MSCNFO: .WORD ^B0000000 CRTTYP: .WORD 3 ;TELETYPE CRTESC: .BYTE 0,CR,0,0,0,0,0 FILCNT: .BYTE 10. .BLKB 4 CRTNFO: .WORD 0.,72. .BYTE 0,0,0,0 EOF: .BYTE 3 FLUSH: .BYTE 6 BREAK: .BYTE 0 STOP: .BYTE 23 CHRDEL: .BYTE '_ BADCHR: .BYTE '? LINDEL: .BYTE 177 ALTMOD: .BYTE 33 .BLKB 6 SEGTBL: .BLKW 3* .PAGE .CSECT IOTRAP ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; KW-11, 4 & 10 TRAP HANDLERS ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; T4$INT: TRAP BADMEM T10$INT:TRAP NOTIMP ; CROAK SYSTEM FOR ILLEGAL OPCODE FP$INT: TRAP FPIERR ; EXECUTION ERROR! KW$INT: ADC @#LOTIME ; IN 60-TH'S...CARRY IS SET IN TRAP VECTOR ADC @#HITIME RTI INTRTN: ; ALL IO DRIVERS MUST USE JUMP HERE INSTEAD OF ; DOING THEIR OWN RTI...THE SYSTEM MAY HANG IN THE WAIT ; INSTRUCTION OF UNITIO IF THIS IS NOT DONE!! CMP @(SP),(PC)+ ; IS THE NEXT INSTRUCTION A WAIT?? WAIT BNE 1$ ; IF NOT THEN DO IT ADD #2,@SP ; ELSE SKIP THE WAIT OPCODE AND THEN 1$: RTI ; RETURN .PAGE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; "TRAP" INTERRUPT HANDLER ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TP$INT: ; ENTRY POINT FOR "TRAP" INSTRUCTION INTERRUPTS. THESE ; ARE USED FOR EXECUTION ERRORS AND SOME SYSTEM REQUESTS. MOV R1,-(SP) ; R1 IS USED FOR DETERMINING TRAP TYPE MOV 2(SP),R1 ; GRAB OLD PC OFF THE STACK MOV -(R1),R1 ; NOW R1 HAS TRAP INSTRUCTION FROM CORE MOVB R1,R1 ; ISOLATE LOW BYTE WITH SIGN EXTEND BLT TPRQST ; A MINUS PARAM IS A SYSTEM REQUEST BGT XQ.ERR ; GREATER THAN IS EXECUTION ERROR RESET ; ZERO IS FATAL SYSTEM ERROR...REBOOT! JMP @24 ; USE POWER-UP VECTOR FOR BOOT ADDR XQ.ERR: ; HERE WE ARE FOR AN EXECUTION ERROR...RESTORE A VALID ; ENVIRONMENT FOR THE SYSTEM AND CXP 0,2...EXECERROR MOV LASTMP,MP MOV STKBAS,BASE MOV #BACK,BK MOV (PC)+,@BK ; ENSURE OP FETCH IS OK...STOP BREAKING GETNEXT MOVB R1,XEQERR ; SET UP PARAMS IN SYSCOM TO ERR HANDLERS MOV SP,BOMBP ; SET UP BOMB MCSWP FOR DEBUGGER SUB #MSDLTA+4,BOMBP MOV IPC,BOMBIPC CLR -(SP) MOV BK,-(SP) MOV #CXP0.2,IPC RTI CXP0.2: .BYTE 77.+128.,0,2,326 TPRQST: ASL R1 ; DOUBLE FOR WORD ADDRESSING SUB R1,PC ; CASE STMT, R1 NEGATIVE...REALLY ADDS R1 TRAP SYSERR ; SHOULD NEVER DO THIS BR TTYOUT ; -1 IS TTYOUT REQUEST TTYOUT: TST TXCHAR ; SEE IF ANY CHAR WAITING ALREADY BPL TTYOUT ; >=0 -> BUSY...HANG UNTIL NEG MOV R0,TXCHAR ; PLACE THE CHAR IN HIGH PRIOR BUFFER MOV (SP)+,R1 ; RESTORE REG TSTB @TXCSR ; SEE IF DL-11 IS READY FOR A CHAR BPL 1$ ; IF NOT THEN RETURN ELSE JMP TX$INT ; MAKE TX THINK AN IO IS COMPLETED 1$: RTI .PAGE ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; ; ; CRT INPUT-OUTPUT HANDLER ; ; ; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; TRCSR: .WORD 177560 TRBUF: .WORD 177562 TRBFSZ = 64. ; BYTES IN TT INPUT BUFFER TRBUFR: .BLKB TRBFSZ ; RING BUFFER FOR TTY INPUT TRHEAD: .WORD 0 ; INDEX OF CURRENT QUEUE HEAD TRTAIL: .WORD 0 ; INDEX OF CURRENT QUEUE TAIL TRQUED: .WORD 0 ; CHARS IN QUEUE WAITING TO BE READ TRUNIT: .WORD 0 ; UNIT # OF CURRENT IO (ZERO MEANS NONE) TRBUFA: .WORD 0 ; ADDRESS OF USERS BUFFER (BYTE ADDR) TRLENG: .WORD 0 ; NUMBER OF BYTES USER WANTS READ IN TROFST = 6 ; OFFSET FROM MY STACK TO PARAMS BUZZ = 07 SFLAG: .WORD 0 ; NON-ZERO IF OUTPUT TO BE STOPPED OFLAG: .WORD 0 ; NON-ZERO IF OUTPUT TO BE FLUSHED ALOCK: .WORD 0 ; ZERO -> ALPHA LOCK ON TR$INT: ; ENTRY POINT FOR KEYBOARD INTERRUPTS MOV R0,-(SP) ; SAVE R0, R0 IS USED FOR CHAR MOVB @TRBUF,R0 ; GRAB CHAR FROM DL-11 BIC #177600,R0 ; CHUCK PARITY AND ANY JUNK BITS CMPB R0,BREAK ; IS IT THE STANDARD BREAK CHAR BNE 1$ BIT #NOBREAK,MSCNFO ; BREAK DISABLED?? BNE TREXIT ; IF SO THEN NO BLOWUP MOV (PC)+,R0 ; STICK TRAP OP INTO R0 TRAP UBREAK MOV R0,@#BACK ; STICK TRAP INTO FETCH SEQUENCE BR TREXIT 1$: CMPB R0,STOP ; IS IT A CONTROL S? (START-STOP) BNE 2$ COM SFLAG ; FLIP STATE OF STOPPED FLAG (0 MEANS GOING) BR TREXIT ; AND SPLIT 2$: CMPB R0,FLUSH ; A CONTROL F? (FLUSH REQUEST?) BNE 3$ COM OFLAG ; FLIP FLUSH STATE CLR TXLENG ; HALT ANY IO IN PROGRESS BR TREXIT ; AND THEN GO AWAY 3$: CMPB R0,#DC2 ; ALPHALOC/K SWAP? BNE TRQCHR COM ALOCK BR TREXIT TRQCHR: CMP TRQUED,#TRBFSZ ; OVERFLOW BUFFER? BLT 1$ ; IF NOT THEN OK TO QUEUE CHAR .TTYOUT #BUZZ ; TELL THE USER HIS INPUT WAS CHUCKED BR TREXIT ; AND FORGET IT (LIFE'S A BITCH) 1$: TST ALOCK ; CHECK OUT ALHPA LOCK TOGGLE BNE 5$ ; ZERO SIGNALS ALOCK ON CMPB R0,#'A!40 ; COMPARE TO A LOWER CASE A BLT 5$ ; IF LESS THEN PASS ON THOUGH CMPB R0,#'Z!40 ; NOW SEE IF LEQ LC Z BHI 5$ ; IF > Z THEN PASS THROUGH BIC #40,R0 ; ELSE ZAP LC BIT FOR 'A..'Z 5$: MOV R3,-(SP) ; SAVE R3 FOR USE AS SCRATCH MOV TRTAIL,R3 ; POINTER TO TAIL OF INPUT QUEUE MOVB R0,TRBUFR(R3) ; PLACE THE CHAR INTO TAIL OF QUEUE INC R3 ; POINT AT NEXT POSITION IN QUEUE BIC #TRBFSZ,R3 ; CHECK FOR WRAPAROUND INC TRQUED ; COUNT THE CHAR AS QUEUED MOV R3,TRTAIL ; AND SAVE FOR NEXT INPUT MOV (SP)+,R3 ; RESTORE R3 TST TRUNIT ; ANY IO'S IN PROGRESS TO KEYBOARD? BEQ TREXIT ; EQUAL ZERO IF NOT...QUIT TRFLBF: MOV R3,-(SP) ; WELL, PUT SOME CHARS INTO INPUT BUFFER MOV TRHEAD,R3 ; POINTER TO HEAD OF INPUT QUEUE MOVB TRBUFR(R3),R0 ; MOVE A QUEUED CHAR TO USER BUFFER MOVB R0,@TRBUFA ; BUT WE WANT IT IN R0 FOR ECHO TOO INC R3 ; BUMP QUEUE HEAD POINTER BIC #TRBFSZ,R3 ; WRAPAROUND AGAIN (MAYBE) MOV R3,TRHEAD ; AND STASH NEW HEAD POINTER DEC TRQUED ;ONE LESS CHAR IN INPUT QUEUE MOV (SP)+,R3 ; AND RESTORE R3 CMP TRUNIT,#UNITBL+6 ; SEE IF WE WANT TO ECHO AS WE READ IN BNE 2$ ; IF NOT INPUT UNIT, SKIP ECHO STUFF CMPB R0,EOF ; INPUT EOF CHAR? BNE 3$ ; IF NOT THEN SKIP MOV TRLENG,R0 ; USE R0 FOR LOOP COUNTER 1$: CLRB @TRBUFA ; ELSE NULL FILL INPUT BUFFER INC TRBUFA SOB R0,1$ ; FOR ALL REMAINING CHARS BR TRQUIT ; AND CONSIDER IO COMPLETE 3$: CMPB R0,#177 ; A DEL??? BEQ 2$ ; DONT ECHO IT...TERAK BUG CMPB R0,CRTESC ; IS IT THE ESCAPE CHAR? BEQ 2$ ; DONT ECHO...MAY MESS UP FORMATTING BIC #100,@TRCSR ; PREVENT INPUT WHILE ECHOING (FUNNY WINDOW) .TTYOUT ; SEND R0 TO TTY AS ECHO 2$: BIS #100,@TRCSR ; RESTORE INPUT ENABLE INC TRBUFA ; BUMP BUFFER ADDRESS DEC TRLENG ; ONE FEWER CHARS TO READ INTO BUFFER BEQ TRQUIT ; WE ARE DONE IF IT GOES TO ZERO TST TRQUED ; WE CAN TRANSFER MORE CHARS IF ANY IN BUFFER BGT TRFLBF ; SO GO TO FILL BUFFER LOCATION BR TREXIT ; WELL, NO CHARS, RETURN TO USER NOT DONE TRQUIT: BIC #BSYBIT,@TRUNIT ; MARK OUR UNIT AS NOT BUSY CLR TRUNIT ; AND NOW HANDLER IS NOT BUSY EITHER TREXIT: MOV (SP)+,R0 ; RESTORE R0 JMP INTRTN ; AND RETURN TO WHEREVER TRSTRT: ; THIS IS THE ENTRY POINT FOR STARTING I-O'S TO THE ; KEYBOARD DEVICE. NOTE THE REASON THIS CODE IS HERE ; IS TO MAKE BRANCHING EASY. ALSO PLEASE FORGIVE ; THE DIDLING TO SAVE REGISTERS ACROSS TRFLBF ETC. TST TRUNIT ; SEE IF ANY IO'S IN PROGRESS BNE TRSTRT ; AND HANG IF SO MTPS #200 ; PREVENT ANY INTERRUPTS NOW MOV R1,TRUNIT ; MARK AS IO IN PROGRESS BIS #BSYBIT,(R1) ; MARK UNIT AS BUSY CLR (SP) ; ON RTI, BE AT PR0 TST (R3)+ ; GET RETURN ADDRESS AND MOV R3,-(SP) ; PLACE ON STACK FOR RTI AT TREXIT MOV R0,-(SP) ; NOW STACK LOOKS LIKE INSIDE OF TRINT MOV (SP),TRBUFA ; SAVE USER BUF ADDR MOV (SP),TRLENG ; AND REQUESTED TRANSFER LENG BEQ TRQUIT ; IF NOTHING, THEN QUIT NOW TST TRQUED ; IF SOME CHARS WAITING, THEN GET EM BNE TRFLBF ; AND PUT EM IN USERS BUFFER BR TREXIT ; ELSE RETURN TO SYSTEM TRMSTRT:; THIS ROUTINE JUST FIGURES IF INPUT OR OUTPUT ; REQUEST AND TRANSFERS TO THE PROPER HANDLER. TST @R3 ; ZERO MEANS A WRITE REQUEST...SEE UWRITE BEQ TXSTRT ; SO START TERM TRANSMIT BR TRSTRT ; ELSE A READ START TRMABRT:; ENTERED TO CANCEL ANY IO'S PENDING ; OR IN PROGRESS ON CRT DEVICE MTPS #200 CLR SFLAG CLR OFLAG CLR TRQUED MOV TRTAIL,TRHEAD TST TRUNIT BEQ 1$ CLR TRLENG BIC #BSYBIT,@TRUNIT CLR TRUNIT 1$: TST TXUNIT BEQ 2$ CLR TXLENG BIC #BSYBIT,@TXUNIT CLR TXUNIT 2$: MTPS #0 RTS PC TXCSR: .WORD 177564 TXBUF: .WORD 177566 TXUNIT: .WORD 0 ; UNIT TABLE ADDRESS OF IO IN PROGRESS TXLENG: .WORD 0 ; NUMBER OF BYTES LEFT TO BE SENT TO TERMINAL TXBUFA: .WORD 0 ; BYTE ADDRESS OF NEXT CHAR TO SEND TXCHAR: .WORD -1 ; HIGH PRIORITY CHAR TO SEND...FROM TTYOUT TXOFST = 4 TXSTRT: ; THIS CODE STARTS IO'S TO THE CONSOLE DEVICE ; ACCORDING TO STANDARD IO.OPS PROTOCOL TST TXUNIT ; SEE IF AN IO ALREADY IN PROGRESS BNE TXSTRT ; IF SO LOOP UNTIL THE IO IS COMPLETE MTPS #200 ; NO INTERRUPTS PLEASE MOV R1,TXUNIT ; MARK HANDLER AS BUSY BIS #BSYBIT,(R1) ; MARK LOGICAL UNIT AS BUSY CLR (SP) ; SET UP RETURN STUFF ON STACK...PR-0 PS TST (R3)+ ; SKIP R3 OVER IO INFO WORD MOV R3,-(SP) ; NOW THE RETURN ADDRESS CMP R1,#UNITBL+14 ; IS THE WRITE TO SYSTERM?? BNE 1$ ; IF NOT THEN LEAVE OUTPUT FLAGS ALONE CLR SFLAG ; ELSE CLEAR THE STOP FLAG CLR OFLAG ; AND FLUSH FLAG 1$: TST OFLAG ; IF OUTPUT TO BE FLUSHED? BNE TXQUIT ; IF SO THEN MARK IO AS COMPLETE NOW MOV (SP),TXBUFA ; GRAB USER BUFFER ADDR MOV (SP),TXLENG ; AND REQUESTED IO LENGTH TX$INT: BIC #100,@TXCSR ; NO INTERRUPTS PLEASE TST TXCHAR ; SEE IF ANY CHARS TO SEND RIGHT NOW BMI NOCHAR ; IF NEG THEN NO CHAR TO SEND MOV R0,-(SP) ; STASH A REG FOR NULLING MOV TXCHAR,R0 ; GRAB THE ACTUAL CHAR MOVB R0,@TXBUF CMP R0,#CR ; IS IT ACR (MUST FILL AND LF) BNE 1$ JSR PC,NULLER ; SEND STUFF FOR FILL COUNT 1$: COM TXCHAR ; FLIP NEG BIT...NO DATA ANYMORE MOV (SP)+,R0 ; RESTORE BIS #100,@TXCSR ; OK TO INTERRUPT NOW JMP INTRTN ; AND GO ON AS IF NOTHING HAPPENED NOCHAR: TST TXUNIT ; ANY IO'S IN PROGRESS BEQ TXEXIT ; IF NOT JUST FORGET IT TST TXLENG ; ANY CHARS LEFT TO BE SENT? BEQ TXQUIT ; IF NOT THEN FINISH UP IO TST SFLAG ; SEE IF OUTPUT IS STOPPED BEQ 1$ ; IF NOT THEN SKIP THE WAITING STATE MTPS #0 ; LEAVE CRITICAL REGION FOR DEVICE MTPS #200 ; BACK UP TO PR-4 BR NOCHAR ; AND GO TEST SFLAG AGAIN 1$: MOV R0,-(SP) ; STASH REG CLR R0 BISB @TXBUFA,R0 ; GRAB CHAR FROM USER BUFFER MOVB R0,@TXBUF ; SEND CHAR TO DL CMPB R0,#CR ; IS IT A CR?? BNE 2$ ; IF NOT THEN....SKIP JSR PC,NULLER ; SEND FILL AND LF 2$: MOV (SP)+,R0 ; RESTORE TEMP REG BIS #100,@TXCSR ; ENABLE FOR NEXT COMPLETE INC TXBUFA ; BUMP BUFFER POINTER TO NEXT CHAR DEC TXLENG ; ALSO REFLECT ONE FEWER CHAR TO SEND JMP INTRTN ; THIS STRUCTURE IMPLIES AN IO IS NOT ; DONE UNTIL THE LAST INTERRUPT IS RECEIVED TXQUIT: BIC #BSYBIT,@TXUNIT ; CLEAR BUSY BIT IN IO UNIT TABLE CLR TXUNIT ; MARK HANDLER AS NOT BUSY NOW TXEXIT: JMP INTRTN ; AND BACK NOW TO WHEREVER NULLER: ; HANDY SUBROUTINE FOR NULL FILLING AND LF AFTER CR ; ASSUME R0 SCRATCH (WELL...=CR) AND INTERRUPTS DISABLED MTPS #0 .IF NDF,TERAK MOVB FILCNT,R0 ; GRAB NILL COUNT (IF ANY) BEQ 2$ 1$: TSTB @TXCSR ; HANG UNTIL DL READY BPL 1$ CLRB @TXBUF SOB R0,1$ .ENDC 2$: TSTB @TXCSR ; HANG UNTIL READY FOR LF SEND BPL 2$ MOVB #LF,@TXBUF MTPS #200 RTS PC .PAGE .CSECT TABLES .BLKW 128. ; ROOM FOR OP XFER TABLE UNITBL: .WORD 0,0,0 ; UNIT 0 NOT USED .WORD INBIT!OUTBIT,TRMSTRT,TRMABRT .WORD INBIT!OUTBIT,TRMSTRT,TRMABRT .REPT .WORD 0,0,0 .ENDR .END ======================================================================================== DOCUMENT :usus Folder:VOL19:vol19.doc.text ======================================================================================== USUS Volume #19 ---> DEC & RX01 Specific <--- UCSD Version I.3 bootable run-time system and DEC notes VOL19: MODEM.PAS.TEXT 6 A simple routine to redirect I/O DEC.INDEX.TEXT 6 An index of the DEC specific software already in the USUS Library 2K.KEY.TEXT 12 Some patches for the 2k Key PATCHES.TEXT 30 A summary of the patches to the UCSD DEC PATCH.CONT.TEXT 20 interpreters to make them work right SYSTEM.INTERP 18 The interpreter for I.3 SYSTEM.PASCAL 110 The operating system for I.3 XFER.CODE 3 A single drive file transfer program for I.3 BOOTER.CODE 2 The I.3 bootstrap copier SETUP.CODE 13 The I.3 Setup utility MAKE_I.3.TEXT 4 An RT-11 command file to assemble and link the I.3 interpreter RX11.TEXT 26 The I.3 floppy driver EIS.TEXT 4 A conditional assembly definition MACROS.TEXT 14 Macro definitions for the I.3 interp MAINOP.TEXT 64 Part of the guts of the I.3 interp TRAPS.TEXT 36 ditto PROCOP.TEXT 64 ditto LP11.TEXT 10 The printer driver for I.3 RXBOOT 2 The boot block for I.3 PVM.MAC.TEXT 16 A RAMDISK handler for II.0 ZAPRAM.TEXT 6 A utility to initialize RAMDISK on boot VOL19.DOC.TEXT 10 You're reading it __________________________________________________________________________ Please transfer the text below to a disk label if you copy this volume. USUS Volume 19 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Some notes from the editor: I.3 bootable run-time system This disk should boot on an RX01. It will not work with an RX02. If you are lucky and it does boot, then welcome to the wonderful world of I.3. Read up on YALOE as I.3 doesn't have a screen editor. There is documentation available in the USUS archive, but not in soft form. I am going to try to get the users manual in soft form into the Library sometime. In the meanwhile, you'll have to fake it. The system is marginally set up for an H-19. The sources for the operating system are on volume 17, with the source to the debugger on volume 18. The interpreter sources are on this disk, but you must have RT-11 or HT-11 to assemble them and FORLIB.OBJ or SYSLIB.OBJ to link them. The file MAKE_I.3 is an RT-11 command file to assemble and link the interpreter. You can use EDITTORT11.CODE (in your UCSD distribution kit) to move the sources over to RT-11 and the interpreter back to UCSD. You must use the B(inary option to move the interpreter. PATCHES The UCSD interpreter was never implemented "right" for the LSI-11. This file lists some of the most common problems and object patches that you can do with PATCH, DISKREAD, UNLPATCH or some other patch utility to "fix" the problems. 2K_KEY This is a description of the bootstrap patches necessary to make the 2K_KEY ROM (for an H-27) be able to recognize the 4k bytes extra memory that you bought it for. DEC_INDEX This is a short index of all of the DEC specific software published in previous volumes of the USUS Software Library. MODEM.PAS This simple routine redirects the remote port to the console port so that you can control your p-system from a remote terminal. It works on both IV.0 and II.0. You have to cold boot to switch it back. PVM.MAC This is an adaption of the VM.MAC RAMDISK handler in DECUS. It is supposed to work with II.0 and an LSI-11/23 with the KT-11 MMU and extended memory. There will be an upcoming article in the newsletter by Eli Willner about RAMDISK. ZAPRAM is a Pascal program which you can install as SYSTEM.STARTUP to initialize RAMDISK on bootup. You need RT-11 and the II.0 building kit or sources to install it. ======================================================================================== DOCUMENT :usus Folder:VOL19:xfer.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL19:zapram.text ======================================================================================== program zapramdisk; { Creates a directory for RAMDISK, assumed to be device #11: Note the constant values and change as desired or appropriate. Compile and rename .CODE file to SYSTEM.STARTUP By Eliakim Willner USUS DEC SIG Chairman } const dirblk = 2; RamUnit = 11; {If you changed this in the macro file, change here too} UnitName = 'RAMDISK'; {Change to your taste} NumOfBlocks = 374; {Valid for systems with 256kb. Adjust as needed} type daterec = packed record month: 0..12; day: 0..31; year: 0..100 end; filkind = (untypedfil,xdskfil,codefil,textfil, infofil,datafil,graffil,fotofil,securedir); direntry = packed record dfirstblk: integer; { first physical disk addr } dlastblk: integer; { points at block following dir } case dfkind: filkind of securedir, untypedfil: { only in beginning of dir; volume info } (somejunk : 0..2048; dvid: string[7]; { volume name } deovblk: integer; { lastblk of volume } dnumfils: 0..77; { number of files in dir } dloadtime: integer; dlastboot: daterec); xdskfil,codefil,textfil,infofil, datafil,graffil,fotofil: (morejunk : 0..1024; status : boolean; dtid: string[15]; dlastbyte: 1..512; daccess: daterec) end; var dir0 : direntry; begin with dir0 do begin dfirstblk := 0; dlastblk := 6; dfkind := untypedfil; dvid := UnitName; deovblk := NumOfBlocks; end; unitwrite (RamUnit, dir0, sizeof(dir0), dirblk); end. ======================================================================================== DOCUMENT :usus Folder:VOL20:autopsy.text ======================================================================================== PROGRAM AUTOPSY; (*Version 1.0, 20 Oct 81*) USES (*$U screen.code*) SCREEN; CONST FILESIZE = 23; (*23+1 blocks/file (22 of text)*) checking = true; TYPE FNAME = STRING[24]; VAR FIN, FOUT : FILE; BLANK,BUFFER : PACKED ARRAY [0..511] OF CHAR; BLKNO,BLKSXFERRED,I,J,TOTALBLKS,RSLT : INTEGER; BADIO : BOOLEAN; SFIN,SFOUT,STEMP : FNAME; REPLY : CHAR; ISTRG : STRING; (*$I-*) PROCEDURE RSTFILE(VAR S : FNAME; X,Y : INTEGER); BEGIN REPEAT READLN(S); RESET(FIN,S); RSLT := IORESULT; IF (RSLT <> 0) THEN BEGIN IF (RSLT = 10) THEN BEGIN S := CONCAT(S,'.TEXT'); RESET(FIN,S); RSLT := IORESULT END; IF (RSLT = 12) THEN BEGIN CLOSE(FIN,LOCK) END; IF (RSLT <> 0) THEN BEGIN GOTOXY(0,22); WRITE('IO error ',RSLT,'. Correct and type to continue or Q(uit'); REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN ['Q','q',' ']; CLEARSPACE(0,22,80); IF (REPLY IN ['Q','q']) THEN EXIT(PROGRAM) ELSE CLEARSPACE(X,Y,LENGTH(S)) END END UNTIL RSLT = 0 END; PROCEDURE RWRFILE; BEGIN REPEAT REWRITE(FOUT,SFOUT); RSLT := IORESULT; IF (RSLT <> 0) THEN BEGIN GOTOXY(0,22); WRITE('Ouput file IO error ',RSLT,'. Correct and type to continue or Q(uit.'); REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN [' ','Q','q']; IF REPLY IN ['Q','q'] THEN BEGIN CLEARSCREEN; EXIT(PROGRAM) END ELSE CLEARSPACE(0,23,80) END UNTIL (RSLT = 0) END; Procedure checkit(inblock : boolean); begin if checking then if inblock then begin badio := ((blksxferred < 1) or (ioresult > 0)); if badio then writeln('Inblock ',BLKNO,' Ioresult = ',IORESULT,'. Blksxferred = ',BLKSXFERRED); end else begin badio := ((blksxferred < 1) or (ioresult > 0)); if badio then writeln('Outblock ',BLKNO,' Ioresult = ',IORESULT,'. Blksxferred = ',BLKSXFERRED); end end; BEGIN (*program*) CLEARSCREEN; BADIO := FALSE; WRITE('Enter name of input file (file to be divided): '); RSTFILE(SFIN,47,0); WRITELN; WRITE('Enter base name (VOL:XXXXXXXX (8 digits max) of output files: '); REPEAT READLN(STEMP); IF (LENGTH(STEMP)-POS(':',STEMP) > 8) OR (LENGTH(STEMP) = 0) THEN BEGIN GOTOXY(0,22); WRITE('Improper file name. Type to continue, Q(uit.'); REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN [' ','Q','q']; IF REPLY IN ['Q','q'] THEN EXIT(PROGRAM); CLEARSPACE(0,22,80); CLEARSPACE(45,2,24); END; UNTIL (LENGTH(STEMP)-POS(':',STEMP) <= 8) AND (LENGTH(STEMP) > 0); WRITELN; FOR J := 0 TO 511 DO BLANK[J] := CHR(0); I := 1; BLKNO := 2; REPEAT STR(I,ISTRG); SFOUT := CONCAT(STEMP,'.',ISTRG,'.TEXT'); RWRFILE; TOTALBLKS := 0; FOR J := 1 TO 2 DO BEGIN BLKSXFERRED := BLOCKWRITE(FOUT,BLANK,1,TOTALBLKS); checkit(false); TOTALBLKS := TOTALBLKS+1 END; BLKSXFERRED := BLOCKREAD(FIN,BUFFER,1,BLKNO); checkit(true); WHILE NOT EOF(FIN) AND (TOTALBLKS<=FILESIZE) AND (IORESULT=0) AND (NOT BADIO) AND (BLKSXFERRED=1) DO BEGIN BLKSXFERRED := BLOCKWRITE(FOUT,BUFFER,1,TOTALBLKS); BADIO := ((BLKSXFERRED < 1) OR (IORESULT > 0)); if checking then writeln('Outblock ',TOTALBLKS,' Ioresult = ',IORESULT,'. Blksxferred = ',BLKSXFERRED); BLKNO := BLKNO+1; TOTALBLKS := TOTALBLKS+1; IF (TOTALBLKS <= FILESIZE) THEN BEGIN BLKSXFERRED := BLOCKREAD(FIN,BUFFER,1,BLKNO); checkit(true) END; END; I := I+1; IF EOF(FIN) THEN BEGIN BLKSXFERRED := BLOCKWRITE(FOUT,BUFFER,1,TOTALBLKS); TOTALBLKS := TOTALBLKS +1; checkit(false) END; CLOSE(FOUT,LOCK); UNTIL EOF(FIN) OR (BADIO) OR (IORESULT <> 0); WRITELN(BLKNO-1,' blocks transferred; ',I-1,' files created.'); END. ======================================================================================== DOCUMENT :usus Folder:VOL20:base.text ======================================================================================== PROGRAM BASE; (*Version 2.1 - 10 Feb 83*) USES {$U H19UTIL.CODE} H19UTIL, {$U NUMBER2.CODE} NUMBER2; VAR DATA : INTEGER; REPLY : CHAR; S : STRING; FIRSTTIME : BOOLEAN; PROCEDURE GETDEC(VAR DATA : INTEGER); VAR RL : REAL; PROCEDURE ERRHNDLR; CONST BELL = 7; BEGIN CLEARSPACE(0,0,80); WRITE(CHR(BELL),'Improper number. Retype.'); GOTOXY(XCUR,YCUR); CLEAR_EOL; GETDEC(DATA); SAVECURSOR(XCUR,YCUR); CLEARSPACE(0,0,80); GOTOXY(XCUR,YCUR); EXIT(GETDEC) END; BEGIN SAVECURSOR(XCUR,YCUR); RL := INREAL(INPUT,INPT); IF (RL>32767.0) OR (RL<-32768.0) THEN ERRHNDLR; DATA := TRUNC(RL) END; PROCEDURE ASKFORIT(S : STRING); BEGIN WRITE('Enter ',S,' number: '); END; BEGIN FIRSTTIME := TRUE; REPEAT CLEARSCREEN; IF NOT(FIRSTTIME) THEN BEGIN GOTOXY(0,6); CASE REPLY OF 'B' : BEGIN S := 'binary'; ASKFORIT(S); GETBINARY(DATA); END; 'D' : BEGIN S := 'decimal'; ASKFORIT(S); GETDEC(DATA); END; 'F' : BEGIN S := 'fliphex'; ASKFORIT(S); GETFLIP(DATA); END; 'H' : BEGIN S := 'hex'; ASKFORIT(S); GETHEX(DATA); END; 'O' : BEGIN S := 'octal'; ASKFORIT(S); GETOCTAL(DATA); END; 'Q' : BEGIN CLEARSCREEN; EXIT(PROGRAM) END END; WRITELN(' Decimal value = ',DATA); WRITE(' Binary value = '); WRITEBIN(DATA); WRITELN; WRITE(' Octal value = '); WRITEOCTAL(DATA); WRITELN; WRITE(' Hex value = '); WRITEHEX(DATA); WRITE(' Flipped hex value = '); WRITEFLIP(DATA); WRITELN; WRITELN; WRITELN; WRITELN; END ELSE BEGIN FIRSTTIME := FALSE; GOTOXY(0,14) END; REPLY := COMMAND('D(ecimal, O(ctal, H(exadecimal, B(inary, F(lipbyte, Q(uit', ['B','D','F','H','O','Q']); UNTIL FALSE END. ======================================================================================== DOCUMENT :usus Folder:VOL20:bios.const.text ======================================================================================== ; This section defines the constants used to identify ports, bits, ; and other constant elements of the BIOS environment. ; Port assignments ; ---- ----------- CNT_MDM .EQU 8BH ; Clock divider for serial ; port controllers. CNT_REG_0 .EQU 88H ; Counter register 0. CNT_REG_1 .EQU 89H ; Counter register 1. CNT_REG_2 .EQU 8AH ; Counter register 2. CRT_DATA .EQU 0A8H ; CRT data port. CRT_STAT .EQU 0A9H ; CRT status port. DIA_DATA .EQU 86H ; Output to printer. DIA_STAT .EQU 87H ; Printer status register. DMA_CTL .EQU 0B8H ; DMA mode port. DMA_ADR .EQU 0B0H ; DMA address entry port. DMA_TCNT .EQU 0B1H ; DMA terminal count. FDC_DATA .EQU 0A1H ; FDC command and results. FDC_INT .EQU 0A2H ; [7] indicates FDC command ; completion. FDC_STAT .EQU 0A0H ; FDC status. PRT_DIA .EQU 86H ; Diablo printer port address, KGB ; config. PRT_MODEM .EQU 84H ; Modem controller address, cur- ; rently not implemented. ; Disk Control Parameters ; ---- ------- ---------- FDC_ONLIN .EQU 5 ; Ready in SR3. FMT_SKEW .EQU 7 ; Sector skew to apply to disk ; formatting--Pascal interleave and ; skew are [1:0]. MFD_INTL .EQU 1 ; Interleave for single-sided disks. MFD_SKEW .EQU 0 ; Skew for single-sided disks. DSK_RETRY .EQU 5 ; Number of errors to allow before ; reporting CRC failure. ; Serial Board Control Parameters ; ------ ----- ------- ---------- DIA_SPEED .EQU 13 ; Speed divisor for Diablo 630 printer ; --9600 Baud. PRT_DSR .EQU 7 ; Device on-line flag. MDM_SPEED .EQU 13 ; Dummy: no current modem device. PRT_RRDY .EQU 1 ; Receive register full. STAT_PRT .EQU 1 ; Offset of Status serial port. PRT_RTSB .EQU 0 ; Ready to send. PRT_THBE .EQU 2 ; Transmit buffer empty. ; Disk Control Block Offsets ; ---- ------- ----- ------- ; Phone Port Offsets ; ----- ---- ------- ; Phone Control Parameters ; ----- ------- ---------- ; ASCII Character Codes ; ----- --------- ----- ACR .EQU 0DH ; . AESC .EQU 1BH ; . ======================================================================================== DOCUMENT :usus Folder:VOL20:bios.data.text ======================================================================================== ; This section defines the working storage data blocks used by the ; BIOS for its own purposes. ; Disk Command Tables ; ---- ------- ------ SIS_CMD_TB: ; Table to define Sense Interrupt Status command. .BYTE 08H FDC_CMD_TBL: ; Table of control parameters needed by FDC. Symboled entries ; are variable. Not all commands require the full table, but all ; need an ordered subset. FDC_CMD .BYTE 0 ; Command. FDC_DRVNO .BYTE 0 ; Disk number. FDC_TRACK .BYTE 0 ; Track number of track to which disk ; is currently positioned, or 0FFH if ; position is not known. .BYTE 0 ; Head number. FDC_SECTR .BYTE 0 ; Sector number. .BYTE 2 ; Sector size = 2 for 512. .BYTE 9 ; Sectors / track. .BYTE 27 ; Gap-3 read/write length. Format ; length is 84 bytes for Sony disks. .BYTE 0FFH ; Data length (superseded ; by sector size. FDC_FMT_TBL: ; Command list for formatting a track. .BYTE 4DH ; Format command byte. .BYTE 1 ; Disk number (always 1). .BYTE 2 ; Bytes/sector (2 => 512). .BYTE 9 ; Sectors/track. .BYTE 84 ; Gap 3 length for formatting. .BYTE 4EH ; Formatted disk filler byte. ; Formatting Sector Definition Lists ; ---------- ------ ---------- ----- FMT_0_LST: ; Sector sequence for track 0, to optimize access to bootstrap. .BYTE 0, 0, 1, 2 .BYTE 0, 0, 6, 2 .BYTE 0, 0, 7, 2 .BYTE 0, 0, 8, 2 .BYTE 0, 0, 9, 2 .BYTE 0, 0, 2, 2 .BYTE 0, 0, 3, 2 .BYTE 0, 0, 4, 2 .BYTE 0, 0, 5, 2 FMT_I_LST: ; Sector sequence for track 1, to optimize access ; through BIOS per format change study. .BYTE 0, 0, 1, 2 .BYTE 0, 0, 6, 2 .BYTE 0, 0, 2, 2 .BYTE 0, 0, 7, 2 .BYTE 0, 0, 3, 2 .BYTE 0, 0, 8, 2 .BYTE 0, 0, 4, 2 .BYTE 0, 0, 9, 2 .BYTE 0, 0, 5, 2 ; Operating System Link Storage ; --------- ------ ---- ------- PASDCH .BLOCK 2 ; Address of disk change routine. PASEVENT .BLOCK 2 ; Address of event signal acceptor. ; Disk Control Storage ; ---- ------- ------- FDC_DMADR .BLOCK 2 ; Address of sector buffer. FDC_DMA_LEN .BLOCK 2 ; Termination count for DMA. FDC_XFR_CMD .BLOCK 1 ; Storage for read/write command ; until needed. FDC_TGT_TK .BLOCK 1 ; Target track of next seek command. R_W_MSK .BLOCK 1 ; Error selection byte which ; prevents Write Only errors ; in the read operation. ; Disk Formatting Storage ; ---- ---------- ------- FMT_D_LST .BLOCK FMT_SKEW * 4 ; Pre-sector-table extension for ; rotating sector list through skew ; of 4. FMT_N_LST .BLOCK 36 ; Working copy of format list ; rotated to match skew requirements. ; NOTICE! This table MUST follow ; FMT_D_LST immediately! FMT_X_BLK .BLOCK 512 ; Block for moving bootstrap from ; one disk to another during format. ======================================================================================== DOCUMENT :usus Folder:VOL20:bios.disks.text ======================================================================================== FMT_DISK: ; This service, available through an addition to the Pascal jump ; table, formats the disk in Drive 1 and copies the bootstrap on ; the disk on drive 0 to drive 1. ; On Exit: ; (A) = IO_RESULT. ; Interaction with the operator is through a Pascal program which uses ; this service. ; This SBIOS assumes that the interleave and skew are adjusted during ; formatting, so that the Pascal interleave is 1 and skew is 0. ; Recalibrate drive 1. LD C, 1 CALL DSKDKN CALL FDC_RECAL RET NZ ; Set track 0 format to optimize bootstrap loading. LD HL, FMT_0_LST CALL SEND_F_LST ; Format track 0. CALL SEND_FMT AND A RET NZ ; Other tracks are set to interleave 2, skew 2. Set up base ; format list for track 1. LD HL, FMT_I_LST LD DE, FMT_N_LST LD BC, 36 LDIR LD B, 69 LD C, 1 $1: PUSH BC ; Set track number into FMT_N_LST. LD B, 9 LD HL, FMT_N_LST $2: LD (HL), C INC HL INC HL INC HL INC HL DJNZ $2 CALL DSKDKT CALL FDC_SEK LD HL, FMT_N_LST CALL SEND_F_LST CALL SEND_FMT ; Rotate the sector list to produce desired skew. LD DE, FMT_D_LST LD HL, FMT_N_LST LD BC, 36 LDIR LD HL, FMT_D_LST LD BC, FMT_SKEW * 4 LDIR ; Analyze the result of the format command and report errors. POP BC AND A RET NZ INC C DJNZ $1 ; Read sectors of drive 0, track 0, and copy to drive 1, track 0. LD C, 0 CALL DSKDKT LD BC, FMT_X_BLK CALL DSKDKB LD B, 9 LD C, 1 $3: ; Set the sector. Note that transfer is not done in optimal ; sequence for track 0. PUSH BC CALL DSKDKS ; Read sector from Disk 0. LD C, 0 CALL DSKDKN CALL DSKDKR AND A JR NZ, $4 ; No read errors. Write sector onto disk 1. LD C, 1 CALL DSKDKN CALL DSKDKW AND A $4: POP BC RET NZ INC C DJNZ $3 ; Return to call. RET SEND_F_LST: ; This service prepares the DMA controller to send a format parameter ; list to the FDC as needed during track formatting. ; On Entry: ; (HL) => Format Control list. LD C, DMA_ADR OUT (C), L OUT (C), H INC C ; DMA_TMCNT LD HL, 8023H OUT (C), L OUT (C), H LD A, 41H OUT (DMA_CTL), A RET SEND_FMT: ; This service sends the format command list to the FDC and interprets ; its response. LD HL, FDC_FMT_TBL LD B, 6 CALL SEND_CMD CALL POLL_INT CALL INT_R_W_ST RET SEND_CMD: ; Write a command to the disk. ; On Entry: ; (B) = Command Table Length. ; (HL) => Command Table. ; On Exit: ; (B), (C), (HL) spoiled. LD C, FDC_DATA $1: ; Wait for FDC to be ready. IN A, (FDC_STAT) AND 0C0H CP 080H JR NZ, $1 ; Send next character. OUTI RET Z JR $1 DED_DSK: ; Report disastrous disk error (unrecoverable protocol conflict). LD HL, RPTDER $1: LD A, (HL) CP 0FFH JR Z, $ LD C, A CALL DR_CRO INC HL JR $1 RPTDER: ; Clear screen, home cursor and report error. .BYTE 1AH, 1EH .ASCII "Unrecoverable disk protocol error." .BYTE 0DH, 0AH, 0FFH VRFY_DRIV: ; This service tests the drive number against the floppy disk unit ; numbers and returns an off-line status if the unit is too large. LD A, (FDC_DRVNO) CP 2 LD A, 9 RET FDC_RECAL: ; This service restores the active drive to track 0. ; On Exit: ; (A) = 0 | if recalibration successful. ; (ZF) set | ; (A) = IO_RESULT if recalibration unsuccessful, or ; drive off line. LD HL, FDC_CMD_TBL LD (HL), 07H ; Recalibrate command. LD B, 2 CALL SEND_CMD ; Wait for recalibration to complete. CALL POLL_INT ; Sense status and interpret. CALL SNS_INT_ST AND A PUSH AF LD HL, FDC_TRACK JR Z, $1 LD A, 0FFH $1: LD (HL), A POP AF RET CLR_DISK: ; This service clears all of the disk drives, restoring them to track ; 0, and thereby synchronizing them with the initialized control tables. ; Drive 0. LD C, 0 CALL DSKDKN CALL DSKDKI ; Drive 1. LD C, 1 CALL DSKDKN CALL DSKDKI RET DSKDKI: ; This service initializes a Pascal disk drive. ; Filter for Semi-Disks. CALL VRFY_DRIV RET NC ; Recalibrate the drive. Recalibration will diagnose off-line ; condition, if present. CALL FDC_RECAL RET DSKDKN: ; This service sets the number of the active disk. ; On Entry: ; (C) = Disk number. LD A, C LD (FDC_DRVNO), A ; Set the current track number to impossible value to cause seek on ; next read or write. LD HL, FDC_TRACK LD (HL), 0FFH RET DSKDKT: ; This service sets the number of the track to be selected on the next ; read or write. ; On Entry: ; (C) = Track number. LD A, C LD (FDC_TGT_TK), A RET DSKDKS: ; This service records the number of the sector selected for use with ; the next read or write. ; On entry: ; (C) = Sector Number. LD A, C LD (FDC_SECTR), A RET DSKDKB: ; This service sets the active buffer location. ; On Entry: ; (BC) = Buffer address. LD (FDC_DMADR), BC RET FDC_SEK: ; This service positions the disk drives. ; On Exit: ; (A) = 0 | if seek successful. ; (ZF) set | ; Check for too large track number. LD A, (FDC_TGT_TK) CP 70 JR C, $2 ; Track number too high. Discard immediate return and exit read or ; write procedure with final status. POP HL LD A, 3 AND A RET $2: ; Check for change since last seek. LD B, A LD HL, FDC_TRACK SUB (HL) RET Z LD A, B LD (HL), A ; Check for track zero. AND A JP Z, FDC_RECAL ; Construct seek command. LD HL, FDC_CMD_TBL LD (HL), 0FH ; Seek command. LD B, 3 CALL SEND_CMD ; Wait for seek completion. CALL POLL_INT ; Interpret result. CALL SNS_INT_ST AND A RET Z LD HL, FDC_TRACK LD (HL), 0FFH RET POLL_INT: ; Detect FDC interrupt signal. This signals the begining of the ; result phase for many FDC functions. IN A, (FDC_INT) RLA RET C ; Poll the other IO units for input if the disk is not yet done. ; The address of the following call is set up during system ; initialization. CALL 0 PASPOL .EQU $ - 2 JR POLL_INT SNS_INT_ST: ; Checks the status of the FDC after completion os a seek or ; recalibrate. ; On Exit: ; (A) = 0 if no error. ; 1 if seek abnormally completed. ; 9 if drive off-line. ; Send prompt command. LD HL, SIS_CMD_TB ; Sense Interrupt command table. LD B, 1 CALL SEND_CMD ; Accept the two result bytes. Only the first is important. CALL GET_RSLT_BT LD B, A CALL GET_RSLT_BT ; Decode error flags. BIT 3, B LD A,9 RET NZ LD A, 0D0H AND B RET Z LD A, 1 RET INT_R_W_ST: ; Interpret the seven byte status returned by the FDC after a ; read or write command. Only the first three bytes are im- ; portant, but all bytes must be read. Give immediate pre- ; ference to non-CRC errors. ; On Exit: ; (A) = 0 if no error. ; 1 if CRC error. ; 2 if seek error. ; 3 if illegal IO request. ; 9 if drive off-line. ; 16 if write protected error. ; Accept first three bytes and interpret error flags. CALL GET_RSLT_BT ; ST0 byte. LD E, 6 BIT 3, A ; Not ready bit. LD B, A LD A, 9 JR NZ, $1 LD A, 0D0H ; Interrupt code, Equip Chk. AND B LD D,A CALL GET_RSLT_BT ; ST1 byte. DEC E LD B,A LD A, (R_W_MSK) ; Write protected. AND B LD A, 16 JR NZ, $1 LD A, 84H ; End cyl, No data. AND B LD A, 3 JR NZ, $1 LD A, 61H ; Data Error, Overrun, MAM. AND B OR D LD D,A CALL GET_RSLT_BT ; ST2 byte. DEC E LD B, A LD A, 12H ; Bad cylinder error. AND B LD A, 2 JR NZ, $1 LD A, B OR D LD A, 0 JR Z, $1 INC A $1: ; Read and discard remaining result bytes. LD B, E LD E, A $2: CALL GET_RSLT_BT DJNZ $2 LD A, E RET GET_RSLT_BT: ; Wait until FDC is ready to send, and then accept input byte ; in (A). IN A, (FDC_STAT) AND 0C0H CP 0C0H JR NZ, GET_RSLT_BT ; Accept character. IN A, (FDC_DATA) RET DSKDKR: ; Read the designated sector from the disk. ; Actual read is done below. Set up read command and read ; error mask and DMA length. ; Do not report Write Protected errors in read operation. LD A, 00H LD (R_W_MSK), A LD HL, 41FFH LD (FDC_DMA_LEN), HL ; Store command for reference in common segment. LD HL, FDC_XFR_CMD LD (HL), 46H ; Read command. JR FDC_DSK_R_W DSKDKW: ; Write the disignated sector from the disk. ; Set up write command, DMA length and error mask. ; Report all write errors. LD A, 02H LD (R_W_MSK), A LD HL, 81FFH LD (FDC_DMA_LEN), HL ; Store write command for reference in common segment. LD HL, FDC_XFR_CMD LD (HL), 45H ; Write command. FDC_DSK_R_W: ; Common part of DSKDKW and DSKDKR. ; Filter out Semi-Disk units. CALL VRFY_DRIV RET NC ; Initialize retry count. LD E, DSK_RETRY $1: ; Seek the designated track. CALL FDC_SEK JR Z, $4 CP 9 RET Z $2: ; Designated track could not be found. If retry count is not ; exhausted, recalibrate and retry. LD A, E SUB 3 LD E, A LD A, 1 RET C CALL FDC_RECAL JR $1 $4: ; Seek has been completed successfully. Code and enable DMA. LD C, DMA_ADR LD HL, (FDC_DMADR) OUT (C), L OUT (C), H INC C ; DMA_TMCNT LD HL, (FDC_DMA_LEN) OUT (C), L OUT (C), H LD A, 41H OUT (DMA_CTL), A ; Send command. Get code from temporary storage. LD A, (FDC_XFR_CMD) LD HL, FDC_CMD_TBL LD (HL), A LD B, 9 CALL SEND_CMD ; Set status. Exit if successful completion. CALL POLL_INT PUSH DE CALL INT_R_W_ST POP DE AND A RET Z ; Error. Count down retries. CP 2 JR Z, $2 DEC E JR NZ, $2 ; Retries exhausted. Report last error. RET ======================================================================================== DOCUMENT :usus Folder:VOL20:bios.phone.text ======================================================================================== PHNSTT: PHCOUT: PHCIN: ; The phone is currently not implemented. ; Return off-line status. LD A, 9 RET ======================================================================================== DOCUMENT :usus Folder:VOL20:bios.serpt.text ======================================================================================== INIT: ; This service initializes the entire system on cold start. ; On Entry: ; (BC) => PASCAL support service jump vector. ; Set up jump vectors to callable Pascal services. LD (PASPOL), BC INC BC INC BC INC BC ; This storage is the address of a JP instruction in the disk BIOS. LD (PASDCH), BC INC BC INC BC INC BC LD (PASEVENT), BC ; Clear the screen. LD C, 27 CALL DR_CRO LD C, "*" CALL DR_CRO ; Restore all disks. CALL CLR_DISK RET DR_CRB: ; This service is a dummy to report successful initialization of the ; terminal. XOR A RET DR_CRS: ; This service tests for the presence of an input character from the ; terminal. ; On Exit: ; (A) = 0 to indicate console is on-line. ; (C) = 0 if no character, else 0FFH. LD C, 0 IN A, (CRT_STAT) AND 02H RET Z DEC C XOR A RET DR_CRI: ; This service reads the next available character from the keyboard. ; It is extremely simple since the terminal and CPU are so closely ; interconnected in the Escort that failure in this link is highly ; improbable, and it would not be useful to do anything about it anyway. ; On Exit: ; (A) = 0 to indicate console is on-line. ; (C) = Character. ; Wait for the next character to be ready. IN A, (CRT_STAT) AND 02H JR Z, DR_CRI ; Pick up the character. IN A, (CRT_DATA) LD C, A XOR A RET DR_CRO: ; This service sends a character to the terminal. ; On Entry: ; (C) = Character to send. ; On Exit: ; (A) = 0 to indicate successful transmission. ; Attempt to send the character. IN A, (CRT_STAT) AND 01H JR Z, DR_CRO LD A, C OUT (CRT_DATA), A XOR A RET DR_DIB: ; This service reports the status of the printer. It does not do any ; initialization of the printer because of the variation in printer ; characteristics which may be encountered with a portable computer system. ; On Exit: ; (A) = IO Result-- ; 0: Printer initialized successfully. ; 1: Error in operation. ; 9: Printer off line. ; Test status for off-line. LD A, PRTDIA CALL PRT_WS CP 9 RET Z XOR A RET DR_DIS: ; This service is a dummy status routine for the Diablo printer to conform ; to PASCAL requirements. ; On Entry: ; (C) = I/O Direction Flag-- ; =0: Output status desired. ; >0: Input status desired. ; On Exit: ; (A) = Status-- ; 0: Printer is on-line. ; 9: Diablo is off line. ; (C) = Channel status (0--no character). ; 0: Input direction or printer not busy. ; 0FFH: Output direction and printer busy. ; Move direction flag out of the way and collect write status (read status ; is not relevant, since flow control is via hardware). LD E, C LD A, PRTDIA CALL PRT_WS ; Set up input direction return of no character waiting. LD C, 0 CP 9 RET Z ; Printer is not off-line. Investigate direction flag to interpret ; status IO Result. PUSH AF LD A, E AND A JR Z, $1 ; Input direction--report only good IO Result with no character ; waiting flag. POP AF XOR A RET $1: ; Output direction--interpret busy status. POP AF CP 16 ; Return if not busy. RET NZ DEC C RET DR_DII: ; This service is a dummy to provide illegal operation from the Diablo ; to conform to PASCAL requirements. ; On Exit: ; (A) = Status-- ; 3: Illegal operation. ; (C) = Character (ANUL) LD A, 3 LD C, 0 RET DR_DIO: ; Output driver for Diablo printer, operation at 9600 Baud. Uses RTS ; protocol to avoid buffer overrun. Assumes that pins 9 and 20 of inter- ; face cable to Diablo 630 printer have been exchanged. ; On Entry: ; (C) = character to send ; On Exit: ; (A) = Status-- ; 0: Successful transmission. ; 1: Transmission error. ; 9: Printer off-line. ; All other registers spoiled. ; Mask out high order bit to avoid parity errors. LD A, C AND 7FH LD E, A $1: ; Attempt transmission of character until buffer is available, or until ; error occurs. LD A, PRTDIA CALL PRT_WT CP 16 RET NZ JR $1 PRT_IN: ; This service initializes the designated serial port to the characteris- ; tics indicated in its parameters. ; On Entry: ; (A) = Base Port for device. ; (E) = Line Control Register for device. ; On Exit: ; (A - C) spoiled. ; Note: This service does not return any status as required by UCSD Pascal ; or CP/M. It prepares the serial port so that subsequent status and output ; calls will function as intended. ; Be certain that UART is in command mode, with RTS and DTR off. LD C, A INC C ; Device status port. LD A, 90H OUT (C), A ; Force Mode Instruction mode in UART. LD A, 40H OUT (C), A ; Establish line characteristics. OUT (C), E ; Turn on port. LD A, 37H OUT (C), A RET PRT_RD: ; This service reads waits for a character to appear at the designated ; serial port and reads it when it shows up. It tests for transmission ; and timing errors and diagnoses their occurrence. ; On Input: ; (A) = Serial Port address. ; On Output: ; (A) = IO Result-- ; 0: Character is good. ; 1: Character is in error. Value is replaced with ANUL. ; 9: Device is off-line. ; (C) = Character code. ; All other registers spoiled. ; Save port address. LD D, A $1: ; Wait for character to be available or error to occur. LD A, D CALL PRT_RS ; If character is present, read it. INC C JR NZ, $2 LD C, D IN C, (C) RET $2: ; Character not available. If no error, continue waiting; otherwise, return ; dummy character. AND A RET NZ JR $1 PRT_RS: ; This service determines the status of the designated serial port for a ; read operation. ; On Entry: ; (A) = Serial Port address. ; On Exit: ; (A) = IO Result-- ; 0: No error detected by port. ; 1: Overrun, framing or parity error. ; 9: Device off-line. ; (C) = Ready Result-- ; 0: No character waiting. ; FF: Character waiting. ; Determine on-line status from modem status. LD C, A INC C ; Device status port. IN B, (C) BIT PRT_DSR, B LD A, 9 JR Z, $1 ; Read line status. Begin by checking error status. LD A, 38H AND B LD A, 1 JR NZ, $0 ; Terminal is on-line status and there are no errors. XOR A $0: ; Determine if there is a character waiting. LD C, 0FFH BIT PRT_RRDY, B RET NZ $1: ; Off-line or no character present. LD C, 0 RET PRT_WT: ; This service writes a character to the designated serial port. ; On Entry: ; (A) = Serial Port address. ; (E) = Character. ; On Exit: ; (A) = IO Result-- ; 0: Transmission of character completed successfully. ; 9: Device is off-line. ; 16: Device is not ready to receive data. ; Save the port address for later use. LD D, A $1: ; Test the write status to determine if transmit buffer is ready. LD A, D CALL PRT_WS CP 1 JR Z, $1 ; Return immediately if device is off-line or unready to receive data. RET NC ; Send character to device. LD C, D OUT (C), E RET PRT_WS: ; This service tests the status of the serial port for writing. ; On Entry: ; (A) = Serial Port address. ; On Exit: ; (A) = IO Result-- ; 0: Transmit buffer empty, write possible. ; 1: Transmit buffer busy, no errors. ; 9: Device is off-line. ; 16: Device is not ready to receive data. ; (BC) spoiled. ; First determine if modem is on-line. LD C, A INC C ; Device status register. IN B, (C) BIT PRT_DSR, B LD A, 9 RET Z ; On-line. Test for ready to send. BIT PRT_RTSB, B LD A, 16 RET Z ; Read line status for transmit buffer condition. XOR A BIT PRT_THBE, B RET NZ ; Buffer is busy. INC A RET CONINI: ; Since Pascal could not be bootstrapped without the console being opera- ; tional, this service is null. ; On Exit: ; (A) = 0 to imply successful initialization. XOR A RET OFFLIN: ; This service provides off-line status indications for all drivers which ; are not implemented. LD A, 9 NULL: ; This service provides immediate return for null drivers. RET ======================================================================================== DOCUMENT :usus Folder:VOL20:boot.write.text ======================================================================================== .NARROW_PAGE .TITLE "Balke Associates Bootstrap Installer" ; Programmer: Karl Balke ; Version: 001 16 Jan 82 .INCLUDE bios.const .PROC BOOT_WRIT, 2 ; This service writes a bootstrap track, whose contents are ; supplied in an argument array, to the diskette in Unit 5. ; It is declared in the calling Pascal program as: ; PROCEDURE boot_writ ; ; (VAR ; rslt: INTEGER; ; {Result of the format process. Values ; correspond to IO_RESULT.} ; ; VAR ; boot_ary); ; {Bootstrap to be installed on new disk.} ; ; EXTERNAL; ; Recalibrate drive B. CALL FDC_RECAL ; Position SBIOS address for DMA programming. POP HL EX (SP), HL ; Interpret result of recalibration. JR NZ, $1 ; Write bootstrap to track 0. CALL SEND_W_LST CALL SEND_BUT $1: ; Return result of write to calling program. POP DE POP HL LD (HL), A INC HL LD (HL), 0 EX DE, HL JP (HL) SEND_W_LST: ; This service prepares the DMA controller to send a bootstrap parameter ; list to the FDC as needed during SBIOS updating. ; On Entry: ; (HL) => SBIOS Control list. LD C, DMA_ADR OUT (C), L OUT (C), H INC C ; DMA_TMCNT LD HL, 91FFH OUT (C), L OUT (C), H LD A, 41H OUT (DMA_CTL), A RET SEND_BUT: ; This service sends the format command list to the FDC and interprets ; its response. LD HL, FDC_BUT_TBL LD B, 9 CALL SEND_CMD CALL POLL_INT CALL INT_R_W_ST RET SEND_CMD: ; Write a command to the disk. ; On Entry: ; (B) = Command Table Length. ; (HL) => Command Table. ; On Exit: ; (B), (C), (HL) spoiled. LD C, FDC_DATA $1: ; Wait for FDC to be ready. IN A, (FDC_STAT) AND 0C0H CP 080H JR NZ, $1 ; Send next character. OUTI RET Z JR $1 FDC_RECAL: ; This service restores the active drive to track 0. ; On Exit: ; (A) = 0 | if recalibration successful. ; (ZF) set | ; (A) = IO_RESULT if recalibration unsuccessful, or ; drive off line. LD HL, FDC_RCL_TBL LD B, 2 CALL SEND_CMD ; Wait for recalibration to complete. CALL POLL_INT ; Sense status and interpret. CALL SNS_INT_ST AND A RET POLL_INT: ; Detect FDC interrupt signal. This signals the begining of the ; result phase for many FDC functions. IN A, (FDC_INT) RLA RET C JR POLL_INT SNS_INT_ST: ; Checks the status of the FDC after completion os a seek or ; recalibrate. ; On Exit: ; (A) = 0 if no error. ; 1 if seek abnormally completed. ; 9 if drive off-line. ; Send prompt command. LD HL, SIS_CMD_TB ; Sense Interrupt command table. LD B, 1 CALL SEND_CMD ; Accept the two result bytes. Only the first is important. CALL GET_RSLT_BT LD B, A CALL GET_RSLT_BT ; Decode error flags. BIT 3, B LD A,9 RET NZ LD A, 0D0H AND B RET Z LD A, 1 RET INT_R_W_ST: ; Interpret the seven byte status returned by the FDC after a ; read or write command. Only the first three bytes are im- ; portant, but all bytes must be read. Give immediate pre- ; ference to non-CRC errors. ; On Exit: ; (A) = 0 if no error. ; 1 if CRC error. ; 2 if seek error. ; 3 if illegal IO request. ; 9 if drive off-line. ; 16 if write protected error. ; Accept first three bytes and interpret error flags. CALL GET_RSLT_BT ; ST0 byte. LD E, 6 BIT 3, A ; Not ready bit. LD B, A LD A, 9 JR NZ, $1 LD A, 0D0H ; Interrupt code, Equip Chk. AND B LD D,A CALL GET_RSLT_BT ; ST1 byte. DEC E LD B,A LD A, 02H ; Write protected. AND B LD A, 16 JR NZ, $1 LD A, 84H ; End cyl, No data. AND B LD A, 3 JR NZ, $1 LD A, 61H ; Data Error, Overrun, MAM. AND B OR D LD D,A CALL GET_RSLT_BT ; ST2 byte. DEC E LD B, A LD A, 12H ; Bad cylinder error. AND B LD A, 2 JR NZ, $1 LD A, B OR D LD A, 0 JR Z, $1 INC A $1: ; Read and discard remaining result bytes. LD B, E LD E, A $2: CALL GET_RSLT_BT DJNZ $2 LD A, E RET GET_RSLT_BT: ; Wait until FDC is ready to send, and then accept input byte ; in (A). IN A, (FDC_STAT) AND 0C0H CP 0C0H JR NZ, GET_RSLT_BT ; Accept character. IN A, (FDC_DATA) RET ; This section defines the working storage data blocks used by the ; Bootmaker for its own purposes. ; Disk Command Tables ; ---- ------- ------ SIS_CMD_TB: ; Table to define Sense Interrupt Status command. .BYTE 08H FDC_RCL_TBL: ; Table of recalibration control parameters needed by FDC. .BYTE 07H ; Recalibrate command. .BYTE 1 ; Disk number. FDC_BUT_TBL: ; Table of SBIOS writing control parameters needed by FDC. .BYTE 45H ; Write command. .BYTE 1 ; Disk number. .BYTE 0 ; Track number of track to which disk ; is currently positioned by recalibrate. .BYTE 0 ; Head number. .BYTE 1 ; Initial sector number. .BYTE 2 ; Sector size = 2 for 512. .BYTE 9 ; Sectors / track. .BYTE 27 ; Gap-3 read/write length. Format ; length is 84 bytes for Sony disks. .BYTE 0FFH ; Data length (superseded ; by sector size. .END ********** George: This looked OK as it was echoed to me. Please let me know if there are any problems with it. Karl Action? purge Purged. Action? ======================================================================================== DOCUMENT :usus Folder:VOL20:bootmaker.text ======================================================================================== {Version 001 16 Jan 82 KGB Original issue.} {$I-} PROGRAM bootmaker; {********************************************************************** * (C) 1982 K. G. Balke, Associates. * * All rights reserved. * **********************************************************************} {$C (C) 1982 K. G. Balke, Associates} {This program installs a complete bootstrap and SBIOS on a Sony micro- floppy disk.} CONST bios_len = 4; bios_pos = 2560; sboot_len = 4; boot_pos = 0; sboot_nam = 'load.sboot'; sboot_pos = 512; VAR blks: INTEGER; {Number of blocks read from bootstrap file in most recent block read.} boot_ary: PACKED ARRAY [0 .. 4607] OF CHAR; {Transfer block for accumulating new bootstrap and bios components. Order is: Primary bootstrap 1 Secondary bootstrap 4 SBIOS 4} boot_file: FILE; {File for reading bootstrap and bios components.} boot_rslt: INTEGER; {IO_RESULT equivalent returned by the formatting service of the SBIOS.} f_rslt_str: STRING; {String for accumulating formatting error diagnostic message.} in_ary: PACKED ARRAY [0 .. 1] OF CHAR; PROCEDURE boot_writ {Format a diskette with interleave 2, skew 4.} (VAR rslt: INTEGER; {Result of the format process. Values correspond to IO_RESULT.} VAR boot_ary); {Bootstrap to be installed on new disk.} EXTERNAL; PROCEDURE diag_file {Diagnose result of block read and abort program if error.} (r: INTEGER; {Number of blocks actually read.} t: INTEGER; {Target block count.} i: INTEGER); {IO Result of operation.} BEGIN {diag_file} IF (r <> t) OR (i > 0) THEN BEGIN GO_TO_X_Y (0, 23); WRITE ('Bootstrap files could not be read. Result = ', i, '.'); EXIT (bootmaker) END END {diag_file}; BEGIN {bootmaker} WRITE (CHR (27), '*'); GO_TO_X_Y (56, 0); WRITE (CHR (27), 'k'); GO_TO_X_Y (23, 0); WRITE (CHR (27), 'j PASCAL DISK BOOTSTRAP INSTALLER'); GO_TO_X_Y (55, 1); WRITE (CHR (27), 'm'); GO_TO_X_Y (22, 1); WRITE (CHR (27), 'l(C) 1982 K. G. Balke, Associates'); FILL_CHAR (boot_ary, 4608, CHR (0)); RESET (boot_file, 'e.load.boot'); blks := BLOCK_READ (boot_file, boot_ary [boot_pos], 1); diag_file (blks, 1, IO_RESULT); CLOSE (boot_file); RESET (boot_file, sboot_nam); blks := BLOCK_READ (boot_file, boot_ary [sboot_pos], sboot_len); diag_file (blks, sboot_len, IO_RESULT); CLOSE (boot_file); RESET (boot_file, 'e.load.bios'); blks := BLOCK_READ (boot_file, boot_ary [bios_pos], bios_len); diag_file (blks, bios_len, IO_RESULT); CLOSE (boot_file); GO_TO_X_Y (0, 23); WRITE ('Bootstrap Track Constructed.'); UNIT_CLEAR (5); GO_TO_X_Y (5, 10); WRITE ('Place disk to receive new bootstrap in Unit #5.'); GO_TO_X_Y (5, 11); WRITE ('Enter to install bootstrap, other key to stop.'); REPEAT UNIT_READ (2, in_ary, 1,, 12); IF in_ary [0] = CHR (13) THEN BEGIN boot_writ (boot_rslt, boot_ary); GO_TO_X_Y (0, 23); IF boot_rslt IN [0, 9] THEN BEGIN CASE boot_rslt OF 0: f_rslt_str := 'Bootstrap installed successfully.'; 9: f_rslt_str := 'No disk in Unit #5. ' END; WRITE (f_rslt_str) END ELSE WRITE ('Installation result = ', boot_rslt, '. ') END ELSE BEGIN GO_TO_X_Y (0, 23); WRITE ('Installation terminated. ') END UNTIL in_ary [0] <> CHR (13) END {bootmaker}. ======================================================================================== DOCUMENT :usus Folder:VOL20:bootr-genr.text ======================================================================================== cbootmaker t aboot.write boot.write lt boot.write bootmaker.code frt.code yq ======================================================================================== DOCUMENT :usus Folder:VOL20:e.boot.text ======================================================================================== .TITLE "K. G. Balke, Associates, Primary Courier Pascal Bootstrap" ; Author: Karl G. Balke ; Brian K. E. Balke ; Version: 15 September 1982 .INCLUDE bios.const BIOS_BASE .EQU 0F800H ; Base of BIOS as loaded from Track ; 0 of disk. S_BOOT_PSN .EQU 8200H ; Location of secondary bootstrap. .PROC PRIM_BOOT ; This program will be loaded into locations 2800-28FFH ; by the bootstrap ROM in the computer. It will then load the ; secondary bootstrap and the SBIOS, sete up the initial stack ; contents for the secondary bootstrap, and initiate Pascal system ; loading. ; Set up a stack for calls to GET_DATA. LD SP, 8000H ; Initialize the Pascal stack with disk parameters per boot source. ; Note that this bootstrap assumes that it is being loaded from a ; double-sided, double-density disk in KGBA standard format. LD DE, BIOS_BASE - 5 LD BC, 24 LD HL, PAS_STK_TP - 1 LDDR ; Specify disk characteristics per table. LD HL, FDC_SPC_TB LD C, 3 CALL WRT_FDC_CMD ; Disk is on line. Restore it to track 0. LD HL, FDCTBL LD (HL), 07H ; Recalibrate command. LD C, 2 CALL WRT_FDC_CMD CALL POLL_INT CALL GET_INT_ST AND 0D8H JR NZ, $ ; Load the secondary bootstrap from sectors 2-5 into 8200H. LD HL, S_BOOT_PSN LD DE, 47FFH CALL RD_FDC AND A JR NZ, $ ; Load the SBIOS from sectors 6-8 into BIOS_BASE. LD A, 6 LD (FDCTBL + 4), A LD HL, BIOS_BASE LD DE, 45FFH CALL RD_FDC AND A JR NZ, $ ; Initialize serial port controller timers. LD HL, DIA_SPEED LD A, 36H OUT (CNT_MDM), A LD C, CNT_REG_0 OUT (C), L OUT (C), H LD HL, MDM_SPEED LD A, 76H OUT (CNT_MDM), A INC C ; CNT_REG_1 OUT (C), L OUT (C), H ; Establish the line characteristics for the Diablo printer. LD A, 4EH OUT (PRTDIA + STAT_PRT), A ; Turn on port. LD A, 37H OUT (PRTDIA + STAT_PRT), A ; Bootstrap properly loaded. Execute secondary bootstrap. LD SP, BIOS_BASE - 28 JP S_BOOT_PSN DBG_WRT: PUSH AF $1: IN A, (CRT_STAT) AND 01H JR Z, $1 POP AF OUT (CRT_DATA), A RET RD_FDC: ; This subroutine programs the DMA according to input values, ; writes and executes the read command, and analyzes the result. ; On entry: ; (DE) = DMA termination count. ; (HL) = DMA buffer address. ; Program DMA. LD C, DMA_ADR OUT (C), L OUT (C), H INC C OUT (C), E OUT (C), D LD A, 41H OUT (DMA_CTL), A ; Execute read and get result. LD HL, FDCTBL LD (HL), 46H ; Read command. LD C, 9 CALL WRT_FDC_CMD CALL GET_RD_RSLT RET GET_RD_RSLT: ; Accept result characters from FDC and analyse error flags. ; On exit: ; (A) = 0 if no errors, <> 0 otherwise. CALL POLL_INT CALL GET_RSLT_BT AND 0D8H LD C, A CALL GET_RSLT_BT OR C LD C, A CALL GET_RSLT_BT AND 073H OR C LD C, A ; Drop rest of result message. LD B, 4 $1: CALL GET_RSLT_BT DJNZ $1 LD A, C RET POLL_INT: ; Wait for FDC to generate interrupt, signaling that command ; execution is completed. IN A, (FDC_INT) RLA JR NC, POLL_INT RET GET_RSLT_BT: ; Poll FDC for ready to send status, and accept character. ; On exit: ; (A) = character. IN A, (FDC_STAT) AND 0C0H CP 0C0H JR NZ, GET_RSLT_BT IN A, (FDC_DATA) RET GET_INT_ST: ; Write Sense Interrupt Status enquiry to FDC and accept response. ; On exit: ; (A) = response. LD HL, FDCTBL LD (HL), 08H LD C, 1 CALL WRT_FDC_CMD ; Get SR0 and save. CALL GET_RSLT_BT LD B, A ; Discard present cylinder number. CALL GET_RSLT_BT LD A, B RET WRT_FDC_CMD: ; Output the prepared command to the FDC. ; Test FDC ready status. IN A, (FDC_STAT) RLA JR NC, WRT_FDC_CMD ; Output next byte of command. LD A, (HL) OUT (FDC_DATA), A INC HL DEC C RET Z JR WRT_FDC_CMD .ALIGN 2 FDCTBL: ; FDC command table. Only command and sector are variable in ; this application. .BYTE 0 ; command .BYTE 0 ; disk # .BYTE 0 ; track # .BYTE 0 ; head # .BYTE 2 ; sector # .BYTE 2 ; sector size = 2 for 512 .BYTE 9 ; sectors/track .BYTE 27 ; gap .BYTE 0FFH ; data length (superseded by sector size) FDC_SPC_TB: ; FDC Specify Command Table. Specifies characteristics of Sony ; 3-1/4" single-sided micro-floppy drives. .BYTE 003H ; Specify instruction. .BYTE 01FH ; Head unload time/Step rate. .BYTE 03CH ; 60 ms head load delay. PAS_STK_BT: ; Bootstrap control stack. .WORD 100H ; Interpreter address. .WORD BIOS_BASE ; SBIOS jump vector location. .WORD 100H ; Lowest memory. .WORD BIOS_BASE - 2 ; Highest available memory. .WORD 70 ; Tracks/disk. .WORD 9 ; Sectors/track. .WORD 512 ; Bytes/sector. .WORD MFD_INTL ; Interleave. .WORD 1 ; First Pascal track. .WORD MFD_SKEW ; Track to track skew. .WORD 9 ; Maximum sectors/track. .WORD 512 ; Maximum bytes/sector. PAS_STK_TP: .WORD 0 .END ======================================================================================== DOCUMENT :usus Folder:VOL20:e.load.bios ======================================================================================== Ã]øÃøÃ2ùÃøÉøÔøÃ`úÃjúÃoúÃtúÃûÃ/ûÃXúÃ6ùÃ6ùßøéøÃÂøÃÇøÃŒûÃŒûÃŒûÃŒûÃ4ùÃ4ùÃ4ùÃ4ùÃûóÉûÉÃ7ùíC®úíCðûíCòûÍ”ø*Í”øÍGúɯÉÛ©æÈ ¯ÉÛ©æ(úÛ¨O¯ÉÛ©æ(úyÓ¨¯É>†Íùþ ȯÉY>†Íùþ Èõ{§(ñ¯ÉñþÀ É>Éyæ_>†ÍùþÀöO >íy>@íyíY>7íyÉWzÍöø JíHɧÀñO í@Ëx> ( >8 > ¯ÿËHÀÉWzÍùþ(øÐJíYÉO í@Ëx> ÈË@>ȯËPÀ<ɯÉ> ÉÍ`úÍ+úÀ!¨ûͼùÍÏù§À!Ìûü$í°EÅ !üq####ùÍjúÍyú!üͼùÍÏùûû!ü$í°!ûûí°Á§À ËÍjú;üÍtú ÅÍoúÍ`úÍû§ Í`úÍ/û§ÁÀ ãÉ°íiía !#€íiía>AÓ¸É!¢ûÍÞùÍ©úÍÍúÉ¡Û æÀþ€ øí£Èó!üù~þÿ(þOÍ”ø#ôUnrecoverable disk protocol error. ÿ:šûþ> É!™û6ÍÞùÍ©úͲú§õ!›û(>ÿwñÉÍ`úÍXúÍ`úÍXúÉÍ#úÐÍ+úÉy2šû!›û6ÿÉy2ùûÉy2ûÉíCôûÉ:ùûþF8á>§ÉG!›û–Èxw§Ê+ú!™û6ÍÞùÍ©úͲú§È!›û6ÿÉÛ¢ØÍ÷!˜ûÍÞùÍûGÍûËX> À>РÈ>ÉÍûË_G> 0>РWÍûG:úû > >„ > >a ²WÍûG> > x²>(2úû!ÿA"öû!øû6F>2úû!ÿ"öû!øû6EÍ#úÐÍyú(þ È{Ö_>ØÍ+úì°*ôûíiía *öûíiía>AÓ¸:øû!™ûw ÍÞùÍ©úÕÍÍúѧÈþ(Å ÂÉ> É>!É ÿM TN  $CURSOR $EQUAL  O.c§c§ ======================================================================================== DOCUMENT :usus Folder:VOL20:e.load.boot ======================================================================================== 1€û÷! )í¸!ï(ÍØ(!æ(6ÍØ(Í´(ÍÅ(æØ þ!‚ÿGÍy(§ þ>2ê(!øÿEÍy(§ þ! >6Ó‹ˆíiía! >vÓ‹ íiía>NÓ‡>7Ó‡1ä÷ÂõÛ©æ(úñӨɰíiía íYíQ>AÓ¸!æ(6F ÍØ(Í–(ÉÍ´(ͺ(æØOͺ(±Oͺ(æs±Oͺ(ûyÉÛ¢0ûÉÛ æÀþÀ øÛ¡É!æ(6ÍØ(ͺ(Gͺ(xÉÛ 0û~Ó¡# Èó ÿ<øþ÷F  Ã]øÃøÃ2ùÃøÉøÔøÃ`úÃjúÃoúÃtúÃûÃ/ûÃXúÃ6ùÃ6ùßøéøÃÂøÃÇøÃŒûÃŒûÃŒûÃŒûÃ4ùÃ4ùÃ4ùÃ4ùÃûóÉûÉÃ7ùíC®úíCðûíCòûÍ”ø*Í”øÍGúɯÉÛ©æÈ ¯ÉÛ©æ(úÛ¨O¯ÉÛ©æ(úyÓ¨¯É>†Íùþ ȯÉY>†Íùþ Èõ{§(ñ¯ÉñþÀ É>Éyæ_>†ÍùþÀöO >íy>@íyíY>7íyÉWzÍöø JíHɧÀñO í@Ëx> ( >8 > ¯ÿËHÀÉWzÍùþ(øÐJíYÉO í@Ëx> ÈË@>ȯËPÀ<ɯÉ> ÉÍ`úÍ+úÀ!¨ûͼùÍÏù§À!Ìûü$í°EÅ !üq####ùÍjúÍyú!üͼùÍÏùûû!ü$í°!ûûí°Á§À ËÍjú;üÍtú ÅÍoúÍ`úÍû§ Í`úÍ/û§ÁÀ ãÉ°íiía !#€íiía>AÓ¸É!¢ûÍÞùÍ©úÍÍúÉ¡Û æÀþ€ øí£Èó!üù~þÿ(þOÍ”ø#ôUn ======================================================================================== DOCUMENT :usus Folder:VOL20:ebios-genr.text ======================================================================================== aebios ebios lebios x*compress nF800 *system.wrk e.load.bios fnyn q ======================================================================================== DOCUMENT :usus Folder:VOL20:ebios.text ======================================================================================== .TITLE "K. G. Balke, Associates, Z80 Pascal SBIOS" ; Author: Karl G. Balke ; Version: 6 July 1982 .INCLUDE bios.const .PROC COUR_BIOS CRJMP00: ; This vector connects the UCSD PASCAL interpreter to the SBIOS routines. ; #00 SYSINIT Entry. JP INIT ; #03 SYSHALT Entry. JP $ ; #06 CONINIT Entry. JP CONINI ; #09 CONSTAT Entry. JP DR_CRS ; #12 CONREAD Entry. JP DR_CRI ; #15 CONWRIT Entry. JP DR_CRO ; #18 SETDISK Entry. JP DSKDKN ; #21 SETTRAK Entry. JP DSKDKT ; #24 SETSECT Entry. JP DSKDKS ; #27 SETBUFR Entry. JP DSKDKB ; #30 DSKREAD Entry. JP DSKDKR ; #33 DSKWRIT Entry. JP DSKDKW ; #36 DSKINIT Entry. JP DSKDKI ; #39 DSKSTRT Entry. JP NULL ; #42 DSKSTOP Entry. JP NULL ; #45 PRNINIT Entry. JP DR_DIB ; #48 PRNSTAT Entry. JP DR_DIS ; #51 PRNREAD Entry. JP DR_DII ; #54 PRNWRIT Entry. JP DR_DIO ; #57 REMINIT Entry. JP PHN_STT ; #60 REMSTAT Entry. JP PHN_STT ; #63 REMREAD Entry. JP PH_CIN ; #66 REMWRIT Entry. JP PHCOUT ; #69 USRINIT Entry. JP OFFLIN ; #72 USRSTAT Entry. JP OFFLIN ; #75 USRREAD Entry. JP OFFLIN ; #78 USRWRIT Entry. JP OFFLIN ; #81 CLKREAD Entry. JP CLK_RD ; #84 QUIET Entry. (IV.02 and later only) DI RET NOP ; #87 ENABLE Entry. (IV.02 and later only) EI RET NOP ; #90 FORMAT Entry. (Courier BIOS only) JP FMT_DISK .INCLUDE BIOS.SERPT .INCLUDE BIOS.DISKS .INCLUDE BIOS.PHONE CLK_RD: ; This service provides dummy results for the BIOS clock procedures. ; Actual clock management is provided by Pascal procedures. LD A, 0 LD DE, 0 LD HL, 0 RET .INCLUDE BIOS.DATA ; Padding for pascal Blue - courier system transfer routine. .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 .WORD 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 .END ======================================================================================== DOCUMENT :usus Folder:VOL20:eboot-genr.text ======================================================================================== ae.boot e.boot le.boot x*compress n2800 *system.wrk e.load.boot fnyn q ======================================================================================== DOCUMENT :usus Folder:VOL20:escort.doc.text ======================================================================================== This disk contains the files necessary to construct and install an SBIOS for the Jonos Escort portable computer. This SBIOS is suitable for use with SofTech MicroSystems UCSD Pascal, Version IV.1 (UCSD Pascal and p-System are registered trademarks of the Regents of the University of California). In addition to the basic SBIOS files, it contains the text of a program to format the SONY 3.5" single sided disks which the Escort uses, and one side of a file transfer program which can be used to exchange Pascal files through one of the serial ports at up to 9600 bits per second. The accompanying program material material is copyrighted. Permission is hereby granted for the free private use and modification of the programs on this disk by any members of USUS or their associates for any non-commercial use only. The disk contains text files for the SBIOS, the installation program (bootmaker), the disk formatting program (formatter), the serial port transfer program (trans-mgr), and miscellaneous supporting programs and units which these programs need to operate. In addition, it contains assembled versions of the bootstrap and SBIOS code, suitable for installation on a disk as described below. Each program on this disk can be assembled and/or compiled using an appropriate redirection file. The names of all redirection files end in '-genr.text'. The suite of programs is sufficient to install the p-System on an Escort once a working system disk is available for that machine; however, it does not contain a method for transferring the files from a p-System to the Escort to begin with. A simple serial port transfer can be constructed under CP/M (which comes with the Escort) (CP/M is a registered trademark of Digital Research) to get the load files installed on track 0 to begin with. I suggest that the bootstrap (file 'E.LOAD.BOOT' on this disk) be installed in sector 1, the secondary bootstrap (which you must extract from your SMS distribution disk) be installed in sectors 2-5, and the SBIOS itself (file 'E.LOAD.BIOS' on this disk) be installed in sectors 6-9. The code may be well enough documented internally so that it is clear to an experienced Z80 assembly language programmer with access to the SofTech Adaptable System "Installation Guide" and the IV.1 supplementary documentation. I simply do not have time to write a more thorough explanation of the code, or how to use it. Good luck with your installation! ======================================================================================== DOCUMENT :usus Folder:VOL20:fastread.text ======================================================================================== { FASTREAD - fast text file string read for UCSD pascal. } { dhd - PCD Systems, Inc. } { S+} { 17 Aug 82 [acd] Fixed bug on consecutive null lines with no blank compression 17 Aug 82 [acd] Intrinsic declarations for Apple iron made conditional 14 Aug 82 [acd] Changed to intrinsic for Apple ][ 12 Aug 82 [acd] Fixed error on blank lines with indent count } UNIT FastRead ; {%IFT Apple } (*INTRINSIC CODE 16 ;*) {%ENDC } INTERFACE CONST BufSiz = 1024 ; LineMax = 255 ; TYPE LineIndex = 0..LineMax ; LongString = String[LineMax] ; FFile = FILE ; Fcb = RECORD InLFN : STRING[30] ; { input file name } Line : LongString ; { current text line } BPos : INTEGER ; { buffer position } EndFile : BOOLEAN ; { true when end of file } Buf : PACKED ARRAY [0..BufSiz] OF CHAR ; BlkNr : INTEGER ; END ; { Fcb } PROCEDURE GetString ( VAR Phyle : Fcb ; VAR InFile: FFile ; VAR s : LongString ) ; PROCEDURE OpenFile ( VAR Phyle : Fcb ; VAR InFile: FFile ; VAR Lfn : STRING ) ; IMPLEMENTATION PROCEDURE OpenFile { VAR Phyle : Fcb ; VAR InFile: FFile ; VAR Lfn : STRING } ; BEGIN { OpenFile } WITH Phyle DO BEGIN RESET( InFile, Lfn ) ; InLFN := Lfn ; Line := '' ; BPos := BufSiz + 1 ; EndFile := FALSE ; BlkNr := 2 ; END ; END ; { OpenFile } PROCEDURE GetString { VAR Phyle : Fcb ; VAR InFile: FFile ; VAR s : LongString } ; CONST Cr = 13 ; Dle = 16 ; VAR BCnt, Chg : INTEGER ; Found : BOOLEAN ; BEGIN { GetString } {$R- disable string range checks } WITH Phyle DO REPEAT IF BPos >= BufSiz THEN { time for next buffer } BEGIN BCnt := BLOCKREAD( InFile, Buf[0], 2, BlkNr ) ; BPos := 0 ; BlkNr := BlkNr + BCnt ; IF BCnt < 2 THEN { eof } BEGIN EndFile := TRUE ; EXIT( GetString ) END ; { if } END ; { if } Chg := SCAN( BufSiz-BPos, =CHR(Cr), Buf[BPos] ) ; IF (BPos + Chg) < BufSiz THEN { found a carriage return } BEGIN MOVELEFT( Buf[BPos], s[1], Chg ) ; { copy string except CR } s[0] := CHR( Chg ) ; BPos := SUCC( BPos + Chg ) ; Found := TRUE END ELSE BEGIN Chg := SCAN( BufSiz-BPos, =CHR(0), Buf[BPos] ) ; { look for null } IF (BPos + Chg) < BufSiz THEN BEGIN MOVELEFT( Buf[BPos], s[1], Chg-1 ) ; s[0] := CHR( Chg ) ; BPos := BufSiz ; END ; Found := FALSE END ; UNTIL Found ; IF LENGTH( s ) >= 2 THEN { acd - 12 Aug 82 } IF s[1] = CHR(dle) THEN { insert leading blanks } BEGIN Chg := ORD( s[2] ) - ORD( ' ' ) ; IF Chg > 2 THEN MOVERIGHT( s[3], s[Chg+1], LENGTH(s)-2 ) ELSE MOVELEFT( s[3], s[Chg+1], LENGTH(s)-2 ) ; FILLCHAR( s[1], Chg, ' ' ) ; s[0] := CHR( LENGTH(s)+Chg-2 ) ; END ; {$R+} END ; { GetString } END. { of unit } ======================================================================================== DOCUMENT :usus Folder:VOL20:fmt-genr.text ======================================================================================== cformatter t lt fmt-link formatter.code frt.code yq ======================================================================================== DOCUMENT :usus Folder:VOL20:formatter.text ======================================================================================== PROGRAM formattr; {********************************************************************** * (C) 1982 K. G. Balke, Associates. * * All rights reserved. * **********************************************************************} {$C (C) 1982 K. G. Balke, Associates} {This program formats a Sony micro-floppy diskette in [2:7] format for use with the Courier portable computer. The formatting algorithms are included in the SBIOS.} VAR f_rslt_str: STRING; {String for accumulating formatting error diagnostic message.} fmt_rslt: INTEGER; {IO_RESULT equivalent returned by the formatting service of the SBIOS.} in_ary: PACKED ARRAY [0 .. 1] OF CHAR; PROCEDURE fmt_lnk {Format a diskette with interleave 2, skew 4.} (VAR rslt: INTEGER); {Result of the format process. Values correspond to IO_RESULT.} EXTERNAL; BEGIN {formattr} WRITE (CHR (27), '*'); GO_TO_X_Y (52, 0); WRITE (CHR (27), 'k'); GO_TO_X_Y (26, 0); WRITE (CHR (27), 'j PASCAL DISK FORMATTER '); GO_TO_X_Y (53, 1); WRITE (CHR (27), 'm'); GO_TO_X_Y (25, 1); WRITE (CHR (27), 'l(C) 1983 Balke Associates'); GO_TO_X_Y (5, 10); WRITE ('Place disk to be formatted in Unit #5.'); GO_TO_X_Y (5, 11); WRITE ('Enter to format, other key to stop.'); UNIT_READ (2, in_ary, 1,, 12); IF in_ary [0] = CHR (13) THEN BEGIN fmt_lnk (fmt_rslt); GO_TO_X_Y (5, 13); IF fmt_rslt IN [0, 9] THEN BEGIN CASE fmt_rslt OF 0: f_rslt_str := 'Disk formatted successfully.'; 9: f_rslt_str := 'No disk in Unit #5.' END; WRITE (f_rslt_str) END ELSE WRITE ('Format result = ', fmt_rslt, '.') END ELSE BEGIN GO_TO_X_Y (5, 13); WRITE ('Format not done.') END END {formattr}. ======================================================================================== DOCUMENT :usus Folder:VOL20:h19util.text ======================================================================================== {This unit was written for use with the H19 (Z19) terminal. It may be edited for use with some other terminals. Procedures or functions requiring editing include: CLEARSCREEN, SAVECURSOR, LINE25, GOTO25, NORMALKEYPAD, SHIFTKEYPAD, and IN_REAL. For the latter SAVECURSOR is almost essential; however, IN_REAL's error messages may be moved from line 24 (the "25th" line) to line 0 by making the changes marked with (**instruction **). Real numbers may be input from the terminal or a text file using IN_REAL. In either instance, input ofn of a number may be terminated by a space, comma, or carriage return. IN_REAL will not accept plus (+) signs. Modification to accept plus signs is possible by creating boolean variables POSNO and POSEXP and adding code similar to that for handling minus signs. The back space (erase) routines will have to be rewritten to handle no, plus, and minus signs. Another possibly useful alternative would be to rewrite IN_REAL as FUNCTION IN_REAL(VAR S : STRING): REAL where the string form of the number is saved (in the event it needed to be written out elsewhere).---Henry E. Baumgarten} (*$S+*) UNIT H19UTIL; (*Version 1.2, 17 Jan 83*) INTERFACE TYPE FILECODE = (INPT,INFIL,OUTFIL); VISIBLE = SET OF ' '..'~'; VAR XCUR,YCUR : INTEGER; PROCEDURE CLEARSCREEN; PROCEDURE CLEARSPACE(XCSP,YCSP,N : INTEGER); PROCEDURE SAVECURSOR(VAR XCUR,YCUR : INTEGER); PROCEDURE LINE25(ON : BOOLEAN); PROCEDURE GOTO25; PROCEDURE NORMALKEYPAD; PROCEDURE SHIFTKEYPAD; PROCEDURE CLEAR_EOL; PROCEDURE CLEAR_EOS; PROCEDURE GETREPLY (VAR REPLY : CHAR); FUNCTION DOIT : BOOLEAN; PROCEDURE PAUSE; FUNCTION CONTINUE: BOOLEAN; FUNCTION COMMAND(S : STRING; GOODSET : VISIBLE): CHAR; FUNCTION GOAHEAD: BOOLEAN; FUNCTION IN_REAL(VAR F : TEXT; FCODE : FILECODE): REAL; IMPLEMENTATION PROCEDURE CLEARSCREEN; VAR T : PACKED ARRAY [0..1] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('E'); UNITWRITE(1,T,2) END; PROCEDURE CLEAR_EOS; {clear to end of screeen (page)} VAR T : PACKED ARRAY [0..1] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('J'); UNITWRITE(1,T,2) END; PROCEDURE CLEAR_EOL; {clear to end of line} VAR T : PACKED ARRAY [0..1] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('K'); UNITWRITE(1,T,2) END; PROCEDURE CLEARSPACE (*XCSP,YCSP,N : INTEGER*); VAR I : INTEGER; CS :PACKED ARRAY [1..160] OF CHAR; BEGIN GOTOXY(XCSP,YCSP); FILLCHAR(CS,N,' '); FILLCHAR(CS[N+1],N,CHR(8)); UNITWRITE(1,CS[1],2*N); END; PROCEDURE SAVECURSOR (*VAR XCUR,YCUR : INTEGER*); VAR T : PACKED ARRAY [0..7] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('j'); T[2] := 27; T[3] := ORD('n'); UNITWRITE(1,T,4); UNITREAD(2,T[4],4); XCUR := T[7] - 32; YCUR := T[6] - 32 END; PROCEDURE LINE25(*ON : BOOLEAN*); VAR T : PACKED ARRAY [0..2] OF 0..255; BEGIN T[0] := 27; IF ON THEN T[1] := ORD('x') ELSE T[1] := ORD('y'); T[2] := ORD('1'); UNITWRITE(2,T,3) END; PROCEDURE GOTO25; VAR T : PACKED ARRAY [0..3] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('Y'); T[2] := 56; {Y=24+32} T[3] := 32; {X=0+32} UNITWRITE(2,T,4) END; PROCEDURE NORMALKEYPAD; VAR T : PACKED ARRAY[0..1] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('u'); UNITWRITE(1,T,2) END; PROCEDURE SHIFTKEYPAD; VAR T : PACKED ARRAY[0..1] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('t'); UNITWRITE(1,T,2) END; PROCEDURE GETREPLY (*VAR REPLY : CHAR*); VAR SURROGATE : PACKED ARRAY[0..0] OF CHAR; BEGIN UNITREAD(2,SURROGATE[0],1); REPLY := SURROGATE[0]; IF REPLY IN ['a'..'z'] THEN REPLY := CHR(ORD(REPLY) - 32); END; FUNCTION DOIT(* : BOOLEAN*); VAR REPLY : CHAR; BEGIN REPEAT GETREPLY(REPLY) UNTIL REPLY IN ['Y','N']; IF REPLY = 'Y' THEN DOIT := TRUE ELSE DOIT := FALSE END; PROCEDURE PAUSE; VAR REPLY : CHAR; BEGIN REPEAT GETREPLY(REPLY) UNTIL REPLY = ' ' END; FUNCTION CONTINUE(* : BOOLEAN*); VAR REPLY : CHAR; BEGIN REPEAT GETREPLY(REPLY) UNTIL REPLY IN [' ','Q']; IF REPLY = ' ' THEN CONTINUE := TRUE ELSE CONTINUE := FALSE END; FUNCTION COMMAND(*S : STRING; GOODSET : VISIBLE): CHAR*); VAR REPLY : CHAR; BEGIN WRITELN(S); REPEAT GETREPLY(REPLY) UNTIL REPLY IN GOODSET; COMMAND := REPLY END; FUNCTION GOAHEAD(* : BOOLEAN*); VAR REPLY : CHAR; BEGIN WRITELN('Check entries for errors. accepts, rejects, quits'); REPEAT GETREPLY(REPLY) UNTIL ((REPLY = ' ') OR (REPLY = CHR(9)) OR (REPLY = CHR(27))); IF (REPLY = CHR(27)) THEN BEGIN CLEARSCREEN; EXIT(PROGRAM) END; IF (REPLY = ' ') THEN GOAHEAD := TRUE ELSE GOAHEAD := FALSE; CLEARSCREEN END; FUNCTION IN_REAL(*VAR F : TEXT; FCODE : FILECODE): REAL*); TYPE NUMBERS = PACKED ARRAY[1..38] OF 0..255; VAR I,J,K : INTEGER; INTG,IFRACTN,FRACTION,EXPONENT,SUM,TESTNO : REAL; INT,FRAC,EX : NUMBERS; NEGNO,NEGEXP,DEC,EXPNT,FRACDONE : BOOLEAN; BS,CR,CH : CHAR; PROCEDURE ERRORHNDLR(KEY : INTEGER); VAR S : STRING; BEGIN SAVECURSOR(XCUR,YCUR); {CLEARSPACE(0,0,80); (**replaces next 2 lines**)} LINE25(TRUE); GOTO25; CASE KEY OF 1 : S := 'Number too large.'; 2 : S := 'Too many decimal points.'; 3 : S := 'Misplaced minus sign.'; 4 : S := 'Non-numerical character present.'; 5 : S := 'Misplaced "E"'; 6 : S := 'Exponent too large'; 7 : S := 'Mantissa = 0'; 8 : S := 'Plus sign not acceptable'; END; WRITE(S,' Type to continue or Q(uit.'); IF NOT CONTINUE THEN BEGIN CLEARSCREEN; (**delete 3 lines**) GOTOXY(0,0); LINE25(FALSE); CLEARSCREEN; EXIT(PROGRAM) END; {CLEARSPACE(0,0,80)} (**replaces next line**) CLEARSCREEN; GOTOXY(XCUR,YCUR); LINE25(FALSE); (**delete 1 line**) IF (FCODE = INPT) THEN WRITE(BS,' ',BS) END; PROCEDURE GET_INTEGER; BEGIN IF (CH IN ['0'..'9']) THEN BEGIN IF (INTG <= ((1.0E37 - ORD(CH) + ORD('0'))/10)) THEN BEGIN IF (I<0) THEN I := 0; I := I+1; INT[I] := ORD(CH)-ORD('0'); INTG := INTG*10 + ORD(CH) - ORD('0'); END ELSE ERRORHNDLR(1) END ELSE IF (CH = '.') THEN BEGIN DEC := TRUE; I := I+1; J := J+1; CH := '0'; END ELSE IF (CH = '-') THEN BEGIN CH := '0'; IF (I < 0) THEN BEGIN NEGNO := TRUE; I := I+1; END ELSE ERRORHNDLR(3) END ELSE IF (CH = '+') THEN ERRORHNDLR(8) ELSE IF (CH = 'E') THEN BEGIN CH := '0'; SUM := INTG; IF NOT(SUM = 0) THEN BEGIN EXPNT := TRUE; I := I+1; TESTNO := ROUND(LOG(SUM)) END ELSE ERRORHNDLR(7); END ELSE IF (CH = BS) THEN BEGIN IF (FCODE = INPT) THEN BEGIN IF (I<0) THEN WRITE(' ') ELSE WRITE(' ',BS) END; CH := '0'; IF (INTG>0) THEN INTG := (INTG - INT[I])/10 ELSE IF (I=0) THEN NEGNO := FALSE; IF (I>=0) THEN I := I-1; IF (I=0) AND (NOT NEGNO) THEN I := -1; END; IF NOT (CH IN [' ','0'..'9']) THEN ERRORHNDLR(4); END; PROCEDURE GET_FRACTION; BEGIN IF (CH IN ['0'..'9']) THEN BEGIN IF (J>=37) THEN BEGIN IF NOT FRACDONE THEN BEGIN IF ((ORD(CH)-ORD('0'))>=5) THEN BEGIN IFRACTN := IFRACTN+1.0; FRACDONE := TRUE END; FRAC[38] := ORD(CH)-ORD('0'); END; J := J+1; I := I+1 END ELSE BEGIN I := I+1; J := J+1; FRAC[J] := ORD(CH)-ORD('0'); IFRACTN := IFRACTN*10 + FRAC[J]; END END ELSE IF (CH = '.') THEN ERRORHNDLR(2) ELSE IF (CH = '-') THEN ERRORHNDLR(3) ELSE IF (CH = 'E') THEN BEGIN EXPNT := TRUE; CH := '0'; I := I+1; IF (J>=37) THEN SUM := INTG + IFRACTN/PWROFTEN(37) ELSE SUM := INTG + IFRACTN/PWROFTEN(J); IF NOT(SUM=0) THEN TESTNO := ROUND(LOG(SUM)) ELSE ERRORHNDRLR(7) END ELSE IF (CH = BS) THEN BEGIN IF (FCODE = INPT) THEN BEGIN IF (I<0) THEN WRITE(' ') ELSE WRITE(' ',BS) END; CH := '0'; IF (J=0) THEN DEC := FALSE ELSE IF (J>=38) THEN BEGIN IF FRACDONE THEN BEGIN IFRACTN := IFRACTN-1.0; FRACDONE := FALSE END END ELSE IF (IFRACTN>0) THEN IFRACTN := (IFRACTN - FRAC[J])/10; J := J-1; I := I-1 END ELSE IF NOT (CH IN ['0'..'9']) THEN ERRORHNDLR(4) END; PROCEDURE GET_EXPONENT; VAR EX0 : 0..255; EX1 : REAL; BEGIN IF (CH IN ['0'..'9']) THEN BEGIN EX0 := ORD(CH)-ORD('0'); IF (EXPONENT <= (37-EX0)/10) THEN BEGIN EX1 := EXPONENT*10+EX0; IF NOT((EX1+TESTNO)>37) THEN BEGIN IF (K<0) THEN K := 0; I := I+1; K := K+1; EX[K] := EX0; EXPONENT := EX1 END ELSE ERRORHNDLR(1) END ELSE ERRORHNDLR(6) END ELSE IF (CH = 'E') THEN ERRORHNDLR(5) ELSE IF (CH = '+') THEN ERRORHNDLR(8) ELSE IF (CH = '-') THEN BEGIN IF (K<0) THEN BEGIN I := I+1; K := 0; NEGEXP := TRUE; TESTNO := -TESTNO; CH := '0' END ELSE ERRORHNDLR(3) END ELSE IF (CH = BS) THEN BEGIN IF (FCODE = INPT) THEN BEGIN IF (I<0) THEN WRITE(' ') ELSE WRITE(' ',BS) END; CH := '0'; IF (EXPONENT>0) THEN EXPONENT := (EXPONENT - EX[K])/10 ELSE IF (K=0) THEN BEGIN NEGEXP := FALSE; TESTNO := -TESTNO END ELSE IF (K<0) THEN EXPNT := FALSE; IF (K>=0) THEN K := K-1; IF (K=0) AND (NOT NEGEXP) THEN K := -1; I := I-1 END ELSE IF NOT (CH IN ['0'..'9']) THEN ERRORHNDLR(4) END; BEGIN (*IN_REAL*) BS := CHR(8); CR := CHR(13); DEC := FALSE; NEGNO := FALSE; EXPNT := FALSE; NEGEXP := FALSE; FRACDONE := FALSE; I := -1; J := -1; K := -1; CH := '0'; INTG := 0; IFRACTN := 0; FRACTION := 0; EXPONENT := 0; IF (FCODE = INPT) THEN READ(F,CH); IF ((CH = CR) OR (CH = ',')) THEN CH := ' '; WHILE (NOT EOLN(F)) AND (NOT (CH = ' ')) DO BEGIN IF (FCODE = INFIL) THEN READ (F,CH); IF ((CH = CR) OR (CH = ',')) THEN CH := ' '; IF (NOT(DEC)) AND (NOT(EXPNT)) THEN GET_INTEGER ELSE IF DEC AND (NOT(EXPNT)) THEN GET_FRACTION ELSE IF EXPNT THEN GET_EXPONENT; IF (FCODE = INPT) THEN BEGIN READ(F,CH); IF ((CH = CR) OR (CH = ',')) THEN CH := ' '; END END; IF EOLN(F) THEN READLN(F); IF DEC THEN BEGIN IF (J>37) THEN J := 37; FRACTION := IFRACTN/PWROFTEN(J) END; EXPONENT := PWROFTEN(TRUNC(EXPONENT)); IF NEGEXP THEN EXPONENT := 1/EXPONENT; INTG := (INTG+FRACTION)*EXPONENT; IF NEGNO THEN INTG := -INTG; IN_REAL := INTG END; END. {of Unit} ======================================================================================== DOCUMENT :usus Folder:VOL20:home_loan.text ======================================================================================== { Changes made by reviewer: Replaced CHR(31) by RLF. Replaced CHR(29) by CEOL. Replaced PAGE(OUTPUT) by CLEARSCREEN. Added code for screen control and line DEFINESTRINGS. Cleaned up display (alignment, removal of previous entries, etc.) It was fairly easy to modify this program to (optionally) send output to the PRINTER. This was not done in this version because the exact code depends on the capability of the printer (presence or absence of form feeds for example). ---Henry E. Baumgarten } PROGRAM HOME_LOAN; TYPE SHORTSTRING = STRING[3]; VAR CEOL,CEOP,RLF,CLEAR_LINE : SHORTSTRING; A,R,Y,RATE,P,R12,R1,NP,FR,CM,CM1: REAL; PROCEDURE CLEARSCREEN; {Clears the TEXT screen} VAR CS : PACKED ARRAY[0..1] OF 0..255; BEGIN CS[0] := 27; CS[1] := ORD('E'); UNITWRITE(1,CS,2) END; PROCEDURE DEFINESTRINGS; BEGIN CEOL := '12'; {CEOL clears from cursor to end of line} CEOL[1] := CHR(27); CEOL[2] := 'K'; {The following was used by the Grundlers CEOL := '1'; CEOL[1] := CHR(29);} RLF := '1'; {RLF is a reverse line feed} RLF[1] := CHR(11); {The following is for the H19 RLF := '12'; RLF[1] := CHR(27); RLF[2] := 'I';} {The following was used by the Grundlers RLF := '1'; RLF[1] := CHR(31);} CEOP := '12'; {CEOP clears from cursor to end of page (screen)} CEOP[1] := CHR(27); CEOP[2] := 'J'; {The following was used by the Grundlers CEOP := '1'; CEOP[1] := CHR(11);} CLEAR_LINE := '1'; CLEAR_LINE[1] := CHR(13); {carriage return} CLEAR_LINE := CONCAT(CEOL,CLEAR_LINE); END; FUNCTION INPUT_VALUE:REAL; { function by: EDWARD J GRUNDLER } VAR I:INTEGER; INP:STRING; DEC,NEX,EX,NEG,OK:BOOLEAN; EXPO,J,X:REAL; BEGIN REPEAT DEC:=FALSE; EX:=FALSE; READLN(INP); IF LENGTH(INP)=0 THEN INP:='0'; OK:=NOT(INP[1]='E'); IF LENGTH(INP)>1 THEN OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E')); FOR I:=1 TO LENGTH(INP) DO BEGIN OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']); IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']); OK:=OK AND NOT(DEC AND(INP[I]='.')); IF NOT DEC THEN DEC:=(INP[I]='.'); OK:=OK AND NOT(EX AND (INP[I]='E')); IF NOT EX THEN EX:=(INP[I]='E'); IF I>1 THEN OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E')); OK:=OK AND NOT(EX AND (INP[I]='.')) END; OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']); OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9'])); IF NOT OK THEN WRITE(RLF,'Read Error. Try Again ',CEOL) UNTIL OK; X:=0; DEC:=FALSE; EXPO:=0; NEG:=FALSE; EX:=FALSE; J:=1; FOR I:=1 TO LENGTH(INP) DO BEGIN IF NOT DEC THEN DEC:=(INP[I]='.'); IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-'); IF NOT NEX THEN NEX:=EX AND (INP[I]='-'); IF NOT EX THEN EX:=(INP[I]='E'); IF EX AND NOT(INP[I] IN ['+','-','E']) THEN EXPO:=EXPO*10+ORD(INP[I])-ORD('0'); IF NOT EX THEN BEGIN IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN BEGIN J:=J/10; X:=X+(ORD(INP[I])-ORD('0'))*J END ELSE IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0') END END; IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO); IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X END; PROCEDURE GET_DATA; VAR CH: CHAR; BEGIN CLEARSCREEN; WRITE(' Type to continue or Q(uit'); READ(KEYBOARD,CH); IF CH IN ['Q','q'] THEN EXIT(HOME_LOAN); WRITELN; WRITE('Amt. of loan = '); A:=INPUT_VALUE; WRITE('Annual percent interest rate = '); RATE:=INPUT_VALLUE; WRITE('Length of loan (years) = '); Y:=INPUT_VALUE; END; { procedure GET_DATA } PROCEDURE PAYMENT; FUNCTION POWER(A,B:REAL):REAL; BEGIN POWER:=EXP(B*LN(A)) END; BEGIN R:=RATE/100; R12:=R/12; P:=A*R12/(1-POWER(1+R12,-12*Y)) END; PROCEDURE DISPLAY; VAR YR,MO,NEXTYR: INTEGER; BEGBAL,PAYINT,PAYPRIN,ENDBAL,TOTINT,TOTPRIN: REAL; CH: CHAR; PROCEDURE FIRST_STUFF; BEGIN CLEARSCREEN; WRITELN(' Amt of Loan = ',A:12:2,' Interest rate = ',RATE:6:2,' percent'); WRITELN(' Length of loan = ',Y:6:2,' years Monthly payment = ',P:8:2); R1:=RATE/1200+1; NP:=12*Y; FR:=0.5; CM:=NP+LN(1-FR*(1-EXP(-NP*LN(R1))))/LN(R1); WRITELN('The loan is ',(1-FR)*100:5:2,' percent paid off at ',TRUNC(CM/12)+1, ' years ',CM-12*TRUNC(CM/12):5:2,' months'); CM1:=NP+LN(0.5)/LN(R1)+1; WRITELN('Cross-over payment : ',TRUNC(CM1/12)+1,' years ', CM1-12*TRUNC(CM1/12):5:2,' months'); WRITELN; END; BEGIN FIRST_STUFF; WRITELN(' Beginning Payment Applied to Ending'); WRITELN(' Year Month Balance Interest Principal Balance'); YR:=1; MO:=1; BEGBAL:=A; TOTINT:=0; TOTPRIN:=0; WHILE BEGBAL>0 DO BEGIN PAYINT:=BEGBAL*R12; PAYPRIN:=P-PAYINT; ENDBAL:=BEGBAL-PAYPRIN; IF (YR=1) OR (YR=Y) OR (YR=NEXTYR) THEN begin WRITELN(YR:4,MO:6,BEGBAL:11:2,PAYINT:9:2,PAYPRIN:12:2,ENDBAL:11:2); TOTINT:=TOTINT+PAYINT; TOTPRIN:=TOTPRIN+PAYPRIN; IF MO=12 THEN begin WRITELN; WRITELN(' Totals for year: Interest = ',TOTINT:8:2, ' Principal = ',TOTPRIN:8:2); WRITELN; WRITE('Enter next year you want printed (0 to quit): ',CEOL); NEXTYR:=TRUNC(INPUT_VALUE); IF NEXTYR=0 THEN EXIT(DISPLAY); TOTINT:=0; TOTPRIN:=0; GOTOXY(0,7) end; end; BEGBAL:=ENDBAL; IF MO<12 THEN MO:=MO+1 ELSE begin MO:=1; YR:=YR+1 END; END; END; BEGIN { main program HOME_LOAN } DEFINESTRINGS; REPEAT GET_DATA; PAYMENT; DISPLAY UNTIL FALSE; END. ======================================================================================== DOCUMENT :usus Folder:VOL20:lwrcase.text ======================================================================================== program lowercase; {Version 1.1, 26 Oct 81} var ch,reply : char; sfin,sfout : string; fin,fout : text; i,rslt : integer; skip : boolean; procedure clearscreen; var lf : packed array [1..24] of char; i : integer; begin gotoxy(0,23); for i := 1 to 24 do lf[i] := chr(10); unitwrite(1,lf,24); gotoxy(0,0) end; procedure clearspace (x,y,n : integer); var i : integer; cs :packed array [1..160] of 0..255; begin gotoxy(x,y); for i := 1 to n do cs[i] := 32; for i := n+1 to n+n do cs[i] := 8; unitwrite(1,cs[1],n); unitwrite(1,cs[n+1],n) end; (*$I-*) procedure getinfile; begin repeat begin readln(sfin); reset(fin,sfin); rslt := ioresult; if rslt <> 0 then begin if rslt = 10 then begin sfin := concat(sfin,'.text'); reset(fin,sfin); rslt := ioresult end; if rslt <> 0 then begin gotoxy(0,20); write('IO error',rslt:3,'. Correct and type to continue or Q(uit)'); repeat read (keyboard, reply) until reply in ['Q','q',' ']; clearspace(0,20,72); if reply in ['Q','q'] then begin close(fout,lock); exit(program) end else clearspace(31,4,length(sfin)) end end end until rslt = 0 end; (*$I+*) (*$I-*) procedure getoutfile; begin repeat readln(sfout); rewrite(fout,sfout); rslt := ioresult; if rslt <> 0 then begin gotoxy (0,20); write('IO error',rslt:3,'. Correct and type to continue or Q(uit)'); repeat read(keyboard,reply) until reply in ['Q','q',' ']; clearspace(0,20,72); if reply in ['Q','q'] then begin clearscreen; exit(program) end else clearspace(32,2,length(sfout)) end until rslt = 0 end; (*$I+*) begin clearscreen; writeln('This program copies files in lower case.'); writeln; write('Enter output (lower case) file: '); getoutfile; writeln; write('Enter input (upper case) file: '); getinfile; writeln; writeln('Lines copied'); skip := false; I := 1; while (not eof(fin)) do begin while (not eoln(fin)) do begin read(fin,ch); if (ch in ['''','{','}']) then skip := not skip; if (ch >= 'A') and (ch <= 'Z') and not skip then ch := chr(ord(ch) + 32); write(fout,ch) end; readln(fin); writeln(fout); write('.'); if ((i mod 50) = 0) then writeln; i := i+1 end; close(fout,lock); close(fin) end. ======================================================================================== DOCUMENT :usus Folder:VOL20:number2.text ======================================================================================== (*$S+*) UNIT NUMBER2; INTERFACE USES {$U H19UTIL.CODE} H19UTIL; TYPE NUMBERTYPE = (DEC,HEX,OCT,BIN); HEXNUM = PACKED ARRAY [1..4] OF 0..15; BINNUM = PACKED ARRAY [0..15] OF 0..1; OCTNUM = PACKED RECORD O5,O4,O3,O2,O1: 0..7; O6 : 0..1; END; CHAMELEON = RECORD CASE NUMBERTYPE OF DEC : (INT : INTEGER); HEX : (HEXINT : HEXNUM); OCT : (OCTINT : OCTNUM); BIN : (BININT : BINNUM) END; VAR OCTAL,BINARY,HEXA : BOOLEAN; PROCEDURE WRITEHEX (INTG : INTEGER); PROCEDURE WRITEFLIP (INTG : INTEGER); PROCEDURE WRITEOCTAL (INTG : INTEGER); PROCEDURE WRITEBIN (INTG : INTEGER); PROCEDURE GETHEX (VAR DATA : INTEGER); PROCEDURE GETFLIP (VAR DATA : INTEGER); PROCEDURE GETOCTAL (VAR DATA : INTEGER); PROCEDURE GETBINARY (VAR DATA : INTEGER); IMPLEMENTATION VAR LEN : INTEGER; PROCEDURE WRITEHEX(* INTG : INTEGER *); VAR N : INTEGER; NUMBER : CHAMELEON; BEGIN NUMBER.INT := INTG; WITH NUMBER DO BEGIN FOR N := 4 DOWNTO 1 DO BEGIN IF (HEXINT[N] <= 9) THEN WRITE(HEXINT[N]) ELSE WRITE(CHR(HEXINT[N] + ORD('A') - 10)) END END END; PROCEDURE WRITEFLIP(* INTG : INTEGER *); VAR N : INTEGER; NUMBER : CHAMELEON; BEGIN NUMBER.INT := INTG; WITH NUMBER DO BEGIN FOR N := 2 DOWNTO 1 DO BEGIN IF (HEXINT[N] <= 9) THEN WRITE(HEXINT[N]) ELSE WRITE(CHR(HEXINT[N] + ORD('A') - 10)) END; FOR N := 4 DOWNTO 3 DO BEGIN IF (HEXINT[N] <= 9) THEN WRITE(HEXINT[N]) ELSE WRITE(CHR(HEXINT[N] + ORD('A') - 10)) END END END; PROCEDURE WRITEOCTAL(* INTG : INTEGER *); VAR N : INTEGER; NUMBER : CHAMELEON; BEGIN NUMBER.INT := INTG; WITH NUMBER.OCTINT DO WRITE(O6,O5,O4,O3,O2,O1) END; PROCEDURE WRITEBIN (* INTG : INTEGER *); VAR N : INTEGER; NUMBER : CHAMELEON; BEGIN NUMBER.INT := INTG; WITH NUMBER DO FOR N := 15 DOWNTO 0 DO WRITE(BININT[N]) END; PROCEDURE ERRHNDLR(VAR DATA : INTEGER); CONST BELL = 7; BEGIN CLEARSPACE(0,0,80); WRITE(CHR(BELL),'Improper number. Retype.'); CLEARSPACE(XCUR,YCUR,LEN); (*XCUR,YCUR are globals*) IF OCTAL THEN GETOCTAL(DATA) ELSE IF BINARY THEN GETBINARY(DATA) ELSE IF HEXA THEN GETHEX(DATA) ELSE GETFLIP(DATA); SAVECURSOR(XCUR,YCUR); CLEARSPACE(0,0,80); GOTOXY(XCUR,YCUR); IF OCTAL THEN EXIT(GETOCTAL) ELSE IF BINARY THEN EXIT(GETBINARY) ELSE IF HEXA THEN EXIT(GETHEX) ELSE EXIT(GETFLIP) END; PROCEDURE GETHEX(*VAR DATA : INTEGER*); VAR I : INTEGER; NUMBER : CHAMELEON; STR : STRING; BEGIN OCTAL := FALSE; BINARY := FALSE; HEXA := TRUE; SAVECURSOR(XCUR,YCUR); READLN(STR); LEN := LENGTH(STR); FOR I := 1 TO LEN DO IF NOT (STR[I] IN ['0'..'9','A'..'F']) THEN ERRHNDLR(DATA); IF (LEN > 4) THEN ERRHNDLR(DATA); FOR I := 1 TO (4-LEN) DO STR := CONCAT('0',STR); WITH NUMBER DO FOR I := 4 DOWNTO 1 DO IF STR[I] IN ['0'..'9'] THEN HEXINT[5-I] := ORD(STR[I]) - ORD('0') ELSE HEXINT[5-I] := ORD(STR[I]) - ORD('A') + 10; DATA := NUMBER.INT END; PROCEDURE GETFLIP(*VAR DATA : INTEGER*); VAR I : INTEGER; NUMBER : CHAMELEON; FLIPSTR,STR : STRING; BEGIN OCTAL := FALSE; BINARY := FALSE; HEXA := FALSE; STR := '1234'; SAVECURSOR(XCUR,YCUR); READLN(FLIPSTR); LEN := LENGTH(FLIPSTR); FOR I := 1 TO LEN DO IF NOT (FLIPSTR[I] IN ['0'..'9','A'..'F']) THEN ERRHNDLR(DATA); IF (LEN > 4) THEN ERRHNDLR(DATA); FOR I := 1 TO (4-LEN) DO FLIPSTR := CONCAT('0',FLIPSTR); STR[1] := FLIPSTR[3]; STR[2] := FLIPSTR[4]; STR[3] := FLIPSTR[1]; STR[4] := FLIPSTR[2]; WITH NUMBER DO FOR I := 4 DOWNTO 1 DO IF STR[I] IN ['0'..'9'] THEN HEXINT[5-I] := ORD(STR[I]) - ORD('0') ELSE HEXINT[5-I] := ORD(STR[I]) - ORD('A') + 10; DATA := NUMBER.INT END; PROCEDURE GETOCTAL(*VAR DATA : INTEGER*); VAR I : INTEGER; NUMBER : CHAMELEON; STR : STRING; BEGIN OCTAL := TRUE; BINARY := FALSE; HEXA := FALSE; SAVECURSOR(XCUR,YCUR); READLN(STR); LEN := LENGTH(STR); FOR I := 1 TO LEN DO IF NOT (STR[I] IN ['0'..'7']) THEN ERRHNDLR(DATA); IF (LEN > 6) THEN ERRHNDLR(DATA); FOR I := 1 TO (6-LEN) DO STR := CONCAT('0',STR); IF (STR > '177777') THEN ERRHNDLR(DATA); WITH NUMBER.OCTINT DO BEGIN O6 := ORD(STR[1]) - ORD('0'); O5 := ORD(STR[2]) - ORD('0'); O4 := ORD(STR[3]) - ORD('0'); O3 := ORD(STR[4]) - ORD('0'); O2 := ORD(STR[5]) - ORD('0'); O1 := ORD(STR[6]) - ORD('0') END; DATA := NUMBER.INT END; PROCEDURE GETBINARY(*VAR DATA : INTEGER*); VAR I : INTEGER; NUMBER : CHAMELEON; STR : STRING; BEGIN OCTAL := FALSE; BINARY := TRUE; HEXA := FALSE; SAVECURSOR(XCUR,YCUR); READLN(STR); LEN := LENGTH(STR); FOR I := 1 TO LEN DO IF NOT (STR[I] IN ['0','1']) THEN ERRHNDLR(DATA); IF (LEN > 16) THEN ERRHNDLR(DATA); FOR I := 1 TO (16-LEN) DO STR := CONCAT('0',STR); WITH NUMBER DO FOR I := 15 DOWNTO 0 DO BININT[I] := ORD(STR[16-I]) - ORD('0'); DATA := NUMBER.INT END; END. (* of unit *) ======================================================================================== DOCUMENT :usus Folder:VOL20:othello.1.text ======================================================================================== (*included from othello.text*) PROCEDURE findlegalmoves(VAR status: gamestatus; VAR legallist: movelist); VAR x,y: coordinate; sq: squareloc; flips,direcflips: INTEGER; borderflips: INTEGER; stopdirec: BOOLEAN; oppcolor: color; direc: direction; trydirs,gooddirs: SET OF direction; possible: BOOLEAN; sqstatus: squarestatus; BEGIN WITH status, legallist DO BEGIN oppcolor := flipof(nextmover); movecount := 0; FOR x := 1 TO 8 DO FOR y := 1 TO 8 DO BEGIN possible := FALSE; WITH boardstatus[x,y] DO IF NOT occupied THEN IF adjacentpieces[oppcolor] <> [] THEN BEGIN possible := TRUE; trydirs := adjacentpieces[oppcolor]; END; IF possible THEN BEGIN gooddirs := []; flips := 0; borderflips := 0; FOR direc := north TO nw DO IF direc IN trydirs THEN BEGIN sq := board[x,y].adjacentsq[direc]; sq := board[sq.row,sq.col].adjacentsq[direc]; IF sq.onboard THEN BEGIN direcflips := 1; stopdirec := FALSE; REPEAT sqstatus := boardstatus[sq.row,sq.col]; IF sqstatus.occupied THEN IF sqstatus.occupier = oppcolor THEN BEGIN direcflips := direcflips + 1; sq := board[sq.row,sq.col].adjacentsq[direc]; END ELSE stopdirec := TRUE ELSE BEGIN direcflips := 0; stopdirec := TRUE; END; UNTIL ( stopdirec OR (NOT sq.onboard) ); IF (stopdirec AND (direcflips>0)) THEN BEGIN flips := flips + direcflips; gooddirs := gooddirs + [direc]; IF board[x,y].border AND board[sq.row,sq.col].border THEN borderflips := borderflips + direcflips; END; END; (*IF sq.onboard...*) END; (*IF direc IN...*) IF flips > 0 THEN BEGIN movecount := movecount + 1; WITH okmove[movecount] DO BEGIN moveloc.onboard := TRUE; moveloc.row := x; moveloc.col := y; points := flips; dirsflipped := gooddirs; bordrsqsflipped := borderflips; END; END; END; (*IF possible...*) END; (*FOR x :=...FOR y :=...*) END; (*WITH status, legallist...*) END; (*findlegalmoves*) PROCEDURE inputmove(mover: color; legallist: movelist; VAR move: movedesc); VAR x,y: coordinate; xch,ych: CHAR; i,listindex: INTEGER; c: CHAR; BEGIN listindex := 0; REPEAT REPEAT GOTOXY(0,23); WRITE('Enter move for ',colorword[mover],': '); GOTOXY(22,23); READ(xch,ych); IF ych IN ['1'..'8'] THEN BEGIN (*Want xy but we'll accept yx*) c := ych; ych := xch; xch := c; END; IF ych IN ['a'..'h'] THEN ych := CHR(ORD(ych)-32); UNTIL ((xch IN ['1'..'8']) AND (ych IN ['A'..'H'])); x := ORD(xch) - ORD('1') + 1; y := ORD(ych) - ORD('A') + 1; i := 1; REPEAT IF legallist.okmove[i].moveloc.row = x THEN IF legallist.okmove[i].moveloc.col = y THEN listindex := i; i := i+1; UNTIL ((i>legallist.movecount) OR (listindex <> 0)); UNTIL listindex <> 0; move := legallist.okmove[listindex]; END; (*inputmove*) PROCEDURE makemove(*VAR status: gamestatus; VAR move: movedesc; updateadjacent: BOOLEAN*); VAR direc,direc2: direction; sq,sq2: squareloc; oppcolor: color; flips: INTEGER; emptyneighbors: SET of direction; BEGIN WITH status, move DO BEGIN lastmoveloc := moveloc; WITH boardstatus[moveloc.row,moveloc.col] DO BEGIN emptyneighbors := [north..nw] - adjacentpieces[white] - adjacentpieces[black]; occupied := TRUE; occupier := nextmover; END; oppcolor := flipof(nextmover); flips := 0; FOR direc := north TO nw DO IF direc IN dirsflipped THEN BEGIN sq := board[moveloc.row,moveloc.col].adjacentsq[direc]; REPEAT IF updateadjacent THEN FOR direc2 := north TO nw DO IF NOT (direc2 IN [direc,opposdir[direc]]) THEN BEGIN sq2 := board[sq.row,sq.col].adjacentsq[direc2]; IF sq2.onboard THEN WITH boardstatus[sq2.row,sq2.col] DO IF NOT occupied THEN BEGIN adjacentpieces[nextmover]:=adjacentpieces[nextmover] + [opposdir[direc2]]; adjacentpieces[oppcolor]:=adjacentpieces[oppcolor] - [opposdir[direc2]]; END; END; boardstatus[sq.row,sq.col].occupier := nextmover; flips := flips + 1; sq := board[sq.row,sq.col].adjacentsq[direc]; UNTIL boardstatus[sq.row,sq.col].occupier = nextmover; END ELSE IF updateadjacent THEN IF direc IN emptyneighbors THEN BEGIN sq := board[moveloc.row,moveloc.col].adjacentsq[direc]; IF sq.onboard THEN WITH boardstatus[sq.row,sq.col] DO adjacentpieces[nextmover] := adjacentpieces[nextmover] + [opposdir[direc]]; END; score[nextmover] := score[nextmover] + flips + 1; score[oppcolor] := score[oppcolor] - flips; nextmover := oppcolor; END; END; (*makemove*) PROCEDURE calcmove( mover: color; VAR status: gamestatus; VAR legallist: movelist; VAR bestmove: movedesc); TYPE movearray = ARRAY[1..30] OF movedesc; VAR bestsofar,cornmoves,m,respcornmoves: INTEGER; move,movetemp: movedesc; aftermove: gamestatus; responses: movelist; PROCEDURE checkposition(VAR legallist: movelist; VAR cornmoves: INTEGER); VAR m,bestm,bestyet: INTEGER; BEGIN bestyet := -MAXINT; cornmoves := 0; FOR m := 1 TO legallist.movecount DO WITH legallist.okmove[m], board[moveloc.row,moveloc.col] DO BEGIN bordnoncorn := FALSE; IF incenter4by4 THEN points := points + 10 ELSE BEGIN IF corner THEN BEGIN points := points + 60; cornmoves := cornmoves + 1; END ELSE IF border THEN BEGIN bordnoncorn := TRUE; points := points + 25; END ELSE IF diagnexttocorner THEN points := points - 50; END; IF points > bestyet THEN BEGIN bestyet := points; bestm := m; end; END; (*FOR m := 1 TO legallist.movecount...*) movetemp := legallist.okmove[1]; legallist.okmove[1] := legallist.okmove[bestm]; legallist.okmove[bestm] := movetemp; END; (*checkposition*) PROCEDURE sortmoves(VAR okmove: movearray; l,r: INTEGER) (*into descending order by points*) ; VAR i,j,baseval: INTEGER; BEGIN i := l; j := r; baseval := okmove[(i+j) DIV 2].points; REPEAT WHILE okmove[i].points > baseval DO i := i+1; WHILE okmove[j].points < baseval DO j := j-1; IF i <= j THEN BEGIN movetemp := okmove[i]; okmove[i] := okmove[j]; okmove[j] := movetemp; i := i+1; j := j-1; END; UNTIL i > j; IF l < j THEN sortmoves(okmove, l, j ); IF i < r THEN sortmoves(okmove, i, r ) END (* sortmoves *) ; PROCEDURE checkresponses(mover: color; VAR move: movedesc; VAR responses: movelist; bestsofar: INTEGER); (*$G+*) LABEL 0; VAR contingent,c,r: INTEGER; x,y: coordinate; sq: squareloc; direc: direction; oppcolor: color; afterresp: gamestatus; cornercounter: BOOLEAN; respondmove: movedesc; counterresp: movelist; BEGIN oppcolor := flipof(mover); WITH move DO BEGIN contingent := 0; r := 1; REPEAT respondmove := responses.okmove[r]; IF NOT board[moveloc.row,moveloc.col].incenter4by4 THEN FOR direc := north TO nw DO WITH respondmove DO IF direc IN dirsflipped THEN WITH moveloc DO IF board[row,col].adjacentsq[direc] = move.moveloc THEN BEGIN move.points := move.points - 5; IF move.points <= bestsofar THEN EXIT(checkresponses); END; afterresp := aftermove; makemove(afterresp,respondmove,FALSE); IF bordnoncorn THEN WITH moveloc DO IF afterresp.boardstatus[row,col].occupier = oppcolor THEN BEGIN bordnoncorn := FALSE; points := points - 65; (*40, plus the 25 given in checkposition*) IF points <= bestsofar THEN EXIT(checkresponses); END ELSE contingent := contingent + 8*respondmove.bordrsqsflipped; WITH respondmove.moveloc DO IF board[row,col].corner THEN BEGIN points := points - 55; IF cornmoves > 1 THEN IF board[moveloc.row,moveloc.col].corner THEN points := points -20; IF points <= bestsofar THEN EXIT(checkresponses); END; FOR x:=1 TO 8 DO FOR y:=1 TO 8 DO WITH afterresp.boardstatus[x,y] DO IF occupied THEN IF occupier = mover THEN FOR direc := north TO nw DO WITH afterresp DO BEGIN sq.row := x; sq.col := y; REPEAT sq := board[sq.row,sq.col].adjacentsq[direc]; IF NOT sq.onboard THEN GOTO 0; IF NOT boardstatus[sq.row,sq.col].occupied THEN GOTO 0 UNTIL boardstatus[sq.row,sq.col].occupier = oppcolor; END; makemove(afterresp,respondmove,TRUE); findlegalmoves(afterresp,counterresp); cornercounter := FALSE; c := 1; WITH counterresp DO WHILE ( (c <= movecount) AND (NOT cornercounter) ) DO BEGIN WITH okmove[c].moveloc DO IF board[row,col].corner THEN cornercounter := TRUE; c := c + 1; END; IF NOT cornercounter THEN BEGIN points := points -190; IF points <= bestsofar THEN EXIT(checkresponses); END; 0: IF afterresp.score[mover] = 0 THEN BEGIN points := -MAXINT+1; (*might be our only choice, so +1*) EXIT(checkresponses); END; r := r + 1; UNTIL r > responses.movecount; IF bordnoncorn THEN BEGIN points := points - contingent; WITH board[moveloc.row,moveloc.col] DO IF specialbordersq THEN WITH otherofpair, status.boardstatus[row,col] DO IF occupied THEN IF occupier = mover THEN WITH status.boardstatus[between.row,between.col] DO IF NOT occupied THEN points := points - 90; END; END; (*WITH move...*) END; (*checkresponses*) BEGIN (*calcmove*) GOTOXY(0,23); WRITE('Calculating move for ',colorword[mover],'...'); checkposition(legallist,cornmoves); IF legallist.movecount > 2 THEN sortmoves(legallist.okmove,2,legallist.movecount); bestsofar := -MAXINT; FOR m := 1 TO legallist.movecount DO BEGIN move := legallist.okmove[m]; aftermove := status; makemove(aftermove,move,TRUE); findlegalmoves(aftermove,responses); WITH move DO BEGIN IF responses.movecount = 0 THEN points := points + 100 ELSE IF points > bestsofar THEN BEGIN checkposition(responses,respcornmoves); checkresponses(mover,move,responses,bestsofar); END; IF points > bestsofar THEN BEGIN bestsofar := points; bestmove := move; END; END; (*WITH move...*) END; (*FOR m := 1 TO legallist.movecount...*) END; (*calcmove*) PROCEDURE play(mover: color); BEGIN GOTOXY(0,20+ORD(mover)); IF legalmoves[mover] > 0 THEN BEGIN WRITE(spaces); IF mover = usercolor THEN inputmove(mover,legallist,move) ELSE calcmove(mover,status,legallist,move); makemove(status,move,TRUE); updatecrt(crtstatus,status); crtstatus := status; END ELSE BEGIN WRITE('(No legal moves for ',colorword[mover],')'); status.nextmover := flipof(mover); END; END; (*play*) FUNCTION userquits: BOOLEAN; VAR playagain: CHAR; BEGIN GOTOXY(0,20); WRITELN(spaces); WRITELN(spaces); WRITELN; WRITE(spaces); GOTOXY(0,23); WRITE('Start a new game? (y/n): '); READ(playagain); userquits := NOT (playagain IN ['Y','y']); END; (*userquits*) BEGIN (*PROGRAM OTHELLO*) REPEAT initgame; findlegalmoves(status,legallist); legalmoves[white] := legallist.movecount; REPEAT play(white); findlegalmoves(status,legallist); legalmoves[black] := legallist.movecount; play(black); findlegalmoves(status,legallist); legalmoves[white] := legallist.movecount; UNTIL (legalmoves[white]=0) and (legalmoves[black]=0); UNTIL userquits; END. ======================================================================================== DOCUMENT :usus Folder:VOL20:othello.text ======================================================================================== (* COPYRIGHT (C) 1979 Software Supply. All rights reserved. *) (*$S+*) (* UCSD Pascal *) PROGRAM OTHELLO; (* Steve Brecher 16-Jun-79 *) (* modified to be independant of the system clock - gws 01 Jan 83*) (* The position evaluation weights were derived from a FORTRAN program *) (* headed "from Creative Computing/Klaus E Liebold/4-26-78". *) (* This program provides playing instructions to the user on request. *) CONST (* The game pieces are shown on the screen as 2 rows of 3 characters, e.g. *) (* OOO *) (* OOO *) (* If your crt has a "block" character (like the cursor on some crts), that*) (* is good for the white piece, and capital letter O is good for black, *) (* especially if it has a rectangular shape. Otherwise, choose characters *) (* that are centered within the character dot matrix; try to maximize the *) (* difference in intensity between the black and white pieces while maxi- *) (* mizing the absolute intensity of the black piece. Avoid characters with*) (* semantic content, e.g. "W" and "B" are not so good. *) whiteascii = 96; (*ascii value of char making up piece of first mover*) blackascii = 79; (* " " " " " " " " 2nd " *) {minticks = 22.0; (*min # clock ticks between crt square updates *) (*--should be long enough for a distinct, separate *) (*terminal bell sound on each square updated *)} dwell_time = 2000; (*loop argument for delay between computer moves, change it to produce about 2 or 3 beeps/second*) spaces = ' '; TYPE coordinate = 1..8; color = (white,black); squareloc = RECORD CASE onboard: BOOLEAN OF TRUE: (row,col: coordinate); END; direction = (north,south,east,west,sw,ne,se,nw); (*pairs of opposites*) squarestatus = RECORD CASE occupied: BOOLEAN OF TRUE: (occupier: color ); FALSE: (adjacentpieces: ARRAY[color] OF SET of direction); END; gamestatus = RECORD boardstatus: ARRAY[coordinate,coordinate] OF squarestatus; nextmover: color; lastmoveloc: squareloc; score: ARRAY[color] OF INTEGER; END; movedesc = RECORD moveloc: squareloc; points: INTEGER; dirsflipped: SET OF direction; bordrsqsflipped: INTEGER; bordnoncorn: BOOLEAN; END; movelist = RECORD movecount: INTEGER; okmove: ARRAY[1..30] OF movedesc; END; position = RECORD border: BOOLEAN; corner: BOOLEAN; diagnexttocorner: BOOLEAN; incenter4by4: BOOLEAN; adjacentsq: ARRAY[direction] OF squareloc; (* "special" border squares are those border squares *) (* adjacent to a corner or adjacent to board midline; there *) (* are 2 pairs of such squares on each border. Sample pair: *) (* (1,2) and (1,4); for each we want a pointer to the other *) (* and to the border square between them (1,3). *) CASE specialbordersq: BOOLEAN OF TRUE: (otherofpair,between: squareloc); END; VAR board: ARRAY[coordinate,coordinate] OF position; status,crtstatus: gamestatus; square: squareloc; legallist: movelist; move: movedesc; opposdir: ARRAY[direction] OF direction; legalmoves: ARRAY[color] OF INTEGER; colorword: ARRAY[color] OF STRING[5]; usercolor: color; {lastchange: REAL; (*time of last square change on crt*)} delay: integer; (* COPYRIGHT (C) 1979 Software Supply. All rights reserved. *) PROCEDURE updatecrt(VAR oldstatus,newstatus: gamestatus); FORWARD; FUNCTION flipof(oldcolor: color): color; FORWARD; PROCEDURE makemove(VAR status: gamestatus; VAR move: movedesc; updateadjacent: BOOLEAN); FORWARD; SEGMENT PROCEDURE initgame; CONST backspace = 8; VAR x,y: coordinate; direc: direction; answer: CHAR; {h,l,h0,l0: INTEGER; (*for testing whether clock is on*)} PROCEDURE defineboard; BEGIN FOR x := 1 TO 8 DO FOR y := 1 TO 8 DO WITH board[x,y] DO BEGIN border := (x IN [1,8]) OR (y IN [1,8]); corner := (x IN [1,8]) AND (y IN [1,8]); incenter4by4 := (x IN [3..6]) AND (y IN [3..6]); diagnexttocorner := (x IN [2,7]) AND (y IN [2,7]); FOR direc := north TO nw DO WITH adjacentsq[direc] DO BEGIN CASE direc OF north: onboard := x>1; ne: onboard := (x>1) AND (y<8); east: onboard := y<8; se: onboard := (x<8) AND (y<8); south: onboard := x<8; sw: onboard := (x<8) AND (y>1); west: onboard := y>1; nw: onboard := (x>1) AND (y>1); END; (*CASE*) IF onboard THEN BEGIN CASE direc OF north,ne,nw: row := x-1; east,west: row := x; south,se,sw: row := x+1; END; CASE direc OF nw,west,sw: col := y-1; north,south: col := y; ne,east,se: col := y+1; END; END; END; (*FOR direc...WITH adjacentsq...*) specialbordersq := border AND (NOT corner) AND ( (x IN [2,4,5,7]) OR (y IN [2,4,5,7]) ); IF specialbordersq THEN BEGIN otherofpair.onboard := TRUE; between.onboard := TRUE; IF x IN [1,8] THEN BEGIN otherofpair.row := x; between.row := x; IF y IN [2,5] THEN BEGIN otherofpair.col := y+2; between.col := y+1; END ELSE BEGIN otherofpair.col := y-2; between.col := y-1; END; END ELSE BEGIN otherofpair.col := y; between.col := y; IF x IN [2,5] THEN BEGIN otherofpair.row := x+2; between.row := x+1; END ELSE BEGIN otherofpair.row := x-2; between.row := x-1; END; END; END; (*IF specialbordersq...*) END; (*FOR x:= ... FOR y:= ... WITH board[x,y]...*) END; (*defineboard*) PROCEDURE showemptyboard; CONST vertdivs = '| | | | | | | | |'; horzdivs = '|-----|-----|-----|-----|-----|-----|-----|-----|'; colnames = ' A B C D E F G H '; blanks = ' '; VAR gamerow : coordinate; BEGIN GOTOXY(0,0); FOR gamerow := 1 TO 8 DO BEGIN IF gamerow>1 THEN (* "IF" because no room for topmost border line *) writeln(blanks,horzdivs); writeln(blanks:29,gamerow,vertdivs); writeln(blanks,vertdivs); END; write(blanks,colnames); GOTOXY(4,0); WRITELN('Score'); WRITELN('-----------'); WRITELN(CHR(whiteascii),'/White:'); WRITELN(CHR(blackascii),'/Black:'); END; (*showemptyboard*) PROCEDURE instructions; VAR i: INTEGER; PROCEDURE page1; BEGIN WRITELN('A move consists of placing '); WRITELN('one of your pieces on an '); WRITELN('unoccupied square which is '); WRITELN('adjacent (vertically, hori- '); WRITELN('zontally, or diagonally) to '); WRITELN('a square occupied by your '); WRITELN('opponent so that a straight '); WRITELN('line starting at your piece '); WRITELN('and continuing in the direc-'); WRITELN('tion of the adjacent oppon- '); WRITELN('ent hits one of your other '); WRITELN('pieces before hitting an un-'); WRITELN('occupied square. All of the'); WRITELN('opponent''s pieces which that'); WRITELN('line crosses are converted '); WRITELN('to become your pieces. Thus'); WRITELN('each move "flips" at least '); WRITELN('one opposing piece. '); WRITE (' (Tap space bar for more...)'); END; (*page1*) PROCEDURE page2; BEGIN WRITELN('Example: a legal move for '); WRITELN('white on the first play '); WRITELN('would be 3E, 4F, 6D, or 5C. '); WRITELN('To make a move at, e.g., 3E '); WRITELN('you may type any of: 3E, 3e,'); WRITELN('E3, or e3. '); WRITELN('If you have no legal move, '); WRITELN('you must pass. The object '); WRITELN('of the game is to end up '); WRITELN('occupying more squares than '); WRITELN('does your opponent. '); WRITELN('Hints on strategy: Usually '); WRITELN('the board position of a move'); WRITELN('is more important than the '); WRITELN('number of pieces it "flips".'); WRITELN('Try to occupy the borders '); WRITELN('(especially corners!) and '); WRITELN('avoid giving them to your '); WRITE ('opponent. (Tap space bar...)'); END; (*page2*) BEGIN (*instructions*) GOTOXY(0,5); WRITE('Want instructions? (y/n): '); READ(answer); IF NOT (answer IN ['N','n']) THEN BEGIN GOTOXY(0,5); page1; READ(answer); GOTOXY(0,5); page2; READ(answer); GOTOXY(0,5); FOR i := 5 TO 22 DO WRITELN(spaces); WRITE(spaces); END ELSE BEGIN GOTOXY(0,5); WRITE(spaces); END; END; (*instructions*) BEGIN (*initgame*) {lastchange := 0; TIME(h0,l0);} defineboard; FOR direc := north TO NW DO IF odd(ORD(direc)) THEN opposdir[direc] := pred(direc) ELSE opposdir[direc] := succ(direc); {TIME(h,l); IF (h=h0) AND (l=l0) THEN BEGIN GOTOXY(20,11); WRITE('Please turn on the clock.'); WHILE l=l0 DO TIME(h,l); END;} showemptyboard; WITH status DO BEGIN score[white] := 0; score[black] := 0; FOR x := 1 TO 8 DO FOR y := 1 TO 8 DO WITH boardstatus[x,y] DO BEGIN occupied := FALSE; adjacentpieces[white] := []; adjacentpieces[black] := []; END; END; crtstatus := status; move.dirsflipped := []; move.points := 0; WITH status DO BEGIN FOR x := 4 TO 5 DO FOR y := 4 TO 5 DO BEGIN move.moveloc.row := x; move.moveloc.col := y; IF x=y THEN nextmover := white ELSE nextmover := black; makemove(status,move,TRUE); updatecrt(crtstatus,status); crtstatus := status; END; (*FOR...FOR...*) nextmover := white; END; (*WITH status...*) instructions; GOTOXY(0,6); WRITELN('White goes first -- Which'); WRITELN('color do you want to play:'); REPEAT GOTOXY(3,8); WRITE('W)hite or B)lack? ',CHR(backspace)); READ(answer); UNTIL answer IN ['W','w','B','b']; IF answer IN ['W','w'] THEN usercolor := white ELSE usercolor := black; GOTOXY (0,6); WRITELN(spaces); WRITELN(spaces); WRITELN(spaces); colorword[white] := 'white'; colorword[black] := 'black'; END; (*initgame*) FUNCTION flipof(*oldcolor: color): color*); BEGIN IF oldcolor = white THEN flipof := black ELSE flipof := white; END; (*flipof*) PROCEDURE updatecrt(*VAR oldstatus,newstatus: gamestatus*); VAR x,y: coordinate; direc: direction; square: squareloc; PROCEDURE showpiece(square: squareloc); PROCEDURE changecrtsq(square: squareloc); CONST bell = 7; VAR s: PACKED ARRAY[1..3] OF CHAR; c: CHAR; crtline,crtcol: INTEGER; h,l: INTEGER; {now: REAL;} BEGIN WITH square DO BEGIN IF newstatus.boardstatus[row,col].occupier = white THEN c := CHR(whiteascii) ELSE c := CHR(blackascii); FILLCHAR(s,3,c); crtline := (3*row) - 3; crtcol := 26 + (6*col); END; {REPEAT TIME(h,l); now := l; IF now < 0.0 THEN now := now + 65536.0; now := (h*65536.0) + now; UNTIL (now - lastchange) > minticks;} for delay := 1 to dwell_time do; {waste some time} GOTOXY(crtcol,crtline); WRITE(s); GOTOXY(crtcol,crtline+1); WRITE(s,CHR(bell)); {lastchange := now;} END; (*changecrtsq*) BEGIN (*showpiece*) WITH square DO IF newstatus.boardstatus[row,col].occupied THEN IF NOT oldstatus.boardstatus[row,col].occupied THEN changecrtsq(square) ELSE IF oldstatus.boardstatus[row,col].occupier <> newstatus.boardstatus[row,col].occupier THEN changecrtsq(square); END; (*showpiece*) BEGIN (*updatecrt*) WITH newstatus DO BEGIN showpiece(lastmoveloc); FOR direc := north to nw DO BEGIN square := lastmoveloc; WHILE boardstatus[square.row,square.col].occupied AND board[square.row,square.col].adjacentsq[direc].onboard DO BEGIN square := board[square.row,square.col].adjacentsq[direc]; showpiece(square); END; (*WHILE...*) END; (*FOR direc...*) GOTOXY(9,2); WRITE(score[white]:2); GOTOXY(9,3); write(score[black]:2); END; (*WITH newstatus...*) GOTOXY(0,0); END; (*updatecrt*) (*$I othello.1.text*) ======================================================================================== DOCUMENT :usus Folder:VOL20:screen.h19.text ======================================================================================== UNIT SCREEN; (*Pure H19 Version - 28 Jun 82*) INTERFACE PROCEDURE CLEARSCREEN; PROCEDURE CLEARSPACE(X,Y,N : INTEGER); PROCEDURE SAVECURSOR(VAR X,Y : INTEGER); PROCEDURE NORMALKEYPAD; PROCEDURE SHIFTKEYPAD; IMPLEMENTATION PROCEDURE CLEARSCREEN; VAR T : PACKED ARRAY [0..1] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('E'); UNITWRITE(1,T,2) END; PROCEDURE CLEARSPACE (*X,Y,N : INTEGER*); VAR I : INTEGER; CS :PACKED ARRAY [1..160] OF 0..255; BEGIN GOTOXY(X,Y); FOR I := 1 TO N DO CS[I] := 32; FOR I := N+1 TO N+N DO CS[I] := 8; UNITWRITE(1,CS[1],N); UNITWRITE(1,CS[N+1],N) END; PROCEDURE SAVECURSOR (*VAR X,Y : INTEGER*); VAR T : PACKED ARRAY [0..7] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('j'); T[2] := 27; T[3] := ORD('n'); UNITWRITE(1,T,4); UNITREAD(2,T[4],4); X := T[7] - 32; Y := T[6] - 32 END; PROCEDURE NORMALKEYPAD; VAR T : PACKED ARRAY[0..1] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('u'); UNITWRITE(1,T,2) END; PROCEDURE SHIFTKEYPAD; VAR T : PACKED ARRAY[0..1] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('t'); UNITWRITE(1,T,2) END; END. 00>¹¡Bÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ ======================================================================================== DOCUMENT :usus Folder:VOL20:screen.text ======================================================================================== UNIT SCREEN; INTERFACE PROCEDURE CLEARSCREEN; PROCEDURE CLEARSPACE(X,Y,N : INTEGER); PROCEDURE SAVECURSOR(VAR X,Y : INTEGER); IMPLEMENTATION PROCEDURE CLEARSCREEN; VAR LF : PACKED ARRAY [1..24] OF CHAR; I : INTEGER; BEGIN GOTOXY(0,23); FOR I := 1 TO 24 DO LF[I] := CHR(10); UNITWRITE(1,LF,24); GOTOXY(0,0) END; PROCEDURE CLEARSPACE (*X,Y,N : INTEGER*); VAR I : INTEGER; CS :PACKED ARRAY [1..160] OF 0..255; BEGIN GOTOXY(X,Y); FOR I := 1 TO N DO CS[I] := 32; FOR I := N+1 TO N+N DO CS[I] := 8; UNITWRITE(1,CS[1],N); UNITWRITE(1,CS[N+1],N) END; PROCEDURE SAVECURSOR (*VAR X,Y : INTEGER*); VAR T : PACKED ARRAY [0..7] OF 0..255; BEGIN T[0] := 27; T[1] := ORD('j'); T[2] := 27; T[3] := ORD('n'); UNITWRITE(1,T,4); UNITREAD(2,T[4],4); X := T[7] - 32; Y := T[6] - 32 END; END. ======================================================================================== DOCUMENT :usus Folder:VOL20:sigfig.19.text ======================================================================================== {Note: The exponent handling routine appears in the main program because the real-to-string routine was written for use in the labeling of axes in a package of plotting routines. For this purpose it desirable to be able to suppress the exponent at the axis tic marks and include it in the title of the axis or to write it in conventional arithmetic form rather than using the E format. For use with a plotting routine or for many other purposes it may be desirable to delete the code marked (**) and to remove the comments on the one line bracketed with comment symbols. When this is done FORMAT defines the upper limit for the mantissa (e.g., a format of 0.0XXX will give numbers less than or equal to 0.0999). Note also that this simple program maps all char except '.' and '0' into 'X'. Zeros other than leading zeros will be treated as X's by the routine. In a more sophisticated program it might be desirable to avoid inadvertent user errors by flagging char other than '.', '0', or 'X' with an error message and providing an opportunity to retype the format specification. This output routine can involve repeated divisions by 10; thus, it is more likely to lose accuracy than an assembly language routine which avoids such division, operating by shifts and rotates.---Henry E. Baumgarten} PROGRAM SIGFIGS; (*Version 1.3 - 04 Feb 83*) USES {$U H19UTIL.CODE} H19UTIL; VAR RL1,RL2 : REAL; N : INTEGER; FORMAT,STRG1,STRG2 : STRING; NEGNO : BOOLEAN; REPLY : CHAR; PROCEDURE PREAMBLE; BEGIN WRITELN ('This program demonstrates the use of two "user-friendly" real number input'); WRITELN ('and output routines, the latter being rather specialized. In the real number'); WRITELN ('input routine the numbers may be terminated with a space, a comma, or a'); WRITELN ('carriage return. The output routine will write either scientific format'); WRITELN ('(X.XXXXXXXEXX) or selected format numbers (any number of decimal places,'); WRITELN ('only about 7 of which are meaningful for the 2-word, real-number internal'); WRITELN ('format). Typical formats are: X.XXXXXXX, XXXXX., XXXXX, .XXXXX or the'); WRITELN ('equivalent 0.XXXXX, and 0.000XXXX. In all cases the output number will'); WRITELN ('be rounded to the chosen number of zeros and digits (with an exponent if'); WRITELN ('necessary), and a leading zero will be appended to all fractional numbers.'); WRITELN ('Typical inputs might be: 1/7, 0.00999/1, 123456789/1, or 0.31415926E1/1.'); END; PROCEDURE REALTOSTR(X:REAL; FORMAT:STRING; VAR S:STRING; VAR EXPNT:INTEGER); VAR DECPT,DIGIT,INTG,FRAC_DIGITS,INDEX,LEN,TEMP_EXPNT : INTEGER; FIRST_DIGIT,ZEROS,I : INTEGER; BOUND : REAL; CARRY,LEAD_ZERO,NEGNO : BOOLEAN; S0 : STRING; BEGIN EXPNT := 0; TEMP_EXPNT := 0; NEGNO := FALSE; LEN := LENGTH(FORMAT); IF (LEN=0) THEN BEGIN FORMAT := 'X.XXXXXX'; LEN := 8 END ELSE FOR I := 1 TO LEN DO IF NOT(FORMAT[I] IN ['0','X','.']) THEN FORMAT[I] := 'X'; DECPT := POS('.',FORMAT); FIRST_DIGIT := POS('X',FORMAT); IF (DECPT=0) THEN FRAC_DIGITS := 0 ELSE FRAC_DIGITS := LEN-DECPT; ZEROS := DECPT+1-FIRST_DIGIT; IF (ZEROS>0) THEN ZEROS := ZEROS-1; IF (DECPT=0) THEN ZEROS := LEN+1-FIRST_DIGIT; IF (ZEROS<0) THEN BOUND := 1/PWROFTEN(ABS(ZEROS)) ELSE BOUND := PWROFTEN(ZEROS); IF (X < 0) THEN BEGIN NEGNO := TRUE; X := ABS(X) END; IF (X >= BOUND) THEN REPEAT X := X/10; EXPNT := EXPNT+1; UNTIL (X < BOUND); IF ((X < (BOUND/10)) AND (X <> 0)) THEN (**) REPEAT (**) X := X*10; (**) (*Omit for plot labels*) EXPNT := EXPNT-1 (**) UNTIL (X >= (BOUND/10)); (**) IF (X > MAXINT) THEN REPEAT X := X/10; TEMP_EXPNT := TEMP_EXPNT + 1; UNTIL (X <= MAXINT); INTG := TRUNC(X); STR(INTG,S); X := (X-INTG)*10; IF (TEMP_EXPNT>0) THEN FOR I := 1 TO TEMP_EXPNT DO BEGIN INTG := TRUNC(X); STR(INTG,S0); S := CONCAT(S,S0); X := (X-INTG)*10; END; IF (FRAC_DIGITS > 0) THEN BEGIN S := CONCAT(S,'.'); FOR I := 1 TO FRAC_DIGITS DO BEGIN INTG := TRUNC(X); STR(INTG,S0); S := CONCAT(S,S0); X := (X-INTG)*10; END END; IF (X >= 5) THEN BEGIN IF (S[1] = '0') THEN LEAD_ZERO := TRUE ELSE LEAD_ZERO := FALSE; INDEX := LENGTH(S); DIGIT := 0; REPEAT IF NOT(S[INDEX] = '.') THEN BEGIN DIGIT := (ORD(S[INDEX])-ORD('0')); IF (DIGIT <> 0) THEN CARRY := FALSE; IF (DIGIT <> 9) THEN DIGIT := DIGIT+1 ELSE BEGIN DIGIT := 0; CARRY := TRUE END; S[INDEX] := CHR(DIGIT + ORD('0')); END; INDEX := INDEX-1 UNTIL ((INDEX = 0) OR (DIGIT > 0)); IF CARRY THEN BEGIN IF NOT(LEAD_ZERO) THEN S := CONCAT('1',S) ELSE S := CONCAT('0',S); (**) (*Delete ELSE part only*) INDEX := POS('.',S); IF (INDEX > 0) THEN (**) (* IF (INDEX > DECPT) THEN *) BEGIN DELETE(S,INDEX,1); INSERT('.',S,INDEX-1) END; DELETE(S,LENGTH(S),1); EXPNT := EXPNT+1 END END; IF NEGNO THEN S := CONCAT('-',S) END; BEGIN{program} CLEARSCREEN; PREAMBLE; REPEAT WRITELN; WRITELN('Enter X and Y for X/Y (either = 0 to quit)'); WRITE(' '); RL1 := INREAL(INPUT,INPT); RL2 := INREAL(INPUT,INPT); IF ((RL1 = 0) OR (RL2 = 0)) THEN EXIT(PROGRAM); WRITELN; WRITELN('Scientific notation? '); WRITELN; IF DOIT THEN FORMAT := 'X.XXXXXX' ELSE BEGIN WRITE('Enter format ( = X.XXXXXX): '); READLN(FORMAT); WRITELN END; REALTOSTR(RL1/RL2,FORMAT,STRG1,N); IF (N<>0) THEN BEGIN STR(N,STRG2); STRG1 := CONCAT(STRG1,'E',STRG2) END; WRITELN(STRG1); UNTIL (RL1=0) END. ======================================================================================== DOCUMENT :usus Folder:VOL20:sxfr.svcs.text ======================================================================================== .TITLE "K. G. Balke, Associates, Escort File Transfer Unit" ; Author: Karl G. Balke ; Version: 01 October 1982 .INCLUDE bios.const .RELPROC MDEM_INIT, 1 ; This service initializes the modem port to the speed indicated in ; its parameter (the clock divisor at 16x speed). ; It assumes that the port is in mode instruction mode on entry. ; It is called from a Pascal program which declares it as follows: ; PROCEDURE mdem_init ; (divisor: INTEGER); ; Position the divisor for programming the clock divider. POP HL EX (SP), HL LD A, 76H OUT (CNT_MDM), A LD A, L OUT (CNT_REG_1), A LD A, H OUT (CNT_REG_1), A ; Set the modem port mode. LD A, 4EH OUT (PRT_MODEM + STAT_PRT), A ; Turn on the port and wait for the chips to settle. LD A, 17H OUT (PRT_MODEM + STAT_PRT), A LD B, 0 DJNZ $ ; Turn off the modem port to clear the line of any noise. LD A, 40H OUT (PRT_MODEM + STAT_PRT), A LD B, 0 DJNZ $ ; Set the modem port mode again. LD A, 4EH OUT (PRT_MODEM + STAT_PRT), A LD A, 37H OUT (PRT_MODEM + STAT_PRT), A RET .RELPROC MDEM_CLR ; This procedure turns off the DSR and CTS lines of the ; modem, indicating that the computer is no longer listening. ; It also places the modem in mode instruction mode. ; It is declared in the caller as: ; PROCEDURE mdem_clr; LD A, 40H OUT (PRT_MODEM + STAT_PRT), A RET .PROC READ_MSG, 1 ; This service reads a message over the designated serial port. ; It interprets the messages according to the following protocol: ; First Ch. Rest Of Message ; --------- --------------- ; A ; B ; 512-byte message if IO Result = 0 ; C -- ; D String (all strings are Pascal form.) ; E String ; G -- ; R String ; W String ; The service also polls for console break-in and detects the serial ; line dropping or going inactive. (DSR/DTR low means line dropped, ; CTS/RTS low means inactive.) ; Console break-in is translated into a line condition code placed in ; the returned message. The console break-in is detected by use of the ; standard SBIOS calls, and must consist of a single escape character ; (others are ignored). ; Line conditions are reported through the leading character of the ; returned message as follows: ; Value Meaning ; ----- ------- ; 1 Line error ; 3 Line dropped ; 4 Pause (cancel message thus far) ; 5 Escape from console ; Procedure is declared in Pascal program as follows: ; PROCEDURE ; (VAR ; msg: {PACKED ARRAY [0 .. 513] OF CHAR}); .DEF HEX_OUT POP HL EX (SP), HL LD (MSG_BASE), HL ; From here on, HL => next character to deposit in message. ; Read the initial incoming character and interpret. CALL RD_DEPOS AND A RET NZ ; Error free transmission occurred. Interpret the message. LD A, E ; Discard initial binary zero on assumption that it is generated ; by serial port when DSR comes high. AND A JR NZ, $0 ; Reset the message pointer and read the next character. LD HL, (MSG_BASE) CALL RD_DEPOS AND A RET NZ LD A, E $0: ; Interpret this character as serious transmission. CP "A" JP Z, RD_DEPOS ; Not "A". Return if not larger. RET C ; Return if greater than "W". CP "W" JR Z, $3 RET NC ; Test remaining long message characters. CP "D" JR Z, $3 CP "E" JR Z, $3 CP "R" JR Z, $3 CP "B" RET NZ ; Block message in response to "G" request. Get IO Result and ; decide whether or not to read 512 characters of block. CALL RD_DEPOS AND A RET NZ ; Check for IO Result if read valid. CP E RET NZ ; Result indicates block will follow. LD BC, 2 $2: ; Read the number of characters specified in BC, where C is high ; order byte. CALL RD_DEPOS AND A RET NZ DJNZ $2 DEC C RET Z JR $2 $3: ; Read the string length character and set up to read the characters ; of string. CALL RD_DEPOS AND A RET NZ LD B, E LD C, 1 JR $2 RD_DEPOS: ; This service reads the next character from the line and deposits it ; into the message. It also polls for console break-in, and detects ; transmission failures. ; On Entry: ; (HL) => Message Deposit Position ; On Exit: ; (A) = Result status. ; (E) = Character read. ; (HL) => Next Message Character. CALL RD_CHAR AND A JR Z, $0 LD HL, (MSG_BASE) LD (HL), A RET $0: LD (HL), E INC HL RET RD_CHAR: ; This service reads a character from the transmission port. ; It detects pause and line dropping signals, and console break-in ; with an escape character. ; On Exit: ; (A) = Event status. ; (E) = Character read. PUSH BC $0: ; Poll for console character ready. IN A, (CRT_STAT) AND 02H JR NZ, $8 ; Look for line dropping. IN A, (PRT_MODEM + STAT_PRT) BIT PRT_DSR, A JR Z, $1 ; Look for pause condition from other end. BIT PRT_RTSB, A JR Z, $2 ; Analyze errors on line. LD B, A AND 38H JR NZ, $3 ; Test for available character on line. BIT PRT_RRDY, B JR Z, $0 ; Character available on line. Read it and return result. IN A, (PRT_MODEM) ; CALL HEX_OUT LD E, A XOR A $9: POP BC RET $8: ; Break-in must be escape. IN A, (CRT_DATA) AND 7FH CP 27 JR NZ, $0 ; Drop CTS and return escape result. LD A, 15H OUT (PRT_MODEM + STAT_PRT), A LD A, 5 JR $9 $1: ; Line has dropped since last poll. LD A, 3 JR $9 $2: ; Ready to send has dropped since last poll. LD A, 4 JR $9 $3: ; Transmission problems. Drop CTS to signal other end that ; transaction unsuccessful. LD A, 17H OUT (PRT_MODEM + STAT_PRT), A LD A, 1 JR $9 MSG_BASE: .WORD 0 HEX_OUT: ; This service presents the character it receives on input on the ; screen in hex format. ; On Entry: ; (A) = Character to print. PUSH AF PUSH BC LD B, A AND 0F0H RLA RLA RLA RLA RLA CALL CONS_OUT LD A, B AND 0FH CALL CONS_OUT LD C, " " CALL CONS_TRAN POP BC POP AF RET CONS_OUT: ; This service converts the offered nibble to a hex digit and sends ; it to the console. ; On Entry: ; (A) = Nibble. ADD A, 30H CP 3AH JR C, $0 ADD A, 7 $0: LD C, A CONS_TRAN: IN A, (CRT_STAT) AND 01H JR Z, CONS_TRAN LD A, C OUT (CRT_DATA), A RET .FUNC WRT_MSG, 2 ; This service writes a message to the file transfer port. It detects ; console break-in and drops the CTS line to indicate a pause in ; transmission. ; The result code is interpreted as follows: ; Value Meaning ; ----- ------- ; 0 Message written. ; 1 Line error. ; 2 Line interrupt (character received). ; 3 Line dropped. ; 4 Pause (RTS dropped). ; 5 Escape break-in from keyboard. ; The function is declared in a Pascal program as follows: ; FUNCTION wrt_msg ; (l: INTEGER; ; VAR ; msg: {PACKED ARRAY [0 .. 513] OF CHAR}): ; INTEGER; .REF HEX_OUT POP DE ; Return. POP HL ; Message pointer. POP BC ; Message length. POP AF ; Dummy function value. PUSH DE ; Position transfer count for efficient processing. LD A, C LD C, B AND A JR Z, $0 INC C $0: LD B, A ; Raise CTS signal if not already on. LD A, 27H OUT (PRT_MODEM + STAT_PRT), A $1: ; Transfer characters until done. LD E, (HL) INC HL CALL WRT_CHAR AND A JR NZ, $3 ; Count down transfer count. DJNZ $1 DEC C JR NZ, $1 ; Report successful status. LD HL, 0 $2: ; Push result onto stack and return. EX (SP), HL JP (HL) $3: ; Error or escape break-in has occurred. Report status. LD L, A LD H, 0 JR $2 WRT_CHAR: ; This service writes a single character to the serial line. It also ; polls for break-in, receipt of a character on the serial line ; in the opposite direction, and loss of line. ; On Entry: ; (E) = Character to transmit. ; On Exit: ; (A) = Result. Values are: ; 0--Successful transmission. ; 1--Line error. ; 2--Reverse direction character. ; 3--Line dropped. ; 4--Pause (RTS dropped). ; 5--Console escape break-in. PUSH BC $0: ; Poll for console character ready. IN A, (CRT_STAT) AND 02H JR NZ, $8 ; See if Host is still connected. IN A, (PRT_MODEM + STAT_PRT) BIT PRT_DSR, A JR Z, $1 ; Identify errors. LD B, A AND 38H JR NZ, $3 ; See if transmit buffer is ready for next character. BIT PRT_THBE, B JR NZ, $4 ; See if Host is trying to send a character. BIT PRT_RRDY, B JR Z, $0 ; Input character from line ready to read. LD A, 2 JR $9 $8: ; Break-in must be escape. IN A, (CRT_DATA) AND 7FH CP 27 JR NZ, $0 ; Drop CTS and return escape result. LD A, 17H OUT (PRT_MODEM + STAT_PRT), A LD A, 5 JR $9 $1: ; Escort off line. LD A, 3 JR $9 $2: ; Escort RTS dropped. LD A, 4 JR $9 $3: ; Line transfer error. LD A, 1 JR $9 $4: ; See if Host has dropped RTS to request pause. BIT PRT_RTSB, B JR Z, $2 ; Ready to send character. LD A, E OUT (PRT_MODEM), A ; CALL HEX_OUT XOR A $9: ; Return result. POP BC RET .END ======================================================================================== DOCUMENT :usus Folder:VOL20:trans-genr.text ======================================================================================== ctransportr $ asxfr.svcs sxfr.svcs ltransportr sxfr.svcs trans-mgr.code frtransportr.code yq ======================================================================================== DOCUMENT :usus Folder:VOL20:transportr.text ======================================================================================== {Version 002 06 Dec 82 KGB Block disk access to improve efficiency of transfer.} {$I-} PROGRAM disk_xfr; {*********************************************************************** * Copyright (C) 1982 K. G. Balke, Associates * * All rights reserved. * ***********************************************************************} {$C (C) 1982 K. G. Balke, Associates} CONST bell = 7; max_msg = 30; {Length of longest informational message.} tank_size = 20; {Number of blocks in disk holding tank.} tran_titl = 'FILE TRANSPORTER'; TYPE file_tank = PACKED ARRAY [1 .. tank_size, 0 .. 511] OF CHAR; {Disk file tank array.} VAR done: BOOLEAN; {True if current iteration is complete.} file_name: STRING [23]; {Name of file being read or written.} mdem_baud: INTEGER; {Divisor to achieve desired baud rate from modem port. Value 13 corresponds to 9600 baud. Faster rates not supported by Escort.} xfr_bufr: PACKED ARRAY [0 .. 514] OF CHAR; {Space for transfer of file blocks between Escort and Host. Consists of type character, then up to 513 bytes of data. The initial character may be a status report or a file transfer directive. An initial status report is a binary integer between 1 and 5; a file transfer directive is one of 'A', 'B', 'C', 'D', 'E', 'G', 'R' or 'W'.} xfr_file: FILE; {Untyped file for file transfer.} {************************************************************************ * The following external procedures are assembler subroutines found in * * the sxfr.svcs file. * ************************************************************************} PROCEDURE mdem_init {Initialize the modem RS232 port for communication.} (divisor: INTEGER); {Clock divisor for producing the desired Baud rate at 8MHz crystal (4MHz clock rate).} EXTERNAL; PROCEDURE mdem_clr; {Turn off the handshaking lines to the Host and place the modem port in Mode Instruction mode for next conversation.} EXTERNAL; PROCEDURE read_msg {Read a complete message from the modem port according to the transfer protocol. Report result.} (VAR msg); {Block to receive the message. Must be 514 bytes long.} EXTERNAL; FUNCTION wrt_msg {Send a complete message to the modem port according to the transfer protocol. Report result.} (ln: INTEGER; {Active length of message (bytes).} VAR msg): {Block containing message. Maximum size is 514 bytes.} INTEGER; {Port-level result of write.} EXTERNAL; PROCEDURE head_scrn (t: STRING); BEGIN {head_scrn} WRITE (CHR (27), '*', t); t := '(C) 1982 K. G. Balke, Assoc.'; GO_TO_X_Y (80 - LENGTH (t), 0); WRITE (t) END {head_scrn}; PROCEDURE err_prcsr {Diagnose all host device read or write errors and set global flow booleans if necessary. (done & terminate)} (error: INTEGER); {This is the error number as returned by a read or write operation.} BEGIN {err_prcsr} IF error > 0 THEN BEGIN {Close transfer file in case it is open on entry.} CLOSE (xfr_file); {Analyze error and diagnose.} CASE error OF 1: {Line error.} BEGIN GO_TO_X_Y (10, 23); WRITE ('Transmission failure. ') END; 2: {Line interrupt.} BEGIN GO_TO_X_Y (10, 23); WRITE ('Host interrupt. ') END; 3: {Line dropped by Host.} BEGIN done := true; GO_TO_X_Y (10, 23); WRITE ('Line dropped. ') END; 4: {Host has paused for own reasons.} BEGIN GO_TO_X_Y (10, 23); WRITE ('Host paused. ') END; 5: {Operator has intervened.} BEGIN mdem_clr; GO_TO_X_Y (10, 23); WRITE ('Operator intervened. '); EXIT (PROGRAM) END; END END END {err_prcsr}; PROCEDURE proto_err; {Improper protocol has been discovered so send a an io_error 3 to the host.} BEGIN {proto_err} xfr_bufr [0] := 'A'; xfr_bufr [1] := CHR (3); err_prcsr (wrt_msg (2, xfr_bufr)) END {proto_err}; FUNCTION good_file {Determine whether the given name is a legal p-System file name.} (fn: STRING): {File name to test.} BOOLEAN; {True if name is acceptable.} VAR cln_ct: INTEGER; {Number of colons in name.} i: INTEGER; {Running index over file name.} last_cln: INTEGER; {Position of last colon in name.} name_rslt: BOOLEAN; {True if file name is acceptable to current point in processing.} BEGIN {good_file} {Initialize volume name validation count and index.} cln_ct := 0; last_cln := 0; {File name must be non-null.} name_rslt := LENGTH (fn) > 0; IF name_rslt THEN {Scan for invalid character or missing file name component.} FOR i := 1 TO LENGTH (fn) DO BEGIN {Look first for invalid character.} IF NOT (fn [i] IN ['!' .. '#', '%' .. '+', '-' .. '<', '>', '@' .. '~']) THEN name_rslt := false ELSE {Character acceptable. Be certain that colon is followed by file name, and that there is only one colon in name.} IF fn [i] = ':' THEN BEGIN cln_ct := cln_ct + 1; last_cln := i END END; good_file := name_rslt AND (cln_ct < 2) AND (last_cln < LENGTH (fn)); END {good_file}; PROCEDURE rpt_flr {Report a failure to the Host in standard protocol as supplied in parameters.} (h: CHAR; {Expected response of Escort to Host.} r: INTEGER); {Result value to report.} VAR msg_bufr: PACKED ARRAY [0 .. 1] OF CHAR; {Space for forming acknowledgement message.} msg_rslt: INTEGER; {Result of write to Host.} BEGIN {rpt_flr} msg_bufr [0] := h; msg_bufr [1] := CHR (r); err_prcsr (wrt_msg (2, msg_bufr)) END {rpt_flr}; PROCEDURE dir_mode; BEGIN END; PROCEDURE eras_mode; VAR problem: INTEGER; BEGIN {eras_mode} {Begin initial acknowledgement message.} xfr_bufr [0] := 'A'; {Attempt file open if file name is acceptable.} IF ORD (xfr_bufr [1]) < 24 THEN BEGIN {File name is short enough to fit in string for use in RESET. Move it into reset string; if it is valid, attempt open and report result.} {$R-} MOVE_LEFT (xfr_bufr [1], file_name [0], ORD (xfr_bufr [1]) + 1); {$R^} IF good_file (file_name) THEN BEGIN RESET (xfr_file, file_name); xfr_bufr [1] := CHR (IO_RESULT); IF IO_RESULT = 0 THEN CLOSE (xfr_file, PURGE) END ELSE {Report unacceptable file name.} xfr_bufr [1] := CHR (7) END ELSE {Report file name too long to analyze.} xfr_bufr [1] := CHR (7); {Write acknowledgement to Host. Ignore result.} problem := wrt_msg (2, xfr_bufr) END {eras_mode}; PROCEDURE writ_mode; PROCEDURE xfr_in; {Follow the transfer protocol for writing a file transmitted from the Host to the open write file.} VAR tank: file_tank; {Disk transfer tank.} tank_idx: INTEGER; {Count of blocks in tank.} xfr_rslt: INTEGER; {Result of block transfer operation.} FUNCTION wrt_tank {Write the current tank full to the file.} (ct: INTEGER): {Number of blocks in tank.} BOOLEAN; {True if tank written successfully.} VAR bloks: INTEGER; {Number of blocks actually written.} BEGIN {wrt_tank} wrt_tank := true; bloks := BLOCK_WRITE (xfr_file, tank, ct); IF (bloks < ct) OR (IO_RESULT > 0) THEN {There is a file write error. Inform Host and terminate file transfer.} BEGIN wrt_tank := false; done := true; rpt_flr ('A', IO_RESULT) END END {wrt_tank}; BEGIN {xfr_in} done := false; tank_idx := 0; REPEAT {Send request for next block.} xfr_bufr [0] := 'G'; xfr_rslt := wrt_msg (1, xfr_bufr); {Diagnose transmission errors.} IF xfr_rslt > 0 THEN BEGIN CLOSE (xfr_file); err_prcsr (xfr_rslt); EXIT (xfr_in) END ELSE {Transmission of block request successful. Wait for Host response and process.} BEGIN read_msg (xfr_bufr); IF xfr_bufr [0] = 'B' THEN {The expected protocol has been followed. Now interpret the IO_RESULT in the second byte.} BEGIN IF xfr_bufr [1] = CHR (0) THEN {Read at Host end successful, and block present for writing to file.} BEGIN tank_idx := tank_idx + 1; MOVE_LEFT (xfr_bufr [2], tank [tank_idx], 512); IF tank_idx = tank_size THEN IF wrt_tank (tank_idx) THEN tank_idx := 0 ELSE EXIT (xfr_in) END ELSE IF xfr_bufr [1] = CHR (13) THEN {File transfer completed. Lock file and wait for next command from Host.} BEGIN IF tank_idx > 0 THEN IF wrt_tank (tank_idx) THEN ; CLOSE (xfr_file, LOCK); EXIT (xfr_in) END ELSE IF xfr_bufr [1] < ' ' THEN {Serial line failure. Diagnose and stop file write.} BEGIN CLOSE (xfr_file); err_prcsr (ORD (xfr_bufr [1])); EXIT (xfr_in) END ELSE {Protocol error. Diagnose to Host and wait for next command.} BEGIN CLOSE (xfr_file); rpt_flr ('A', 3); EXIT (xfr_in) END END ELSE {Protocol not followed correctly. Diagnose to Host and terminate writing.} BEGIN done := true; CLOSE (xfr_file); rpt_flr ('A', 3) END END UNTIL done END {xfr_in}; BEGIN {writ_mode} {Attempt file creation if file name is acceptable.} IF ORD (xfr_bufr [1]) < 24 THEN BEGIN {File name is short enough to fit in string for use in RESET. Move it into reset string; if it is valid, attempt open and report result.} {$R-} MOVE_LEFT (xfr_bufr [1], file_name [0], ORD (xfr_bufr [1]) + 1); {$R^} IF good_file (file_name) THEN BEGIN RESET (xfr_file, file_name); CASE IO_RESULT OF 0: {File already exists.} BEGIN CLOSE (xfr_file); rpt_flr ('A', 11) END; 10: {Expected result--no such file.} BEGIN REWRITE (xfr_file, file_name); IF IO_RESULT > 0 THEN rpt_flr ('A', IO_RESULT) ELSE xfr_in END; 1, 5, 6, 7, 8, 9, 16: {Expected errors.} rpt_flr ('A', IO_RESULT) END; END ELSE {Report unacceptable file name.} rpt_flr ('A', IO_RESULT) END ELSE {Report file name too long to analyze.} rpt_flr ('A', IO_RESULT) END {writ_mode}; PROCEDURE read_mode; {Analyze a request to read a file, following standard protocol and diagnosing failures.} VAR problem: INTEGER; {Receives the result of a wrt_msg.} PROCEDURE xfr_out; {Send successive blocks from the open file until done or an error occurs.} VAR i: INTEGER; {Running index over blocks in tank.} tank: file_tank; {Available material from file for transfer to host.} tank_idx: INTEGER; {Number of blocks read from file.} xfr_rslt: INTEGER; {Space for IO_RESULT around any operations which may change it.} FUNCTION read_tank {Read the next tank full of data from the file for transmission to host.} (VAR ct: INTEGER): {Number of blocks read.} BOOLEAN; {True if transfer successful.} BEGIN {read_tank} read_tank := true; ct := BLOCK_READ (xfr_file, tank, tank_size); IF ct < tank_size THEN BEGIN IF IO_RESULT > 0 THEN BEGIN read_tank := false; ct := 0 END; IF ct = 0 THEN CLOSE (xfr_file) END END {read_tank}; BEGIN {xfr_out} read_msg (xfr_bufr); REPEAT IF read_tank (tank_idx) THEN IF tank_idx > 0 THEN FOR i := 1 TO tank_idx DO BEGIN {Analyze and process transmission failures or operator intervention.} IF xfr_bufr [0] < ' ' THEN BEGIN err_prcsr (ORD (xfr_bufr [0])); EXIT (xfr_out) END ELSE IF xfr_bufr [0] = 'G' THEN {The host has requested a block so attempt to read one for it.} BEGIN xfr_bufr [0] := 'B'; xfr_bufr [1] := CHR (0); MOVE_LEFT (tank [i], xfr_bufr [2], 512); err_prcsr (wrt_msg (514, xfr_bufr)); read_msg (xfr_bufr) END ELSE {Host did not request a block from the open file.} BEGIN proto_err; EXIT (xfr_out) END END ELSE BEGIN xfr_bufr [0] := 'B'; xfr_bufr [1] := CHR (13); err_prcsr (wrt_msg (2, xfr_bufr)); EXIT (xfr_out) END ELSE BEGIN xfr_bufr [0] := 'B'; xfr_bufr [1] := CHR (IO_RESULT); err_prcsr (wrt_msg (2, xfr_bufr)); EXIT (xfr_out) END UNTIL false; END {xfr_out}; BEGIN {read_mode} {Begin initial acknowledgement message.} xfr_bufr [0] := 'A'; {Attempt file open if file name is acceptable.} IF ORD (xfr_bufr [1]) < 24 THEN BEGIN {File name is short enough to fit in string for use in RESET. Move it into reset string; if it is valid, attempt open and report result.} {$R-} MOVE_LEFT (xfr_bufr [1], file_name [0], ORD (xfr_bufr [1]) + 1); {$R^} IF good_file (file_name) THEN BEGIN RESET (xfr_file, file_name); xfr_bufr [1] := CHR (IO_RESULT) END ELSE {Report unacceptable file name.} xfr_bufr [1] := CHR (7) END ELSE {Report file name too long to analyze.} xfr_bufr [1] := CHR (7); {Write acknowledgement to Host.} problem := wrt_msg (2, xfr_bufr); {Complete read response protocol if no error has occurred so far.} IF (problem = 0) AND (xfr_bufr [1] = CHR (0)) THEN xfr_out ELSE err_prcsr (problem); CLOSE (xfr_file) END {read_mode}; PROCEDURE note_obsv {Place a note on the screen informing an interested observer what the system is doing.} (msg: STRING); {Message to display.} VAR msg_strng: STRING; BEGIN {note_obsv} {Construct a message string whose length is independent of the message to clear out residual characters.} {$R-} FILL_CHAR (msg_strng [1], max_msg, ' '); MOVE_LEFT (msg [1], msg_strng [1], LENGTH (msg)); msg_strng [0] := CHR (max_msg); {$R^} {Place the message.} GO_TO_X_Y (10, 12); WRITE (msg_strng); {Move the cursor out of the way.} GO_TO_X_Y (0, 0) END {note_obsv}; BEGIN {disk_xfr} head_scrn (tran_titl); {Establish the baud rate divisor. First place menu of available rates on screen.} GO_TO_X_Y (5, 6); WRITE ('Available transmission rates:'); GO_TO_X_Y (10, 8); WRITE ('0 -- 9600 bps'); GO_TO_X_Y (10, 9); WRITE ('1 -- 4800 bps'); GO_TO_X_Y (10, 10); WRITE ('2 -- 2400 bps'); GO_TO_X_Y (10, 11); WRITE ('3 -- 1200 bps'); GO_TO_X_Y (10, 12); WRITE ('4 -- 600 bps'); GO_TO_X_Y (5, 14); WRITE ('Select:'); {Request selection and filter for plausibility.} REPEAT {Assume 9600 Baud if no number entered.} mdem_baud := 0; {Clear result of prior erroneous entry.} GO_TO_X_Y (14, 14); WRITE (' ', CHR (8), CHR (8), CHR (8), CHR (8), CHR (8)); {Get operator input and filter.} READ_LN (mdem_baud) UNTIL mdem_baud IN [0 .. 4]; {Start the screen over again.} head_scrn (tran_titl); {Translate selection into baud rate divisor and record result.} GO_TO_X_Y (10, 10); CASE mdem_baud OF 0: {9600 Baud.} BEGIN mdem_baud := 13; WRITE ('9600 Baud transmission.') END; 1: {4800 Baud.} BEGIN mdem_baud := 26; WRITE ('4800 Baud transmission.') END; 2: {2400 Baud.} BEGIN mdem_baud := 52; WRITE ('2400 Baud transmission.') END; 3: {1200 Baud.} BEGIN mdem_baud := 104; WRITE ('1200 Baud transmission.') END; 4: {600 Baud.} BEGIN mdem_baud := 208; WRITE ('600 Baud transmission.') END END; {The hunt mode loop begins here. This loop is used during initialization.} FILL_CHAR (xfr_bufr, SIZE_OF (xfr_bufr), CHR (0)); note_obsv ('Waiting for Host message.'); {Initialize the modem port to the desired baud rate.} mdem_init (mdem_baud); {Search for Host serial port.} done := false; REPEAT read_msg (xfr_bufr); done := (xfr_bufr [0] = CHR (5)) OR (xfr_bufr [0] IN ['D', 'E', 'R', 'W']) UNTIL done; {Serial port has come up with initial command or transfer has been aborted by operator intervention.} IF xfr_bufr [0] = CHR (5) THEN {Operator has terminated transfer.} note_obsv ('Operator terminated.') ELSE BEGIN {Initial command received. Process commands until operator terminates or Host drops line.} done := false; REPEAT IF xfr_bufr [0] < ' ' THEN err_prcsr ( ORD (xfr_bufr [0])) ELSE CASE xfr_bufr [0] OF 'D': {Directory request.} BEGIN note_obsv ('Sending directory.'); dir_mode; note_obsv ('Waiting.'); END; 'E': {Erase file.} BEGIN note_obsv ('Erasing file.'); eras_mode; note_obsv ('Waiting.'); END; 'R': {Send a file.} BEGIN note_obsv ('Sending file to Host.'); read_mode; note_obsv ('Waiting.'); END; 'W': {Recieve a file.} BEGIN note_obsv ('Getting file from Host.'); writ_mode; note_obsv ('Waiting.'); END END; {If no fatal error has occurred, read the next message from the host and interpret it.} IF NOT done THEN read_msg (xfr_bufr); UNTIL done; END; mdem_clr END {disk_xfr}. ======================================================================================== DOCUMENT :usus Folder:VOL20:unlpatch.1.text ======================================================================================== (*$S+*)(*$G+*) PROGRAM UNLPATCH; (*version 2.4, 2 Nov 82*) CONST EVERMORE = FALSE; MAXMEMORY = 59; (*block no.*) MAXDISK = 987; (*block no.*) TYPE SNUM = STRING[7]; BASE = 2..16; JEKYLLHYDE = RECORD CASE BOOLEAN OF TRUE : (ADDR : INTEGER); FALSE : (DATA : ^INTEGER) END; CHAMELEON = RECORD CASE BOOLEAN OF TRUE : (CH : PACKED ARRAY[0..1] OF CHAR); FALSE : (INT : INTEGER) END; ONELINE = PACKED RECORD ADDRESS : INTEGER; CODE : PACKED ARRAY[0..7] OF CHAMELEON END; NAME = STRING[24]; CHARSET = SET OF CHAR; VAR FIN : FILE; DATA : CHAMELEON; WINDOW : PACKED ARRAY[0..31] OF ONELINE; TEMP : PACKED ARRAY[0..511] OF CHAR; LINENO,COLNO,UNITNO,BLKNO,START,STOP,X,Y,RADIX,BLKRADIX : INTEGER; BYTEBLOCK,HALFPAGE,SHOWCHARS,LOWBYTE,SHOWHEX,SHOWDEC : BOOLEAN; DONE,FILEBLOCK,MEMORYBLOCK,DISKBLOCK,ALTLINE,WAIT : BOOLEAN; REPLY : CHAR; SFIN : NAME; VISIBLE : CHARSET; STRG : STRING; PROCEDURE CLEARSCREEN; VAR LF : PACKED ARRAY [1..24] OF CHAR; I : INTEGER; BEGIN GOTOXY(0,23); FOR I := 1 TO 24 DO LF[I] := CHR(10); UNITWRITE(1,LF,24); GOTOXY(0,0) END; PROCEDURE CLEARSPACE (X,Y,N : INTEGER); VAR I : INTEGER; CS :PACKED ARRAY [1..160] OF 0..255; BEGIN GOTOXY(X,Y); FOR I := 1 TO N DO CS[I] := 32; FOR I := N+1 TO N+N DO CS[I] := 8; UNITWRITE(1,CS[1],N); UNITWRITE(1,CS[N+1],N) END; FUNCTION COMMAND(COMMANDSET : CHARSET) : CHAR; VAR REPLY : CHAR; SURROGATE : PACKED ARRAY [0..0] OF CHAR; BEGIN REPEAT UNITREAD(2,SURROGATE[0],1); REPLY := SURROGATE[0]; IF REPLY IN ['a'..'z'] THEN REPLY := CHR(ORD(REPLY) - 32); UNTIL REPLY IN COMMANDSET; COMMAND := REPLY END; PROCEDURE PAUSE(XCUR,YCUR : INTEGER; S : STRING); VAR REPLY : CHAR; BEGIN GOTOXY(XCUR,YCUR); WRITE(CHR(7),S); REPLY := COMMAND([' ']); CLEARSPACE(XCUR,YCUR,LENGTH(S)) END; FUNCTION CONTINUE : BOOLEAN; VAR REPLY : CHAR; BEGIN REPLY := COMMAND([' ','Q']); IF (REPLY = ' ') THEN CONTINUE := TRUE ELSE CONTINUE := FALSE END; FUNCTION DOIT : BOOLEAN; VAR REPLY : CHAR; BEGIN REPLY := COMMAND(['Y','N']); IF (REPLY = 'Y') THEN DOIT := TRUE ELSE DOIT := FALSE END; PROCEDURE GETBYTESTR(VAR CHARSTR : STRING; X,Y : INTEGER); FORWARD; PROCEDURE STRINTCONV (STRG : SNUM; VAR INT : INTEGER; RADIX : BASE; X,Y,LEN,MAX : INTEGER; GETSTR : BOOLEAN); VAR I,RESULT : INTEGER; REPLY : CHAR; S : STRING; PROCEDURE ERRSIR(ERRORNO : INTEGER); BEGIN CASE ERRORNO OF 1 : S := 'Number too large. Type to continue.'; 2 : S := ('Invalid number. Type to continue.'); END; PAUSE(0,23,S); CLEARSPACE(X,Y,LEN); IF GETSTR THEN BEGIN READLN(STRG); STRINTCONV(STRG,INT,RADIX,X,Y,LEN,MAX,TRUE) END ELSE BEGIN GETBYTESTR(STRG,X,Y); STRINTCONV(STRG,INT,RADIX,X,Y,LEN,MAX,FALSE) END; EXIT(STRINTCONV) END; BEGIN IF (LENGTH(STRG) > 0) THEN BEGIN RESULT := 0; FOR I := 1 TO LENGTH(STRG) DO BEGIN IF ((STRG[I] IN ['0'..'9']) AND ((ORD(STRG[I])-ORD('0')) IN [0..RADIX])) THEN BEGIN IF (RESULT <= (MAXINT - (ORD(STRG[I]) - ORD('0'))) DIV RADIX) THEN BEGIN RESULT := RADIX*RESULT + ORD(STRG[I]) - ORD('0'); IF (RESULT > MAX) THEN ERRSIR(1) END ELSE ERRSIR(1) END ELSE IF ((STRG[I] IN ['A'..'F']) AND (RADIX > 10) AND ((ORD(STRG[I])-ORD('A')+10) < RADIX)) THEN BEGIN IF (RESULT <= (MAXINT - ORD(STRG[I]) + ORD('A') - 10) DIV RADIX) THEN BEGIN RESULT := RADIX*RESULT + ORD(STRG[I]) - ORD('A') + 10; IF (RESULT > MAX) THEN ERRSIR(1) END ELSE ERRSIR(1) END ELSE BEGIN ERRSIR(1) END END; INT := RESULT END END; PROCEDURE GETRADIX(ASK : BOOLEAN); VAR SRADIX : STRING; BEGIN IF ASK THEN BEGIN CLEARSPACE(0,0,80); WRITE('Do you want to change the current radix? '); REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN ['Y','y','N','n']; IF (REPLY IN ['N','n']) THEN EXIT(GETRADIX) END; REPEAT CLEARSPACE(0,0,80); WRITE('Enter new radix (8,10,16; 10 defaults to 8 for words): '); READLN(SRADIX) UNTIL ((SRADIX = '8') OR (SRADIX = '10') OR (SRADIX = '16')); STRINTCONV(SRADIX,RADIX,10,55,0,10,16,TRUE); CASE RADIX OF 8 : BEGIN SHOWHEX := FALSE; SHOWDEC := FALSE; END; 10 : BEGIN SHOWDEC := TRUE; SHOWHEX := FALSE END; 16 : BEGIN SHOWHEX := TRUE; SHOWDEC := FALSE END END END; PROCEDURE GETWORD (VAR DATA : INTEGER; X,Y : INTEGER); CONST BS = 8; ESC = 27; CR = 13; VAR RESULT,I,RDX : INTEGER; CH : CHAR; STRG :STRING; PROCEDURE BADNUMBER; BEGIN CLEARSPACE(0,0,80); WRITE(CHR(7),'Improper number. Current word radix = ',RDX,'. Retype. '); CLEARSPACE(X,Y,I); GETWORD(DATA,X,Y); CLEARSPACE(0,0,80); EXIT(GETWORD) END; BEGIN RESULT := 0; I := 0; IF (RADIX = 16) THEN RDX := 16 ELSE RDX := 8; REPEAT READ(INPUT,CH); IF (CH = CHR(CR)) THEN CH := ' '; IF (CH = CHR(BS)) THEN BEGIN IF (I > 0) THEN BEGIN WRITE(' '); WRITE(CHR(BS)); I := I - 1; RESULT := RESULT DIV RDX END ELSE WRITE(' ') END ELSE IF ((RDX = 8) AND ((ORD(CH)-ORD('0')) IN [0..7])) OR ((RDX = 10) AND ((ORD(CH)-ORD('0')) IN [0..9])) THEN BEGIN I := I + 1; IF ((RDX = 8) AND (RESULT > 8191)) OR ((RDX = 10) AND ((RESULT > 6553) OR ((RESULT = 6553) AND ((ORD(CH)-ORD('0')) > 5)))) THEN BADNUMBER ELSE RESULT := RDX*RESULT + ORD(CH) - ORD('0') END ELSE IF (((RDX = 16) AND ((ORD(CH)-ORD('0')) IN [0..9])) OR ((ORD(CH)-ORD('A')) IN [0..5])) THEN BEGIN I := I + 1; IF (RESULT > 4095) THEN BADNUMBER ELSE BEGIN IF ((ORD(CH)-ORD('0')) IN [0..9]) THEN RESULT := RDX*RESULT + ORD(CH) - ORD('0') ELSE RESULT := RDX*RESULT + ORD(CH) - ORD('A') + 10 END END ELSE IF NOT(CH IN [' ',CHR(ESC)]) THEN BADNUMBER UNTIL (CH IN [' ',CHR(ESC)]); IF (CH = ' ') THEN DONE := FALSE ELSE DONE := TRUE; DATA := RESULT END; PROCEDURE WRITEOCTAL (DATA : INTEGER); VAR DIVISOR : INTEGER; BEGIN DIVISOR := 4096; IF (DATA < 0) THEN BEGIN WRITE('1'); DATA:= DATA + 32767 + 1 END ELSE WRITE('0'); REPEAT WRITE(CHR(DATA DIV DIVISOR MOD 8 + ORD('0'))); DIVISOR := DIVISOR DIV 8 UNTIL DIVISOR = 0 END; PROCEDURE WRITEBYTE(CH : CHAR); VAR NUMBER,DIVISOR : INTEGER; BEGIN NUMBER := ORD(CH); DIVISOR := 64; REPEAT WRITE(CHR(NUMBER DIV DIVISOR MOD 8 + ORD('0'))); DIVISOR := DIVISOR DIV 8 UNTIL DIVISOR = 0 END; PROCEDURE WRITEHEXBYTE(CH : CHAR); VAR HEXDIGIT,NUMBER,DIVISOR : INTEGER; BEGIN NUMBER := ORD(CH); DIVISOR := 16; REPEAT HEXDIGIT := NUMBER DIV DIVISOR MOD 16; IF (HEXDIGIT IN [0..9]) THEN WRITE(CHR(HEXDIGIT+ORD('0'))) ELSE WRITE(CHR(HEXDIGIT+ORD('A')-10)); DIVISOR := DIVISOR DIV 16 UNTIL DIVISOR = 0; END; PROCEDURE WRITEDECBYTE(CH : CHAR); VAR NUMBER : INTEGER; BEGIN NUMBER := ORD(CH); IF (NUMBER < 100) THEN WRITE('0'); IF (NUMBER < 10) THEN WRITE('0'); WRITE(NUMBER) END; FUNCTION PEEK(ADDRESS : INTEGER): INTEGER; VAR MEMORY : JEKYLLHYDE; BEGIN MEMORY.ADDR := ADDRESS; PEEK := MEMORY.DATA^ END; PROCEDURE POKE(ADDRESS,INFO : INTEGER); VAR MEMORY : JEKYLLHYDE; BEGIN MEMORY.ADDR := ADDRESS; MEMORY.DATA^ := INFO END; PROCEDURE GETFIN; VAR LEN,RSLT : INTEGER; BEGIN (*$I-*) REPEAT GOTOXY(36,0); READLN(SFIN); IF (LENGTH(SFIN) = 0) THEN BEGIN CLEARSCREEN; EXIT(PROGRAM) END; RESET(FIN,SFIN); RSLT := IORESULT; IF RSLT <> 0 THEN BEGIN GOTOXY(0,23); WRITE(CHR(7),'I/O error ',RSLT:3,'. Correct and type to continue or Q(uit'); IF NOT CONTINUE THEN BEGIN CLEARSCREEN; EXIT(PROGRAM) END; CLEARSPACE(0,23,80); CLEARSPACE(36,0,LENGTH(SFIN)) END UNTIL RSLT = 0 (*$I+*) END; PROCEDURE GETBLKNO; VAR STRG : SNUM; CH : CHAR; MAX : INTEGER; BEGIN CLEARSPACE(0,0,80); WRITE('Current block no. radix = ',BLKRADIX:2,'. Type to accept, 8 or 10 to change: '); REPEAT READ(CH); IF NOT(CH IN [' ','1','8']) THEN CLEARSPACE(70,0,8) UNTIL (CH IN [' ','1','8']); STRG := ' '; STRG[1] := CH; IF (NOT (STRG = ' ')) AND (NOT (STRG = '8')) THEN BEGIN REPEAT READ(CH); IF NOT(CH = '0') THEN CLEARSPACE(71,0,7) UNTIL (CH = '0'); STRG := CONCAT(STRG,'0') END; IF NOT(STRG = ' ') THEN BEGIN READLN; STRINTCONV(STRG,BLKRADIX,10,70,0,8,10,TRUE) END; CLEARSPACE(0,0,80); WRITE('Enter starting block no.: '); READLN(STRG); IF MEMORYBLK THEN MAX := MAXMEMORY ELSE MAX := MAXDISK; STRINTCONV(STRG,BLKNO,BLKRADIX,26,0,8,MAX,TRUE); CLEARSPACE(0,0,40) END; (*$I-*) PROCEDURE GETBLOCK; VAR I : INTEGER; BEGIN IF EOF(FIN) THEN BEGIN CLEARSPACE(0,0,80); WRITELN(CHR(7),'End of file. Do you want to continue? '); IF NOT DOIT THEN EXIT(PROGRAM); RESET(FIN); GETBLKNO END; I := BLOCKREAD(FIN,TEMP,1,BLKNO); IF (IORESULT = 0) AND (I = 1) THEN EXIT(GETBLOCK); WRITELN('Block not transferred. Type to continue or Q(uit.'); IF NOT CONTINUE THEN BEGIN CLEARSCREEN; EXIT(PROGRAM) END; CLEARSCREEN; GETBLKNO; GETBLOCK END; (*$I+*) PROCEDURE GETMEMORYBLOCK; VAR I,N : INTEGER; BEGIN I := 0; N := BLKNO*256; REPEAT DATA.INT := PEEK(N + I); TEMP[I] := DATA.CH[0]; I := I + 1; TEMP[I] := DATA.CH[1]; I := I + 1 UNTIL I >= 512 END; PROCEDURE LOADMEMORY; VAR I,J,K,N : INTEGER; BEGIN K := 0; N := BLKNO*256; FOR I := 0 TO 31 DO FOR J := 0 TO 7 DO BEGIN POKE((N + K),WINDOW[I].CODE[J].INT); K := K + 2 END END; PROCEDURE WRITEADDRESS(RDX : INTEGER; ADDR : INTEGER); VAR DIGIT,DIVISOR : INTEGER; BEGIN DIVISOR := RDX*RDX; REPEAT DIGIT := ADDR DIV DIVISOR MOD RDX; IF (DIGIT IN [0..9]) THEN WRITE(CHR(DIGIT+ORD('0'))) ELSE WRITE(CHR(DIGIT+ORD('A')-10)); DIVISOR := DIVISOR DIV RDX UNTIL DIVISOR = 0; END; PROCEDURE INITWINDOW; VAR I,J,K : INTEGER; BEGIN K := 0; FOR I := 0 TO 31 DO FOR J:= 0 TO 7 DO BEGIN WINDOW[I].ADDRESS := 16*I; WINDOW[I].CODE[J].CH[0] := TEMP[K]; K := K + 1; WINDOW[I].CODE[J].CH[1] := TEMP[K]; K := K + 1 END END; PROCEDURE RELOAD; VAR I,J,K : INTEGER; BEGIN K := 0; FOR I:= 0 TO 31 DO FOR J := 0 TO 7 DO BEGIN TEMP[K] := WINDOW[I].CODE[J].CH[0]; K := K + 1; TEMP[K] := WINDOW[I].CODE[J].CH[1]; K := K + 1 END; END; PROCEDURE BLOCKLINE; BEGIN WRITE('Block number ',BLKNO,' Radix is '); CASE RADIX OF 8 : WRITELN('octal'); 10 : IF BYTEBLOCK THEN WRITELN('decimal') ELSE WRITELN('octal'); 16 : WRITELN('hexadecimal') END; WRITELN END; PROCEDURE OWTOPLINE; BEGIN WRITELN(' 00 02 04 06 10 12 14 16'); WRITELN END; PROCEDURE HWTOPLINE; BEGIN WRITELN(' 00 02 04 06 08 0A 0C OE'); WRITELN END; PROCEDURE OBTOPLINE; BEGIN WRITELN(' 00 01 02 03 04 05 06 07 10 11 12 13 14 15 16 17'); WRITELN END; PROCEDURE HBTOPLINE; BEGIN WRITELN(' 00 01 02 03 04 05 06 07 08 09 0A 0B 0C 0D 0E 0F'); WRITELN END; PROCEDURE SHOWWORDS; VAR J,N : INTEGER; BEGIN IF SHOWHEX THEN HWTOPLINE ELSE OWTOPLINE; FOR N := START TO STOP DO BEGIN WITH WINDOW[N] DO BEGIN IF (NOT SHOWHEX) THEN BEGIN WRITEADDRESS(8,ADDRESS); WRITE(': '); FOR J := 0 TO 7 DO BEGIN WRITE(' '); WRITEOCTAL(CODE[J].INT) END; END ELSE BEGIN WRITEADDRESS(16,ADDRESS); WRITE(': '); FOR J := 0 TO 7 DO BEGIN WRITE(' '); WRITEHEXBYTE(CODE[J].CH[1]); WRITEHEXBYTE(CODE[J].CH[0]); WRITE(' '); END; END; WRITE(' '); FOR J := 0 TO 7 DO BEGIN IF (CODE[J].CH[0] IN VISIBLE) THEN WRITE(CODE[J].CH[0]) ELSE WRITE('.'); IF (CODE[J].CH[1] IN VISIBLE) THEN WRITE(CODE[J].CH[1]) ELSE WRITE('.') END; WRITELN END END END; (*$I #5:UNLPATCH.2.TEXT*) ======================================================================================== DOCUMENT :usus Folder:VOL20:unlpatch.2.text ======================================================================================== PROCEDURE SHOWBYTES; VAR J,N : INTEGER; BEGIN IF SHOWHEX THEN HBTOPLINE ELSE OBTOPLINE; FOR N := START TO STOP DO BEGIN WITH WINDOW[N] DO BEGIN IF (NOT SHOWHEX) THEN WRITEADDRESS(8,ADDRESS) ELSE WRITEADDRESS(16,ADDRESS); WRITE(': '); FOR J := 0 TO 7 DO BEGIN WITH CODE[J] DO BEGIN WRITE(' '); IF ((CH[0] IN VISIBLE) AND (SHOWCHARS)) THEN WRITE(CH[0],' ') ELSE IF SHOWHEX THEN BEGIN WRITEHEXBYTE(CH[0]); WRITE(' ') END ELSE IF SHOWDEC THEN WRITEDECBYTE(CH[0]) ELSE WRITEBYTE(CH[0]); WRITE(' '); IF ((CH[1] IN VISIBLE) AND (SHOWCHARS)) THEN WRITE(CH[1],' ') ELSE IF SHOWHEX THEN BEGIN WRITEHEXBYTE(CH[1]); WRITE(' ') END ELSE IF SHOWDEC THEN WRITEDECBYTE(CH[1]) ELSE WRITEBYTE(CH[1]) END END; WRITELN END END END; PROCEDURE DISPLAY; BEGIN CLEARSCREEN; IF (HALFPAGE) THEN BEGIN START := 0; STOP := 15; END ELSE BEGIN START := 16; STOP := 31 END; GOTOXY(0,2); BLOCKLINE; IF BYTEBLOCK THEN SHOWBYTES ELSE SHOWWORDS; END; PROCEDURE PATCH; FORWARD; PROCEDURE ADVANCE; BEGIN IF LOWBYTE THEN COLNO := COLNO + 1; IF (COLNO > 7) THEN BEGIN IF (LINENO = 31) THEN BEGIN CLEARSPACE(0,1,80); CLEARSPACE(0,0,80); WRITE('End of block. Type to continue.'); REPEAT READ(KEYBOARD,REPLY) UNTIL (REPLY = ' '); EXIT(PATCH) END ELSE IF (LINENO = 15) THEN BEGIN HALFPAGE := NOT HALFPAGE; DISPLAY; LINENO := 16; COLNO := 0 END ELSE BEGIN COLNO := 0; LINENO := LINENO + 1 END END END; PROCEDURE PATCHWORD; BEGIN IF NOT SHOWHEX THEN X := COLNO*7 + 6 ELSE X := COLNO*7 + 7; IF HALFPAGE THEN Y:= LINENO + 6 ELSE Y := LINENO - 10; CLEARSPACE(0,0,80); IF (NOT SHOWHEX) THEN WRITE('Enter new word in XXXXXX (octal) format. continues, terminates.') ELSE IF SHOWHEX THEN WRITE('Enter new word in XXXX (hex) format. continues, terminates.');; CLEARSPACE(X,Y,6); GETWORD(DATA.INT,X,Y); WINDOW[LINENO].CODE[COLNO].INT := DATA.INT; IF HALFPAGE THEN CLEARSPACE(63 + COLNO*2,LINENO + 6,2) ELSE CLEARSPACE(63 + COLNO*2,LINENO - 10,2); WITH WINDOW[LINENO] DO BEGIN IF (CODE[COLNO].CH[0] IN VISIBLE) THEN WRITE(CODE[COLNO].CH[0]) ELSE WRITE('.'); IF (CODE[COLNO].CH[1] IN VISIBLE) THEN WRITE(CODE[COLNO].CH[1]) ELSE WRITE('.') END; LOWBYTE := TRUE; IF DONE THEN EXIT(PATCH) ELSE ADVANCE; PATCHWORD END; PROCEDURE GETBYTESTR(*VAR CHARSTR : STRING; X,Y : INTEGER*); CONST BS = 8; ESC = 27; CR = 13; VAR CH : CHAR; I : INTEGER; ONESTR : STRING[1]; BEGIN I := 0; ONESTR := ' '; CHARSTR := ''; REPEAT READ(INPUT,CH); IF (CH = CHR(CR)) THEN CH := ' '; IF (CH = CHR(BS)) THEN BEGIN WRITE(' '); IF (I > 0) THEN BEGIN WRITE(CHR(BS)); DELETE(CHARSTR, LENGTH(CHARSTR),1); I := I-1 END END ELSE IF NOT(CH IN [' ',CHR(ESC)]) THEN BEGIN I := I + 1; ONESTR[1] := CH; CHARSTR := CONCAT(CHARSTR,ONESTR) END; IF ((I = 0) AND (CH = ' ')) THEN BEGIN CHARSTR := ' '; CH := 'X'; (*anything but ' '*) I := 1 END; IF (I > 3) THEN BEGIN CLEARSPACE(0,0,80); WRITE(CHR(7),'Byte string too long. Retype. '); CLEARSPACE(X,Y,LENGTH(CHARSTR)); GETBYTESTR(CHARSTR,X,Y); CLEARSPACE(0,0,80); EXIT(GETBYTESTR) END UNTIL (CH IN [' ',CHR(ESC)]); IF (CH = ' ') THEN DONE := FALSE ELSE DONE := TRUE; END; PROCEDURE PATCHBYTE; LABEL 999; VAR CHARSTR: SNUM; LEN : INTEGER; NUM : 0..255; BEGIN CLEARSPACE(0,0,80); IF SHOWCHARS THEN WRITELN('Enter new char in X(Ascii) or XXX(ord) format. Current radix = ',RADIX) ELSE IF SHOWHEX THEN WRITELN('Enter new byte in XX(hex) format. ') ELSE WRITELN('Enter new byte in XXX format. Current radix = ',RADIX); WRITE(' continues; terminates'); IF LOWBYTE THEN X := COLNO*8+7 ELSE X := COLNO*8+11; IF HALFPAGE THEN Y:= LINENO + 6 ELSE Y := LINENO - 10; CLEARSPACE(X,Y,3); GETBYTESTR(CHARSTR,X,Y); LEN := LENGTH(CHARSTR); IF (SHOWCHARS AND NOT (LEN IN [1,3])) OR (NOT SHOWCHARS AND NOT SHOWHEX AND NOT (LEN = 3)) THEN BEGIN CLEARSPACE(X,Y,7); WITH WINDOW[LINENO] DO BEGIN IF SHOWCHARS AND (CODE[COLNO].CH[0] IN VISIBLE) THEN WRITE(CODE[COLNO].CH[0],' ') ELSE IF SHOWDEC THEN WRITEDECBYTE(CODE[COLNO].CH[0]) ELSE WRITEBYTE(CODE[COLNO].CH[0]); WRITE(' '); IF SHOWCHARS AND (CODE[COLNO].CH[1] IN VISIBLE) THEN WRITE(CODE[COLNO].CH[1],' ') ELSE IF SHOWDEC THEN WRITEDECBYTE(CODE[COLNO].CH[1]) ELSE WRITEBYTE(CODE[COLNO].CH[1]); WRITE(' '); GOTO 999 END END; IF SHOWCHARS OR (NOT SHOWCHARS AND NOT SHOWHEX) THEN IF (LEN = 3) THEN BEGIN STRINTCONV(CHARSTR,NUM,RADIX,X,Y,3,255,FALSE); IF LOWBYTE THEN WINDOW[LINENO].CODE[COLNO].CH[0] := CHR(NUM) ELSE WINDOW[LINENO].CODE[COLNO].CH[1] := CHR(NUM) END ELSE (*IF LEN = 1*) BEGIN IF LOWBYTE THEN WINDOW[LINENO].CODE[COLNO].CH[0] := CHARSTR[1] ELSE WINDOW[LINENO].CODE[COLNO].CH[1] := CHARSTR[1] END; IF SHOWHEX AND NOT (LEN = 2) THEN BEGIN CLEARSPACE(X,Y,7); WITH WINDOW[LINENO] DO BEGIN WRITE(' '); WRITEHEXBYTE(CODE[COLNO].CH[0]); WRITE(' '); WRITEHEXBYTE(CODE[COLNO].CH[1]); GOTO 999 END END; IF SHOWHEX AND (LEN = 2) THEN BEGIN STRINTCONV(CHARSTR,NUM,16,X,Y,3,255,FALSE); IF LOWBYTE THEN WINDOW[LINENO].CODE[COLNO].CH[0] := CHR(NUM) ELSE WINDOW[LINENO].CODE[COLNO].CH[1] := CHR(NUM) END; LOWBYTE := NOT LOWBYTE; IF DONE THEN EXIT(PATCH) ELSE ADVANCE; 999: PATCHBYTE END; PROCEDURE PATCH; VAR STRG : SNUM; RDX : INTEGER; BEGIN CLEARSPACE(0,0,80); IF SHOWHEX THEN RDX := 16 ELSE RDX := 8; WRITE('Enter line no. of code to be changed: '); READLN(STRG); STRINTCONV(STRG,LINENO,RDX,38,0,8,496,TRUE); LINENO := LINENO DIV 16; IF HALFPAGE AND (LINENO > 15) THEN BEGIN HALFPAGE := FALSE; DISPLAY END; IF NOT HALFPAGE AND (LINENO < 16) THEN BEGIN HALFPAGE := TRUE; DISPLAY END; CLEARSPACE(0,0,80); WRITE('Enter column no. of code to be changed: '); READLN(STRG); STRINTCONV(STRG,COLNO,RDX,40,0,8,17,TRUE); IF (ODD(COLNO)) THEN LOWBYTE := FALSE ELSE LOWBYTE := TRUE; COLNO := COLNO DIV 2; CLEARSPACE(0,0,80); IF (BYTEBLOCK) THEN PATCHBYTE ELSE PATCHWORD; END; PROCEDURE QUERY; VAR I : INTEGER; S : STRING; BEGIN CLEARSCREEN; WRITELN('Select disposition of present block:'); WRITELN(' W(rite patched block to disk (memory))'); WRITELN(' E(xit leaving disk (memory) block unchanged)'); IF (COMMAND(['E','W']) = 'W') THEN BEGIN CLEARSCREEN; RELOAD; IF DISKBLOCK THEN BEGIN UNITWRITE(UNITNO,TEMP,512,BLKNO); UNITREAD(UNITNO,TEMP,512,BLKNO) END ELSE IF MEMORYBLOCK THEN BEGIN LOADMEMORY; GETMEMORYBLOCK END ELSE BEGIN IF EOF(FIN) THEN RESET(FIN); I := BLOCKWRITE(FIN,TEMP,1,BLKNO); GETBLOCK END; INITWINDOW; HALFPAGE := TRUE; DISPLAY; GOTOXY(0,22); WRITE('This is your patched block (no. ',BLKNO,') as read from the disk (memory)'); S := ('..........................Type to continue..........................'); PAUSE(0,23,S); HALFPAGE := FALSE; DISPLAY; S := 'Type to continue'; PAUSE(0,23,S); END; CLEARSCREEN; HALFPAGE := TRUE END; PROCEDURE DUMP; VAR N,RSLT : INTEGER; BEGIN (*$I-*) REPEAT CLOSE(OUTPUT); RESET(OUTPUT,'PRINTER:'); RSLT := IORESULT; IF (RSLT <> 0) THEN BEGIN RESET(OUTPUT,'CONSOLE:'); GOTOXY(0,23); WRITE(CHR(7),'I/O error',RSLT:3,'. Correct and type to continue', 'or Q(uit).'); IF NOT CONTINUE THEN BEGIN CLEARSCREEN; EXIT(PROGRAM) END; CLEARSPACE(0,23,80); END UNTIL RSLT = 0; (*$I+*) IF FILEBLOCK THEN WRITE('File ',SFIN,' '); BLOCKLINE; START := 0; STOP := 31; IF BYTEBLOCK THEN SHOWBYTES ELSE SHOWWORDS; CLOSE(OUTPUT); RESET(OUTPUT,'CONSOLE:') END; PROCEDURE BLKERROR; VAR S : STRING; BEGIN CLEARSPACE(0,0,80); S := 'Improper block number requested. Type to continue.'; PAUSE(0,0,S); GETBLKNO END; PROCEDURE INITIALIZE; BEGIN VISIBLE := [' '..'~']; FILEBLOCK := TRUE; DISKBLOCK := FALSE; MEMORYBLOCK := FALSE; WAIT := FALSE; RADIX := 8; BLKRADIX := 10; CLEARSCREEN; WRITELN('This program displays half a block of words, bytes, or characters'); WRITELN('from a disk or disk file or memory, accepts patches, and rewrites'); WRITELN('the patched block to the disk or disk file or memory.'); WRITELN; WRITELN('F(ile or D(isk or M(emory?'); REPLY := COMMAND(['F','D','M']); CLEARSCREEN; IF (REPLY = 'F') THEN BEGIN WRITE('Enter input file (or to quit): '); GETFIN; GETBLKNO; GETBLOCK; END ELSE IF (REPLY = 'D') THEN BEGIN WRITE('Enter unit number <4 or 5>:'); IF (COMMAND(['4','5']) = '4') THEN UNITNO := 4 ELSE UNITNO := 5; GETBLKNO; UNITREAD(UNITNO,TEMP,512,BLKNO); DISKBLOCK := TRUE; FILEBLOCK := FALSE END ELSE BEGIN WRITE('Current block no. radix = ',BLKRADIX,'. Enter memory block number: '); READLN(STRG); STRINTCONV(STRG,BLKNO,BLKRADIX,57,0,2,16,TRUE); GETMEMORYBLOCK; MEMORYBLOCK := TRUE; FILEBLOCK := FALSE END; CLEARSPACE(0,0,80); HALFPAGE := TRUE; INITWINDOW; BYTEBLOCK := FALSE; SHOWCHARS := FALSE; SHOWHEX := FALSE; SHOWDEC := FALSE; END; PROCEDURE COMMANDLINE; BEGIN CLEARSPACE(0,0,80); IF NOT ALTLINE THEN WRITE('S(wap, F(orward, reV(erse, N(ewblock, P(atch, D(ump, ?') ELSE WRITE('W(ord, C(har, B(yte, R(adix, Q(uit, ?'); ALTLINE := FALSE END; BEGIN(*PROGRAM*); INITIALIZE; REPEAT IF NOT WAIT THEN DISPLAY; WAIT := FALSE; COMMANDLINE; CASE COMMAND(['B','C','D','F','N','P','Q','R','S','V','W','?']) OF 'S' : HALFPAGE := NOT HALFPAGE; 'P' : PATCH; 'D' : DUMP; 'F' : BEGIN QUERY; BLKNO := SUCC(BLKNO); IF FILEBLOCK THEN IF EOF(FIN) THEN BEGIN PAUSE(0,0,'End of file. Type to continue.'); RESET(FIN); GETBLKNO; END; IF ((DISKBLOCK AND (BLKNO > MAXDISK)) OR (MEMORYBLOCK AND (BLKNO > MAXMEMORY))) THEN BLKERROR; IF DISKBLOCK THEN UNITREAD(UNITNO,TEMP,512,BLKNO) ELSE IF MEMORYBLOCK THEN GETMEMORYBLOCK ELSE GETBLOCK; INITWINDOW END; 'V' : BEGIN QUERY; BLKNO := PRED(BLKNO); IF (BLKNO < 0) THEN BLKERROR; IF FILEBLOCK THEN IF EOF(FIN) THEN RESET(FIN); IF DISKBLOCK THEN UNITREAD(UNITNO,TEMP,512,BLKNO) ELSE IF MEMORYBLOCK THEN GETMEMORYBLOCK ELSE GETBLOCK; INITWINDOW END; 'N' : BEGIN QUERY; GETBLKNO; IF FILEBLOCK THEN IF EOF(FIN) THEN RESET(FIN); IF DISKBLOCK THEN UNITREAD(UNITNO,TEMP,512,BLKNO) ELSE IF MEMORYBLOCK THEN GETMEMORYBLOCK ELSE GETBLOCK; INITWINDOW END; 'Q' : BEGIN QUERY; EXIT(PROGRAM) END; 'C' : BEGIN BYTEBLOCK := TRUE; SHOWCHARS := TRUE; GETRADIX(TRUE) END; 'W' : BEGIN BYTEBLOCK := FALSE; SHOWCHARS := FALSE; GETRADIX(TRUE) END; 'B' : BEGIN BYTEBLOCK := TRUE; SHOWCHARS := FALSE; GETRADIX(TRUE) END; 'R' : GETRADIX(FALSE); '?' : BEGIN ALTLINE := NOT ALTLINE; WAIT := TRUE END; END UNTIL EVERMORE END. ======================================================================================== DOCUMENT :usus Folder:VOL20:unlpch.doc.text ======================================================================================== UNLPATCH Submitted by: Henry E. Baumgarten Department of Chemistry University of Nebraska, Lincoln Lincoln, Nebraska 68588-0304 (402) 472-3301 UNLPATCH is a patch-dump program intended to facilitate the examination, revision (patching), and printing (dumping) of UCSD files, disks, and memory. In its present form operations on memory are limited largely to the examin- ation of the UNLPATCH program itself and those portions of the operating system which are resident in memory. This program may also be used for the examination, patching, and dumping of RT-11 disk blocks; however, the present version is not designed to read RT-11 directories; therefore, it cannot be used with RT-11 files. The program is neither as elegant nor as bug-ridden as the UCSD PATCH program the author received with Version 2.0. It is intended to be fairly easy to use and fairly forgiving of user blunders; however, as with most patching operations, it is wise to back-up disks and files before using this program. Preparing the code file: On the author`s Heath H11A system (DEC LSI-11/2, UNL mongrel version) using Version 2.0 of UCSD Pascal, compilation of UNLPATCH.1.TEXT gives a runnable version of UNLPATCH.CODE (without linking)---i.e., the "software tools" the author often uses are built into the program rather than taken from a library. Those persons having an editor capable of handling large files may wish to combine UNLPATCH.1.TEXT WITH UNLPATCH.2.TEXT. The program appears to compile and work properly with Version 4.0 also; however, for many purposes the author prefers Version 2.0 over 4.0 and has not used this program extensively with 4.0. Furthermore, the author has found that that Version 2.0 is sometimes more forgiving than Version 4.0; therefore, it is possible that "bugs" not known to the author may still be lurking within. Since the author has not had the opportunity to test this program with non-DEC microprocessors, users should test this program carefully to determine if their microprocessors have system-dependent idiosyncracies that will require editing of the source. This will be especially important for those persons having machines whose byte sex is different from that of the LSI-11 (least significant byte goes into byte 0 of a word, most significant byte into byte 1). Making changes to accommodate different byte sexes should not be difficult. Making the the changes necessary to address extended memory may be more difficult. UNLPATCH conventions: Data formats allowed are bytes, words, and characters. Data, whether from a file, a disk, or memory, is handled in blocks of 512 bytes. Radices (number bases) in this version are limited to the following. Disk, file, or memory blocks: 8 or 10 (starting block = 0) Words (16 bits): 8 or 16 (10 defaults to 8) Bytes (8 bits): 8, 10, or 16 Addresses: 8 or 16 (10 defaults to 8) Characters are assumed to be ASCII-coded with non-printable char (0 to 31, 128 to 255 (base 10)) given in byte-form in the current radix. ======================================================================================== DOCUMENT :usus Folder:VOL20:uprcase.text ======================================================================================== PROGRAM UPPERCASE; {Version 1.1, 26 Oct 81} VAR CH,REPLY : CHAR; SFIN,SFOUT : STRING; FIN,FOUT : TEXT; I,RSLT : INTEGER; SKIP : BOOLEAN; PROCEDURE CLEARSCREEN; VAR LF : PACKED ARRAY [1..24] OF CHAR; I : INTEGER; BEGIN GOTOXY(0,23); FOR I := 1 TO 24 DO LF[I] := CHR(10); UNITWRITE(1,LF,24); GOTOXY(0,0) END; PROCEDURE CLEARSPACE (X,Y,N : INTEGER); VAR I : INTEGER; CS :PACKED ARRAY [1..160] OF 0..255; BEGIN GOTOXY(X,Y); FOR I := 1 TO N DO CS[I] := 32; FOR I := N+1 TO N+N DO CS[I] := 8; UNITWRITE(1,CS[1],N); UNITWRITE(1,CS[N+1],N) END; (*$I-*) PROCEDURE GETINFILE; BEGIN REPEAT BEGIN READLN(SFIN); RESET(FIN,SFIN); RSLT := IORESULT; IF RSLT <> 0 THEN BEGIN IF RSLT = 10 THEN BEGIN SFIN := CONCAT(SFIN,'.TEXT'); RESET(FIN,SFIN); RSLT := IORESULT END; IF RSLT <> 0 THEN BEGIN GOTOXY(0,20); WRITE('IO error',RSLT:3,'. Correct and type to continue or Q(uit)'); REPEAT READ (KEYBOARD, REPLY) UNTIL REPLY IN ['Q','q',' ']; CLEARSPACE(0,20,72); IF REPLY IN ['Q','q'] THEN BEGIN CLOSE(FOUT,LOCK); EXIT(PROGRAM) END ELSE CLEARSPACE(36,4,LENGTH(SFIN)) END END END UNTIL RSLT = 0 END; (*$I+*) (*$I-*) PROCEDURE GETOUTFILE; BEGIN REPEAT READLN(SFOUT); REWRITE(FOUT,SFOUT); RSLT := IORESULT; IF RSLT <> 0 THEN BEGIN GOTOXY (0,20); WRITE('IO error',RSLT:3,'. Correct and type to continue or Q(uit)'); REPEAT READ(KEYBOARD,REPLY) UNTIL REPLY IN ['Q','q',' ']; CLEARSPACE(0,20,72); IF REPLY IN ['Q','q'] THEN BEGIN CLEARSCREEN; EXIT(PROGRAM) END ELSE CLEARSPACE(37,2,LENGTH(SFOUT)) END UNTIL RSLT = 0 END; (*$I+*) BEGIN CLEARSCREEN; WRITELN('This program copies files in upper case.'); WRITELN; WRITE('Enter output file (upper case file): '); GETOUTFILE; WRITELN; WRITE('Enter input file (lower case file): '); GETINFILE; WRITELN; WRITELN('Lines copied'); SKIP := FALSE; I := 1; WHILE (NOT EOF(FIN)) DO BEGIN WHILE (NOT EOLN(FIN)) DO BEGIN READ(FIN,CH); IF (CH IN ['''','{','}']) THEN SKIP := NOT SKIP; IF (CH >= 'a') AND (CH <= 'z') AND NOT SKIP THEN CH := CHR(ORD(CH) - 32); WRITE(FOUT,CH) END; READLN(FIN); WRITELN(FOUT); WRITE('.'); IF ((I MOD 50) = 0) THEN WRITELN; I := I+1 END; CLOSE(FOUT,LOCK); CLOSE(FIN) END. ======================================================================================== DOCUMENT :usus Folder:VOL20:vol20.doc.text ======================================================================================== USUS Library Volume 20 A disk patch utility, a good game, and a complete BIOS for the Jonos ESCORT VOL20: UNLPATCH.1.TEXT 26 The University of Nebraska Lincoln disk patch utility UNLPATCH.2.TEXT 24 it displays its data in octal UNLPCH.DOC.TEXT 10 doc for above AUTOPSY.TEXT 10 Divides a file into small enough pieces for the sytem Editor SCREEN.H19.TEXT 10 A screen control unit for Autopsy SCREEN.TEXT 6 A terminal independant version of SCREEN.H19 LWRCASE.TEXT 8 Converts a file to lower case but leaves literals intact UPRCASE.TEXT 8 same but to upper case HOME_LOAN.TEXT 14 A simple minded simple loan calculator SIGFIG.19.TEXT 14 Get another "significant" figure, or maybe even more! OTHELLO.TEXT 28 Steve Brecher's OTHELLO game, originally on Volume 3 OTHELLO.1.TEXT 26 an include file. This game is a real killer! BASE.TEXT 6 A numeric base converter, works nice. H19UTIL.TEXT 24 A screen control unit for BASE. Modify it for other terminals NUMBER2.TEXT 12 A unit for BASE. FASTREAD.TEXT 10 Another version of a fast string read routine. ESCORT.DOC.TEXT 8 Documentation for the Jonos ESCORT BIOS E.BOOT.TEXT 14 EBIOS.TEXT 8 BIOS.CONST.TEXT 8 BIOS.SERPT.TEXT 22 BIOS.DISKS.TEXT 26 BIOS.PHONE.TEXT 4 BIOS.DATA.TEXT 10 SXFR.SVCS.TEXT 26 FORMATTER.TEXT 8 TRANSPORTR.TEXT 42 BOOTMAKER.TEXT 10 EBIOS-GENR.TEXT 4 EBOOT-GENR.TEXT 4 FMT-LINK.CODE 3 FMT-GENR.TEXT 4 TRANS-GENR.TEXT 4 FORMATTER.CODE 3 SXFR.SVCS.CODE 3 TRANS-MGR.CODE 8 BOOTR-GENR.TEXT 4 BOOT.WRITE.CODE 3 BOOTMAKER.CODE 4 E.BOOT.CODE 3 E.LOAD.BOOT 1 EBIOS.CODE 7 E.LOAD.BIOS 4 BOOT.WRITE.TEXT 16 VOL20.DOC.TEXT 8 You're reading it __________________________________________________________________________ Please transfer the text below to a disk label if you copy this volume. USUS Volume 20 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ Some notes from the editor: Othello This is a game of Othello which plays a VERY GOOD game. It's ripped up most self-proclaimed "experts" that have played it. The original was on Volume 3, but since that volume has been withdrawn, I am placing it here so all USUS members can have it. The original also used the TIME intrinsic to pace its moves, but I have coded that out and replaced it with a simple delay loop. You have to set a constant "dwell_time" to get about 2 or 3 beeps per second for your hardware. The value which is already there is about right for an LSI-11/23. I've only beaten this game twice, its beat me at least 50 times. FastRead FastRead is a routine which allows you to read string info much faster than the p-system will do it. It has been updated and improved by Arley Dealey. The following programs were submitted by Henry Baumgarten UNLPatch This disk patch utility displays its output in octal for you hex haters. It is particularly useful for following assembler listings which list generated code in octal, such as the RT-11 assembler. Autopsy Autopsy breaks a large text file into small pieces so they can be digested by the stock system editors. Those of you with ASE won't need it. UprCase and LwrCase This programs do case conversions on files, but leave literals, such as strings, alone. This can be useful if you have recieved software where the case of the source is not to your liking. SigFig.19 Some time ago a chap in Byte bemoaned the loss of one sigficant figure in the UCSD output of real numbers. This program fragment will recover that digit (plus as many other---nonsignificant--- figures as your heart may desire). Try it by entering 1.23456789 and 1 and an output format of your choise, or compare 1 divided by any integer with the result from your HP-67 or HP-41. More seriously the routine used is useful for converting real numbers to strings for using in plotting programs, etc. Base This is a numeric base converter to convert numbers of one base to another. It works pretty well. You will have to modify the screen control unit, H19UTIL so that it works with your terminal. The Jonos ESCORT BIOS Karl Balke wrote the BIOS for the Jonos ESCORT and was generous enough to contribute his work to the USUS Library. While the BIOS is machine specific, it is for a Z80. This should be an excellent example of how to write a BIOS for other Z80 machines also. ======================================================================================== DOCUMENT :usus Folder:VOL22:contour.text ======================================================================================== {$L- LEVEL_CURVES.LIST} { program by: KEN GAAL (9-21-79) EDWARD J GRUNDLER (AUG 79) Changes made by reviewer: The ranges in SCREENTYPE were correct in this one!!!!! Changed boolean CLEAR_SCREEN to CLR_SCRN (to avoid conflict with procedure CLEARSCREEN). Replaced CHR(31) by RLF. Replaced CHR(29) by CEOL. Replaced PAGE(OUTPUT) by CLEARSCREEN. Added line DEFINESTRINGS to main program. ---Henry E. Baumgarten } PROGRAM LEVEL_CURVES; USES {$U GRAPH.LIBRARY} SCREEN_STUFF, POST_ENTRY_OF_FUNCTION; TYPE SCREENTYPE = PACKED ARRAY[0..239,0..319] OF BOOLEAN; VAR NEW_FUNCTION,NEW_LIMITS,CLR_SCRN,CONTOUR,SCAN_AGAIN:BOOLEAN; ANS,CH,DIR:CHAR; R,I,XAXIS,YAXIS,ERROR_COUNT,J:INTEGER; X,XL,XR,YL,YU,XRNG,YRNG,XINC,YINC,Y,ZV,XSEARCH,YSEARCH,XPLOT,YPLOT:REAL; ST:SCREENTYPE; PROCEDURE DRAWLINE(VAR R:INTEGER; VAR ST:SCREENTYPE; RW,XSTART,YSTART,DX,DY,INK:INTEGER); EXTERNAL; FUNCTION INPUT_VALUE:REAL; { function by: EDWARD J GRUNDLER } VAR I:INTEGER; INP:STRING; DEC,NEX,EX,NEG,OK:BOOLEAN; EXPO,J,X:REAL; BEGIN REPEAT DEC:=FALSE; EX:=FALSE; READLN(INP); IF LENGTH(INP)=0 THEN INP:='0'; OK:=NOT(INP[1]='E'); IF LENGTH(INP)>1 THEN OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E')); FOR I:=1 TO LENGTH(INP) DO BEGIN OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']); IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']); OK:=OK AND NOT(DEC AND(INP[I]='.')); IF NOT DEC THEN DEC:=(INP[I]='.'); OK:=OK AND NOT(EX AND (INP[I]='E')); IF NOT EX THEN EX:=(INP[I]='E'); IF I>1 THEN OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E')); OK:=OK AND NOT(EX AND (INP[I]='.')) END; OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']); OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9'])); IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL) UNTIL OK; X:=0; DEC:=FALSE; EXPO:=0; NEG:=FALSE; EX:=FALSE; J:=1; FOR I:=1 TO LENGTH(INP) DO BEGIN IF NOT DEC THEN DEC:=(INP[I]='.'); IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-'); IF NOT NEX THEN NEX:=EX AND (INP[I]='-'); IF NOT EX THEN EX:=(INP[I]='E'); IF EX AND NOT(INP[I] IN ['+','-','E']) THEN EXPO:=EXPO*10+ORD(INP[I])-ORD('0'); IF NOT EX THEN BEGIN IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN BEGIN J:=J/10; X:=X+(ORD(INP[I])-ORD('0'))*J END ELSE IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0') END END; IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO); IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X END; PROCEDURE HELP; BEGIN CLEARSCREEN; WRITELN('THIS PROGRAM PLOTS THE ENTERED FUNCTION'); WRITELN; WRITELN('THE OPERATOR IS ASKED FOR THE FOLLOWING INPUTS:'); WRITELN; WRITELN('F(X,Y) = '); WRITELN('THE X,Y LIMITS FOR THE SCREEN DISPLAY'); WRITELN('THE Z VALUE FOR THE LEVEL CURVE'); WRITELN; WRITELN('press RETURN to continue'); READLN; CLEARSCREEN END; PROCEDURE INITIALIZE; BEGIN ERROR_COUNT:=0; GOTOXY(0,0); WRITE(CEOL,CHR(10),CEOL,CHR(10),CEOL,CHR(10)); GOTOXY(0,0); IF NOT NEW_FUNCTION THEN BEGIN WRITE('DO YOU WANT TO ENTER A NEW FUNCTION? '); READ(KEYBOARD,ANS); NEW_FUNCTION:=ANS IN ['Y','y']; WRITELN END; IF NEW_FUNCTION THEN REPEAT WRITE(RLF,'F(X,Y) = ',CEOL); GET_FUNCTION; WRITE(CEOL); IF ERROR THEN CASE ERROR_CODE OF 1:WRITELN('UNBALANCED PARENTHESES',RLF); 2:WRITELN('UNRECOGNIZED SYMBOL',RLF); 3:WRITELN('MULTIPLE DECIMAL POINTS IN A CONSTANT',RLF) END; {OF CASE} NEW_FUNCTION:=FALSE UNTIL NOT ERROR; IF NOT NEW_LIMITS THEN BEGIN WRITE(RLF,'DO YOU WANT NEW LIMITS ON THE DISPLAY? ',CEOL); READ(KEYBOARD,ANS); NEW_LIMITS:=ANS IN ['Y','y']; WRITELN END; IF NEW_LIMITS THEN BEGIN CLR_SCRN:=TRUE; FILLCHAR(ST,SIZEOF(ST),CHR(0)); REPEAT CLEARSCREEN; WRITE('ENTER THE LOWER VALUE OF "X" '); XL:=INPUT_VALUE; WRITE('ENTER THE UPPER VALUE OF "X" '); XR:=INPUT_VALUE UNTIL XL260) or (YNEW<30) or (YNEW>230)); BEG:=(XNEW=XBEG) AND (YNEW=YBEG); BLOWUP:=ABS(FNEW) >= MAXERR; IF BEG or ((PATH=2) and (BOARDER or BLOWUP)) THEN begin (* GOTOXY(10,10); WRITELN('NFXY,NPTS,NFXY/NPTS ',NFXY:6,NPTS:6,NFXY/NPTS:8:5); *) EXIT(PLOT) end; IF NOT (BOARDER OR BLOWUP) THEN begin ST[YNEW,XNEW]:=TRUE; NPTS:=NPTS+1 end; {plot pt.} IF (PATH=1) AND (BOARDER or BLOWUP) THEN begin PATH:=2; KNOWN:=[ ]; XNEW:=XBEG; YNEW:=YBEG end; UNTIL FALSE; END; { procedure PLOT } BEGIN {MAIN PROGRAM} DEFINESTRINGS; FILLCHAR(ST,SIZEOF(ST),CHR(0)); UNITWRITE(3,ST,63); NEW_FUNCTION:=TRUE; NEW_LIMITS:=TRUE; CLR_SCRN:=TRUE; CLEARSCREEN; WRITELN('HELP IS AVAILABLE BY PRESSING "H" OR "?"'); WRITELN; WRITELN('press SPACE to continue'); READ(KEYBOARD,CH); IF CH IN ['H','h','/','?'] THEN HELP; REPEAT INITIALIZE; SET_SCREEN; XINC:=XRNG/200; YINC:=YRNG/200; IF XL*XR <= 0 THEN { DRAW Y AXIS } begin YAXIS:=ROUND(60-XL/XINC); DRAWLINE(R,ST,20,YAXIS,30,0,200,1) end; IF YL*YU <= 0 THEN { DRAW X AXIS } begin XAXIS:=ROUND(30+YU/YINC); DRAWLINE(R,ST,20,60,XAXIS,200,0,1) end; GOTOXY(15,1); WRITE('ENTER Z VALUE FOR LEVEL CURVE '); ZV:=INPUT_VALUE; GOTOXY(0,1); WRITELN(' ':80); GOTOXY(3,1); WRITE('Z = ',ZV:8:3); SCAN_AGAIN:=TRUE; REPEAT SCAN; IF CONTOUR THEN PLOT; GOTOXY(15,2); WRITE('SEARCH FOR ANOTHER CONTOUR WITH Z = ',ZV:8:3,' (Y/N)'); READ(KEYBOARD,CH); SCAN_AGAIN:=CH IN ['Y','y']; GOTOXY(15,2); WRITE(' ':65); UNTIL NOT SCAN_AGAIN; GOTOXY(30,2); WRITE('press RETURN to CONTINUE or "Q" RETURN to QUIT'); READLN(KEYBOARD,CH); UNTIL CH IN ['Q','q']; UNITWRITE(3,ST,7); CLEARSCREEN END. ======================================================================================== DOCUMENT :usus Folder:VOL22:curve_fit.text ======================================================================================== {$L- CURVE_FIT.LIST} { program by: EDWARD J GRUNDLER Changes made by reviewer: Reversed ranges in type SCREEN. Replaced PAGE(OUTPUT) with CLEARSCREEN. Replaced definitions of RLF and CEOL with those in SCREEN_STUFF. Replaced missing unit EDS_STUFF with REAL_INPUT. ___Henry E. Baumgarten } PROGRAM CURVE_FIT; USES {$U GRAPH.LIBRARY} SCREEN_STUFF, REAL_INPUT; CONST MAXIMUM_POINTS = 50; MAXIMUM_FUNCTIONS = 10; MAX_PLUS_1 = 11; TYPE MATRIX = ARRAY[1..MAXIMUM_FUNCTIONS,1..MAX_PLUS_1] OF REAL; REAL_ARRAY = ARRAY[1..MAXIMUM_POINTS] OF REAL; SCREEN = PACKED ARRAY[0..239,0..319] OF BOOLEAN; VAR ERROR_SUM,SQUARE_SUM:REAL; C,X,Y,YLS,ERROR,ERROR_SQ:REAL_ARRAY; R,NUMB_OF_POINTS,NUMBER_OF_FUNCTIONS:INTEGER; TITLE:STRING; ANSWER,TYPE_FUNCTION,NEW:CHAR; ERROR_FLAG,STARTED:BOOLEAN; A:MATRIX; PROCEDURE DRAWLINE(VAR R:INTEGER; VAR S:SCREEN; RW,XS,YS,DX,DY,INK:INTEGER); EXTERNAL; PROCEDURE QUERY(Q:STRING); BEGIN WRITELN(Q); REPEAT READ(KEYBOARD,ANSWER) UNTIL ANSWER IN ['Y','y','N','n'] END; FUNCTION F(X:REAL;I:INTEGER):REAL; FUNCTION F1:REAL; BEGIN I:=I-1; IF I=0 THEN F1:=1 ELSE F1:=F1*X END; BEGIN {F} CASE TYPE_FUNCTION OF 'P','p':F:=F1; END {OF CASE} END; PROCEDURE DISPLAY; VAR I:INTEGER; XL,XU,YL,YU,XRNG,YRNG,XINC,YINC:REAL; S:SCREEN; PROCEDURE SET_SCREEN; VAR J,XSTART,YSTART:INTEGER; BEGIN {SET_SCREEN} CLEARSCREEN; FILLCHAR(S,SIZEOF(S),CHR(0)); UNITWRITE(3,S,63); FOR J:=0 TO 9 DO DRAWLINE(R,S,20,24,44+J*20,5,0,1); FOR J:=0 TO 10 DO DRAWLINE(R,S,20,39+J*28,229,0,-5,1); GOTOXY(0,4); FOR J:=0 TO 9 DO BEGIN WRITELN(YU-J*YRNG/9:2:2); IF J<>9 THEN WRITELN END; FOR J:=0 TO 10 DO BEGIN GOTOXY(3+7*J,23); WRITE(XL+J*XRNG/10:7:2) END; GOTOXY(0,0); IF ABS(319-XU/XINC)>319 THEN XSTART:=0 ELSE XSTART:=ROUND(319-XU/XINC); IF XSTART IN [24..319] THEN DRAWLINE(R,S,20,XSTART,39,0,190,1); IF ABS(44+YU/YINC)>239 THEN YSTART:=0 ELSE YSTART:=ROUND(44+YU/YINC); IF YSTART IN [40..229] THEN DRAWLINE(R,S,20,24,YSTART,295,0,1) END; {SET_SCREEN} PROCEDURE PLOT_POINTS; VAR XSTART,YSTART,J:INTEGER; BEGIN {PLOT_POINTS} FOR J:=1 TO NUMB_OF_POINTS DO BEGIN XSTART:=319-ROUND((XU-X[J])/XINC); YSTART:=ROUND((YU-Y[J])/YINC)+44; DRAWLINE(R,S,20,XSTART-5,YSTART+5,5,-5,1); DRAWLINE(R,S,20,XSTART-5,YSTART-5,5,5,1) END END; {PLOT_POINTS} PROCEDURE DRAW_CURVE; VAR J,K,YSTART,YSTOP:INTEGER; X1,Y1,X2,Y2:REAL; BEGIN {DRAW_CURVE} FOR J:=39 TO 318 DO BEGIN X1:=XL+(J-39)*XINC; X2:=XL+(J-38)*XINC; Y1:=0; FOR K:=1 TO NUMBER_OF_FUNCTIONS DO Y1:=Y1+C[K]*F(X1,K); Y2:=0; FOR K:=1 TO NUMBER_OF_FUNCTIONS DO Y2:=Y2+C[K]*F(X2,K); IF ABS(44+(YU-Y1)/YINC)>239 THEN YSTART:=0 ELSE YSTART:=ROUND(44+(YU-Y1)/YINC); IF ABS(44+(YU-Y2)/YINC)>239 THEN YSTOP:=0 ELSE YSTOP:=ROUND(44+(YU-Y2)/YINC); IF (YSTART IN [40..229]) AND (YSTOP IN [40..229]) THEN DRAWLINE(R,S,20,J,YSTART,1,YSTOP-YSTART,1) END END; {DRAW_CURVE} BEGIN {DISPLAY} XL:=X[1]; XU:=X[1]; YL:=Y[1]; YU:=Y[1]; FOR I:=2 TO NUMB_OF_POINTS DO BEGIN IF X[I]XU THEN XU:=X[I]; IF Y[I]YU THEN YU:=Y[I] END; IF (XU-XL)=0 THEN BEGIN XL:=XL-0.05; XU:=XU+0.05 END ELSE BEGIN XL:=XL-(XU-XL)/18; XU:=XU+(XU-XL)/19 END; XRNG:=XU-XL; IF (YU-YL)=0 THEN BEGIN YU:=YU+0.045; YL:=YL-0.045 END ELSE BEGIN YL:=YL-(YU-YL)/18; YU:=YU+(YU-YL)/19 END; YRNG:=YU-YL; XINC:=XRNG/280; YINC:=YRNG/180; SET_SCREEN; PLOT_POINTS; DRAW_CURVE; WRITE('press RETURN to continue'); READLN; UNITWRITE(3,S,7) END; {DISPLAY} PROCEDURE OUTPUT_LEAST_SQUARES; VAR I:INTEGER; BEGIN FOR I:=1 TO NUMB_OF_POINTS DO BEGIN IF (I MOD 20)=1 THEN BEGIN CLEARSCREEN; WRITELN(' N X(N) Y(N) Y=L.S.APPROX. ', 'ERR=Y-Y(N) ERR^2'); WRITELN END; WRITELN(I:2,X[I]:15:6,Y[I]:15:6,YLS[I]:15:6,ERROR[I]:15:6, ERROR_SQ[I]:15:6); IF ((I MOD 20)=0) OR (I=NUMB_OF_POINTS) THEN BEGIN WRITE('press RETURN to continue'); IF I=NUMB_OF_POINTS THEN WRITE(' SUMS=',ERROR_SUM:15:6,SQUARE_SUM:15:6); READLN END END END; PROCEDURE LEAST_SQUARES; VAR I,J:INTEGER; BEGIN ERROR_SUM:=0; SQUARE_SUM:=0; FOR I:=1 TO NUMB_OF_POINTS DO BEGIN WRITE('.'); YLS[I]:=0; FOR J:=1 TO NUMBER_OF_FUNCTIONS DO YLS[I]:=YLS[I]+C[J]*F(X[I],J); ERROR[I]:=YLS[I]-Y[I]; ERROR_SQ[I]:=SQR(ERROR[I]); ERROR_SUM:=ERROR_SUM+ERROR[I]; SQUARE_SUM:=SQUARE_SUM+ERROR_SQ[I] END END; PROCEDURE OUTPUT_C; VAR I:INTEGER; BEGIN CLEARSCREEN; WRITELN(TITLE); WRITELN; FOR I:=1 TO NUMBER_OF_FUNCTIONS DO WRITELN('C(',I:2,') = ',C[I]:12:6); WRITELN; WRITELN('press RETURN to continue') END; PROCEDURE GAUSS_SEIDEL; VAR I,J,K:INTEGER; X,ERROR:REAL; BEGIN {GAUSS_SEIDEL} K:=0; REPEAT ERROR:=0; K:=K+1; WRITE('.'); FOR I:=1 TO NUMBER_OF_FUNCTIONS DO BEGIN X:=A[I,NUMBER_OF_FUNCTIONS+1]; FOR J:=1 TO NUMBER_OF_FUNCTIONS DO IF NOT (J=I) THEN X:=X-A[I,J]*C[J]; X:=X/A[I,I]; ERROR:=ERROR+ABS(X-C[I]); C[I]:=X END; IF (K MOD 50)=0 THEN WRITELN UNTIL (ERROR=0) OR (K=150); FOR I:=1 TO NUMBER_OF_FUNCTIONS DO A[I,NUMBER_OF_FUNCTIONS+1]:=C[I] END; {GAUSS_SEIDEL} PROCEDURE ROW_ECHELON(A:MATRIX; ROWS,COLS:INTEGER); TYPE INTEGER_ARRAY = ARRAY[1..MAX_PLUS_1] OF INTEGER; VAR I,J,K:INTEGER; SCALAR:INTEGER_ARRAY; PROCEDURE CLEAR_COL(I,J,N:INTEGER); VAR K,L,M:INTEGER; MULT:REAL; BEGIN {CLEAR_COL} FOR K:=I TO J DO BEGIN IF A[K,N]<>0 THEN BEGIN MULT:=-A[K,N]/A[N,N]; FOR L:=1 TO COLS DO A[K,L]:=A[K,L]+MULT*A[N,L] END END END; {CLEAR_COL} PROCEDURE SWAP_ROWS(I:INTEGER); VAR J,L,M:INTEGER; HOLD,MAX:REAL; BEGIN {SWAP_ROWS} MAX:=ABS(A[I,I]); M:=I; FOR J:=I+1 TO ROWS DO BEGIN IF ABS(A[J,I])>MAX THEN BEGIN MAX:=ABS(A[J,I]); M:=J END END; IF M<>I THEN BEGIN FOR L:=1 TO COLS DO BEGIN HOLD:=A[I,L]; A[I,L]:=A[M,L]; A[M,L]:=HOLD END END END; {SWAP_ROWS} PROCEDURE DIVIDE_ROW(I:INTEGER); VAR M:INTEGER; DIVISOR:REAL; BEGIN {DIVIDE_ROW} DIVISOR:=A[I,I]; FOR M:=1 TO COLS DO A[I,M]:=A[I,M]/DIVISOR END; {DIVIDE_ROW} PROCEDURE UNSCALE; VAR I,J:INTEGER; X:REAL; BEGIN {UNSCALE} FOR J:=1 TO NUMBER_OF_FUNCTIONS+1 DO BEGIN X:=1; FOR I:=1 TO SCALAR[J] DO X:=X*2; FOR I:=1 TO NUMBER_OF_FUNCTIONS DO A[I,J]:=A[I,J]*X END END; {UNSCALE} PROCEDURE SCALE; VAR I,J:INTEGER; X:REAL; BEGIN {SCALE} FOR I:=1 TO NUMBER_OF_FUNCTIONS+1 DO SCALAR[I]:=0; FOR J:=1 TO NUMBER_OF_FUNCTIONS+1 DO BEGIN X:=ABS(A[1,J]); FOR I:=2 TO NUMBER_OF_FUNCTIONS DO IF ABS(A[I,J])>X THEN X:=ABS(A[I,J]); WHILE X>10 DO BEGIN SCALAR[J]:=SCALAR[J]+1; X:=X/2 END; X:=1; FOR I:=1 TO SCALAR[J] DO X:=X*2; FOR I:=1 TO NUMBER_OF_FUNCTIONS DO A[I,J]:=A[I,J]/X END END; {SCALE} BEGIN {ROW_ECHELON} SCALE; FOR I:=1 TO ROWS DO BEGIN WRITE('.'); SWAP_ROWS(I); IF A[I,I]<>0 THEN CLEAR_COL(I+1,ROWS,I) ELSE BEGIN ERROR_FLAG:=TRUE; EXIT(ROW_ECHELON) END END; UNSCALE; FOR I:=ROWS DOWNTO 1 DO BEGIN WRITE('.'); DIVIDE_ROW(I); CLEAR_COL(1,I-1,I) END; FOR I:=1 TO ROWS DO C[I]:=A[I,NUMBER_OF_FUNCTIONS+1]; WRITELN END; {ROW_ECHELON} PROCEDURE B_SOLVE; VAR I,J:INTEGER; BEGIN FOR I:=1 TO NUMBER_OF_FUNCTIONS DO BEGIN WRITE('.'); A[I,NUMBER_OF_FUNCTIONS+1]:=0; FOR J:=1 TO NUMB_OF_POINTS DO A[I,NUMBER_OF_FUNCTIONS+1]:=A[I,NUMBER_OF_FUNCTIONS+1]+F(X[J],I)*Y[J] END; WRITELN END; PROCEDURE A_SOLVE; VAR I,J,K:INTEGER; BEGIN FOR I:=1 TO NUMBER_OF_FUNCTIONS DO BEGIN FOR J:=1 TO NUMBER_OF_FUNCTIONS DO BEGIN WRITE('.'); A[I,J]:=0; FOR K:=1 TO NUMB_OF_POINTS DO A[I,J]:=A[I,J]+F(X[K],I)*F(X[K],J) END; WRITELN END END; PROCEDURE GET_HOW_MANY; BEGIN REPEAT CLEARSCREEN; WRITELN('ENTER THE NUMBER OF FUNCTIONS'); WRITELN; WRITELN('FOR EXAMPLE;'); WRITELN('IF YOU ARE SOLVING FOR A POLYNOMIAL'); WRITELN('ENTER 3 FOR C( 1)+C( 2)X+C( 3)X^2'); REPEAT; WRITE('NUMBER OF FUNCTIONS = '); NUMBER_OF_FUNCTIONS:=ROUND(INPUT_VALUE); IF NUMBER_OF_FUNCTIONS>MAXIMUM_FUNCTIONS THEN WRITE('MAXIMUM IS CURRENTLY ',MAXIMUM_FUNCTIONS,' ') ELSE IF NUMBER_OF_FUNCTIONS>NUMB_OF_POINTS THEN WRITE('ALL FUNCTIONS GREATER THAN ',NUMB_OF_POINTS, ' WOULD EVALUATE TO 0. '); UNTIL NUMBER_OF_FUNCTIONS IN[1..NUMB_OF_POINTS]; WRITE('NUMBER OF FUNCTIONS IS ',NUMBER_OF_FUNCTIONS); QUERY(' -- IS THAT CORRECT') UNTIL ANSWER IN ['Y','y'] END; PROCEDURE VERIFY_DATA; VAR I:INTEGER; PROCEDURE FIX_DATA; VAR X_OR_Y:CHAR; J:INTEGER; BEGIN {FIX_DATA} REPEAT REPEAT WRITELN(RLF,'DO YOU WANT TO CHANGE AN X OR Y VALUE? ',CEOL); READ(KEYBOARD,X_OR_Y) UNTIL X_OR_Y IN ['X','x','Y','y']; REPEAT WRITE(RLF,'WHICH ',X_OR_Y,' DO YOU WANT TO CHANGE? ',CEOL); J:=ROUND(INPUT_VALUE) UNTIL J IN [((I-1) DIV 20*20+1)..I]; WRITE(RLF,'ENTER VALUE FOR ',X_OR_Y,'(',J,') ',CEOL); IF X_OR_Y IN ['X','x'] THEN BEGIN X[J]:=INPUT_VALUE; GOTOXY(2,(J-1) MOD 20+2); WRITE(X[J]:15:3) END ELSE BEGIN Y[J]:=INPUT_VALUE; GOTOXY(17,(J-1) MOD 20+2); WRITE(Y[J]:10:3) END; GOTOXY(0,(I-1) MOD 20+3); QUERY('ARE THERE ANY MORE POINTS TO CHANGE?') UNTIL ANSWER IN ['N','n'] END; {FIX_DATA} BEGIN {VERIFY_DATA} FOR I:=1 TO NUMB_OF_POINTS DO BEGIN IF (I MOD 20)=1 THEN BEGIN CLEARSCREEN; WRITELN(' I X Y'); WRITELN; END; WRITELN(I:2,X[I]:15:3,Y[I]:10:3); IF (I=NUMB_OF_POINTS) OR ((I MOD 20)=0) THEN BEGIN QUERY('ARE ALL OF THE ABOVE DATA CORRECT?'); IF ANSWER IN ['N','n'] THEN FIX_DATA END END END; {VERIFY_DATA} PROCEDURE GET_DATA; VAR I:INTEGER; BEGIN CLEARSCREEN; REPEAT REPEAT WRITE('HOW MANY DATA POINTS ARE THERE? '); NUMB_OF_POINTS:=ROUND(INPUT_VALUE); IF NUMB_OF_POINTS>MAXIMUM_POINTS THEN WRITELN('CURRENT MAXIMUM IS ',MAXIMUM_POINTS,' POINTS') UNTIL NUMB_OF_POINTS IN [1..MAXIMUM_POINTS]; WRITE('NUMBER OF POINTS IS ',NUMB_OF_POINTS); QUERY(' -- IS THAT CORRECT?') UNTIL ANSWER IN ['Y','y']; FOR I:=1 TO NUMB_OF_POINTS DO BEGIN WRITE('ENTER THE VALUE FOR X(',I,') '); X[I]:=INPUT_VALUE; WRITE('ENTER THE VALUE FOR Y(',I,') '); Y[I]:=INPUT_VALUE END END; PROCEDURE NEW_OR_OLD; BEGIN IF STARTED THEN BEGIN CLEARSCREEN; WRITE('do you want to enter N(ew data or use the O(ld data? '); REPEAT READ(KEYBOARD,NEW) UNTIL NEW IN ['N','n','O','o'] END ELSE BEGIN STARTED:=TRUE; NEW:='N' END END; PROCEDURE GET_TYPE; BEGIN CLEARSCREEN; WRITELN('THE TYPE FUNCTIONS AVAILABLE ARE:'); WRITELN; WRITELN('P(olynomial'); WRITELN; WRITELN('PLEASE SELECT'); REPEAT READ(KEYBOARD,TYPE_FUNCTION) UNTIL TYPE_FUNCTION IN ['P','p'] END; PROCEDURE GET_TITLE; BEGIN REPEAT WRITELN('ENTER THE TITLE OF THIS CURVE '); READLN(TITLE); WRITELN(TITLE); QUERY('IS THAT CORRECT?') UNTIL ANSWER IN ['Y','y'] END; PROCEDURE INITIALIZE; BEGIN DEFINESTRINGS; CLEARSCREEN; STARTED:=FALSE; WRITELN('THIS PROGRAM ACCEPTS DATA POINTS, P(X,Y) AS INPUT'); WRITELN('AND GIVES A LEAST SQUARES APPROXIMATION CURVE'); WRITELN('FOR THE DATA.'); WRITELN; WRITELN('SEVERAL OPTIONS WILL BE PRESENTED AT'); WRITELN('APPROPRIATE TIMES. WHEN THESE OPTIONS'); WRITELN('ARE PRESENTED, ENTER ONLY THE UPPER CASE'); WRITELN('LETTER. FOR EXAMPLE: ENTER P FOR'); WRITELN('P(olynomial.'); WRITELN END; BEGIN INITIALIZE; REPEAT ERROR_FLAG:=FALSE; GET_TITLE; GET_TYPE; NEW_OR_OLD; IF NEW IN ['N','n'] THEN BEGIN GET_DATA; VERIFY_DATA END; GET_HOW_MANY; A_SOLVE; B_SOLVE; ROW_ECHELON(A,NUMBER_OF_FUNCTIONS,NUMBER_OF_FUNCTIONS+1); GAUSS_SEIDEL; IF ERROR_FLAG THEN BEGIN WRITELN('THERE IS NO UNIQUE SOLUTION'); WRITELN; WRITELN('press RETURN to continue'); READLN END ELSE BEGIN OUTPUT_C; LEAST_SQUARES; READLN; OUTPUT_LEAST_SQUARES END; DISPLAY; CLEARSCREEN; QUERY('IS THAT THE LAST CURVE FIT?') UNTIL ANSWER IN ['Y','y'] END. ======================================================================================== DOCUMENT :usus Folder:VOL22:distrib.text ======================================================================================== {$S+} {$L-DISTRIB.LIST} PROGRAM DISTRIB; USES {$U GRAPH.LIBRARY} SCREEN_STUFF, POST_ENTRY{ by EDWARD J GRUNDLER}, GRAPHICS, FACTORIAL_STUFF; VAR P:REAL; {probability of success. 1-P is the probability of failure} N:INTEGER; {number of trials} X1:INTEGER; {number of successes, or number of occurences} MU:REAL; { the population mean } SIGMA:REAL; { the population standard deviation } VALUE:REAL; {value returned by INPUT_VALUE} LAST,COMMANDLN:STRING; OLD_XMAX,OLD_XMIN,OLD_YMAX,YMAX,XMAX,XMIN,STEP,XEND,YEND:REAL; HRDCPY:BOOLEAN; I:INTEGER; CH:CHAR; { Changes made by reviewer: Replaced missing unit DGS_STUFF by FACTORIAL_STUFF. This unit provides the functions LNFACTORIAL(X:INTEGER):REAL and LN_COMBINATION(N,X:INTEGER):REAL. Removed three lines X:=0; Y:=0; Z:=0; which seemed to do nothing with undefined variables (may have been defined in DGS_STUFF). Concocted FUNCTION INPUT_VALUE from FUNCTION INPUT_VALUE in UNIT REAL_INPUT (which see). Added real variable, VALUE. Changed CHR(29) to CEOL. Changed PAGE(OUTPUT) to CLEARSCREEN. Added DEFINESTRINGS to PROCEDURE FIRST_TIME. Added last two lines to FIRST_TIME and added forward reference. ---Henry E. Baumgarten} FUNCTION INPUT_VALUE(VAR R:REAL; INP:STRING) : REAL; VAR I,INDEX:INTEGER; DEC,NEX,EX,NEG,OK:BOOLEAN; EXPO,J:REAL; BEGIN INDEX := POS('=',INP); INP := COPY(INP,INDEX+1,LENGTH(INP)-INDEX); REPEAT DEC:=FALSE; EX:=FALSE; IF LENGTH(INP)=0 THEN INP:='0'; OK:=NOT(INP[1]='E'); IF LENGTH(INP)>1 THEN OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E')); FOR I:=1 TO LENGTH(INP) DO BEGIN OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']); IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']); OK:=OK AND NOT(DEC AND(INP[I]='.')); IF NOT DEC THEN DEC:=(INP[I]='.'); OK:=OK AND NOT(EX AND (INP[I]='E')); IF NOT EX THEN EX:=(INP[I]='E'); IF I>1 THEN OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E')); OK:=OK AND NOT(EX AND (INP[I]='.')) END; OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']); OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9'])); IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL) (*****) UNTIL OK; R:=0; DEC:=FALSE; EXPO:=0; NEG:=FALSE; EX:=FALSE; J:=1; FOR I:=1 TO LENGTH(INP) DO BEGIN IF NOT DEC THEN DEC:=(INP[I]='.'); IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-'); IF NOT NEX THEN NEX:=EX AND (INP[I]='-'); IF NOT EX THEN EX:=(INP[I]='E'); IF EX AND NOT(INP[I] IN ['+','-','E']) THEN EXPO:=EXPO*10+ORD(INP[I])-ORD('0'); IF NOT EX THEN BEGIN IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN BEGIN J:=J/10; R:=R+(ORD(INP[I])-ORD('0'))*J END ELSE IF NOT(INP[I] IN ['.','+','-']) THEN R:=R*10+ORD(INP[I])-ORD('0') END END; IF EX AND NEX THEN EXPO:=-EXPO; R:=R*EXP(LN(10)*EXPO); IF NEG THEN R:=-R; INPUT_VALUE := R END; PROCEDURE PREPARE_PLOT; FORWARD; PROCEDURE FIRST_TIME; BEGIN DEFINESTRINGS; CLEARSCREEN; ENTERED_FUNCTION:='0'; LAST:='NONE'; XMIN:=-5; XMAX:=5; YMAX:=0.4; MU:=1; SIGMA:=1; N:=25; P:=0.5; QUIET:=FALSE; SETUP(SCREEN); PSCALE:=6; HRDCPY:=FALSE; OLD_XMAX:=0; OLD_XMIN:=0; OLD_YMAX:=0; CH := 'A'; PREPARE_PLOT; END; PROCEDURE SET_VARIABLE; VAR NAME:STRING; RN:REAL; BEGIN RN:=N; NAME:=COPY(COMMANDLN,1,POS('=',COMMANDLN)-1); IF NAME ='MU' THEN MU := INPUT_VALUE(VALUE,COMMANDLN) ELSE IF NAME ='SIGMA' THEN SIGMA := INPUT_VALUE(VALUE,COMMANDLN) ELSE IF NAME ='P' THEN P := INPUT_VALUE(VALUE,COMMANDLN) ELSE IF NAME ='YMAX' THEN YMAX := INPUT_VALUE(VALUE,COMMANDLN) ELSE IF NAME ='XMAX' THEN XMAX := INPUT_VALUE(VALUE,COMMANDLN) ELSE IF NAME ='XMIN' THEN XMIN := INPUT_VALUE(VALUE,COMMANDLN) ELSE IF NAME ='PSCALE' THEN PSCALE := INPUT_VALUE(VALUE,COMMANDLN) ELSE IF NAME ='N' THEN RN := INPUT_VALUE(VALUE,COMMANDLN) ELSE EXIT(SET_VARIABLE); N:=ROUND(RN); WRITE(NAME,' = ',VALUE:7:4,' ',CEOL); IF SIGMA <= 0.0 THEN WRITE('INVALID ENTRY FOR SIGMA. SIGMA MUST BE > 0.0', CEOL); IF (P<0.0) OR (P>1.0) THEN WRITE('P MUST BE IN THE RANGE 0.0 TO 1.0',CEOL); END; PROCEDURE HELP; PROCEDURE FINISH_HELP; BEGIN WRITELN;WRITE('press "RETURN" to continue'); READLN; CLEARSCREEN; NEXT_FRAME(SCREEN,NO_CLEAR,ALL,ALL,NOT_DONE); END; BEGIN {HELP} NEXT_FRAME(SCREEN,NO_CLEAR,OFF,ALL,NOT_DONE); CLEARSCREEN; WRITELN('The following commands are available to the user when prompted:'); WRITELN;WRITELN('NORMAL for a normal distribution plot'); WRITELN('BINOMIAL for a binomial distribution'); WRITELN('POISSON for a poisson distribution'); WRITELN('ALL or COMPARE for a comparison of all three distributions'); WRITELN('SAME to plot another curve of the same type as before'); WRITELN;WRITELN('CLEARSCREEN to erase any plot on the screen'); WRITELN('HARDCOPY if the plotter is to draw the plot as well as the screen'); WRITELN('VALUE to print the value of the variables'); WRITELN('QUIT or DONE to leave the program'); WRITELN;WRITELN;WRITELN('The first letter of the command is sufficient' ,' for every one of the '); WRITELN('above commands with the exception of COMPARE {use A}'); WRITELN('Follow each command with a "RETURN"'); WRITELN;WRITELN('You may alter the value of the variables by entering the', ' following:'); WRITELN('The name of the variable followed by an = then the new value'); WRITELN('ie. XMAX=25 "RETURN"'); FINISH_HELP; END; FUNCTION POISSON(X:INTEGER; MU:REAL):REAL; VAR TEMP:REAL; BEGIN IF MU=0 THEN BEGIN POISSON:=0; EXIT(POISSON); END; TEMP:= -MU+X*LN(MU)-LN_FACTORIAL(X); IF TEMP>87.4 THEN POISSON:=1.0E37 ELSE POISSON:=EXP(TEMP); END; FUNCTION NORMAL(X,MU,SIGMA:REAL):REAL; VAR TEMP:REAL; BEGIN TEMP:=-SQR(X-MU)/(2.0*SQR(SIGMA)); IF TEMP < -20.0 THEN NORMAL:=0.0 ELSE NORMAL:=1/(SIGMA*SQRT(8.0*ATAN(1.0){2PI}))*EXP(TEMP) END; FUNCTION BINOMIAL(N,X:INTEGER; P:REAL):REAL; VAR TEMP:REAL; BEGIN IF (P=0.0) OR (P=1.0) THEN BEGIN BINOMIAL:=0.0; EXIT(BINOMIAL) END; TEMP:=LN_COMBINATION(N,X)+X*LN(P)+(N-X)*LN(1-P); IF TEMP>87.4 THEN BINOMIAL:=1.0E37 ELSE BINOMIAL:=EXP(TEMP); END; PROCEDURE DRAW_AXIS; VAR I,XTEMP:INTEGER; BEGIN FOR I:=0 TO 8 DO BEGIN GOTOXY(0,4+2*I); WRITE(YMAX-YMAX/9*I:6:4) END; PICTURE(49,229,270,0,1); XTEMP:=ROUND(-XMIN*270/(XMAX-XMIN)+50); IF (XTEMP<320) AND (XTEMP>49) THEN PICTURE(XTEMP,29,0,200,1); END; PROCEDURE PREPARE_PLOT; PROCEDURE DRAW_PLOT(FUNCTN:STRING); PROCEDURE PLOT_IT(TYPE_OF_PLOT:STRING); VAR YTEMP:INTEGER; XTEMP:INTEGER; CH:CHAR; PROCEDURE GET_POINT; FUNCTION IN_RNG(X:REAL):INTEGER; BEGIN IF X>32767.0 THEN X:=32767.0; IF X<-32767 THEN X:=-32767; IN_RNG:=ROUND(X) END; BEGIN {GET_POINT} CASE CH OF 'P' : YEND:=POISSON(ROUND(XEND),MU); 'B' : YEND:=BINOMIAL(N,ROUND(XEND),P); 'N' : YEND:=NORMAL(XEND,MU,SIGMA); END; XTEMP:=IN_RNG(270*(XEND-XMIN)/(XMAX-XMIN)+49); YTEMP:=229-IN_RNG(200.0/YMAX*YEND) END; BEGIN {PLOT_IT} CH:=TYPE_OF_PLOT[1]; GET_POINT; DRAW(XTEMP,YTEMP,UP); WHILE XEND<=XMAX DO BEGIN XEND:=XEND+STEP; GET_POINT; GOTOXY(0,3); DRAW(XTEMP,YTEMP,DOWN); IF ESCAPE_PLOT THEN EXIT(PREPARE_PLOT) END END; BEGIN{DRAW_PLOT} IF (LAST='NONE') OR (COMMANDLN='') THEN EXIT(DRAW_PLOT); CH:=FUNCTN[1]; IF NOT((OLD_XMAX=XMAX) AND (OLD_XMIN=XMIN) AND (OLD_YMAX=YMAX)) OR HRDCPY THEN BEGIN IF HRDCPY THEN NEXT_FRAME(BOTH,CLEAR,ALL,ALL,NOT_DONE) ELSE NEXT_FRAME(SCREEN,CLEAR,ALL,ALL,NOT_DONE); DRAW_AXIS END; OLD_XMAX:=XMAX; OLD_XMIN:=XMIN; OLD_YMAX:=YMAX; IF CH='N' THEN BEGIN STEP:=(XMAX-XMIN)/270; XEND:=XMIN; END ELSE BEGIN IF (XMAX-XMIN)/270.0 < 1.0 THEN STEP:=1 ELSE STEP:=ROUND((XMAX-XMIN)/270.0); IF XMIN>0.0 THEN XEND:=XMIN ELSE XEND:=0; END; GOTOXY(0,0); WRITE(CEOL); DRAW(XLOC,YLOC,NEW_COLOR); GOTOXY(0,1); WRITE(CEOL); GOTOXY(0,0); WRITELN(' I am plotting a ',FUNCTN,' curve!',CEOL); WRITELN; PLOT_IT(FUNCTN); DRAW(0,ROUND(ABS(239*6/PSCALE)),UP); HRDCPY:=FALSE; LAST:=FUNCTN; END; PROCEDURE ERROR_MESSAGE(ERR_MSSG:STRING); BEGIN GOTOXY(0,1); WRITELN(ERR_MSSG,CEOL); EXIT(PREPARE_PLOT); END; BEGIN{ PREPARE_PLOT} IF XMIN>XMAX THEN ERROR_MESSAGE('XMIN must be < XMAX'); IF SIGMA <= 0.0 THEN ERROR_MESSAGE('SIGMA must be > 0 '); IF (P<0.0) OR (P>1.0) THEN ERROR_MESSAGE('P must be between 0 and 1 inclusive'); IF NOT(MU>0.0) AND (COMMANDLN='POISSON') THEN ERROR_MESSAGE('MU be >= 0 when plotting the POISSON DISTRIBUTION'); ESCAPE_PLOT:=FALSE; IF CH='S' THEN CH:=LAST[1]; CASE CH OF 'C' : BEGIN NEXT_FRAME(SCREEN,CLEAR,ALL,ALL,NOT_DONE); DRAW_AXIS END; 'H' : IF COMMANDLN='HELP' THEN HELP ELSE HRDCPY:=TRUE; 'A' :BEGIN SIGMA:=SQRT(N*P*(1-P)); MU:=N*P; YMAX:=1/(SIGMA*SQRT(8.0*ATAN(1.0){2PI})); XMIN:=MU-3*SIGMA; XMAX:=MU+3*SIGMA; DRAW_PLOT('BINOMIAL'); DRAW_PLOT('NORMAL'); DRAW_PLOT('POISSON'); LAST:='ALL' END; 'B','N','P' : DRAW_PLOT(COMMANDLN); 'V' : BEGIN NEXT_FRAME(SCREEN,NO_CLEAR,OFF,ALL,NOT_DONE); CLEARSCREEN; WRITELN('SIGMA =':20,SIGMA:10:4); WRITELN('MU =':20,MU:10:4); WRITELN('P =':20,P:10:4); WRITELN('N =':20,N:5); WRITELN;WRITELN('XMAX =':20,XMAX:10:4); WRITELN('XMIN =':20,XMIN:10:4); WRITELN('YMAX =':20,YMAX:10:4); WRITELN;WRITELN('PSCALE =':20,PSCALE:10:4); WRITELN;WRITELN;WRITELN('press RETURN to continue'); READLN; CLEARSCREEN; NEXT_FRAME(SCREEN,NO_CLEAR,ALL,ALL,NOT_DONE); END; END END; BEGIN FIRST_TIME; DRAW_AXIS; GOTOXY(0,1); WRITELN('Help is available by entering HELP followed by a "RETURN" at any time'); REPEAT GOTOXY(0,0); COMMANDLN:=''; WRITE('YOUR COMMAND ? ',CEOL); READLN(COMMANDLN); WRITE(CEOL); I:=1; WHILE I<= LENGTH(COMMANDLN) DO BEGIN IF COMMANDLN[I] = ' ' THEN BEGIN DELETE(COMMANDLN,I,1); I:=I-1; END; I:=I+1; END; IF LENGTH(COMMANDLN)>0 THEN CH:=COMMANDLN[1]; IF COMMANDLN='COMPARE' THEN COMMANDLN:='ALL'; IF POS('=',COMMANDLN)>0 THEN SET_VARIABLE ELSE PREPARE_PLOT; UNTIL CH IN ['D','Q']; NEXT_FRAME(BOTH,CLEAR,OFF,ALL,DONE); CLEARSCREEN; END. ======================================================================================== DOCUMENT :usus Folder:VOL22:fact_stuff.text ======================================================================================== {This unit is was written by Henry E. Baumgarten to replace a unit, DGS_STUFF, missing in the Grundler submissions. The exact composition of the missing unit is not known; thus, the routines given here could be worse (or better) than those in the original unit. There are several alternative ways of combining these procedures and functions. At present the N_FACTORIAL procedure will be undefined for arguments greater than 32. There is an alternative (probably better), iterative procedure for using long integers to determine n! in R. Clark's, "The UCSD Pascal Handbook." A recursive procedure was used here to avoid copyright problems. This procedure here uses integers for arguments up to 7 and long integers for 8 to 32. Two ways of computing ln(n!) are given, both of which use Stirling's approximation. Stirling's approximation is described in Knuth's "Fundamental Algorithms" (Vol. 1). The function LN_FACTORIAL uses the N_FACTORIAL procedure for integer arguments up to 8 and the Stirling approximation for larger arguments. In the function LX_FACTORIAL the Stirling approximation is also used, but with a real argument. The approximation appears to be fairly good, with most errors in the sixth digit. The function XFACTORIAL is also based on the Stirling approximation and appears to sufficiently accurate for use in calculating the gamma function, gamma(x) = (x-1)!, to 5 or 6 places. . According to Knuth, gamma(1.4616321450) = 0.8856031944. With 2-word reals the calculated gamma = 0.885602. Adding terms to the approximation might improve its accuracy but this was not tested. The binomial coefficents and their uses are also described in Knuth. This unit was assembled in haste for review purposes and has been neither thoroughly tested nor carefully optimized. If an out-of-range argument is used, the routines will return a value of zero (undefined) with F_ERROR set to TRUE and with a F_ERRORCODE set as follows: 1 : argument out of range 2 : argument too close to negative integer 3 : not defined for negative argument} UNIT FACTORIAL_STUFF; {version 1.4 - 04 Jan 82} INTERFACE TYPE LONGTYPE = INTEGER[36]; VAR F_ERROR : BOOLEAN; F_ERRORCODE : INTEGER; PROCEDURE NFACTORIAL(N : INTEGER; VAR NFACT : LONGTYPE); FUNCTION XFACTORIAL(X : REAL) : REAL; FUNCTION LN_FACTORIAL(N : INTEGER): REAL; FUNCTION LX_FACTORIAL(X : REAL): REAL; FUNCTION BINOM_COEFF(N,X : INTEGER): REAL; FUNCTION LN_COMBINATION(N,X : INTEGER): REAL; IMPLEMENTATION CONST LNSQRT2PI = 0.918938533204673; {Values largely from Knuth, Vol. 1} SQRTPI = 1.772453850905516; SQRT2 = 1.414213562373095; FUNCTION LONGTOREAL(LONG : LONGTYPE): REAL; VAR RESULT: LONGTYPE; RL,FRACTION : REAL; I : INTEGER; NEGNO : BOOLEAN; BEGIN NEGNO := FALSE; IF (LONG < 0) THEN BEGIN NEGNO := TRUE; LONG := -LONG END; I := 0; FRACTION := 0; IF (LONG > MAXINT) THEN REPEAT RESULT := LONG DIV 10; FRACTION := FRACTION + PWROFTEN(I)*TRUNC(LONG - RESULT*10); LONG := RESULT; I := I + 1; UNTIL (LONG < MAXINT); RL := TRUNC(LONG)*PWROFTEN(I) + FRACTION; IF NEGNO THEN RL := -RL; LONGTOREAL := RL END; PROCEDURE BLUNDER(N : INTEGER); BEGIN F_ERRORCODE := N; F_ERROR := TRUE END; FUNCTION INFACT(N : INTEGER): INTEGER; {for n <= 7 only} BEGIN F_ERROR := FALSE; IF N>7 THEN BEGIN BLUNDER(1); INFACT := 0 END ELSE IF (N=0) THEN INFACT := 1 ELSE INFACT := N*INFACT(N-1) END; PROCEDURE NFACTORIAL{(N : INTEGER; VAR NFACT : LONGTYPE}; VAR I : INTEGER; BEGIN F_ERROR := FALSE; IF ((N>32) OR (N<0)) THEN BEGIN BLUNDER(1); NFACT := 0 END ELSE IF (N=0) THEN NFACT := 1 ELSE BEGIN IF (N<8) THEN BEGIN NFACT := INFACT(N); EXIT(NFACTORIAL) END ELSE NFACTORIAL(N-1,NFACT); NFACT := N*NFACT END END; FUNCTION XFACTORIAL{(X : REAL): REAL)}; VAR ATEST2,XFACT : REAL; ATEST1,N : INTEGER; FUNCTION FACT(A:REAL; M:INTEGER): REAL; VAR B,BFACT : REAL; BEGIN B := A+M; BFACT := SQRTPI*SQRT2*EXP(LN(B)*(B+0.5)-B+(1-1/(30*B*B))/(12*B)); FOR N := 0 TO M-1 DO BFACT := BFACT/(B-N); FACT := BFACT END; BEGIN F_ERROR := FALSE; IF ((X<=-20.0) OR (X>30.0)) THEN BEGIN BLUNDER(1); XFACT := 0 END ELSE IF (X=0) THEN XFACT := 1 ELSE IF (X>0) THEN XFACT := FACT(X,3) ELSE BEGIN ATEST1 := TRUNC(ABS(X)+0.1); IF (ATEST1>0) THEN BEGIN ATEST2 := ABS(ABS(X)-ATEST1); IF (((ATEST1 < 10) AND (ATEST2 < 0.00001)) OR ((ATEST1 >= 10) AND (ATEST2 < 0.0001))) THEN BEGIN BLUNDER(2); XFACTORIAL := 0; EXIT(XFACTORIAL) END END; XFACT := FACT(X,TRUNC(ABS(X)+4)) END; XFACTORIAL := XFACT END; FUNCTION LXFACTORIAL{(X : REAL): REAL}; VAR B,LNXFACT,LNBFACT : REAL; N : INTEGER; BEGIN F_ERROR := FALSE; IF (X<0) THEN BEGIN BLUNDER(3); LNXFACT := 0 END ELSE IF (X>10000) THEN BEGIN BLUNDER(1); LNXFACT := 0 END ELSE IF (X=0) THEN LNXFACT := 0 ELSE BEGIN B := X+3; LNBFACT := LNSQRT2PI+(LN(B)*(B+0.5))-B+(1-1/(30*B*B))/(12*B); FOR N := 0 TO 2 DO LNBFACT := LNBFACT-LN(B-N); LNXFACT := LNBFACT END; LXFACTORIAL := LNXFACT END; FUNCTION LN_FACTORIAL{(N : INTEGER): REAL}; VAR RFACT : REAL; NFACT : LONGTYPE; BEGIN IF (N<8) THEN LN_FACTORIAL := LN(INFACT(N)) ELSE LN_FACTORIAL := LX_FACTORIAL(N) END; FUNCTION LN_COMBINATION{(N,X : INTEGER): REAL}; BEGIN LN_COMBINATION := LN_FACTORIAL(N)-LN_FACTORIAL(N-X)-LN_FACTORIAL(X) END; FUNCTION BINOM_COEFF{(N,X : INTEGER): REAL}; VAR TEMP : REAL; BEGIN TEMP := LN_COMBINATION(N,X); IF (TEMP > 87.4) THEN BINOM_COEFF := 1.0E37 ELSE BINOM_COEFF := EXP(TEMP) END; END. {of unit} ======================================================================================== DOCUMENT :usus Folder:VOL22:func.text ======================================================================================== {$S+} {$L-PLOT_FUNC.LIST} { program by: EDWARD J GRUNDLER modifications by: KEN GAAL modifications by: DENNIS E GRUNDLER edited by: Henry E. Baumgarten Clifford L. Bettis Changes made in editing and notes: Changed CEOL (clear_to_end_of_line) and RLF (reverse_line_feed) and removed these to the unit SCREEN_STUFF. For use with the Terak the reviewer used Terak emulator code in SCREEN_STUFF. RLF did not appear to function properly in all instances, but the screen display was legible. The orginal version would appear to be acceptable for the Terak in the TK emulator mode. Changed all instances of PAGE(OUTPUT) to CLEARSCREEN, which clears the text but not graphics portion of the screen (required by versions 1.5 and 2.0 from Terak). Changed the Boolean variable CLEAR_SCREEN to CLR_SCREEN. Initialized PSCALE to 6.0. Was not initialized in original, leading on occasion to run-time errors depending on what was pointed to by PSCALE. Hiplot routines could not be checked on the Terak. To test these the external procedures, DRAWLINE and THROTTLE, in the GRAPHICS unit were replaced with the commented-out procedures given there (which should function acceptably but may not be as fast as the assembly language routines provided as intrinsics by Terak) and all UNITWRITE's to unit 3 were commented out. With these revisions the hard copy routines appeared to duplicate the screen output. Note, however, that the plotter pen may hit the stops, and the plots are rather crude by current standards. The routines are intended only for the small, dumb Hiplot, although they could be edited to function with any of the Hiplot series. POST_ENTRY_OF_FUNCTION may be replaced by POST_FIX if the extra features of the latter are desired. Despite assertions in the source program, the reviewers find that undefined values of F(X) ARE plotted (as the last defined value) and error counts are not reported. } PROGRAM FUNC; USES {$U GRAPH.LIBRARY} SCREEN_STUFF,POST_ENTRY_OF_FUNCTION,GRAPHICS; VAR NEW_FUNCTION,NEW_LIMITS,CLR_SCREEN,BREAK,HARDCOPY,TICK_MARKS:BOOLEAN; LF,ANS,CH:CHAR; R,I,XSTART,YSTART,YSTOP,ERROR_COUNT:INTEGER; X,X1,XL,XR,YL,YU,XRNG,YRNG,XINC,YINC,Y1,Y2,YTOP,YBOT,XTICK,YTICK:REAL; DEVICE:UNITTYPE; FIRST_TIME:BOOLEAN; { The modifications that were made by KEN GAAL served to make the number of dots along the X and Y axes equally proportional. These modifications also changed the method of labeling the X and Y axes. The SCREEN had boundaries placed upon it for a more appealing output. } { The modifications made by DENNIS E GRUNDLER were extensive modifications which enhanced the operation of the program considerably. The user may now enter a constant expression when asked for a value (*even pi may be entered*). Many sections of the code were rewritten for clarification. (* several of these modifications were fairly minor *) The major modification was to bind in a unit (GRAPHICS) which allows the user to drive either the PLOTTER or the SCREEN or BOTH devices. The unit gives the programmer more time to concentrate upon the program rather than having to figure out how to make the plot.} FUNCTION INPUT_VALUE(PROMPT:STRING):REAL; VAR SAVED_FUNCTION:STRING; BEGIN SAVED_FUNCTION:=ENTERED_FUNCTION; WRITE(RLF,PROMPT,CEOL); GET_FUNCTION; INPUT_VALUE:=F(0,0,0); ENTERED_FUNCTION:=SAVED_FUNCTION; REPLACE_FUNCTION; END; PROCEDURE HELP; BEGIN CLEARSCREEN; WRITELN('THIS PROGRAM PLOTS THE ENTERED FUNCTION'); WRITELN; WRITELN('THE OPERATOR IS ASKED FOR THE FOLLOWING INPUTS:'); WRITELN; WRITELN('F(X) = '); WRITELN('THE LOWER VALUE OF "X"'); WRITELN('THE UPPER VALUE OF "X"'); WRITELN('THE LOWER VALUE OF "Y"'); WRITELN('THE UPPER VALUE OF "Y"'); WRITELN; WRITELN('IF THE FUNCTION IS EVALUATED AT AN UNDEFINED POINT,'); WRITELN('NOTHING IS PLOTTED'); WRITELN; WRITELN('press RETURN to continue'); READLN; CLEARSCREEN END; PROCEDURE INITIALIZE; FUNCTION QUERY(PROMPT:STRING):BOOLEAN; BEGIN WRITELN(RLF,PROMPT,CEOL); READ(KEYBOARD,ANS); QUERY:=ANS IN ['Y','y']; END; BEGIN {INITIALIZE} ERROR_COUNT:=0; GOTOXY(0,0); WRITE(CEOL,LF,CEOL,LF,CEOL); GOTOXY(0,0); IF NOT NEW_FUNCTION THEN BEGIN NEW_FUNCTION:=QUERY('DO YOU WANT TO ENTER A NEW FUNCTION? '); END; IF NEW_FUNCTION THEN REPEAT WRITE(RLF,'F(X) = ',CEOL); GET_FUNCTION; WRITE(CEOL,LF,CEOL); IF ERROR THEN CASE ERROR_CODE OF 1:WRITELN('UNBALANCED PARENTHESES',RLF); 2:WRITELN('UNRECOGNIZED SYMBOL',RLF); 3:WRITELN('MULTIPLE DECIMAL POINTS IN A CONSTANT',RLF) END; {OF CASE} NEW_FUNCTION:=FALSE UNTIL NOT ERROR; GOTOXY(0,0); HARDCOPY:=QUERY('DO YOU WANT A HARDCOPY? '); IF NOT NEW_LIMITS THEN NEW_LIMITS:=QUERY('DO YOU WANT NEW LIMITS ON THE DISPLAY? '); IF NEW_LIMITS THEN BEGIN CLR_SCREEN:=TRUE; REPEAT CLEARSCREEN; XL:=INPUT_VALUE('ENTER THE LOWER VALUE OF "X" '); XR:=INPUT_VALUE('ENTER THE UPPER VALUE OF "X" ') UNTIL XL0.0; REPEAT YTICK:=INPUT_VALUE('TICKS AT WHAT INTERVAL ALONG Y-AXIS? '); UNTIL YTICK>0.0; END; END; IF NOT CLR_SCREEN THEN CLR_SCREEN:=QUERY('DO YOU WANT THE SCREEN CLEARED? '); END; PROCEDURE SET_SCREEN; VAR XTEMP,YTEMP:INTEGER; TEMP_PSCALE:REAL; BEGIN IF HARDCOPY THEN DEVICE:=BOTH ELSE DEVICE:=SCREEN; IF FIRST_TIME THEN BEGIN TEMP_PSCALE:=PSCALE; SETUP(DEVICE); PSCALE:=TEMP_PSCALE; FIRST_TIME:=FALSE; END ELSE NEXT_FRAME(DEVICE,CLR_SCREEN,ALL,ALL,NOT_DONE); IF CLR_SCREEN THEN BEGIN PICTURE(0,239,319,0,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); PICTURE(319,0,-319,0,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); PICTURE(29,24,201,0,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); PICTURE(230,24,0,200,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); PICTURE(230,224,-200,0,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); PICTURE(30,224,0,-200,DOWN); IF XL*XR <= 0 THEN PICTURE(30+ROUND(-XL/XINC),24,0,200,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); IF YU*YL <= 0 THEN PICTURE(230,224-ROUND(-YL/YINC),-200,0,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); NEW_LIMITS:=FALSE; CLEARSCREEN; IF TICK_MARK THEN BEGIN FOR I:= TRUNC(YU/YTICK) DOWNTO TRUNC(YL/YTICK) DO BEGIN YTEMP:= 24+ROUND((I*YTICK-YL)/YINC); PICTURE(25,YTEMP,5,0,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); GOTOXY(0,24-(YTEMP DIV 10)); WRITE(I*YTICK:2:2); END; FOR I:= TRUNC(XL/XTICK) TO TRUNC(XR/XTICK) DO BEGIN XTEMP:=30+ROUND((I*XTICK-XL)/XINC); PICTURE(XTEMP,229,0,-5,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); GOTOXY((XTEMP DIV 4)-3,23); WRITE(I*XTICK:7:4); END; END ELSE BEGIN FOR I:=0 TO 10 DO PICTURE(25,24+I*20,5,0,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); FOR I:=0 TO 10 DO PICTURE(30+I*20,229,0,-5,DOWN); IF ESCAPE_PLOT THEN EXIT(SET_SCREEN); GOTOXY(0,2); FOR I:=0 TO 10 DO BEGIN WRITELN(YU-I*YRNG/10:2:2); IF I<>10 THEN WRITELN END; FOR I:=0 TO 5 DO BEGIN GOTOXY(2+10*I,23); WRITE(XL+I*XRNG/5:10:5); END END; CLR_SCREEN:=FALSE END; IF HARDCOPY THEN DRAW(XLOC,YLOC,NEW_COLOR); GOTOXY(0,0); WRITELN('F(X) = ',ENTERED_FUNCTION,CEOL); WRITE(CEOL); END; PROCEDURE TABLE; VAR ANS: BOOLEAN; XSTART,DX,X: REAL; J: INTEGER; CH: CHAR; BEGIN ANS:=TRUE; REPEAT GOTOXY(60,0); WRITELN('(X,F(X)) TABLE'); GOTOXY(50,1); WRITELN('enter XSTART and X INCREMENT'); GOTOXY(57,2); XSTART:=INPUT_VALUE('XSTART= '); GOTOXY(57,3); DX:=INPUT_VALUE('X INC = '); GOTOXY(50,1); WRITE(CEOL); GOTOXY(57,2); WRITE(CEOL); GOTOXY(57,3); WRITE(CEOL); GOTOXY(62,1); WRITELN('X',' ':8,'F(X)'); FOR J:=0 TO 20 DO begin GOTOXY(58,J+2); X:=XSTART+J*DX; WRITE(X:10:6,F(X,0,0):10:6) end; GOTOXY(60,0); WRITE(CEOL); GOTOXY(50,0); WRITE('another table? (Y/N)'); READ(KEYBOARD,CH); GOTOXY(50,0); WRITE(CEOL); ANS:=CH IN ['Y','y']; FOR J:=2 TO 23 DO begin GOTOXY(58,J); WRITE(CEOL) end; UNTIL ANS=FALSE; END; FUNCTION BOUNDS(Y:REAL):REAL; BEGIN IF Y>YTOP THEN BOUNDS:=YTOP ELSE BOUNDS:=Y; IF Y0 THEN BEGIN GOTOXY(0,1); WRITE(ERROR_COUNT,' POINT'); IF ERROR_COUNT>1 THEN WRITE('S'); WRITE(' NOT PLOTTED BECAUSE OF EVALUATION ERRORS') END; END; BEGIN {MAIN PROGRAM} PSCALE:=6.0; DEFINESTRINGS; LF:=CHR(10); QUIET:=FALSE; FIRST_TIME:=TRUE; NEW_FUNCTION:=TRUE; NEW_LIMITS:=TRUE; CLR_SCREEN:=TRUE; CLEARSCREEN; WRITELN('HELP IS AVAILABLE BY PRESSING "H" OR "?"'); WRITELN; WRITELN('press SPACE to continue'); READ(KEYBOARD,CH); IF CH IN ['H','h','/','?'] THEN HELP; REPEAT ESCAPE_PLOT:=FALSE; INITIALIZE; SET_SCREEN; PLOT_IT; GOTOXY(0,1); WRITE(CEOL); GOTOXY(30,1); WRITE('do you want a table of (x,F(x))? (Y/N)'); READ(KEYBOARD,CH); GOTOXY(30,1); WRITE(CEOL); IF CH='Y' THEN TABLE; GOTOXY(40,0); WRITE('press RETURN to CONTINUE or "Q" to QUIT'); READ(KEYBOARD,CH) UNTIL CH IN ['Q','q']; NEXT_FRAME(DEVICE,CLEAR,OFF,ALL,DONE); CLEARSCREEN END. ======================================================================================== DOCUMENT :usus Folder:VOL22:graph.doc.text ======================================================================================== Terak Graphics Programs Reviewed by: Henry E. Baumgarten Department of Chemistry University of Nebraska-Lincoln Lincoln, Nebraska 68588-0304 The programs on this diskette were written by Edward J. Grundler, Dennis E. Grundler, and Ken Gaal, apparently sometime in the period, 1978-1980. The programs are intended for use with the Terak LSI-11-based computer and are highly machine-dependent. Unfortunately, documentation for most of these programs is not available, and several of the original units required are missing from the package. The brief description given here was written by the reviewer, whose experience with the Terak has been limited to the three sessions during which he and Clifford E. Bettis (Department of Physics, University of Nebraska-Lincoln) attempted to run the programs on one of the Terak computers in our undergraduate physics laboratory. These Teraks run on version 2.0 of the UCSD system; therefore, everything said here refers to that version. Users of more recent versions should make appropriate changes. We encountered a number of problems (besides those mentioned above) in attempting to test these programs. First, the Terak uses terminal emulators, which are capable of emulating more than one conventional terminal. The Teraks in our physics department are set up with the "Terak terminal emulator" (which appears to be similar in many respects to a VT-52 (or H19) terminal). The original programs were written for a different emulator. Although changing to a different emulator is not difficult (if the code files are available), it does require maintaining a separate system disk just for these programs. Also, the command PAGE(OUTPUT) was used in the original programs to clear the text (but not the graphics) screen. Apparently, this is no longer done, and certainly it did nothing useful in our tests. Therefore, this reviewer decided to remove all terminal-dependent code and place it in a unit called SCREEN_STUFF. Before attempting to compile these programs and units, edit the file SCRN_STUFF to fit your terminal emulator (or terminal), compile it, and place the code file in a library called GRAPH.LIBRARY. A second problem encountered was in the array bounds for the various definitions of a type generally called SCREENTYPE, which is used in calls to the intrinsic DRAWLINE. In the orginal programs this type was defined as a PACKED ARRAY[0..319,0..239] OF BOOLEAN, which is just backwards from the type definition described in our manuals (from version 1.4 on), although even these sources are ambiguous. Since DRAWLINE is one of those intrinsics (written in LSI-11/PDP-11 assembly language) that will write whereever it is directed), the to us unexpected order of subscripts caused the program FUNC to die as soon as DRAWLINE was called. Reversal of the array order (essentially to [Y,X]) corrected this problem. Oddly enough, two of the programs had the "correct" order, causing us to wonder how the submitters managed to get all of the programs to run. All of the programs on this diskette have been edited to the order which worked for us. [In retrospect this reviewer should have placed SCREENTYPE as a global type in SCREEN_STUFF so that it could be changed by users in one convenient location. To do so will require removing the type definition from all of the programs and making certain that all DRAWLINE's use the same TYPE.] Although there was no way of knowing what was in the missing units, the reviewer attempted to assemble, edit, or (as a last resort) write these units using more or less the same algorithms and style employed by the submitters. These units have not been thoroughly tested, and some involve matters with which the reviewer has had little experience. They worked in the limited tests carried out, but almost certainly could be improved upon. The specific units prepared in this way are: REAL_INPUT (based on the FUNCTION INPUT_VALUE, widely used in these programs), PLOTTER (based on the Pascal implementation of DRAWLINE given in the 1.5 manual---on which the Grundlers appear to base their line- drawing routines), FACT_STUFF (based on algorithms in Knuth). In order to use the programs, the following procedure should work. Edit the file, SCRN_STUFF, and put it in the library, GRAPH.LIBRARY. Then edit (if necessary) the units, REAL_INPUT, POST_ENTRY, PLOTTER (must be edited to work with your serial or parallel board or to use REMOUT with the plotter), GRAPHICS, and FACT_STUFF, compile them, and place them in the same library on your system disk. The comment blocks placed in the interface sections of some units have been moved to the beginning of the unit (before the unit declaration) as compilation with them in their original places would waste a lot of library space (anything in the INTERFACE section will be put in the library). Next the individual programs can be edited (if necessary), compiled, and run in the usual fashion. Because of limited access to the Teraks and the problems encountered in testing the programs, it was not possible to test all of the programs. However, all were compiled successfully, and some that could not be tested on the Terak were tested on the reviewer's mongrel LSI-11/2 system, using a DMP2 Hiplot plotter for output (something NOT recommended for the weak in heart). If any (brave? foolhardy?) user wants to try these programs but doesn't have a Terak, here is how it can be done in a quick and dirty fashion. First, set up the plotter so it can be turned off quickly! For any program using the units PLOTTER or GRAPHICS and in which the hard copy option is clearly allowed, the changes are simple. For the former (1) Convert the DRAWLINE call from external to a dummy procedure. Find the line PROCEDURE DRAWLINE(...parameters...); EXTERNAL; and change it to PROCEDURE DRAWLINE(...parameters...); BEGIN END; If the procedure THROTTLE appears as an external procedure comment it out. (A Pascal version of THROTTLE is in one of the units but isn't needed here.) (2) Remove (or comment out) all UNITWRITE's to unit 3 (the Terak screen). (3) If your computer isn't an LSI-11 or PDP-11, you will have to rewrite PLOTTER to use REMOUT to output one char rather than the Pascal version of assembly language provided in PLOTTER. The program POLAR gives very good results with the reviewer's LSI-11/2 and the DMP2 Hiplot. If the programs uses GRAPHICS, you will have to edit graphics following the instructions in the graphics program, recompile, and place the unit in the library. That should be the only required change for most programs. For those programs which do not use either GRAPHICS or PLOTTER, the procedure is more complicated and the results may or may not be satisfactory. However, if you wish, you may do the following. (1) Edit and compile the unit REVIEW which contains DRAWLINE, HOME (the pen), and THROTTLE procedures which are intended for use only with the Grundler-Gaal programs (because the (0,0) point on the plotter corresponds to the (0,239) point on the screen and the DRAWLINE procedure maps the screen coordinates onto the plotter coordinates) and place the unit in GRAPH.LIBRARY. (2) Remove or comment out the definitions of DRAWLINE and THROTTLE as external procedures in the program. (3) Remove or comment out the type definition of SCREENTYPE (it is already in the unit REVIEW). (4) At the beginning of the program add the line INITPLOT and at the end HOME. (5) Either edit the program to compensate for the differences in the resolution between the Terak and the plotter (the resolution of the Terak is 320 in the x-direction, the Hiplot 2000), or edit REVIEW to cause the plot to move 4 or 5 steps rather than 1 for each move in the x, y, or xy directions (this will increase the size of the plot but it will be rather crude). PXMAX and PYMAX should be defined to be either 2000 and 1400 or 319 and 239, depending on your decision. (6) Remove or comment out all UNITWRITE's to unit 3. With caution considerable other code can be eliminated when only the plotter is being used. Note that the output will be rather marginal with some programs and in some will be almost weird. Only the graphics material will appear on the screen; the text (axis labels, for example) will appear on the terminal, and the plots may appear crude by plotter standards. All sorts of lines that you wouldn't use with a plotter but might with a terminal will appear (if you haven't deleted the code), and things will seem incrediby slow. However, the program IVP gave fairly good results after a thorough editing. Space does not permit including the edited version on this diskette. Comments on individual programs follow. POST_ENTRY. This is such a potentially useful unit that it is documented separately as well as within the unit. Depending on the decision of the editor of the library, it may appear on a different diskette from the rest of the programs and units. The unit is used for the entry of functions in algebraic (infix) form as strings from the terminal and for the evaluation of the entered function (in postfix form). An excellent unit. REAL_INPUT. The purpose of this unit is to facilitate the entering of real numbers as strings from the terminal. It appears to work quite well and should be useful in any application in which a string (terminated with a carriage return) is acceptable. It does accept scientific format and handles most (but not all) improper entries without killing the system. SCRN_STUFF. Screen control units for most of the programs on this diskette. This unit should be edited for your terminal or terminal emulator, compiled and put in GRAPH.LIBRARY before compiling most of the other units. PLOTTER. A simple line drawing unit of the type used in the Grundler programs, all of which appear to be based on the Pascal implementation of DRAWLINE described in the version 1.5 manual. It is intended for the dumb Hiplots but could (with care) be rewritten for the smart Hiplots or other plotters. GRAPHICS. Apparently the final unit in a chain of development in which the original PLOTTER unit was one link. This unit provides line drawing procedures of several sorts for both the Terak graphics terminal and the DMP2 Hiplot plotter. The unit is fairly well documented within the unit. If you are trying to adapt these program to some other graphics device and are not familiar with the Terak, reading this unit will help. If you want to use the Hiplot but not the Terak graphics parts, instructions are given in the unit for removing the Terak stuff. In the opinion of the reviewer this unit contained one serious error at the very end of the unit and some strange code in the middle. Using the unit as received, the program DISTRIB could not plot properly with PSCALE set any value other than 6.0. When the last line of code in GRAPHICS was changed from PICTURE(ROUND(PLOT_XLOC/PSCALE),239-ROUND(PLOT_YLOC/PSCALE), XEND- ROUND(PLOT_XLOC/PSCALE),YEND-239-ROUND(PLOT_YLOC/PSCALE)),PEN); to that in this package, the program worked properly. This was discovered very late in the review. Hopefully the change will not foul up something else. The strange code is found in procedure PLOT (in GRAPHICS) and is labeled CORRECTION FOR STEPPER MOTOR SCALING. One would assume that this was used to correct for mechanical differences in stepper motors in the x- and y-directions. However, when the reviewer removed this code entirely, he could discern no difference in the plots, and he was concerned about the failure to initialize the variables PLOT_XSTRT and PLOT_YSTRT, which appear no where else in the unit. The code was left in---perhaps some more knowledgeable user can figure out why it is there. FACT_STUFF. This unit contains several procedures or functions for calculating n! and x! and their natural logarithms as well as related functions required by the program DISTRIB. Documentation appears within the unit. This or some similar unit should be of general interest to persons needing factorials for various purposes, e.g., calculating the gamma function or doing statistical calculations. FUNC. This program calculates and plots functions y = F(x) entered from the terminal. The program is interactive and fairly simple to run. It gave good results on the Terak during our tests. The Hiplot output was fairly crude and better results could be achieved using POST_ENTRY with other plotting routines. A potentially useful program for teaching purposes. POLAR. This program calculates and plots functions r = F(theta) entered from the console as r = F(x). The program is interactive; however, the functions of some of the entries are not defined on the screen. Thus, you will have to experiment with SCALE and UNIT_SCALE to determine their effect on your plots. Choosing SCALE too large will cause the plot to move outside the boundaries on the screen and can jamb the plotter pen against the rail, something to be avoided. Therefore, do not use the default scale value: begin with a scale of 0.1 or 0.2. Some good functions to begin with are: (1) a limacon of Pascal, r = 4*cos(x)+3 for x = 0 to 6.28, scale = 0.2; (2) r = x for x = 0 to 25.12, scale = 0.05; (3) r = 8*(cos(3*x)), scale = 0.2; (4) r = 3*sqrt(1/x) for x = 0.1 to 18.8496, scale = 0.2; (5) r = r*sin(x)/x for x = - 3.1416 to 3.1416, scale = 0.2. Worked well with both the Terak and the DMP2 Hiplot. DISTRIB. This program plots normal, binomial, and Poisson distributions or all of these for various entered values of sigma (standard deviation), p (probability), n (number of trials), and mu (mean). The program is interactive but not particularly informative. You have to understand what you are doing to use this program. Furthermore, the program sat indefinitely waiting for the user to be clever enough to type an "A" to get things started. Therefore, the program was slightly revised to eliminate that requirement. Tested only on the Hiplot, where the reviewer found the plots to be rather crude. One unit required for this procedure was missing; thus, a substitute was prepared (the INPUT_VALUE function). Whether this substitute is adequate is not known; however, the program appears to function with the substitute. SINES. Plots two sine waves on the screen, sin(x) plus a*sin(b*x+c)+d. Easy to use. Worked very well on the Terak. The reviewer made the mistake of trying this one on the Hiplot using REVIEW. This is definitely not recommended. The two plots are made simultaneously, one with solid and the other with dashed lines. On the screen this is fine, but with the plotter it is very, very slow, and the plotter jumps back and forth between the two curve protesting loudly. HISTOGRAM. Tested only with the Hiplot. This program plots histograms of data entered from the console of from a file. The data file used by the reviewer is on the diskette under the name HISTOGRAM.DATA. This program is fairly interactive, but you will have to hang in there insisting on getting the data plotted the way you want it, because the program tries to change things the way it wants. The number of histogram bars that can be plotted is limited to 22, although presumably this could be changed by editing. This program is probably all right on the Terak where changes can be made fairly rapidly, and perhaps on experimenting with the input parameters the program would be found to be more flexible than it appears to the reviewer. CURVE_FIT. A program to fit data to a polynomial and plot the resulting function. Was compiled but not tested. Apparently this was the first part of a planned general program for fitting data to several types of functions. CONTOUR. Apparently this program plots the intersection of a plane parallel to the xy plane with a surface defined by z = F(x,y). The user-program interface is not quite as good as in some of the other programs; therefore, you will have to experiment with the various input parameters. Tested only on the Hiplot using REVIEW, using as the surface a sphere impaled on the z-axis. The program appears to be quite clever as an appropriate intersection is sought and the contour line is plotted. It coped very well with the lower half of the sphere but couldn't handle the upper surface. TRIANGLE. This program accept as input a partial definition of a triangle (e.g., the length of one side and the two angles at the ends of that side), then computes the remaining sides and angles and plots the resultant triangle. Compiled but not tested. TRAVERSE. According a colleague in the Department of Civil Engineering, this is a program for surveyors. It accepts the usual input for calculating traverses, computes areas, angles, makes corrections, etc. Compiled but not tested. IVP. This program accepts a differential equation of the type y' = F(x,y) and appropriate boundary conditions, y(X0) = y0. It then "solves" the differential equation using either the Euler method or a fourth-order Runge- Kutta technique. If this doesn't mean anything to you, either this program is not for you or you will have do some reading elsewhere (Conte and de Boor, "Elementary Numerical Analysis, Chapter 8, give FORTRAN versions which should be easy to translate into Pascal if you would like alternative procedures, and the Runge-Kutta method was described briefly in Micro, No. 46, p. 13ff (1982) along with a BASIC program). The numerical solution by either or both methods may be plotted (along with the analytical solution if that is known to you so that it can be entered) on the screen. The program worked very well on the Terak and when adapted to the Hiplot. The tic marks on the axes are arbitrarily placed at intervals of 1/10th of the axis length. Therefore, the plots will look best if you choose x and y limits accordingly. The review edited his copy to turn of the TABLE_OPTION toggle (set it FALSE in INITIALIZE) because it really slows down the plot unless you need to see the actual calculated values. To try the program you can use the default example, the examples in Conte and de Boor, make up your own, or use some simple differential equation such as y' = cos(X) for y(0) = 2. ======================================================================================== DOCUMENT :usus Folder:VOL22:graphics.text ======================================================================================== { Provided in this unit are the necessary routines to drive both the graphics for the "TERAK" CONSOLE: and the "HOUSTON INSTRUMENT DIGITAL PLOTTER". The user of these routines needn't worry about how to lay out a SCREEN ARRAY or how to talk directly to the PLOTTER. To use this graphical unit the user must call PROCEDURE SETUP(DEVICE); where device is one of the following: SCREEN,BOTH, or PLOTTER. This is necessary since this routine initializes variables only accessable to this unit. PROCEDURE NEXT_FRAME(DEVICE,CLEARSCREEN,GRAFICS,TXT,FINISHED); is the procedure to use whenever you have finished the last plot and you wish to make another plot. The DEVICE is the same as called for by PROCEDURE SETUP. CLEARSCREEN is a BOOLEAN variable which allows the user to specify that the screen is to be cleared if it was used; or if the plotter was used it indicates that a new sheet of paper has been inserted. The user may use CLEAR or NO_CLEAR if desired. GRAFICS and TXT are parameters that specify which sections of the screen are to be devoted to either GRAPHICS or TEXT (* above you will find the options under: SECTIONS_OF_SCREEN*) The SCREEN can be turned on in the following modes: 0: OFF (all three sections); 1: BOTTOM (only the bottom section on); 2: MIDDLE (only the middle section on); 3: LOW (the bottom and middle sections on); 4: TOP (only the top section on); 5: SPLIT (the top and bottom sections on); 6: HIGH (the top and middle sections on); 7: ALL (all three sections on); FINISHED is a BOOLEAN variable indicating that the user has finished with the plotting. This unit then turns the graphics off if used and it also returns the PLOTTER'S pen to the lower left corner. The user may choose to use DONE and NOT_DONE as the parameter value. PROCEDURE PICTURE(XSTART,YSTART,DX,DY,PEN); is the routine to use if one wants to specify the beginning coordinate and the change in each of the X and Y directions. The pen can take on the values 0 through 4. The top two rows of constants can be used as the parameter for the pen. If PEN=4 nothing will be drawn on either the screen or the PLOTTER; however, if the SCREEN was being used the unit will return the distance to the nearest line along the path that would have been drawn. If PEN=3 the PLOTTER will draw dashed lines while the screen will draw white dots where blacks ones existed and visa-versa. PROCEDURE DRAW(XEND,YEND,PEN); provides all of the same functions as PROCEDURE PICTURE; the major difference lies in the fact that the old ending location is used as the starting point and the line is drawn to the user specified location. The present graphic's cursor is always available to the user as the point(XLOC,YLOC). (*this is immune to changes to these variables*) If the user presses the ESCape key during the plot the ESCAPE_PLOT variable will be set to TRUE. If this happens the user must set it to false or call PROCEDURE SETUP again; otherwise, nothing will be plotted. PSCALE is a variable that is used to adjust the size of the plot on the plotter. The default value is 6. 6 is the number which gives you a full size plot using the same numbers as you would for the screen. QUIET is a BOOLEAN variable that is used to tell the UNIT GRAPHICS that it is not to output messages (*supposedly the user doesn't want any messages or they are writing there own*). SET_PEN is a BOOLEAN variable that indicates that the user should print a message indicating that the plotter's pen should be positioned. Changes made in editing: The array bounds for SCREENTYPE were reversed. The current Terak DRAWLINE intrinsic expects to receive its screen array in the form, SCREEN[Y,X]. Revised the procedure DRAW to make PSCALE operate properly. Note that it should be possible to use these routines with any computer and a dumb Hiplot plotter by the following procedures. Comment out all UNITWRITE's to UNIT 3 (Terak screen). Convert PROCEDURE DRAWLINE from an external to a dummy procedure of the form BEGIN END; Replace the external PROCEDURE THROTTLE with any procedure that will produce a delay for pen changes (from up to down and vice versa). This could involve a software loop or a line- time clock routine where this is possible. See the THROTTLE procedure in the units PLOTTER and REVIEW for a example that works with LSI-11's. Note that REMINOUT is used for the Hiplot. This could be easily changed, if desired. See PLOTTER and REVIEW. ---Henry E. Baumgarten Clifford L. Bettis } {$S+} {$L-GRAPHICS.LIST} UNIT GRAPHICS; INTERFACE { unit by: DENNIS E GRUNDLER based primarily upon UNIT PLOTTER by: EDWARD J GRUNDLER } CONST UP=0; DOWN=1; NEW_COLOR=2; DASHES=3; NO_COLOR=4; NONE=0; WHITE=1; BLACK=2; REVERSE=3; RADAR=4; CLEAR=TRUE; NO_CLEAR=FALSE; DONE=TRUE; NOT_DONE=FALSE; TYPE SECTION_OF_SCREEN = (OFF,BOTTOM,MIDDLE,LOW,TOP,SPLIT,HIGH,ALL); UNITTYPE = (SCREEN,BOTH,PLOTTER); PENTYPE = 0..4; VAR ESCAPE_PLOT,QUIET,SET_PEN:BOOLEAN; RANGE,XLOC,YLOC:INTEGER; PSCALE:REAL; PEN:PENTYPE; PROCEDURE PICTURE(XSTART,YSTART,DX,DY:INTEGER; PEN:PENTYPE); PROCEDURE DRAW(XEND,YEND:INTEGER; PEN:PENTYPE); PROCEDURE SETUP(DEVICE:UNITTYPE); PROCEDURE NEXT_FRAME(DEVICE:UNITTYPE; CLEARSCREEN:BOOLEAN; GRAFICS,TXT: SECTION_OF_SCREEN; FINISHED:BOOLEAN); IMPLEMENTATION TYPE SCREENTYPE = PACKED ARRAY [0..239,0..319] OF BOOLEAN; VAR PLOT_XLOC,PLOT_YLOC,PLOT_XSTRT,PLOT_YSTRT:INTEGER; OLDPEN:PENTYPE; S:SCREENTYPE; CURRENT_DEVICE:UNITTYPE; PROCEDURE THROTTLE(TICKS:INTEGER); EXTERNAL; PROCEDURE DRAWLINE(VAR RANGE:INTEGER; VAR S:SCREENTYPE; ROWWIDTH, XSTART,YSTART,DELTAX,DELTAY:INTEGER; INKPEN:PENTYPE); EXTERNAL; PROCEDURE SETUP; VAR OUT:STRING[3]; BEGIN ESCAPE_PLOT:=FALSE; OLDPEN:=UP; OUT:='y ';{ lift pen } UNITWRITE(8,OUT,3,,1); FILLCHAR(S,SIZEOF(S),0); IF DEVICE IN [SCREEN,BOTH] THEN UNITWRITE(3,S,63); PLOT_XLOC:=0; PLOT_YLOC:=0; SET_PEN:=(DEVICE IN [PLOTTER,BOTH])AND QUIET; IF (DEVICE IN [PLOTTER,BOTH]) AND NOT(QUIET) THEN BEGIN GOTOXY(0,1); WRITE('Position PLOTTER''S pen to the LOWER LEFT CORNER!!', ' press RETURN to continue.'); READLN; END; PSCALE:=6.0; CURRENT_DEVICE:=DEVICE; END; PROCEDURE PLOT(PEN:PENTYPE;PLOT_XEND,PLOT_YEND:INTEGER);FORWARD; PROCEDURE NEXT_FRAME; BEGIN IF CURRENT_DEVICE=SCREEN THEN BEGIN XLOC:=0; YLOC:=239; PLOT_XLOC:=0; PLOT_YLOC:=0 END; IF FINISHED THEN BEGIN IF CLEARSCREEN THEN BEGIN FILLCHAR(S,SIZEOF(S),0); UNITWRITE(3,S,7); END; IF CURRENT_DEVICE IN [PLOTTER,BOTH] THEN PLOT(UP,0,0); EXIT(NEXT_FRAME); END; IF DEVICE IN [SCREEN,BOTH] THEN BEGIN UNITWRITE(3,S,8*ORD(GRAFICS)+ORD(TXT)); IF CLEARSCREEN THEN FILLCHAR(S,SIZEOF(S),0); END; SET_PEN:=(CURRENT_DEVICE=SCREEN) AND (DEVICE IN [PLOTTER,BOTH]) AND QUIET; IF DEVICE IN [PLOTTER,BOTH] THEN BEGIN IF CURRENT_DEVICE=SCREEN THEN IF NOT(QUIET) THEN BEGIN GOTOXY(0,0); WRITELN('Position the PLOTTER''S pen to the lower left corner!'); WRITE('press RETURN to continue'); READLN; END ELSE ELSE PLOT(UP,0,0); END; CURRENT_DEVICE:=DEVICE; END; PROCEDURE PLOT; CONST X_SCALE = 32767; {PLOTTER S/N 7919-9} Y_SCALE = 100; {PLOTTER S/N 7919-9} VAR XINC,YINC1,YINC3,MOVE,DX,DY,X_CORR,Y_CORR:INTEGER; OUT:ARRAY[1..3] OF CHAR; UP_DOWN:BOOLEAN; SAVE_PEN:PENTYPE; CH:CHAR; PROCEDURE HANDLE_KEYBOARD; BEGIN IF ESCAPE_PLOT THEN EXIT(HANDLE_KEYBOARD); IF CH = CHR(27{ESCape}) THEN BEGIN ESCAPE_PLOT:=TRUE; NEXT_FRAME(CURRENT_DEVICE,NO_CLEAR,OFF,ALL,DONE); EXIT(PICTURE); END; UNITREAD(2,CH,1,,1); END; PROCEDURE CHECK_PEN; BEGIN IF ((PEN=DOWN) AND (OLDPEN=UP)) OR ((PEN=UP) AND (OLDPEN=DOWN)) THEN BEGIN OLDPEN:=PEN; IF PEN = DOWN THEN OUT[1]:='z' ELSE OUT[1]:='y'; UNITWRITE(8,OUT,3,,1); SAVE_PEN:=PEN; IF UP_DOWN THEN PEN:=SAVE_PEN; THROTTLE(10); END END; PROCEDURE PLOTPOINT; BEGIN CASE MOVE OF -4: OUT[1]:='u'; -3: OUT[1]:='t'; -2: OUT[1]:='s'; -1: OUT[1]:='v'; 1: OUT[1]:='r'; 2: OUT[1]:='w'; 3: OUT[1]:='p'; 4: OUT[1]:='q'; END{OF CASE}; UNITWRITE(8,OUT,3,,1) END; PROCEDURE DO_FOR_X; {MORE HORIZONTAL} VAR ERROR,I:INTEGER; BEGIN IF DX=0 THEN EXIT(PLOT); ERROR:=DX DIV 2; I:=DX; REPEAT IF NOT(UNITBUSY(2)) THEN HANDLE_KEYBOARD; MOVE:=XINC; ERROR:=ERROR+DY; IF ERROR>=DX THEN BEGIN ERROR:=ERROR-DX; PLOT_YLOC:=PLOT_YLOC+YINC1; MOVE:=MOVE+YINC3 END; PLOT_XLOC:=PLOT_XLOC+XINC; PLOTPOINT; I:=I-1; IF (I MOD 8 = 0) AND UP_DOWN THEN CHECK_PEN; UNTIL I=0 END; PROCEDURE DO_FOR_Y; {MORE VERTICAL} VAR ERROR,I:INTEGER; BEGIN ERROR:=DY DIV 2; I:=DY; REPEAT IF NOT(UNITBUSY(2)) THEN HANDLE_KEYBOARD; MOVE:=YINC3; ERROR:=ERROR+DX; IF ERROR>=DY THEN BEGIN ERROR:=ERROR-DY; MOVE:=MOVE+XINC; PLOT_XLOC:=PLOT_XLOC+XINC END; PLOT_YLOC:=PLOT_YLOC+YINC1; PLOTPOINT; I:=I-1; IF (I MOD 8 = 0) AND UP_DOWN THEN CHECK_PEN; UNTIL I=0 END; BEGIN {PLOT} IF PEN = NO_COLOR THEN EXIT(PICTURE); UP_DOWN:=PEN = DASHES; IF UP_DOWN THEN PEN:=DOWN; UNITREAD(2,CH,1,,1); OUT[2]:=' '; OUT[3]:=' '; CHECK_PEN; X_CORR:=(PLOT_XLOC-PLOT_XSTRT) DIV X_SCALE; {CORRECTION} PLOT_XLOC:=PLOT_XLOC+X_CORR; {FOR } X_CORR:=(PLOT_XEND-PLOT_XSTRT) DIV X_SCALE; {STEPPER } PLOT_XEND:=PLOT_XEND+X_CORR; {MOTOR } Y_CORR:=(PLOT_YLOC-PLOT_YSTRT) DIV Y_SCALE; {SCALING } PLOT_YLOC:=PLOT_YLOC+Y_CORR; Y_CORR:=(PLOT_YEND-PLOT_YSTRT) DIV Y_SCALE; PLOT_YEND:=PLOT_YEND+Y_CORR; WHILE NOT ((PLOT_XLOC=PLOT_XEND) AND (PLOT_YLOC=PLOT_YEND)) DO BEGIN DX:=PLOT_XEND-PLOT_XLOC; DY:=PLOT_YEND-PLOT_YLOC; IF DX<0 THEN BEGIN XINC:=-1; DX:=-DX END ELSE XINC:=1; IF DY<0 THEN BEGIN YINC1:=-1; YINC3:=-3; DY:=-DY END ELSE BEGIN YINC1:=1; YINC3:=3 END; IF DX>=DY THEN DO_FOR_X ELSE DO_FOR_Y; END; PLOT_XEND:=PLOT_XEND-X_CORR; {REMOVE THE CORRECTIONS} PLOT_XLOC:=PLOT_XEND; XLOC:=ROUND(PLOT_XLOC/PSCALE); PLOT_YEND:=PLOT_YEND-Y_CORR; PLOT_YLOC:=PLOT_YEND; YLOC:=239-ROUND(PLOT_YLOC/PSCALE); UNITCLEAR(2); END {PLOT}; PROCEDURE PICTURE; VAR XSTRT,YSTRT:INTEGER; CH:CHAR; FUNCTION BOUNDS(VALUE,LIMIT:INTEGER):INTEGER; VAR TEMP:INTEGER; BEGIN TEMP:=VALUE; IF VALUE>LIMIT THEN TEMP:=LIMIT; IF VALUE<0 THEN TEMP:=0; BOUNDS:=TEMP; END; FUNCTION DELTA(VALUE,LIMIT:INTEGER):INTEGER; VAR TEMP,TEMP1:INTEGER; FLAG:BOOLEAN; BEGIN FLAG:= LIMIT = 319; IF FLAG THEN TEMP:=VALUE+BOUNDS(XSTART,319) ELSE TEMP:=VALUE+BOUNDS(YSTART,239); TEMP1:=BOUNDS(TEMP,LIMIT); DELTA:=TEMP1-TEMP+VALUE; END; BEGIN {PICTURE} IF ESCAPE_PLOT THEN EXIT(PICTURE); UNITREAD(2,CH,1,,1); IF CURRENT_DEVICE IN [SCREEN,BOTH] THEN BEGIN DRAWLINE(RANGE,S,20,BOUNDS(XSTART,319),BOUNDS(YSTART,239), DELTA(DX,319),DELTA(DY,239),PEN); IF CURRENT_DEVICE=SCREEN THEN BEGIN XLOC:=BOUNDS(XSTART,319)+DELTA(DX,319); YLOC:=BOUNDS(YSTART,239)+DELTA(DY,239); PLOT_XLOC:=ROUND(XLOC*PSCALE); PLOT_YLOC:=ROUND((239-YLOC)*PSCALE) END END; IF NOT(UNITBUSY(2)) THEN ESCAPE_PLOT:= CH = CHR(27); UNITCLEAR(2); IF ESCAPE_PLOT THEN EXIT(PICTURE); IF CURRENT_DEVICE IN [PLOTTER,BOTH] THEN BEGIN IF PEN=NEW_COLOR THEN BEGIN IF NOT(QUIET) THEN BEGIN GOTOXY(0,1); WRITE('You may change colors now! press RETURN to continue'); END; PLOT(UP,PLOT_XLOC,PLOT_YLOC); READLN; PEN:=DOWN; END; XSTRT:=ROUND(PSCALE*BOUNDS(XSTART,ROUND(1914/PSCALE))); YSTRT:=ROUND(1434-PSCALE*BOUNDS(YSTART,ROUND(1434/PSCALE))); IF NOT(XSTRT = PLOT_XLOC) OR NOT(YSTRT = PLOT_YLOC) THEN PLOT(UP,XSTRT,YSTRT); IF NOT((DX=0) AND (DY=0)) THEN PLOT(PEN,ROUND(PSCALE*BOUNDS(XSTART+DX,ROUND(1914/PSCALE))), ROUND(1434-PSCALE*BOUNDS(YSTART+DY,ROUND(1434/PSCALE)))); END; END {PICTURE}; PROCEDURE DRAW; BEGIN PICTURE(ROUND(PLOT_XLOC/PSCALE),ROUND((1434-PLOT_YLOC)/PSCALE),XEND- ROUND(PLOT_XLOC/PSCALE),YEND-ROUND((1434-PLOT_YLOC)/PSCALE),PEN); END; END. {END OF UNIT GRAPHICS} ======================================================================================== DOCUMENT :usus Folder:VOL22:histogram.data ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL22:histogram.text ======================================================================================== {$L- HISTOGRAM.LIST} { program by: EDWARD J GRUNDLER Changes made by reviewer: Reversed ranges in type SCREEN. Replaced PAGE(OUTPUT) by CLEARSCREEN. Replaced missing unit EDS_STUFF by REAL_INPUT. ---Henry E. Baumgarten } PROGRAM HISTOGRAM; USES {$U GRAPH.LIBRARY} SCREEN_STUFF, REAL_INPUT; TYPE OPEN_OR_CLOSED = (OPEN,CLOSED); SCREEN = PACKED ARRAY[0..239,0..319] OF BOOLEAN; VAR CH:CHAR; DATA:FILE OF RECORD NUMBER_OF_POINTS:INTEGER; DATA_POINT:ARRAY[1..255]OF REAL END; {OF RECORD} STARTED,OLD_DATA_AVAILABLE,NEW_DATA_USED:BOOLEAN; MIN,MAX,CLASS_WIDTH,LEFT_START:REAL; NUMB_OF_CLASSES,R:INTEGER; LEFT_END,RIGHT_END:OPEN_OR_CLOSED; CLASS:PACKED ARRAY[1..22] OF INTEGER; CLASS_LIMIT:ARRAY[0..22] OF REAL; PROCEDURE DRAWLINE(VAR R:INTEGER; VAR S:SCREEN; RW,XS,YS,DX,DY,INK:INTEGER); EXTERNAL; PROCEDURE THROTTLE(TICKS:INTEGER); EXTERNAL; PROCEDURE DRAW_HISTOGRAM; VAR I,Y_SCALE,XSTART,XSTOP,Y:INTEGER; S:SCREEN; RNG,LEFT,RIGHT,INC:REAL; BEGIN {DRAW_HISTOGRAM} Y_SCALE:=0; FOR I:=1 TO NUMB_OF_CLASSES DO IF CLASS[I]>Y_SCALE THEN Y_SCALE:=CLASS[I]; WHILE NOT (Y_SCALE IN [9,18,45,90,180,270]) DO Y_SCALE:=Y_SCALE+1; CLEARSCREEN; FILLCHAR(S,SIZEOF(S),CHR(0)); UNITWRITE(3,S,63); GOTOXY(0,4); FOR I:=0 TO 9 DO BEGIN DRAWLINE(R,S,20,24,44+I*20,5,0,1); WRITELN(Y_SCALE DIV 9*(9-I):6); IF I<>9 THEN WRITELN END; RNG:=CLASS_WIDTH*NUMB_OF_CLASSES/18; LEFT:=LEFT_START-RNG; RIGHT:=LEFT+20*RNG; RNG:=RIGHT-LEFT; FOR I:=0 TO 10 DO BEGIN DRAWLINE(R,S,20,39+I*28,224,0,-5,1); GOTOXY(3+7*I,23); WRITE(LEFT+I*RNG/10:7:2) END; GOTOXY(0,0); INC:=RNG/280; DRAWLINE(R,S,20,24,43,0,181,1); DRAWLINE(R,S,20,24,224,295,0,1); FOR I:=1 TO NUMB_OF_CLASSES DO BEGIN XSTART:=319-ROUND((RIGHT-CLASS_LIMIT[I-1])/INC); XSTOP:=319-ROUND((RIGHT-CLASS_LIMIT[I])/INC); Y:=224-ROUND(CLASS[I]/Y_SCALE*180); DRAWLINE(R,S,20,XSTART,224,0,Y-224,1); DRAWLINE(R,S,20,XSTOP,224,0,Y-224,1); DRAWLINE(R,S,20,XSTART,Y,XSTOP-XSTART,0,1) END; WRITE('press RETURN to continue'); READLN; UNITWRITE(3,S,7); CLEARSCREEN END; {DRAW_HISTOGRAM} PROCEDURE WRITE_FREQUENCY_DISTRIBUTION; VAR I:INTEGER; BEGIN {WRITE_FREQUENCY_DISTRIBUTION} CLEARSCREEN; FOR I:=1 TO NUMB_OF_CLASSES DO IF I=1 THEN WRITELN('CLASS',I:3,' LEFT BOUNDRY = ',CLASS_LIMIT[I-1]:7:2, ' RIGHT BOUNDRY = ', CLASS_LIMIT[I]:7:2,' NUMBER IN CLASS = ', CLASS[I]:3) ELSE WRITELN(I:8,CLASS_LIMIT[I-1]:24:2,CLASS_LIMIT[I]:25:2,CLASS[I]:23); WRITELN; WRITE('press RETURN to continue'); READLN END; {WRITE_FREQUENCY_DISTRIBUTION} PROCEDURE SCAN_AND_ASSIGN_TO_CLASSES; VAR I,J:INTEGER; BEGIN {SCAN_AND_ASSIGN_TO_CLASSES} WRITELN; WRITE('SCANNING THE DATA'); CLASS_LIMIT[0]:=LEFT_START; FOR I:=1 TO NUMB_OF_CLASSES DO BEGIN CLASS[I]:=0; CLASS_LIMIT[I]:=CLASS_LIMIT[I-1]+CLASS_WIDTH END; WITH DATA^ DO FOR I:=1 TO NUMBER_OF_POINTS DO BEGIN J:=0; WHILE JCLASS_LIMIT[J-1] THEN CLASS[J]:=CLASS[J]+1 ELSE ELSE IF (DATA_POINT[I]>=CLASS_LIMIT[J-1]) AND (DATA_POINT[I]15 THEN NUMB_OF_CLASSES:=15; COMPUTE_CLASS_WIDTH; WRITE_OUTPUT; ASK_ABOUT_CHANGES END; {SET_UP_CLASSES} PROCEDURE SCAN_FOR_LIMITS; VAR I:INTEGER; BEGIN {SCAN_FOR_LIMITS} WITH DATA^ DO BEGIN MIN:=DATA_POINT[1]; MAX:=MIN; FOR I:=2 TO NUMBER_OF_POINTS DO IF DATA_POINT[I]MAX THEN MAX:=DATA_POINT[I] END END; {SCAN_FOR_LIMITS} PROCEDURE GET_DATA; VAR FLAG:BOOLEAN; CH:CHAR; BEGIN {GET_DATA} FLAG:=FALSE; IF NOT STARTED THEN BEGIN STARTED:=TRUE; {$I-}{TURN OFF I/O CHECKING} RESET(DATA,'HISTOGRAM.DATA'); FLAG:=IORESULT<>0; {$I+}{TURN ON I/O CHECKING} OLD_DATA_AVAILABLE:=NOT FLAG END; IF FLAG THEN REWRITE(DATA,'HISTOGRAM.DATA') ELSE BEGIN WRITE('DO YOU WANT TO USE'); IF OLD_DATA_AVAILABLE THEN BEGIN WRITE(' THE D(iskfile DATA'); IF NEW_DATA_USED THEN WRITE(',') END; IF NEW_DATA_USED THEN WRITE(' THE E(ntered DATA'); WRITE(' OR N(ew DATA? '); REPEAT READ(KEYBOARD,CH); IF OLD_DATA_AVAILABLE AND (CH IN ['D','d']) THEN BEGIN NEW_DATA_USED:=FALSE; SEEK(DATA,0); GET(DATA); CH:=CHR(128) END; IF NEW_DATA_USED AND (CH IN ['E','e']) THEN CH:=CHR(128); IF CH IN ['N','n'] THEN BEGIN FLAG:=TRUE; CH:=CHR(128) END UNTIL CH=CHR(128) END; CLEARSCREEN; IF FLAG THEN WITH DATA^ DO BEGIN NEW_DATA_USED:=TRUE; NUMBER_OF_POINTS:=0; WRITELN('ENTER the DATA as requested'); WRITELN; WRITELN('press ETX in place of RETURN after the LAST entry is made'); WRITELN; WHILE (NUMBER_OF_POINTS<>255) AND NOT EOF DO BEGIN NUMBER_OF_POINTS:=NUMBER_OF_POINTS+1; WRITE('POINT ',NUMBER_OF_POINTS,' = '); DATA_POINT[NUMBER_OF_POINTS]:=INPUT_VALUE END; IF EOF THEN BEGIN RESET(INPUT); IF DATA_POINT[NUMBER_OF_POINTS]=0 THEN BEGIN WRITELN; WRITE('DID YOU INTEND FOR THE LAST POINT TO BE ZERO? '); REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['Y','y','N','n']; IF CH IN ['N','n'] THEN NUMBER_OF_POINTS:=NUMBER_OF_POINTS-1; CH:=CHR(128) END END ELSE BEGIN WRITE('255 POINTS IS THE MAXIMUM'); THROTTLE(180) END END END; {GET_DATA} PROCEDURE INITIALIZE; BEGIN {INITIALIZE} CLEARSCREEN; STARTED:=FALSE; NEW_DATA_USED:=FALSE END; {INITIALIZE} BEGIN {HISTOGRAM} INITIALIZE; REPEAT GET_DATA; SCAN_FOR_LIMITS; SET_UP_CLASSES; SCAN_AND_ASSIGN_TO_CLASSES; WRITE_FREQUENCY_DISTRIBUTION; DRAW_HISTOGRAM; WRITE('IS THAT THE LAST HISTOGRAM? '); REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['Y','y','N','n']; CLEARSCREEN UNTIL CH IN ['Y','y']; SEEK(DATA,0); IF NOT OLD_DATA_AVAILABLE THEN PUT(DATA) ELSE IF NEW_DATA_USED THEN BEGIN WRITELN('DO YOU WANT THE NEW DATA SAVED'); WRITE('IN PLACE OF THE OLD ON THE DISK? '); REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['Y','y','N','n']; IF CH IN ['Y','y'] THEN PUT(DATA) END; CLOSE(DATA,LOCK) END {HISTOGRAM}. ======================================================================================== DOCUMENT :usus Folder:VOL22:ivp.text ======================================================================================== {$L-,S- IVP.LIST} PROGRAM IVP; { written by Ken Gaal, 1-25-80 } { last modified on 2-6-80} { This program obtains numerical solutions to an arbitrary Initial Value Problem (IVP). The user types in the differential equation (DE) dy/dx=f(x,y), the initial conditions (IC) Xo Yo, and various other values used to control the form of the graphical display. The main program IVP consists of 2 procedures: INITIALIZE OPTIONS INITIALIZE assigns nominal values to the DE, IC and other variables. The procedure OPTIONS allows the user to select various options. The PROCEDURES used in this program appear in the code in the following order. Indenting indicates that the procedure is local to the procedure above it. Utility Procedures: GET_FUNCTION (in the unit post_entry_of_function) REPLACE_FUNCTION (in the unit post_entry_of_function) DRAWLINE (an external procedure) CLEAR (clears text on a section of a row) INPUT_FUNC (to type in a function expression) INPUT_CONST (to type in a constant expression) SET_SCREEN (clears and resets xy grid) BOUNDRIES (draws boundries for xy grid) AXES (draws xy axes) LABEL_AXES (prints scale values for xy grid) CONVERT (converts xy from actual to screen pt. values) PRTOK (boolean fuction: true if pt is on screen) TABLE_HEAD (prints heading for xy table) LIST_TABLE (prints x,y or x,y,y-Y table values) Program Structure: INITIALIZE (initializes values of functions and variables) ZAP_AXES (erases or plots xy axes) DESCRIBE_PROGRAM (describes program options) OPTIONS (displays options) ENTER_DE (to enter dy/dx=F(x,y) ) ENTER_IC (to enter Xo,Yo) ENTER_SOLN (to enter Y(x) ) OMIT_SOLN (omits Y(x) ) ENTER_DX (to enter Dx increment value) ENTER_XF (to enter final x value (Xf) ) SCREEN_LIMITS(for xy grid limits) GET_XRANGE (options for xmin,xmax values) GET_YRANGE (options for ymin,ymax values) COMPUTE_YRANGE (computes ymin and ymax) SW_TAB_OPT (displays table_option as ON or OFF) PLOT_SOLN (plots Y(x) vs x ) EULER (Euler soln to IVP) RUNGE (4th order Runge-Kutta soln to IVP) Changes made by reviewer: Removed definitions of RLF and CEOL. Added line DEFINESTRINGS. Replaced PAGE(OUTPUT) with CLEARSCREEN. Reversed ranges in SCREENTYPE. ---Henry E. Baumgarten } USES {$U GRAPH.LIBRARY} SCREEN_STUFF, POST_ENTRY_OF_FUNCTION; { POST_ENTRY was written by Ed Grundler. This unit contains procedures: GET_FUNCTION and REPLACE_FUNCTION; the interface variables are: ENTERED_FUNCTION and ERROR_CODE } CONST RW=20; XLEFT=28; XRIGHT=228; { screen boundries } YTOP=25; YBOT=225; { for x,y graph } TYPE SCREENTYPE=PACKED ARRAY[0..239,0..319] OF BOOLEAN; XSCREEN=0..319; YSCREEN=0..239; XTEXT=0..79; YTEXT=0..23; VAR X0,Y0,XF,DX,XSCALE,YSCALE,YMIN,YMAX,XMIN,XMAX,XRANGE,YRANGE: REAL; Y_AT_BOT,Y_AT_TOP: REAL; L: YSCREEN; R,XSTART,YSTART: INTEGER; S: SCREENTYPE; ESC,LF,KB: CHAR; SOLN,XSTOP,TABLE_OPTION,LISTING_SOLN,LIST_OPTIONS: BOOLEAN; FXY,FX: STRING; XTAB,YTAB: ARRAY[1..17] OF REAL; OPTION_KEYS: SET OF CHAR; PROCEDURE DRAWLINE(VAR RANGE:INTEGER;VAR SCREEN:SCREENTYPE;RW, XSTART,YSTART,DX,DY,INK:INTEGER); EXTERNAL; { Drawline is an external procedure } PROCEDURE CLEAR(ROW:YTEXT; LEFT,RIGHT:XTEXT); VAR COL: XTEXT; BEGIN GOTOXY(LEFT,ROW); IF RIGHT = 79 THEN WRITE(CEOL) ELSE FOR COL:= LEFT TO RIGHT DO WRITE(' '); END; PROCEDURE INPUT_FUNC; BEGIN IF EOF THEN RESET(INPUT); { recovers from accidental etx entry } GET_FUNCTION; IF ERROR THEN BEGIN GOTOXY(10,3); WRITE('***INPUT ERROR***'); GOTOXY(10,4); CASE ERROR_CODE OF 1: WRITELN('UNBALANCED PARENTHESES'); 2: WRITELN('UNRECOGNIZED SYMBOL'); 3: WRITELN('MULTIPLE DEC. PT. IN CONSTANT'); 15: WRITELN('ARGUMENT NOT IN PARENTHESES'); END; GOTOXY(10,6); WRITE('sp bar to re-enter data'); READ(KEYBOARD,KB); FOR L:=3 TO 6 DO CLEAR(L,10,40); END; END; { of procedure input_func } PROCEDURE INPUT_CONST(VAR V:REAL; ROW:YTEXT; LEFT,RIGHT:XTEXT); BEGIN REPEAT CLEAR(ROW,LEFT,RIGHT); GOTOXY(LEFT,ROW); INPUT_FUNC; UNTIL NOT ERROR; V:=F(0,0,0); END; { or procedure input_const } PROCEDURE SET_SCREEN; PROCEDURE BOUNDRIES; { local to procedure set_screen } BEGIN { draw boarders } DRAWLINE(R,S,RW,0,0,319,0,1); { top screen } DRAWLINE(R,S,RW,319,0,0,239,1); { right screen } DRAWLINE(R,S,RW,319,239,-319,0,1); { bottom screen } DRAWLINE(R,S,RW,0,239,0,-239,1); { left screen } DRAWLINE(R,S,RW,XLEFT-1,YTOP,XRIGHT-XLEFT+1,0,1); { top grid } DRAWLINE(R,S,RW,XRIGHT,YTOP,0,YBOT-YTOP,1); { right grid } DRAWLINE(R,S,RW,XRIGHT,YBOT,-(XRIGHT-XLEFT),0,1); { bottom grid } DRAWLINE(R,S,RW,XLEFT,YBOT,0,-(YBOT-YTOP),1); { left grid } END; { of procedure boundries } PROCEDURE AXES; { local to procedure set_screen } BEGIN IF YMIN*YMAX<=0 THEN { draw x axes } DRAWLINE(R,S,RW,XLEFT,YBOT-ROUND(-YMIN*YSCALE),XRIGHT-XLEFT,0,1); IF XMIN*XMAX<=0 THEN { draw y axes } DRAWLINE(R,S,RW,XLEFT+ROUND(-XMIN*XSCALE),YTOP,0,YBOT-YTOP,1); END; { of procedure axes } PROCEDURE LABEL_AXES; { local to procedure set_screen } VAR I: INTEGER; XDIV,YDIV: REAL; BEGIN { put numeric lables on axes } YDIV:=(YBOT-YTOP)/10.0; FOR I:=0 TO 10 DO DRAWLINE(R,S,RW,XLEFT,YTOP+ROUND(YDIV*I),4,0,1); XDIV:=(XRIGHT-XLEFT)/10.0; FOR I:=0 TO 10 DO DRAWLINE(R,S,RW,XLEFT+ROUND(XDIV*I),YBOT,0,-4,1); { the following numeric lable values assume a "200 by 200" graph } GOTOXY(0,2); FOR I:=0 TO 10 DO BEGIN WRITELN(YMAX-I*YRANGE/10:7:3); IF I<>10 THEN WRITELN END; FOR I:=0 TO 5 DO BEGIN GOTOXY(10*I,23); WRITE(XMIN+I*XRANGE/5:10:5); END; END; { of procedure label_axes } BEGIN { procedure set_screen } FILLCHAR(S,9600,CHR(0)); { clear graphics } BOUNDRIES; AXES; LABEL_AXES END; { of procedure set_screen } PROCEDURE CONVERT(X,Y:REAL; VAR XPLOT,YPLOT:INTEGER); BEGIN IF ABS((X-XMIN)*XSCALE) < 32000 THEN XPLOT:=XLEFT+ROUND((X-XMIN)*XSCALE) ELSE XPLOT:=0; { pt will not be plotted } IF (Y > Y_AT_BOT) AND (Y < Y_AT_TOP) THEN YPLOT:=YBOT-ROUND((Y-YMIN)*YSCALE); IF Y <= Y_AT_BOT THEN YPLOT:=239; { below screen values = bot of screen } IF Y >= Y_AT_TOP THEN YPLOT:=0; { above screen values = top of screen } END; { of procedure convert } FUNCTION PRTOK(X1,Y1,X2,Y2:INTEGER):BOOLEAN; BEGIN PRTOK:=(X1 IN [0..319]) AND (X2 IN [0..319]) AND (Y1 IN [0..239]) AND (Y2 IN [0..239]); IF (Y1YBOT) THEN PRTOK:=FALSE; { a check to avoid plotting } IF (Y1>YBOT) AND (Y2'); SOLN:=FALSE END; { of porcedure omit_soln } PROCEDURE ENTER_DX; { local to procedure options } BEGIN CLEAR(1,63,79); GOTOXY(63,1); INPUT_CONST(DX,1,63,79); CLEAR(1,63,79); GOTOXY(63,1); WRITE(DX:8:4); END; { of procedure enter_dx } PROCEDURE ENTER_XF; { local to procedure options } BEGIN CLEAR(0,63,79); GOTOXY(63,0); INPUT_CONST(XF,0,63,79); CLEAR(0,63,79); GOTOXY(63,0); WRITE(XF:8:4); END; { of procedure enter_xf } PROCEDURE SCREEN_LIMITS; { local to procedure options } PROCEDURE GET_XRANGE; { local to procedure screen_limits } BEGIN GOTOXY(60,3); WRITE(' X LIMITS ON GRAPH '); GOTOXY(60,4); WRITE('XMIN=',XMIN:8:3); GOTOXY(60,5); WRITE('XMAX=',XMAX:8:3); GOTOXY(60,6); WRITE('***OPTIONS***'); GOTOXY(60,7); WRITE('*FOR X RANGE*'); GOTOXY(60,9); WRITE('(N) No change'); GOTOXY(60,10); WRITE('(I) Input new values'); GOTOXY(60,11); WRITE('(U) Use Xo Xf values'); REPEAT GOTOXY(60,13); WRITE('type N,I, or U'); READ(KEYBOARD,KB); UNTIL KB IN ['N','I','U','n','i','u']; IF KB IN ['n','i','u'] THEN KB:=CHR(ORD(KB)-32); {to upper case} IF KB <> 'I' THEN FOR L:=3 TO 13 DO CLEAR(L,60,79) ELSE FOR L:=6 TO 13 DO CLEAR(L,60,79); CASE KB OF 'N': EXIT(GET_XRANGE); 'I': BEGIN REPEAT INPUT_CONST(XMIN,4,65,79); INPUT_CONST(XMAX,5,65,79) UNTIL XMAX > XMIN; FOR L:=3 TO 5 DO CLEAR(L,60,79); END; 'U': BEGIN XMIN:=X0; XMAX:=XF END; END; { of case opt } XRANGE:=XMAX-XMIN; XSCALE:=(XRIGHT-XLEFT)/XRANGE; { graphic pts / x units } SET_SCREEN END; { of procedure get_xrange } PROCEDURE GET_YRANGE; { local to procedure screen_limits } VAR X1,Y1,DELX: REAL; PROCEDURE COMPUTE_YRANGE; { local to procedure get_yrange} BEGIN GOTOXY(60,3); WRITE('*computing y range*'); Y1:=F(XMIN,0,0); YMIN:=Y1; YMAX:=Y1; DELX:=1/XSCALE; IF SOLN THEN BEGIN GOTOXY(60,4); WRITE('* using soln Y(x) *'); ENTERED_FUNCTION:=FX; REPLACE_FUNCTION; X1:=XMIN; REPEAT Y1:=F(X1,0,0); IF Y1>YMAX THEN YMAX:=Y1; IF Y1XMAX; END ELSE BEGIN GOTOXY(60,4); WRITE('using DE dy/dx'); ENTERED_FUNCTION:=FXY; REPLACE_FUNCTION; X1:=X0; Y1:=Y0; REPEAT Y1:=Y1+F(X1,Y1,0)*DELX; IF Y1>YMAX THEN YMAX:=Y1; IF Y1XMAX; X1:=X0; Y1:=Y0; REPEAT Y1:=Y1+F(X1,Y1,0)*(-DELX); IF Y1>YMAX THEN YMAX:=Y1; IF Y1 2000 THEN YMAX:=2000; IF YMIN < -2000 THEN YMIN:=-2000; YRANGE:=YMAX-YMIN; IF YRANGE=0 THEN { yrange=0 only if y=constant } BEGIN YMIN:=YMIN-0.5; YMAX:=YMAX+0.5; YRANGE:=1 END ELSE BEGIN YMIN:=YMIN-0.1*YRANGE; YMAX:=YMAX+0.1*YRANGE; YRANGE:=1.2*YRANGE END; FOR L:=3 TO 4 DO CLEAR(L,60,79) END; { of procedure compute_yrange } BEGIN { of procedure get_yrange } GOTOXY(60,3); WRITE('Y LIMITS ON GRAPH '); GOTOXY(60,4); WRITE('YMIN=',YMIN:8:3); GOTOXY(60,5); WRITE('YMAX=',YMAX:8:3); GOTOXY(60,6); WRITE('***OPTIONS***'); GOTOXY(60,7); WRITE('*FOR Y RANGE*'); GOTOXY(60,9); WRITE('(N) No change'); GOTOXY(60,10); WRITE('(I) Input new values'); GOTOXY(60,11); WRITE('(C) Compute values'); REPEAT GOTOXY(60,13); WRITE('type N,I, or C'); READ(KEYBOARD,KB); UNTIL KB IN ['N','I','C','n','i','c']; IF KB IN ['n','i','c'] THEN KB:=CHR(ORD(KB)-32); {to upper case} IF KB <> 'I' THEN FOR L:=3 TO 13 DO CLEAR(L,60,79) ELSE FOR L:=6 TO 13 DO CLEAR(L,60,79); CASE KB OF 'N': EXIT(GET_YRANGE); 'I': BEGIN REPEAT INPUT_CONST(YMIN,4,65,79); INPUT_CONST(YMAX,5,65,79) UNTIL YMAX > YMIN; YRANGE:=YMAX-YMIN; FOR L:=3 TO 5 DO CLEAR(L,60,79); END; 'C': COMPUTE_YRANGE END; YSCALE:=(YBOT-YTOP)/YRANGE; { graphic pts / y units } Y_AT_BOT:=YMIN-(239-YBOT)/YSCALE; { y value at bottom of screen } Y_AT_TOP:=YMAX+YTOP/YSCALE; { y value at top of screen } SET_SCREEN END; { of procedure get_yrange } BEGIN { procedure screen_limits } GET_XRANGE; GET_YRANGE END; { of procedure screen_limits } PROCEDURE SW_TAB_OPT(K: CHAR); { local to procedure options } BEGIN IF K='Y' THEN TABLE_OPTIONS:=NOT TABLE_OPTIONS; GOTOXY(77,14); IF TABLE_OPTIONS THEN WRITE('ON ') ELSE WRITE('OFF'); END; { of procedure sw_tab_opt } PROCEDURE PLOT_SOLN; { local to procedure options } VAR X,XINC: REAL; PX1,PX2,PY1,PY2,I: INTEGER; BEGIN { procedure plot_soln } IF (NOT SOLN) THEN EXIT(PLOT_SOLN); GOTOXY(60,3); WRITE('* plotting Y(x) *'); LISTING_SOLN:=TABLE_OPTION; IF TABLE_OPTION THEN BEGIN GOTOXY(60,4); WRITE(' x Y(x)') END; ENTERED_FUNCTION:=FX; REPLACE_FUNCTION; XINC:=1/XSCALE; X:=XMIN-XINC; REPEAT I:=0; REPEAT I:=I+1; X:=X+XINC; CONVERT(X,F(X,0,0),PX1,PY1); CONVERT(X,F(X+XINC,0,0),PX2,PY2); IF PRTOK(PX1,PY1,PX2,PY2) THEN DRAWLINE(R,S,RW,PX1,PY1,1,PY2-PY1,1); IF TABLE_OPTION THEN BEGIN XTAB[I]:=X; YTAB[I]:=F(X,0,0) END; XSTOP:=X>=XMAX UNTIL (XSTOP) OR (I>=16); IF TABLE_OPTION THEN BEGIN XTAB[I+1]:=X+XINC; YTAB[I+1]:=F(X+XINC,0,0); LIST_TABLE(I+1) END; UNTIL XSTOP; FOR L:=3 TO 4 DO CLEAR(L,60,79); LISTING_SOLN:=FALSE END; { of procedure plot_soln } PROCEDURE EULER; { local to options } VAR X,Y: REAL; DELTAX,DELTAY,XNEW,YNEW,I: INTEGER; BEGIN GOTOXY(57,2); WRITE('**Plotting EULER Soln**'); GOTOXY(57,3); WRITE(' for approx. y values'); ENTERED_FUNCTION:=FXY; REPLACE_FUNCTION; IF TABLE_OPTION THEN TABLE_HEAD; X:=X0; Y:=Y0; REPEAT I:=0; REPEAT I:=I+1; IF TABLE_OPTION THEN BEGIN XTAB[I]:=X; YTAB[I]:=Y END; CONVERT(X,Y,XSTART,YSTART); Y:=Y+F(X,Y,0)*DX; X:=X+DX; CONVERT(X,Y, XNEW,YNEW); DELTAX:=XNEW-XSTART; DELTAY:=YNEW-YSTART; IF PRTOK(XSTART,YSTART,XNEW,YNEW) THEN DRAWLINE(R,S,RW,XSTART,YSTART,DELTAX,DELTAY,1); IF DX>0 THEN XSTOP:=X>XF ELSE XSTOP:=X=16); IF TABLE_OPTION THEN BEGIN XTAB[I+1]:=X; YTAB[I+1]:=Y; LIST_TABLE(I+1) END; UNTIL XSTOP; FOR L:=2 TO 4 DO CLEAR(L,57,79); END; { of procedure euler } PROCEDURE RUNGE; { local to procedure options } VAR X,Y,K,K1,K2,K3,K4,H: REAL; I,XOLD,YOLD,XNEW,YNEW,DELTAX,DELTAY: INTEGER; BEGIN GOTOXY(57,2); WRITE('**Plotting RUNGE-KUTTA*'); GOTOXY(57,3); WRITE('soln for approx y val.'); ENTERED_FUNCTION:=FXY; REPLACE_FUNCTION; IF TABLE_OPTION THEN TABLE_HEAD; H:=DX; X:=X0; Y:=Y0; REPEAT I:=0; REPEAT I:=I+1; K1:=F(X,Y,0); K2:=F(X+H/2,Y+K1*H/2,0); K3:=F(X+H/2,Y+K2*H/2,0); K4:=F(X+H, Y+K3*H,0); K:=(K1+2*K2+2*K3+K4)/6; IF TABLE_OPTION THEN BEGIN XTAB[I]:=X; YTAB[I]:=Y END; CONVERT(X,Y,XOLD,YOLD); X:=X+H; Y:=Y+K*H; CONVERT(X,Y,XNEW,YNEW); DELTAX:=XNEW-XOLD; DELTAY:=YNEW-YOLD; IF PRTOK(XOLD,YOLD,XNEW,YNEW) THEN DRAWLINE(R,S,RW,XOLD,YOLD,DELTAX,DELTAY,1); IF DX>0 THEN XSTOP:=X>XF ELSE XSTOP:=X=16); IF TABLE_OPTION THEN BEGIN XTAB[I+1]:=X; YTAB[I+1]:=Y; LIST_TABLE(I+1) END; UNTIL XSTOP; FOR L:=2 TO 4 DO CLEAR(L,57,79); END; { of procedure runge } BEGIN { procedure options } REPEAT IF LIST_OPTIONS THEN BEGIN GOTOXY(57,3); WRITE('KEY******OPTIONS*******'); GOTOXY(57,4); WRITE('**data change options**'); GOTOXY(57,5); WRITE(' F dy/dx = F(x,y) '); GOTOXY(57,6); WRITE(' I Initial cond. Xo,Yo'); GOTOXY(57,7); WRITE(' Y Soln. Y(x) '); GOTOXY(57,8); WRITE(' O Omit soln. Y(x) '); GOTOXY(57,9); WRITE(' D Dx integration step'); GOTOXY(57,10);WRITE(' X Xf = final x value '); GOTOXY(57,11);WRITE('****screeen options****'); GOTOXY(57,12);WRITE(' C Clear graph '); GOTOXY(57,13);WRITE(' L Limits on screen '); GOTOXY(57,14);WRITE(' T xy Table is now '); SW_TAB_OPT('N'); GOTOXY(57,15);WRITE('*soln plotting options*'); GOTOXY(57,16);WRITE(' P Plot soln. Y(x) '); GOTOXY(57,17);WRITE(' E Euler (increment) '); GOTOXY(57,18);WRITE(' R Runge 4th order '); GOTOXY(57,19);WRITE('**termination options**'); GOTOXY(57,20);WRITE(' B Begin program again'); GOTOXY(57,21);WRITE(' Q Quit program '); END; REPEAT GOTOXY(61,23); WRITE('TYPE OPTION KEY:'); READ(KEYBOARD,KB); UNTIL KB IN OPTION_KEYS; IF KB IN ['a'..'z'] THEN KB:=CHR(ORD(KB)-32); { convert to upper case } CLEAR(23,61,79); LIST_OPTIONS:=KB IN ['L','P','E','R']; IF LIST_OPTIONS THEN FOR L:=3 TO 22 DO CLEAR(L,57,79); CASE KB OF 'F': ENTER_DE; 'I': ENTER_IC; 'Y': ENTER_SOLN; 'O': OMIT_SOLN; 'D': ENTER_DX; 'X': ENTER_XF; 'C': SET_SCREEEN; 'L': SCREEN_LIMITS; 'T': SW_TAB_OPT('Y'); 'P': PLOT_SOLN; 'E': EULER; 'R': RUNGE; 'B': EXIT(OPTIONS); 'Q': BEGIN FILLCHAR(S,SIZEOF(S),FALSE); CLEARSCREEN; EXIT(IVP); END END; UNTIL FALSE; END; { of procedure options } BEGIN { main program ivp } REPEAT INITIALIZE; OPTIONS UNTIL FALSE; END. { of main program ivp } ======================================================================================== DOCUMENT :usus Folder:VOL22:plotter.text ======================================================================================== { This unit was assembled for use with Grundler programs using the PLOTTER unit. DMP2PLOT must be edited to use your serial board addresses or replaced with the following or something similar: TYPE BYTE = PACKED ARRAY[0..0] OF 0..255; PROCEDURE DMP2PLOT(CH : CHAR); VAR OUTCODE : BYTE; BEGIN OUTCODE := ORD(CH); UNITWRITE(8,OUTCODE,1) END; to use REMOUT (not recommended). HPXMAX and HPYMAX will have to be redefined for use with the large, "dumb" Hiplot. The "smart" Hiplots may also be used but require more complex routines than those given here. The THROTTLE routine may be removed by Terak users as a similar routine is in the Terak library. } UNIT PLOTTER; {Version 1.1, 23 Dec 1982} INTERFACE VAR PENSTATE,PLOT_XLOC,PLOT_YLOC,OLDIPX,OLDIPY : INTEGER; OLDPEN : BOOLEAN; PROCEDURE THROTTLE(TICKS: INTEGER); PROCEDURE PLOT(PMODE,X,Y : INTEGER); PROCEDURE INITPLOT; IMPLEMENTATION CONST HPXMAX = 2000; (*maximum horizontal plotter steps*) HPYMAX = 1400; (*maximum vertical plotter steps*) PROCEDURE THROTTLE(*TICKS:INTEGER*); VAR COUNT,HITIME,START,STOP,TIMEDIFF : INTEGER; BEGIN COUNT := 0; TIME(HITIME,START); REPEAT COUNT := COUNT+1; (*Without counter routine, CPU is too fast and will stop and give the error message even if the clock is on. The value 1000 works but has not been optimized. Presumably it could be smaller.*) TIME(HITIME,STOP); TIMEDIFF := STOP-START; IF (TIMEDIFF < 0) THEN TIMEDIFF := TIMEDIFF+32767; IF ((TIMEDIFF = 0) AND (COUNT = 1000)) THEN BEGIN GOTOXY(0,23); WRITE(CHR(7),'Turn on the line time clock! Type to continue.'); READLN END; UNTIL (TIMEDIFF >= TICKS) END; PROCEDURE DMP2PLOT(CH : CHAR); {Note: address of serial board receiver status register and receiver buffer must be specified in decimal. The easy way to do this is illustrated for the standard REMOUT addresses, 177524 and 177526 (not used by the reviewer): 200000 - 177524 = 0252 (8) (using octal arithmetic) (0*512)+(2*64)+(5*8)+(2*1) = 172 (10) PXCSR = -172 PXBUF = -170} CONST PXCSR = -684 (*176524 (octal); also reviewer's REMOUT address but seems to cause no problems*); PXBUF = -682 (*176526 (octal)*); BITNO = 7; TYPE INFO = PACKED RECORD CASE BOOLEAN OF TRUE : (CH : PACKED ARRAY [0..1] OF CHAR); FALSE : (BIT : PACKED ARRAY [0..15] OF BOOLEAN); END; IOPORT = PACKED RECORD CASE BOOLEAN OF TRUE : (ADDR : INTEGER); FALSE : (PNTR : ^INFO) END; VAR XCSR,XBUF : IOPORT; BEGIN REPEAT XCSR.ADDR := PXCSR UNTIL XCSR.PNTR^.BIT[BITNO]; XBUF.ADDR := PXBUF; XBUF.PNTR^.CH[0] := CH; END; PROCEDURE ENCODE(COMMAND : INTEGER); CONST SP = ' '; DELAY = 24; (*delay for pen changes*) VAR PENCODE2 : CHAR; I : INTEGER; BEGIN IF (COMMAND IN [0..10]) THEN BEGIN CASE COMMAND OF 0 : PENCODE2 := ' '; (*delay*) 1 : PENCODE2 := 't'; (*-y*) 2 : PENCODE2 := 'p'; (*+y*) 3 : PENCODE2 := 'z'; (*pen down*) 4 : PENCODE2 := 'v'; (*-x*) 5 : PENCODE2 := 'u'; (*-x,-y*) 6 : PENCODE2 := 'w'; (*-x,+y*) 7 : PENCODE2 := 'y'; (*pen up*) 8 : PENCODE2 := 'r'; (*+x*) 9 : PENCODE2 := 's'; (*+x,-y*) 10 : PENCODE2 := 'q'; (*+x,+y*) END; DMP2PLOT(PENCODE2); IF ((COMMAND IN [3,7]) AND (COMMAND <> PENSTATE)) THEN BEGIN PENSTATE := COMMAND; FOR I := 1 TO DELAY DO DMP2PLOT(SP) (*Output spaces for pen delay*) END (*Could use THROTTLE(10) instead*) END; END; PROCEDURE PLOTMOVE(PMODE,PMOVE : INTEGER); BEGIN IF NOT (PMODE IN [0..4]) THEN EXIT(PLOTMOVE); CASE PMODE OF 0 : IF (OLDPEN) THEN BEGIN ENCODE(7); (*raise before*) OLDPEN := FALSE END; 1 : IF (NOT OLDPEN) THEN BEGIN ENCODE(3); (*lower before*) OLDPEN := TRUE END; 2 : BEGIN OLDIPX := 0; (*set current pen position as plotter origin*) OLDIPY := 0; PENSTATE := 0; EXIT(PLOTMOVE) END; 3,4 : ; END; (*case*) ENCODE(PMOVE) END; {The following is based on the Grundler GRAPHICS unit, which appears to be based on the DRAWLINE implementation described in the UCSD manual for version 1.5} PROCEDURE PLOT(*PMODE,X,Y : INTEGER*); VAR DELTAX,DELTAY,XINC,YINC,XCODE,YCODE,XYCODE,PMOVE : INTEGER; PROCEDURE DOFORX; {MORE HORIZONTAL} VAR ERROR,I:INTEGER; BEGIN IF DELTAX=0 THEN EXIT(PLOT); ERROR:=DELTAX DIV 2; I:=DELTAX; REPEAT X := X+XINC; ERROR:=ERROR+DELTAY; IF ERROR>=DELTAX THEN BEGIN ERROR:=ERROR-DELTAX; Y := Y+YINC; PMOVE := XYCODE; END ELSE PMOVE := XCODE; PLOTMOVE(PMODE,PMOVE); I:=I-1; UNTIL I=0 END (*DOFORX*); PROCEDURE DOFORY; {MORE VERTICAL} VAR ERROR,I:INTEGER; BEGIN ERROR:=DELTAY DIV 2; I:=DELTAY; REPEAT Y := Y+YINC; ERROR:=ERROR+DELTAX; IF ERROR>=DELTAY THEN BEGIN ERROR:=ERROR-DELTAY; X := X+XINC; PMOVE := XYCODE; END ELSE PMOVE := YCODE; PLOTMOVE(PMODE,PMOVE); I:=I-1; UNTIL I=0 END (*DOFORY*); BEGIN (*PLOT*) IF (X>HPXMAX) THEN DELTAX := HPXMAX-PLOT_XLOC ELSE IF (X<0) THEN DELTAX := -PLOT_XLOC ELSE DELTAX := X-PLOT_XLOC; IF (Y>HPYMAX) THEN DELTAY := HPYMAX-PLOT_YLOC ELSE IF (X<0) THEN DELTAX := -PLOT_YLOC ELSE DELTAY := Y-PLOT_YLOC; OLDIPX := X; OLDIPY := Y; PLOT_XLOC := PLOT_XLOC+DELTAX; PLOT_YLOC := PLOT_YLOC+DELTAY; IF DELTAX < 0 THEN BEGIN XCODE := 4; XINC := -1; DELTAX := -DELTAX END ELSE BEGIN XCODE := 8; XINC := 1 END; IF DELTAY < 0 THEN BEGIN YCODE := 1; YINC := -1; DELTAY := -DELTAY END ELSE BEGIN YCODE := 2; YINC := 1 END; XYCODE := XCODE+YCODE; IF DELTAX >= DELTAY THEN DOFORX ELSE DOFORY; END (*PLOT*); PROCEDURE INITPLOT; BEGIN PLOTMOVE(2,0); ENCODE(7); OLDPEN := FALSE; PLOT_XLOC := 0; (*actual pen coordinates for limiting pen motion*) PLOT_YLOC := 0; (*assumes that origin will be extreme lower, left corner*) END; END. ======================================================================================== DOCUMENT :usus Folder:VOL22:polar.text ======================================================================================== {$S+} { program by: DENNIS E. GRUNDLER Changes made and comments by reviewer: Changed CHR(CLR_EOL) to CEOL and removed definition of CLR_EOL. Placed definition of CLEAR_LINE in SCREEN_STUFF. Changed PAGE(OUTPUT) to CLEARSCREEN. Added USES SCREEN_STUFF. Provided unit PLOTTER. Reversed range of subscripts in SCREENTYPE. Added boolean variable, PLOT_STARTED (apparently in original PLOTTER unit). Added line PLOT_STARTED := FALSE; in procedure PLOT_IT. Defined UP and DOWN (apparently in original plotter unit). FUNCTION CHECK does NOT protect the plotter; if used with the simple Hiplots, it may be wise to consider rewriting this function. The Grundlers routinely use the system to define pi, using PI := 4*ATAN(1). This is all right as long as ATAN gives the same accuracy as real number accuracy, but why not just enter PI = 3.14159 26535 89793 23846 as a constant to the accuracy of your choice. Added error message 15. } PROGRAM POLAR; USES {$U GRAPH.LIBRARY} SCREEN_STUFF, PLOTTER, POST_ENTRY{the latter by: EDWARD J. GRUNDLER }; CONST ROWWIDTH=20; INK=1; UP=0; DOWN=1; TYPE SCREENTYPE = PACKED ARRAY [0..239,0..319] OF BOOLEAN; VAR SCREEN:SCREENTYPE; HIPLOT,TABLE,FIRST_TIME:BOOLEAN; RANGE:INTEGER; PI,SCALE,UNIT_SCALE,XI,XF,DELTA_ANGLE:REAL; MODE: 1..3; CH:CHAR; SAVED_FUNCTION:STRING; PLOT_STARTED:BOOLEAN; PROCEDURE DRAWLINE(VAR RANGE:INTEGER; VAR SCREEN:SCREENTYPE; ROWWIDTH, XSTART,YSTART,DX,DY,INK:INTEGER);EXTERNAL; PROCEDURE INITIALIZE; PROCEDURE GET_VALUE(PROMPT:STRING;VAR VALUE:REAL); BEGIN{ GET_VALUE} SAVED_FUNCTION:=ENTERED_FUNCTION; GOTOXY(5,7); WRITE(PROMPT); GET_FUNCTION; VALUE:=F(0,0,0); GOTOXY(0,7); WRITE(CEOL); ENTERED_FUNCTION:=SAVED_FUNCTION; REPLACE_FUNCTION; END; PROCEDURE MODIFY_VARIABLES; PROCEDURE CHANGE_EM(TEMP:REAL); BEGIN {CHANGE_EM} XI:=XI*TEMP; XF:=XF*TEMP; DELTA_ANGLE:=DELTA_ANGLE*TEMP; GOTOXY(18,8); WRITE(XI:10:4,CEOL); GOTOXY(18,9); WRITE(XF:10:4,CEOL); GOTOXY(18,10); WRITE(DELTA_ANGLE:10:4,CEOL); GOTOXY(23,11); CASE MODE OF 1 : WRITE('DEGREES',CEOL); 2 : WRITE('RADIANS',CEOL); 3 : WRITE('PI RADIANS',CEOL); END{ OF CASE}; END {OF CHANGE_EM}; BEGIN {MODIFY_VARIABLES} CASE CH OF 'F','f' : BEGIN REPEAT GOTOXY(0,5); WRITE('r(x) = ',CEOL); GET_FUNCTION; IF ERROR THEN BEGIN GOTOXY(0,6); WRITE(CHR(7{BELL})); CASE ERROR_CODE OF 1 : WRITE('<<<< UNBALANCED PARENTHESIS >>>>',CEOL); 2 : WRITE('<<<< UNRECOGNIZED SYMBOL >>>>',CEOL); 3 : WRITE('<< MULTIPLE DECIMAL POINTS IN A CONSTANT >>',CEOL); 15 : WRITE('<< INVALID FUNCTION OR MISSING PARENS >>',CEOL); END{ OF CASE}; END; UNTIL NOT(ERROR); GOTOXY(0,5); WRITELN('r(x) = ',ENTERED_FUNCTION,CEOL); WRITELN(CEOL); END; 'B','b' : REPEAT GET_VALUE('New starting angle = ',XI); IF XF<>XI THEN BEGIN GOTOXY(18,8); WRITE(XI:10:4,CEOL); END; UNTIL(XF<>XI); 'E','e' : REPEAT GET_VALUE('New ending angle = ',XF); IF XF<>XI THEN BEGIN GOTOXY(18,9); WRITE(XF:10:4,CEOL); END; UNTIL(XF<>XI); 'D','d' : REPEAT GET_VALUE('New Delta angle = ',DELTA_ANGLE); IF DELTA_ANGLE<>0 THEN BEGIN GOTOXY(18,10); WRITE(DELTA_ANGLE:10:4,CEOL); END; UNTIL (DELTA_ANGLE<>0); 'S','s' : BEGIN GET_VALUE('New Scale magnification = ',SCALE); IF SCALE<>0 THEN BEGIN GOTOXY(8,12); WRITE(SCALE:10:4,CEOL); END; END; 'U','u' : REPEAT GET_VALUE('ENTER THE MAXIMUM RADIUS EXPECTED: ',UNIT_SCALE); IF UNIT_SCALE>0 THEN BEGIN GOTOXY(13,13); UNIT_SCALE:=100.0/UNIT_SCALE; WRITE(UNIT_SCALE:10:4,CEOL); END; UNTIL UNIT_SCALE>0; 'M','m' : BEGIN IF MODE = 3 THEN MODE:=1 ELSE MODE:=MODE+1; CASE MODE OF 1 : CHANGE_EM(180/(PI*PI)); 2 : CHANGE_EM(PI/180); 3 : CHANGE_EM(PI); END; END; 'C','c' : BEGIN FILLCHAR(SCREEN,SIZEOF(SCREEN),0); DRAWLINE(RANGE,SCREEN,ROWWIDTH,61,120,200,0,INK) {X-AXIS}; DRAWLINE(RANGE,SCREEN,ROWWIDTH,160,21,0,200,INK) {Y-AXIS}; END; 'Q','q' : BEGIN UNITWRITE(3,SCREEN,7); CLEARSCREEN; EXIT(POLAR); END; 'H','h' : HIPLOT:=TRUE; END {OF THE CASE}; GOTOXY(5,24); END {OF MODIFY_VARIABLES}; BEGIN {INITIALIZE} IF FIRST_TIME THEN BEGIN TABLE:=FALSE; FILLCHAR(SCREEN,SIZEOF(SCREEN),0); REPEAT CLEARSCREEN; WRITE('r(x) = '); GET_FUNCTION; UNTIL NOT(ERROR); DRAWLINE(RANGE,SCREEN,ROWWIDTH,61,120,200,0,INK) {X-AXIS}; DRAWLINE(RANGE,SCREEN,ROWWIDTH,160,21,0,200,INK) {Y-AXIS}; DELTA_ANGLE:=PI/180; XI:=0; XF:=8.0*ATAN(1.0); MODE:=2; SCALE:=1; UNIT_SCALE:=100; CLEARSCREEN; GOTOXY(0,4); WRITELN('THE ENTERED FUNCTION IS:',CEOL); WRITELN('r(x) = ',ENTERED_FUNCTION); WRITELN; WRITELN; WRITELN('Beginning angle = ',XI:10:4); WRITELN('Ending angle = ',XF:10:4); WRITELN('Delta angle = ',DELTA_ANGLE:10:4); WRITE('Angular MODE is set at '); CASE MODE OF 1 : WRITELN('DEGREES'); 2 : WRITELN('RADIANS'); 3 : WRITELN('PI RADIANS'); END {OF CASE}; WRITELN('Scale = ',SCALE:10:4); WRITELN('Unit scale = ',UNIT_SCALE:10:4); GOTOXY(0,15); WRITELN('The bell will sound at the end of the plot. '); WRITELN('Pressing any key will continue the program.'); FIRST_TIME:=FALSE; END {OF FIRST TIME INITIALIZATIONS}; UNITWRITE(3,SCREEN,7); GOTOXY(0,0); WRITELN('new F(unction; B(eginning angle; E(nding angle; D(elta angle; '); WRITE('S(cale magnification; angle M(ode; C(learscreen; '); WRITELN('U(nit scale; Q(uit the program.'); WRITELN('H(ardcopy, press "P" to PLOT r(x)'); WRITELN; HIPLOT:=FALSE; REPEAT READ(KEYBOARD,CH); MODIFY_VARIABLES; IF XF>XI THEN DELTA_ANGLE:= ABS(DELTA_ANGLE) ELSE DELTA_ANGLE:= -ABS(DELTA_ANGLE); UNTIL (CH IN ['P','p']); END {OF INITIALIZE}; PROCEDURE PLOTIT; CONST CR=13{ Carriage Return}; VAR X,Y,START_ANGLE,END_ANGLE,ANGLE_CHANGE,TEMP:REAL; XPLOT,YPLOT,XSTART,YSTART,DX,DY:INTEGER; FUNCTION IN_RANGE:BOOLEAN; BEGIN {IN RANGE} IN_RANGE:=(XSTART<320) AND (XSTART>-1) AND (YSTART<240) AND (YSTART>-1) AND (XSTART+DX<320) AND (XSTART+DX>-1) AND (YSTART+DY<240) AND (YSTART+DY>-1); END {IN_RANGE}; FUNCTION CHECK(VALUE:REAL):INTEGER; BEGIN IF ABS(VALUE)>32767 THEN VALUE:=32767*ABS(VALUE)/VALUE; CHECK:=ROUND(VALUE); END; PROCEDURE PLOT_OUT; FUNCTION XRANGE:INTEGER; VAR TEMP:INTEGER; DX_PLOTTER:INTEGER; BEGIN DX_PLOTTER:=1000+CHECK(X*SCALE*UNIT_SCALE*7)-PLOT_XLOC; TEMP:=PLOT_XLOC+DX_PLOTTER; IF TEMP>2000 THEN TEMP:=2000; IF TEMP<0 THEN TEMP:=0; XRANGE:=TEMP; END; FUNCTION YRANGE:INTEGER; VAR TEMP:INTEGER; DY_PLOTTER:INTEGER; BEGIN DY_PLOTTER:=700+CHECK(Y*SCALE*UNIT_SCALE*7)-PLOT_YLOC; TEMP:=PLOT_YLOC+DY_PLOTTER; IF TEMP>1400 THEN TEMP:=1400; IF TEMP<0 THEN TEMP:=0; YRANGE:=TEMP; END; BEGIN {PLOT_OUT} IF NOT PLOT_STARTED THEN BEGIN GOTOXY(0,0); WRITELN('Position the plotter''s pen to the lower left corner.', CEOL); UNITCLEAR(2); WRITELN('Press RETURN to continue'); READLN; {The next couple of lines clear the top three lines of text.} GOTOXY(0,0); WRITE(CLEAR_LINE,CLEAR_LINE,CLEAR_LINE); GOTOXY(35,0); WRITELN('POLAR PLOT'); PLOT_STARTED:=TRUE; PLOT(UP,0,700); PLOT(DOWN,2000,700); PLOT(UP,1000,0); PLOT(DOWN,1000,1400); PLOT(UP,XPLOT,YPLOT); WRITELN('YOU MAY WANT TO CHANGE COLORS, press RETURN to continue'); READLN; GOTOXY(0,1); WRITELN(CEOL); UNITREAD(2,CH,1,,1); END; IF NOT ERROR THEN PLOT(DOWN,XRANGE,YRANGE); END; BEGIN {PLOTIT} IF HIPLOT THEN INITPLOT; PLOT_STARTED := FALSE; UNITWRITE(3,SCREEN,60); {The next couple of lines clear the top three lines of text.} GOTOXY(0,0); WRITE(CLEAR_LINE,CLEAR_LINE,CLEAR_LINE); GOTOXY(35,0); WRITELN('POLAR PLOT'); UNITREAD(2,CH,1,,1);{ read the keyboard while processing continues} CASE MODE OF 1 : BEGIN START_ANGLE:=XI*PI/180; END_ANGLE:=XF*PI/180; ANGLE_CHANGE:=DELTA_ANGLE*PI/180; END; 2 : BEGIN START_ANGLE:=XI; END_ANGLE:=XF; ANGLE_CHANGE:=DELTA_ANGLE; END; 3 : BEGIN START_ANGLE:=XI*PI; END_ANGLE:=XF*PI; ANGLE_CHANGE:=DELTA_ANGLE*PI; END; END {OF CASE}; TEMP:=F(START_ANGLE,0,0); X:=TEMP*COS(START_ANGLE); Y:=TEMP*SIN(START_ANGLE); XPLOT:=1000+CHECK(X*SCALE*7*UNIT_SCALE); YPLOT:=700+CHECK(Y*SCALE*7*UNIT_SCALE); XSTART:=160+CHECK(X*SCALE*UNIT_SCALE); YSTART:=120-CHECK(Y*SCALE*UNIT_SCALE); REPEAT IF NOT UNITBUSY(2) THEN BEGIN IF CH = CHR(27{ESC}) THEN BEGIN IF HIPLOT THEN PLOT(UP,0,0); EXIT(PLOTIT); END; UNITREAD(2,CH,1,,1); END; START_ANGLE:=START_ANGLE+ANGLE_CHANGE; TEMP:=F(START_ANGLE,0,0); X:=TEMP*COS(START_ANGLE); Y:=TEMP*SIN(START_ANGLE); DX:=160+CHECK(X*SCALE*UNIT_SCALE)-XSTART; DY:=120-CHECK(Y*SCALE*UNIT_SCALE)-YSTART; IF HIPLOT THEN PLOT_OUT; IF IN_RANGE AND NOT ERROR THEN DRAWLINE(RANGE,SCREEN,ROWWIDTH,XSTART,YSTART,DX,DY,INK); XSTART:=XSTART+DX; YSTART:=YSTART+DY; UNTIL (START_ANGLE>END_ANGLE); IF HIPLOT THEN PLOT(UP,0,0); IF UNITBUSY(2) THEN UNITCLEAR(2); END {OF PLOTIT}; BEGIN {POLAR} PI:=4*ATAN(1); DEFINESTRINGS; FIRST_TIME:=TRUE; REPEAT INITIALIZE; PLOTIT; WRITE('Press any key to continue ',CHR(7{BELL})); READ(CH); UNTIL FALSE {The program is exited from INITIALIZE}; END {OF THE PROGRAM}. ======================================================================================== DOCUMENT :usus Folder:VOL22:post.doc.text ======================================================================================== POST_ENTRY_OF_FUNCTION Reviewed by: Henry E. Baumgarten Department of Chemistry University of Nebraska-Lincoln Lincoln, Nebraska 68588-0304 The unit POST_ENTRY_OF_FUNCTION was written by Edward J. Grundler, apparently in 1978 or early 1979 (the original text file is dated 11 Feb 1979). The purpose of this unit is to make possible the entry of functions of one to three variables in algebraic form from the console or other input device. The function may then be used as the basis for plotting the function on a graphics terminal or hard-copy plotter, or for calculations of various sorts. Several programs using this unit have been submitted to the USUS library by Edward J. Grundler, Dennis E. Grundler, and Ken Gaal. The unit is fairly well documented internally; however, use of the unit may be facilitated by a brief analysis of its operation. After a function F(x,y,z) is entered as a string, ENTERED_FUNCTION, at the terminal, the string is scanned (1) to remove blanks, (2) to convert lower char to upper case, (3) to make certain that parentheses are balanced, (4) to replace the identifiers for all of its standard functions and its extra functions (those provided by the unit but not in UCSD Pascal) by a single char code (e.g., COS is replaced by C and ASIN by H), and (5) to check for invalid chars left after steps (1) through (4). In the present version an additional step has been added because of problems encountered during review. The string is scanned to make certain that the arguments of all functions are enclosed in parentheses. In the original version this was not required (i.e., sinx and sin(x) were equivalent). Although this has obvious advantages, it can cause problems when valid functions NOT present in this unit are entered. Thus, once again, the lamb of convenience had to be sacrified on the altar of reliability. If no errors are encountered, the function string is transformed from algebraic (infix) to postfix (RPN) form by a sequence of operations resembling that used as a part of some compilers. From this process the function emerges as a string, FUNC, in postfix form together with a constant array V, in which all of the real constants of the function are stored in proper order (all numerical quantities are treated as real numbers). When the unit is called upon to evaluate the function by the call, some VAR := F(x,y,z), evaluation proceeds in typical RPN fashion using a STACK. If errors are noted, an error flag, ERROR, is set TRUE, and the variable, ERROR_CODE, is assigned an appropriate error number. In such instances the function becomes undefined (something that can cause problems if not properly prepared for). Consider, for example, a limacon of Pascal, F(x) = 4*COS(X) + 3, where x is really theta (the counter-clockwise angle from the x-axis) and F(x) is r (the radial distance from the origin). To enter this function, 4*COS(X) + 3 is typed at the terminal (with or without the blanks or spaces). After the initial scan the function string is reduced to the form, 4*C(X)+3. Then this string is rearranged to the postfix form needed in FUNC, VXC*V+, where V is the code for a "value" (or real constant). The actual values, 4 and 3, are stored as the first and second elements, respectively, of the real array, V. At this point the function is ready to accept input values of x (theta). Assume that we wish to evaluate the function at x = 0. By whatever Pascal procedure we may devise we enter some VAR = F(0,0,0). Note that x = 0, and we set the other values (y and z) also to zero because they are not being used by this particular function. The evaluation of the function proceeds by calling each operator in turn from the function string, performing its operation on the stack, and appropriately incrementing or decrementing the stack pointer. For the example function these operations and the contents of the stack can by decribed as in the following chart. Operator Top_of_stack Top_of_stack_minus_one V 4.00000 X 0.00000 4.00000 C 1.00000 4.00000 * 4.00000 V 3.00000 4.00000 + 7.00000 At the end, the value of F(x) = 7 (from the top of the stack) is assigned to VAR. The operations used were (in order): V, push V[1] on stack; X, push X = 0 on stack; C, replace tos with COS(tos); *, replace tos with tos*tos-1, V, push V[2] on stack; +, replace tos with tos+tos-1. The unit provides three procedures or functions, GET_FUNCTION, REPLACE_ FUNCTION, and F(X,Y,Z : REAL) : REAL. GET_FUNCTION is intended for use in obtaining the input function string from the console. It contains a terminal- dependent code line, WRITE(CHR(31)). For the Terak terminal emulator used by the Grundlers, this code causes a reverse line feed, something apparently required by many of the Grundler graphics programs for the Terak computer. In some applications this line could cause problems---particularly for non-Terak computers. If POST_ENTRY is not being used with the Grundler programs, it is recommended that this line be removed and the whole section of code in which it is found be revised. For the Grundler-Gaal programs the line should be edited to fit the terminal emulator (or terminal) being used. REPLACE_FUNCTION may be used to reenter a function (saved in some fashion) after using POST_ENTRY to enter a second function (or a value). However, it can be used in place of GET_FUNCTION if properly coded. If so, note that the reverse line feed still takes place, AND, if a zero-length string or a string of blanks is entered via REPLACE_FUNCTION, the program will probably go into an indefinite loop, waiting for corrective action that cannot be taken: one more reason to get rid of that reverse line feed. Two typical uses of REPLACE_ FUNCTION might be: (1) SAVECURSOR(XCUR,YCUR); (routine that saves cursor coordinates) REPEAT READLN(STRG); FOR I := LENGTH(STRG) DOWNTO 1 DO IF STRG[I] = ' ' THEN DELETE(STRG,I,1); IF (LENGTH(STRG)=0) THEN GOTOXY(XCUR,YCUR); UNTIL ((LENGTH(STRG)>0); ENTERED_FUNCTION := STRG; REPLACE_FUNCTION; (2) SAVED_FUNCTION := ENTERED_FUNCTION; (saves original function) GET_FUNCTION; (enter number string, VALUE_STRG, from terminal) INPUT_VALUE := F(0,0,0); ("computes" the real number) ENTERED_FUNCTION := SAVED_FUNCTION; REPLACE_FUNCTION; Note that in example (1) the possibility of a indefinite loop is circumvented. In (2) the routines are used to enter a real number from the terminal (hopefully protecting the user from some of the vagaries of the usual system input idiosyncracies). Some of the original forgiveness in this unit has been left in. Thus, some missing '*' will be inserted. For example: X9 -- > X*9; XX -- > X*X; COS(X)X -- > COS(X)*X. Restrictions imposed by POST_ENTRY include: (1) Input function string is limited to 80 char (on one line from console). (2) Scientific format for real constants is not implemented. (3) The negative unary operator is processed by GET_UNARY, converting function codes to lower case, COS(X) --> C(X) (chr(67)) -COS(X) --> c(X) (chr(67+32)) --COS(X) --> chr(121)(X) (chr(67+32+32)) so don't enter a string of minus signs. The only change of any consequence made by the reviewer was the following. The original would not enforce encapsulation of function arguments in parentheses. The following pairs were equivalent: sinx + sin(x); sinxx + sin(x)*x; sinxcosx + sin(x)*cos(x). However, the original also accepted cosh(x) (hyperbolic cosine, not provided in the unit), converted it to CH(X), and discarded the C (in the GET_UNARY routine), leaving FUNC = XH (i.e., the arcsin(x), an initially baffling surprise to the reviewers. In this version PROCEDURE VERIFY insists that parentheses surround arguments of functions. In an attempt to retain the original procedure's relaxed attitude toward parentheses, a number of expedients were examined without much success. However, in the process POST_ENTRY was rather thoroughly reorganized and rewritten by the reviewer. Several new functions and debugging facilities were added. The resulting unit was entitled, POST_FIX. For many users POST_ENTRY is entirely adequate; for a few the additional capabilities of POST_FIX may be helpful. The principal changes or enhancements found in POST_FIX are as follows: (1) Standard and extra functions are mapped to the user-defined char set (chr(128)-chr(255)) creating space for a total of 50 functions and 13 constants compared with 26 total constants, functions, and unary operators in POST_ENTRY. (2) The functions COSH, SINH, TANH, ERF, ERFC, MOD, LNFACT(orial) plus the operator ! (for factorial) have been added. ARCCOS, ARCSIN, and ARCTAN are accepted as well as ACOS, ASIN, and ATAN. (For electrochemists and others doing electrochemical research, the implementation of EXP(SQR(Z))*ERFC(Z) as a single function for a very wide range of Z values is very simple.) (3) Input of real constants in scientific format is permitted. Present real constant limits are 1.0E-37 to 1.0E37, with constants smaller than 1.0E-37 being converted to zero (a WARNING flag is set and a WARNING message is made available when this conversion occurs). (4) More extensive checking for errors is carried out. (5) Error messages (as well as error code numbers) are available using a function ERROR_MESSAGE. (6) For debugging purposes (or for pure curiosity) provision is made for step-wise evaluation with output of the post-fix function, the constant stack (array), and of the evaluation stack at each step of the evaluation. (7) Multiple unary inputs (----X, -----X, etc.) are handled correctly. (8) Functions of greater length can be handled. POST_FIX is already being used in both research and interactive educational applications at the University of Nebraska-Lincoln. The POST_FIX unit will be submitted by the reviewer to the USUS library along with examples of its applications. ======================================================================================== DOCUMENT :usus Folder:VOL22:post_entry.text ======================================================================================== {$I-}{$R-} {Note that there is one terminal dependent line of code, marked (*****). This line should be replaced by whatever will provide a reverse line feed on your terminal. If this unit is not to be used with the Grundler programs, this line should be deleted and that section of the unit revised for maximum generality, leaving the terminal-handling code to the main program or other units.---heb PROCEDURE GET_FUNCTION asks for an entry of a three variable function. If only one or two variables are needed, the extra variables are ignored. The variables must be X,Y and Z. The procedure recognizes the standard PASCAL functions. PI, ASIN, ACOS, TAN and ^ for EXPONENTIATION are also recognized. PROCEDURE REPLACE_FUNCTION enables one to replace a string-variable expression for use as F(X,Y,Z). This is done as follows: ENTERED_FUNCTION:= string var REPLACE FUNCTION FUNCTION F(X,Y,Z:REAL):REAL evaluates the function entered in GET_FUNCTION. If all of the variables are not used, set the other variables to ZERO. For example: ANSWER:=F(0,Y,0). If an error is encountered in GET_FUNCTION, control is passed back to the calling program with ERROR set to TRUE and ERROR_CODE set as follows: 1 UNBALANCED PARENTHESES 2 UNRECOGNIZED SYMBOL 3 MULTIPLE DECIMAL POINTS IN A CONSTANT 15 FUNCTION ARGUMENT NOT IN PARENTHESES If an error is encountered in F(X,Y,Z), control is passed back to the calling program with the function undefined, ERROR set to TRUE and ERROR_CODE set as follows: 4 ATTEMPT TO UNROLL THE STACK PAST ITS ORIGIN 5 ATTEMPT TO DIVIDE BY ZERO 6 ATTEMPT TO EXPONENTIATE A NEGATIVE NUMBER (*USES LN EVALUATION*) 7 ATTEMPT TO EVALUATE THE TANGENT WITH THE COSINE EQUAL TO ZERO 8 ATTEMPT TO TRUNC OR ROUND AN ABSOLUTE VALUE > 32767 9 ATTEMPT TO TAKE LOG OR LN OF A ZERO OR NEGATIVE NUMBER 10 ATTEMPT TO TAKE THE SQUARE ROOT OF A NEGATIVE NUMBER 11 STACK POINTER NOT AT BOTTOM OF THE STACK AT END OF THE EVALUATION 12 ATTEMPT TO TAKE ARCSIN WITH ABS(argument) > 1 13 ATTEMPT TO TAKE ARCCOS WITH ABS(argument) > 1 14 ATTEMPT TO EXPONENTIATE WOULD CAUSE OVERFLOW The function that is entered is available to the calling program in ENTERED_FUNCTION. Changes made by reviewer: Changed one line intended to a cause a reverse line feed at the terminal to be compatible with the Terak in the Terak emulator mode. Added the procedure VERIFY, which requires that the arguments of the standard and additional functions be surrounded by parentheses. Otherwise the unit will accept COSH(X) (a function not present in this unit) but will tranform it into the equivalent of ARCSIN(X), a result that can be confusing to the unwary. Changed STR to STRG. Insert missing index [I] in line marked (**) and removed a duplicate line of code (no longer necessary after the insertion) in procedure SCAN_STRING. ---Henry E. Baumgarten } UNIT POST_ENTRY_OF_FUNCTION; INTERFACE { unit by: EDWARD J GRUNDLER } VAR ERROR:BOOLEAN; ERROR_CODE:INTEGER; ENTERED_FUNCTION:STRING; PROCEDURE GET_FUNCTION; PROCEDURE REPLACE_FUNCTION; FUNCTION F(X,Y,Z:REAL):REAL; IMPLEMENTATION VAR V:ARRAY[1..20]OF REAL; FUNC:STRING; J:INTEGER; PROCEDURE GET_F(READIN:BOOLEAN); VAR CH:CHAR; CH_STR:STRING; STR_2:STRING[1]; I:INTEGER; PROCEDURE MISTAKE(I:INTEGER); BEGIN {MISTAKE} ERROR_CODE:=I; ERROR:=TRUE; EXIT(GET_FUNCTION) END; {MISTAKE} PROCEDURE VERIFY; VAR K,LEN : INTEGER; BEGIN LEN := LENGTH(CH_STR); FOR K := 1 TO LEN DO IF NOT(CH_STR[K] IN ['('..'+','-'..'9','A'..'I','L','N','P'..'V', 'X'..'Z']) THEN MISTAKE(2); IF (LEN>1) THEN FOR K := 2 TO LEN DO IF ((CH_STR[K-1] IN ['A'..'I','L','Q'..'U']) AND (NOT(CH_STR[K] = '('))) THEN MISTAKE(15) END; PROCEDURE SCAN_STRING; VAR I,J:INTEGER; BEGIN{SCAN_STRING} J:=0; FOR I:=1 TO LENGTH(CH_STR) DO BEGIN IF CH_STR[I] IN ['a'..'z'] THEN CH_STR[I]:=CHR(ORD(CH_STR[I])-32); IF CH_STR[I]='(' THEN J:=J+1 ELSE IF CH_STR[I]=')' THEN J:=J-1 END; IF J<>0 THEN MISTAKE(1); REPEAT { CODES USED } I:=POS('ASIN',CH_STR); { A ATAN } IF I>0 THEN { B SQR } BEGIN { C COS } DELETE(CH_STR,I,4); { D ABS } INSERT('H',CH_STR,I) { E EXP } END { F PI } UNTIL I=0; { G LOG } REPEAT { H ASIN } I:=POS('SIN',CH_STR); { I TRUNC } IF I>0 THEN DELETE(CH_STR,I+1,2) { J } UNTIL I=0; { K } REPEAT { L LN } I:=POS('ACOS',CH_STR); { M } IF I>0 THEN { N NEGATE } BEGIN { O } DELETE(CH_STR,I,4); { P + UNARY } INSERT('U',CH_STR,I) { Q SQRT } END { R ROUND } UNTIL I = 0; { S SIN } REPEAT { T TAN } I:=POS('COS',CH_STR); { U ACOS } IF I>0 THEN DELETE(CH_STR,I+1,2) { V VALUE } UNTIL I=0; { W } REPEAT { X X ARG } I:=POS('ATAN',CH_STR); { Y Y ARG } IF I>0 THEN DELETE(CH_STR,I+1,3) { Z Z ARG } UNTIL I=0; REPEAT I := POS('TANH', CH_STR); IF I>0 THEN BEGIN DELETE(CH_STR,I,4); INSERT('M',CH_STR,I) END UNTIL I = 0; REPEAT I:=POS('TAN',CH_STR); IF I>0 THEN DELETE(CH_STR,I+1,2) UNTIL I=0; REPEAT I:=POS('TRUNC',CH_STR); IF I>0 THEN BEGIN DELETE(CH_STR,I,5); INSERT('I',CH_STR,I) END UNTIL I=0; REPEAT I:=POS('ROUND',CH_STR); IF I>0 THEN DELETE(CH_STR,I+1,4) UNTIL I=0; REPEAT I:=POS('LN',CH_STR); IF I>0 THEN DELETE(CH_STR,I+1,1) UNTIL I=0; REPEAT I:=POS('LOG',CH_STR); IF I>0 THEN DELETE(CH_STR,I,2) UNTIL I=0; REPEAT I:=POS('EXP',CH_STR); IF I>0 THEN DELETE(CH_STR,I+1,2) UNTIL I=0; REPEAT I:=POS('SQRT',CH_STR); IF I>0 THEN BEGIN DELETE(CH_STR,I+2,2); DELETE(CH_STR,I,1) END UNTIL I=0; REPEAT I:=POS('ABS',CH_STR); IF I>0 THEN BEGIN DELETE(CH_STR,I,3); INSERT('D',CH_STR,I) END UNTIL I=0; REPEAT I:=POS('SQR',CH_STR); IF I>0 THEN BEGIN DELETE(CH_STR,I,3); INSERT('B',CH_STR,I) END UNTIL I=0; REPEAT I:=POS('PI',CH_STR); IF I>0 THEN BEGIN DELETE(CH_STR,I,2); INSERT('F',CH_STR,I) END UNTIL I=0; I:=2; WHILE I<=LENGTH(CH_STR) DO BEGIN IF (CH_STR[I] IN ['(','X'..'Z']) AND (CH_STR[I-1] IN ['F','X'..'Z','0'..'9','.']) THEN INSERT('*',CH_STR,I) ELSE IF (CH_STR[I-1] IN ['X'..'Z',')']) AND (CH_STR[I] IN ['F','X'..'Z','0'..'9','.']) THEN INSERT('*',CH_STR,I) ELSE IF (CH_STR[I-1] IN ['0'..'9','.','X'..'Z']) AND NOT(CH_STR[I] IN ['0'..'9','.','+','-','*','/','^',')']) THEN INSERT('*',CH_STR,I); I:=I+1 END; VERIFY END; {SCAN_STRING} PROCEDURE FIND; BEGIN {FIND} I:=I+1; IF I>LENGTH(CH_STR) THEN STR_2:=',' ELSE STR_2:=COPY(CH_STR,I,1); CH:=STR_2[1] END; {FIND} PROCEDURE EXPRESSION; VAR OP:STRING[1]; PROCEDURE TERM; VAR OP1:STRING[1]; PROCEDURE EXPONENT; VAR OP2:STRING[1]; PROCEDURE FACTOR; VAR UNARY:BOOLEAN; PREFIX:STRING[1]; PROCEDURE GET_UNARY; VAR SAVE:CHAR; BEGIN {GET_UNARY} UNARY:=TRUE; IF NOT (CH IN ['+','-','A'..'E','Q'..'U','L','G'..'I']) THEN MISTAKE(2); IF CH='+' THEN PREFIX:='P' ELSE IF CH='-' THEN PREFIX:='N' ELSE PREFIX:=STR_2; FIND; IF NOT (CH IN ['F','X'..'Z','0'..'9','(','.']) THEN BEGIN SAVE:=PREFIX[1]; GET_UNARY; IF SAVE='N' THEN PREFIX[1]:=CHR(ORD(PREFIX[1])+32) END END; {GET_UNARY} PROCEDURE GET_VALUE; VAR STR:STRING; X:REAL; FUNCTION IN_VALUE(INP:STRING):REAL; VAR I:INTEGER; DEC,OK:BOOLEAN; J,X:REAL; BEGIN {IN_VALUE} DEC:=FALSE; OK:=TRUE; FOR I:=1 TO LENGTH(INP) DO BEGIN OK:=OK AND NOT(DEC AND(INP[I]='.')); IF NOT DEC THEN DEC:=(INP[I]='.'); END; IF NOT OK THEN MISTAKE(3); X:=0; DEC:=FALSE; J:=1; FOR I:=1 TO LENGTH(INP) DO BEGIN IF NOT DEC THEN DEC:=(INP[I]='.'); IF DEC THEN BEGIN IF INP[I]<>'.' THEN BEGIN J:=J/10; X:=X+(ORD(INP[I])-ORD('0'))*J END ELSE {NOTHING} END ELSE X:=X*10+ORD(INP[I])-ORD('0') END; IN_VALUE:=X END; {IN_VALUE} BEGIN {GET_VALUE} STR:=''; WHILE CH IN ['.','0'..'9'] DO BEGIN STR:=CONCAT(STR,STR_2); FIND END; X:=IN_VALUE(STR); J:=J+1; V[J]:=X; FUNC:=CONCAT(FUNC,'V'); I:=I-2; FIND END; {GET_VALUE} BEGIN {FACTOR} UNARY:=FALSE; IF NOT (CH IN ['F','X'..'Z','.','0'..'9','(']) THEN GET_UNARY; IF CH = '(' THEN BEGIN FIND; EXPRESSION; END ELSE IF CH IN ['0'..'9','.'] THEN GET_VALUE ELSE FUNC:=CONCAT(FUNC,STR_2); IF UNARY THEN BEGIN FUNC:=CONCAT(FUNC,PREFIX); UNARY:=FALSE END; FIND END; {FACTOR} BEGIN {EXPONENT} FACTOR; WHILE CH = '^' DO BEGIN OP2:=STR_2; FIND; FACTOR; FUNC:=CONCAT(FUNC,OP2) END END; {EXPONENT} BEGIN {TERM} EXPONENT; WHILE CH IN ['*','/'] DO BEGIN OP1:=STR_2; FIND; EXPONENT; FUNC:=CONCAT(FUNC,OP1) END END; {TERM} BEGIN {EXPRESSION} TERM; WHILE CH IN ['+','-'] DO BEGIN OP:=STR_2; FIND; TERM; FUNC:=CONCAT(FUNC,OP) END END; {EXPRESSION} BEGIN {GET_F} J:=0; FUNC:=''; ERROR:=FALSE; ERROR_CODE:=0; REPEAT IF READIN THEN READLN(ENTERED_FUNCTION); CH_STR:=ENTERED_FUNCTION; (**) FOR I:=LENGTH(CH_STR) DOWNTO 1 DO IF CH_STR[I]=' ' THEN DELETE(CH_STR,I,1); {WRITE(CHR(27),'I'); Reverse Line Feed for H19} (*****) WRITE(CHR(11)); {Reverse Line Feed for Terak in Terak emulator mode} UNTIL LENGTH(CH_STR)>0; SCAN_STRING; I:=0; FIND; EXPRESSION; END; {GET_F} PROCEDURE GET_FUNCTION; BEGIN GET_F(TRUE) END; PROCEDURE REPLACE_FUNCTION; BEGIN GET_F(FALSE) END; FUNCTION F; VAR I,J,K:INTEGER; STACK:ARRAY[1..20] OF REAL; OP:CHAR; PROCEDURE PUSH; BEGIN {PUSH} J:=J+1; CASE OP OF 'X':STACK[J]:=X; 'Y':STACK[J]:=Y; 'Z':STACK[J]:=Z; 'F':STACK[J]:=4*ATAN(1); 'V': BEGIN K:=K+1; STACK[J]:=V[K] END END {OF CASE} END; {PUSH} PROCEDURE WRONG(I:INTEGER); BEGIN {WRONG} ERROR_CODE:=I; ERROR:=TRUE; EXIT(F) END; {WRONG} PROCEDURE CHECK_EXPONENT(X:REAL); BEGIN {CHECK_EXPONENT} IF X>87.498233 THEN WRONG(14) END; {CHECK_EXPONENT} PROCEDURE ALGEBRA; BEGIN {ALGEBRA} IF J<2 THEN WRONG(4); CASE OP OF '+':STACK[J-1]:=STACK[J-1]+STACK[J]; '-':STACK[J-1]:=STACK[J-1]-STACK[J]; '*':STACK[J-1]:=STACK[J-1]*STACK[J]; '/':IF STACK[J]=0 THEN WRONG(5) ELSE STACK[J-1]:=STACK[J-1]/STACK[J]; '^':IF STACK[J-1]<=0 THEN WRONG(6) ELSE BEGIN CHECK_EXPONENT(LN(STACK[J-1])*STACK[J]); STACK[J-1]:=EXP(LN(STACK[J-1])*STACK[J]) END END; {OF CASE} J:=J-1 END; {ALGEBRA} PROCEDURE ARCCOSINE; VAR AC,HPI,PI_IF_AC_NEG:REAL; begin HPI:=2*ATAN(1); AC:=STACK[J]; IF AC<>0 THEN PI_IF_AC_NEG:=HPI*(1-AC/ABS(AC)); IF ABS(AC)>1 THEN WRONG(13) ELSE IF (ABS(AC)=1) OR (AC=0) THEN STACK[J]:=HPI*(1-AC) ELSE STACK[J]:=ATAN(SQRT(1-AC*AC)/AC)+PI_IF_AC_NEG end; { of procedure ARCCOSINE } BEGIN {F(X,Y,Z)} ERROR:=FALSE; ERROR_CODE:=0; J:=0; K:=0; FOR I:=1 TO LENGTH(FUNC) DO BEGIN OP:=FUNC[I]; CASE OP OF 'X','Y','Z','F','V':PUSH; '+','-','*','/','^':ALGEBRA; 'S','s':STACK[J]:=SIN(STACK[J]); 'C','c':STACK[J]:=COS(STACK[J]); 'T','t':IF COS(STACK[J])=0 THEN WRONG(7) ELSE STACK[J]:=SIN(STACK[J])/COS(STACK[J]); 'I','i','R','r': BEGIN IF ABS(STACK[J])>32767 THEN WRONG(8) ELSE CASE OP OF 'I','i':STACK[J]:=TRUNC(STACK[J]); 'R','r':STACK[J]:=ROUND(STACK[J]); END {OF CASE} END; 'L','l','G','g': BEGIN IF STACK[J]<=0 THEN WRONG(9) ELSE CASE OP OF 'L','l':STACK[J]:=LN(STACK[J]); 'G','g':STACK[J]:=LOG(STACK[J]); END {OF CASE} END; 'H','h': BEGIN IF ABS(STACK[J])>1 THEN WRONG(12) ELSE IF ABS(STACK[J])=1 THEN STACK[J]:=2*ATAN(STACK[J]) ELSE STACK[J]:=ATAN(STACK[J]/SQRT(1-SQR(STACK[J]))) END; 'U','u':ARCCOSINE; 'D','d':STACK[J]:=ABS(STACK[J]); 'A','a':STACK[J]:=ATAN(STACK[J]); 'E','e': BEGIN CHECK_EXPONENT(STACK[J]); STACK[J]:=EXP(STACK[J]) END; 'Q','q':IF STACK[J]<0 THEN WRONG(10) ELSE STACK[J]:=SQRT(STACK[J]); 'B','b':STACK[J]:=SQR(STACK[J]); 'P':; 'N':STACK[J]:=-STACK[J]; END; {OF CASE} IF OP IN ['a'..'z'] THEN STACK[J]:=-STACK[J] END; IF NOT (J=1) THEN WRONG(11); F:=STACK[1] END {F(X,Y,Z)} END {END OF UNIT POST_ENTRY_OF_FUNCTION}. ======================================================================================== DOCUMENT :usus Folder:VOL22:real_input.text ======================================================================================== { This unit was reconstructed from a function in the program LEVEL_CURVES in the file, CONTOUR.TEXT, to replace a missing unit, EDS_STUFF, in the Grundler submissions. The function INPUT_VALUE was written by Edward J. Grundler (ca. Aug 1979). If the unit is not used with the Grundler programs it may be necessary to edit the lines marked (*****) to fit the console display requirements of your program. } UNIT REAL_INPUT; INTERFACE USES {$U GRAPH.LIBRARY} SCREEN_STUFF; (*****) FUNCTION INPUT_VALUE:REAL; IMPLEMENTATION FUNCTION INPUT_VALUE{:REAL}; VAR I:INTEGER; INP:STRING; DEC,NEX,EX,NEG,OK:BOOLEAN; EXPO,J,X:REAL; BEGIN REPEAT DEC:=FALSE; EX:=FALSE; READLN(INP); IF LENGTH(INP)=0 THEN INP:='0'; OK:=NOT(INP[1]='E'); IF LENGTH(INP)>1 THEN OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E')); FOR I:=1 TO LENGTH(INP) DO BEGIN OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']); IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']); OK:=OK AND NOT(DEC AND(INP[I]='.')); IF NOT DEC THEN DEC:=(INP[I]='.'); OK:=OK AND NOT(EX AND (INP[I]='E')); IF NOT EX THEN EX:=(INP[I]='E'); IF I>1 THEN OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E')); OK:=OK AND NOT(EX AND (INP[I]='.')) END; OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']); OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9'])); IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL) (*****) UNTIL OK; X:=0; DEC:=FALSE; EXPO:=0; NEG:=FALSE; EX:=FALSE; J:=1; FOR I:=1 TO LENGTH(INP) DO BEGIN IF NOT DEC THEN DEC:=(INP[I]='.'); IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-'); IF NOT NEX THEN NEX:=EX AND (INP[I]='-'); IF NOT EX THEN EX:=(INP[I]='E'); IF EX AND NOT(INP[I] IN ['+','-','E']) THEN EXPO:=EXPO*10+ORD(INP[I])-ORD('0'); IF NOT EX THEN BEGIN IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN BEGIN J:=J/10; X:=X+(ORD(INP[I])-ORD('0'))*J END ELSE IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0') END END; IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO); IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X END; END. ======================================================================================== DOCUMENT :usus Folder:VOL22:review.text ======================================================================================== {$L- PRINTER:} UNIT REVIEW; INTERFACE CONST PXMAX = 2000; {for small Hiplot} PYMAX = 1400; TYPE SCREENTYPE = PACKED ARRAY [0..4,0..4] OF BOOLEAN; VAR PENSTATE,OLDIPX,OLDIPY : INTEGER; OLDPEN : BOOLEAN; PROCEDURE INITPLOT; PROCEDURE DRAWLINE(VAR RANGE:INTEGER; VAR S:SCREENTYPE; ROWWIDTH, XSTART,YSTART,DELTAX,DELTAY,INK:INTEGER); PROCEDURE HOME; PROCEDURE THROTTLE(TICKS : INTEGER); IMPLEMENTATION PROCEDURE DMP2PLOT(CH : CHAR); {Note: address of serial board receiver status register and receiver buffer must be specified in decimal. The easy way to do this is illustrated for the standard REMOUT addresses, 177524 and 177526 (not used by the reviewer): 200000 - 177524 = 252 (8) (using octal arithmetic) (0*512)+(2*64)+(5*8)+(2*1) = 172 (10) PXCSR = -172 PXBUF = -170} CONST PXCSR = -684 (*176524 (octal); DLV11J address*); PXBUF = -682 (*176526 (octal); DLV11J address*); BITNO = 7; TYPE INFO = PACKED RECORD CASE BOOLEAN OF TRUE : (CH : PACKED ARRAY [0..1] OF CHAR); FALSE : (BIT : PACKED ARRAY [0..15] OF BOOLEAN); END; IOPORT = PACKED RECORD CASE BOOLEAN OF TRUE : (ADDR : INTEGER); FALSE : (PNTR : ^INFO) END; VAR XCSR,XBUF : IOPORT; BEGIN REPEAT XCSR.ADDR := PXCSR UNTIL XCSR.PNTR^.BIT[BITNO]; XBUF.ADDR := PXBUF; XBUF.PNTR^.CH[0] := CH; END; PROCEDURE ENCODE(COMMAND : INTEGER); CONST SP = ' '; DELAY = 24; (*delay for pen changes*) VAR PENCODE2 : CHAR; I : INTEGER; BEGIN IF (COMMAND IN [0..10]) THEN BEGIN CASE COMMAND OF 0 : PENCODE2 := ' '; (*NOP*) 1 : PENCODE2 := 't'; (*-y*) 2 : PENCODE2 := 'p'; (*+y*) 3 : PENCODE2 := 'z'; (*pen down*) 4 : PENCODE2 := 'v'; (*-x*) 5 : PENCODE2 := 'u'; (*-x,-y*) 6 : PENCODE2 := 'w'; (*-x,+y*) 7 : PENCODE2 := 'y'; (*pen up*) 8 : PENCODE2 := 'r'; (*+x*) 9 : PENCODE2 := 's'; (*+x,-y*) 10 : PENCODE2 := 'q'; (*+x,+y*) END; DMP2PLOT(PENCODE2); IF ((COMMAND IN [3,7]) AND (COMMAND <> PENSTATE)) THEN BEGIN PENSTATE := COMMAND; FOR I := 1 TO DELAY DO DMP2PLOT(SP) END END; END; PROCEDURE PLOT(MOVE,INK : INTEGER); BEGIN IF NOT (INK IN [0..2]) THEN EXIT(PLOT); CASE INK OF 0 : BEGIN OLDIPX := 0; (*set current pen position as plotter origin*) OLDIPY := 0; (*and initializes pen to undefined state*) PENSTATE := 0; EXIT(PLOT) END; 1 : IF (NOT OLDPEN) THEN BEGIN ENCODE(3); (*lower before*) OLDPEN := TRUE END; 2 : IF (OLDPEN) THEN BEGIN ENCODE(7); (*raise before*) OLDPEN := FALSE END; END; (*case*) ENCODE(MOVE) END; PROCEDURE DRAWLINE(*VAR RANGE:INTEGER; VAR S:SCREENTYPE; ROWWIDTH, XSTART,YSTART,DELTAX,DELTAY,INK:INTEGER*); {This is a revision of the Pascal implementation from Version 1.5 manual. Added or revised code in lower case. Several lines were deleted.} VAR X,Y,XINC,YINC,mode,move,xcode,ycode,xycode,dx,dy : INTEGER; PROCEDURE DOFORX; {MORE HORIZONTAL} VAR ERROR,I:INTEGER; BEGIN IF DELTAX=0 THEN EXIT(DRAWLINE); ERROR:=DELTAX DIV 2; I:=DELTAX; REPEAT X := X+XINC; ERROR:=ERROR+DELTAY; IF ERROR>=DELTAX THEN BEGIN ERROR:=ERROR-DELTAX; Y := Y+YINC; move := xycode; if (y>PYMAX) or (y<0) then move := move-ycode END else begin move := xcode; if (x>PXMAX) or (x<0) then move := 0 end; plot(move,ink); I:=I-1; UNTIL I=0 END (*DOFORX*); PROCEDURE DOFORY; {MORE VERTICAL} VAR ERROR,I:INTEGER; BEGIN ERROR:=DELTAY DIV 2; I:=DELTAY; REPEAT Y := Y+YINC; ERROR:=ERROR+DELTAX; IF ERROR>=DELTAY THEN BEGIN ERROR:=ERROR-DELTAY; X := X+XINC; move := xycode; if (x>PXMAX) or (x<0) then move := move-xcode END else begin move := ycode; if (y>PYMAX) or (y<0) then move := 0 end; plot(move,ink); I:=I-1; UNTIL I=0 END (*DOFORY*); BEGIN (*DRAWLINE*) X := XSTART; Y := pymax-YSTART; {in pen coordinates} DELTAY := -DELTAY; {in pen coordinates} if (X<>oldipx) or (Y<>oldipy) then begin dx := x-oldipx; dy := oldipy-y; drawline(RANGE,S,ROWWIDTH,oldipx,pymax-oldipy,dx,dy,2); end; oldipx := x+deltax; oldipy := y+deltay; IF DELTAX < 0 THEN BEGIN xcode := 4; XINC := -1; DELTAX := -DELTAX END ELSE begin xcode := 8; XINC := 1 end; IF DELTAY < 0 THEN BEGIN ycode := 1; YINC := -1; DELTAY := -DELTAY END else begin ycode := 2; YINC := 1 end; xycode := xcode+ycode; IF DELTAX >= DELTAY THEN DOFORX ELSE DOFORY; END (*DRAWLINE*); PROCEDURE INITPLOT; BEGIN PLOT(0,0); ENCODE(7); OLDPEN := FALSE; END; PROCEDURE HOME; VAR RANGE,R:INTEGER; S:SCREENTYPE; BEGIN DRAWLINE(RANGE,S,R,OLDIPX,PYMAX-OLDIPY,-OLDIPX,OLDIPY,2); END; PROCEDURE THROTTLE(*TICKS:INTEGER*); VAR COUNT,HITIME,START,STOP,TIMEDIFF : INTEGER; BEGIN COUNT := 0; TIME(HITIME,START); REPEAT COUNT := COUNT+1; TIME(HITIME,STOP); TIMEDIFF := STOP-START; IF (TIMEDIFF < 0) THEN TIMEDIFF := TIMEDIFF+32767; IF ((TIMEDIFF = 0) AND (COUNT = 1000)) THEN BEGIN GOTOXY(0,23); WRITE(CHR(7),'Turn on the line time clock! Type to continue.'); READLN END; UNTIL (TIMEDIFF >= TICKS) END; END. ======================================================================================== DOCUMENT :usus Folder:VOL22:scrn_stuff.text ======================================================================================== { This unit was written to put in one place the screen handling conventions employed in the Grundler submissions. This unit will have to be edited to fit your terminal or (in the case of the Terak) your terminal emulator. The parameters given here are for the Terak in the Terak terminal emulator mode (which was used by the reviewers). Except for RLF, these will work also for the H19. The RLF given here for the H19 could work for the Terak (as apparently there are some undocumented alternatives), but this was not tested. The original parameters from the Grundler submission are also given; presumably these are for a different terminal emulator. In the original submission, CLEARSCREEN appeared as PAGE(OUTPUT), and was intended to clear the screen of TEXT. This will not work on our Teraks with UCSD version 2.0---and is considered by us to be obsolete. You will have to enter the proper code for the clearing of your TEXT screen without clearing the graphics screen.--- Clifford L. Bettis and Henry E. Baumgarten } {$L- PRINTER:} UNIT SCREEN_STUFF; INTERFACE TYPE SHORTSTRING = STRING[3]; VAR CEOL,CEOP,RLF,CLEAR_LINE : SHORTSTRING; PROCEDURE CLEARSCREEN; PROCEDURE DEFINESTRINGS; IMPLEMENTATION PROCEDURE CLEARSCREEN; {Clears the TEXT screen} VAR CS : PACKED ARRAY[0..1] OF 0..255; BEGIN CS[0] := 27; CS[1] := ORD('E'); UNITWRITE(1,CS,2) END; PROCEDURE DEFINESTRINGS; BEGIN CEOL := '12'; {CEOL clears from cursor to end of line} CEOL[1] := CHR(27); CEOL[2] := 'K'; {The following was used by the Grundlers CEOL := '1'; CEOL[1] := CHR(29);} RLF := '1'; {RLF is a reverse line feed} RLF[1] := CHR(11); {The following is for the H19 RLF := '12'; RLF[1] := CHR(27); RLF[2] := 'I';} {The following was used by the Grundlers RLF := '1'; RLF[1] := CHR(31);} CEOP := '12'; {CEOP clears from cursor to end of page (screen)} CEOP[1] := CHR(27); CEOP[2] := 'J'; {The following was used by the Grundlers CEOP := '1'; CEOP[1] := CHR(11);} CLEAR_LINE := '1'; CLEAR_LINE[1] := CHR(13); {carriage return} CLEAR_LINE := CONCAT(CEOL,CLEAR_LINE); END; END. ======================================================================================== DOCUMENT :usus Folder:VOL22:sines.text ======================================================================================== {$L- SINES.LIST} { program by: EDWARD J GRUNDLER Changes made by reviewer: Reversed ranges in SCREENTYPE. Provided PROCEDURE CLEARSCREEN (for Terak in Terak emulator mode or for H19---Edit for your terminal or emulator). Replaced PAGE(OUTPUT) by CLEARSCREEN. ---Henry E. Baumgarten } PROGRAM SINES; TYPE SCREENTYPE = PACKED ARRAY [0..239,0..319] OF BOOLEAN; VAR S:SCREENTYPE; DEG,PRAD:BOOLEAN; CH:CHAR; X1,Y1,YINC,YMAX,YMIN,A,B,C,D,X,Y:REAL; R,RW,XSTART,YSTART,DX,DY,INK,I:INTEGER; PROCEDURE DRAWLINE(VAR R:INTEGER; S:SCREENTYPE; RW,XSTART,YSTART,DX,DY,INK:INTEGER); EXTERNAL; PROCEDURE CLEARSCREEN; BEGIN WRITE(CHR(27),'E') END; FUNCTION INPUT_VALUE:REAL; VAR I:INTEGER; INP:STRING; DEC,NEX,EX,NEG,OK:BOOLEAN; EXPO,J,X:REAL; BEGIN REPEAT DEC:=FALSE; EX:=FALSE; READLN(INP); IF LENGTH(INP)=0 THEN INP:='0'; OK:=NOT(INP[1]='E'); IF LENGTH(INP)>1 THEN OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E')); FOR I:=1 TO LENGTH(INP) DO BEGIN OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']); IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']); OK:=OK AND NOT(DEC AND(INP[I]='.')); IF NOT DEC THEN DEC:=(INP[I]='.'); OK:=OK AND NOT(EX AND (INP[I]='E')); IF NOT EX THEN EX:=(INP[I]='E'); IF I>1 THEN OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E')); OK:=OK AND NOT(EX AND (INP[I]='.')) END; OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']); OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9'])); IF NOT OK THEN WRITE(CHR(31),'READ ERROR, TRY AGAIN ',CHR(29)) UNTIL OK; X:=0; DEC:=FALSE; EXPO:=0; NEG:=FALSE; EX:=FALSE; J:=1; FOR I:=1 TO LENGTH(INP) DO BEGIN IF NOT DEC THEN DEC:=(INP[I]='.'); IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-'); IF NOT NEX THEN NEX:=EX AND (INP[I]='-'); IF NOT EX THEN EX:=(INP[I]='E'); IF EX AND NOT(INP[I] IN ['+','-','E']) THEN EXPO:=EXPO*10+ORD(INP[I])-ORD('0'); IF NOT EX THEN BEGIN IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN BEGIN J:=J/10; X:=X+(ORD(INP[I])-ORD('0'))*J END ELSE IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0') END END; IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO); IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X END; PROCEDURE HELP; BEGIN CLEARSCREEN; WRITELN('This program plots the functions Y=SIN(X) and Y=A(SIN(BX+C)+D'); WRITELN; WRITELN('The range of "X" is -90 to 720 degrees'); WRITELN('The range of "Y" is determined by the values of "A" and "D"'); WRITELN; WRITELN('The value of "C" can be input as degrees, radians or pi-radians '); WRITELN('as selected by "D", "R" or "P"'); WRITELN; WRITELN; WRITELN('press RETURN to continue'); READLN; CLEARSCREEN END; PROCEDURE PROMPT; BEGIN REPEAT GOTOXY(0,0); WRITELN('SINES: H(elp, D(egrees, R(adians, P(i-radians, Q(uit'); READ(KEYBOARD,CH); CASE CH OF 'H','h','/','?': HELP; 'D','d' : DEG:=TRUE; 'R','r' : ; 'P','p' : PRAD:=TRUE; 'Q','q' : EXIT(PROGRAM); END;{OF CASE} IF CH IN ['D','d','R','r','P','p'] THEN BEGIN GOTOXY(15,3); WRITE('Y=A(SIN(BX+C))+D'); GOTOXY(0,6); WRITE('ENTER A '); A:=INPUT_VALUE; GOTOXY(0,7); WRITE('ENTER B '); B:=INPUT_VALUE; GOTOXY(0,8); WRITE('ENTER C '); C:=INPUT_VALUE; IF DEG THEN C:=C/57.29577951; IF PRAD THEN C:=C*3.141592654; GOTOXY(0,9); WRITE('ENTER D '); D:=INPUT_VALUE END UNTIL CH IN ['D','d','R','r','P','p'] END; PROCEDURE INITIALIZE; BEGIN CLEARSCREEN; FILLCHAR(S,9600,CHR(0)); UNITWRITE(3,S,63); DEG:=FALSE; PRAD:=FALSE; CH:=' ' END; BEGIN{MAIN PROGRAM} REPEAT INITIALIZE; PROMPT; YMAX:=(ABS(A)+D); IF YMAX<1 THEN YMAX:=1; YMIN:=(D-ABS(A)); IF YMIN>-1 THEN YMIN:=-1; YINC:=(YMAX-YMIN)/80; YSTART:=ROUND(239+YMIN/YINC); DRAWLINE(R,S,20,0,YSTART,314,0,1); GOTOXY(79,YSTART DIV 10); WRITE('X'); DRAWLINE(R,S,20,35,239,0,-80,1); GOTOXY(8,15); WRITE('Y'); YSTART:=YSTART+1; FOR I:=0 TO 9 DO BEGIN XSTART:=35*I; DRAWLINE(R,S,20,XSTART,YSTART,0,-5,1) END; FOR I:=0 TO 4 DO BEGIN YSTART:=239-20*I; DRAWLINE(R,S,20,34,YSTART,5,0,1); END; GOTOXY(0,11); WRITE('"X" SCALE GRADUATIONS ARE IN UNITS OF '); IF DEG THEN WRITELN('90 DEGREES') ELSE WRITELN('0.5 PI-RADIANS'); WRITE('"Y" SCALE GRADUATIONS ARE IN UNITS OF ',(YMAX-YMIN)/4:5:2, ' FROM ',YMIN:4:2,' TO ',YMAX:4:2); GOTOXY(80,0); FOR I:=0 TO 313 DO BEGIN X:=-1.570796327+I/314*14.13716694; Y:=A*SIN(B*X+C)+D; X1:=-1.570796327+(I+1)/314*14.13716694; Y1:=A*SIN(B*X1+C)+D; YSTART:=ROUND(239-(SIN(X)-YMIN)/YINC); DY:=ROUND(239-(SIN(X1)-YMIN)/YINC-YSTART); IF ODD((I+1) DIV 4) THEN INK:=1 ELSE INK:=0; DRAWLINE(R,S,20,I,YSTART,1,DY,INK); YSTART:=ROUND(239-(Y-YMIN)/YINC); DY:=ROUND(239-(Y1-YMIN)/YINC-YSTART); DRAWLINE(R,S,20,I,YSTART,1,DY,1) END; GOTOXY(0,2); WRITELN('DOTTED CURVE IS Y=SIN(X)'); WRITELN('SOLID CURVE IS'); GOTOXY(20,5); WRITE('press RETURN to continue'); READLN; UNTIL FALSE END. ======================================================================================== DOCUMENT :usus Folder:VOL22:traverse.text ======================================================================================== {$L- TRAVERSE.LIST} { program by: EDWARD J GRUNDLER Changes made and comments by reviewer: This program used REMOTE and was written to be used with a DECWRITER (presumably an older model than the reviewer's DECWRITER IV). An attempt was made to substitute REMIN and REMOUT for REMOTE, but this change was not tested. The present program uses a rather crude, but presumably effective, way of preventing the computer from outrunning the printer. The hard copy output could be greatly simplified by using PRINTER: or by providing assembly language drivers. Reversed ranges on type SCREEN. Replaced PAGE(OUTPUT) by CLEARSCREEN. Removed definitions of CEOL,EOP,RLF. Added line DEFINESTRINGS to main program. Changed EOP to CEOP. Provided missing unit PLOTTER. Changed TTY to TTYIN AND TTYOUT (hopefully correctly). Defined UP and DOWN (for use with PLOTTER). ---Henry E. Baumgarten } PROGRAM TRAVERSE; USES {$U GRAPH.LIBRARY} SCREEN_STUFF, PLOTTER; CONST MAX_NO_OF_SIDES = 50; F_TO_M = 0.3048; R_TO_D = 57.29577951; SQ_FT_TO_ACRES = 43560.0; UP = 0; DOWN = 1; TYPE SCREEN = PACKED ARRAY[0..239,0..319] OF BOOLEAN; REAL_ARRAY = ARRAY[1..MAX_NO_OF_SIDES] OF REAL; CHAR_ARRAY = ARRAY[1..MAX_NO_OF_SIDES] OF CHAR; VAR CLOSE_D,CLOSE_M,SIDES,I:INTEGER; CLOSE_S,DX,DY,FT_SQ,M_SQ,ACRES,N_MIN,N_MAX,RNG,E_MIN,E_MAX:REAL; REF_D,REF_M,REF_S,REF,PRECISION,PERIMETER,CLOSURE:REAL; FEET:BOOLEAN; L,LA,LB,CLOSE_L1,CLOSE_L2,ANSWER:CHAR; TITLE:STRING; SIDE,DIR,NORTH,EAST,X,Y,XC,YC,DEG,MIN,SEC,SLOPE:REAL_ARRAY; L1,L2,L3:CHAR_ARRAY; PROCEDURE DRAWLINE(VAR R:INTEGER; VAR S:SCREEN; RW,XSTRT,YSTRT,DX,DY,INK:INTEGER); EXTERNAL; PROCEDURE DIS_TO_BEAR(X,Y:REAL; VAR D,M:INTEGER; VAR S:REAL; VAR L1,L2:CHAR); VAR DIST:REAL; BEGIN DIST:=SQRT(SQR(Y)+SQR(X)); IF Y=0 THEN S:=90 ELSE S:=ABS(ATAN(X/Y))*R_TO_D; D:=TRUNC(S); S:=(S-D)*60; M:=TRUNC(S); S:=(S-M)*60; IF Y<0 THEN L1:='S' ELSE L1:='N'; IF X<0 THEN L2:='W' ELSE L2:='E' END; PROCEDURE PLOT_PAPER; CONST SIZE = 1400; VAR INC:REAL; J,XEND,YEND:INTEGER; BEGIN INITPLOT; INC:=RNG/SIZE; XEND:=ROUND((EAST[1]-E_MIN)/INC); YEND:=ROUND((NORTH[1]-N_MIN)/INC); WRITELN('put PAPER in the PLOTTER and press RETURN to continue'); READLN; WRITELN('the LOWER LEFT corner of the plot is location X = 0, Y = 0'); PLOT(UP,XEND,YEND); XEND:=XEND+20; PLOT(DOWN,XEND,YEND); XEND:=XEND-40; PLOT(DOWN,XEND,YEND); XEND:=XEND+20; PLOT(DOWN,XEND,YEND); YEND:=YEND+20; PLOT(DOWN,XEND,YEND); YEND:=YEND-40; PLOT(DOWN,XEND,YEND); YEND:=YEND+20; PLOT(DOWN,XEND,YEND); FOR I:=1 TO SIDES DO BEGIN J:=I MOD SIDES+1; XEND:=ROUND((EAST[J]-E_MIN)/INC); YEND:=ROUND((NORTH[J]-N_MIN)/INC); PLOT(DOWN,XEND,YEND); XEND:=XEND+20; YEND:=YEND+20; PLOT(DOWN,XEND,YEND); XEND:=XEND-40; YEND:=YEND-40; PLOT(DOWN,XEND,YEND); XEND:=XEND+20; YEND:=YEND+20; PLOT(DOWN,XEND,YEND); XEND:=XEND+20; YEND:=YEND-20; PLOT(DOWN,XEND,YEND); XEND:=XEND-40; YEND:=YEND+40; PLOT(DOWN,XEND,YEND); XEND:=XEND+20; YEND:=YEND-20; PLOT(DOWN,XEND,YEND) END; PLOT(UP,1700,1000); PLOT(DOWN,1700,1200); PLOT(DOWN,1660,1160); PLOT(UP,1680,1220); PLOT(DOWN,1680,1260); PLOT(DOWN,1720,1220); PLOT(DOWN,1720,1260); PLOT(UP,0,0) END; PROCEDURE PLOT_SCREEN; CONST SIZE = 240; VAR MIN,MID,MAX,INC:REAL; R,J,XSTRT,XSTP,YSTRT,YSTP:INTEGER; S:SCREEN; BEGIN CLEARSCREEN; FILLCHAR(S,SIZEOF(S),CHR(0)); UNITWRITE(3,S,63); N_MAX:=NORTH[1]; N_MIN:=NORTH[1]; E_MAX:=EAST[1]; E_MIN:=EAST[1]; FOR I:=2 TO SIDES DO BEGIN IF NORTH[I]>N_MAX THEN N_MAX:=NORTH[I] ELSE IF NORTH[I]E_MAX THEN E_MAX:=EAST[I] ELSE IF EAST[I](E_MAX-E_MIN) THEN BEGIN MAX:=N_MAX+(N_MAX-N_MIN)/18; MIN:=N_MIN-(N_MAX-N_MIN)/18 END ELSE BEGIN MAX:=E_MAX+(E_MAX-E_MIN)/18; MIN:=E_MIN-(E_MAX-E_MIN)/18 END; RNG:=MAX-MIN; INC:=RNG/SIZE; MID:=(N_MAX+N_MIN)/2; N_MAX:=MID+INC*120; N_MIN:=MID-INC*120; MID:=(E_MAX+E_MIN)/2; E_MAX:=MID+INC*120; E_MIN:=MID-INC*120; YSTRT:=ROUND((N_MAX-NORTH[1])/INC); XSTRT:=279-ROUND((E_MAX-EAST[1])/INC); FOR I:=1 TO SIDES DO BEGIN J:=I MOD SIDES + 1; YSTP:=ROUND((N_MAX-NORTH[J])/INC); XSTP:=279-ROUND((E_MAX-EAST[J])/INC); DRAWLINE(R,S,20,XSTRT,YSTRT,XSTP-XSTRT,YSTP-YSTRT,1); XSTRT:=XSTP; YSTRT:=YSTP END; WRITELN('press'); WRITELN('RETURN'); WRITELN('to'); WRITELN('continue'); READLN; CLEARSCREEN; UNITWRITE(3,S,7) END; FUNCTION INPUT_VALUE:REAL; { function by: EDWARD J GRUNDLER } VAR I:INTEGER; INP:STRING; DEC,NEX,EX,NEG,OK:BOOLEAN; EXPO,J,X:REAL; BEGIN REPEAT DEC:=FALSE; EX:=FALSE; READLN(INP); IF LENGTH(INP)=0 THEN INP:='0'; OK:=NOT(INP[1]='E'); IF LENGTH(INP)>1 THEN OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E')); FOR I:=1 TO LENGTH(INP) DO BEGIN OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']); IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']); OK:=OK AND NOT(DEC AND(INP[I]='.')); IF NOT DEC THEN DEC:=(INP[I]='.'); OK:=OK AND NOT(EX AND (INP[I]='E')); IF NOT EX THEN EX:=(INP[I]='E'); IF I>1 THEN OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E')); OK:=OK AND NOT(EX AND (INP[I]='.')) END; OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']); OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9'])); IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL) UNTIL OK; X:=0; DEC:=FALSE; EXPO:=0; NEG:=FALSE; EX:=FALSE; J:=1; FOR I:=1 TO LENGTH(INP) DO BEGIN IF NOT DEC THEN DEC:=(INP[I]='.'); IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-'); IF NOT NEX THEN NEX:=EX AND (INP[I]='-'); IF NOT EX THEN EX:=(INP[I]='E'); IF EX AND NOT(INP[I] IN ['+','-','E']) THEN EXPO:=EXPO*10+ORD(INP[I])-ORD('0'); IF NOT EX THEN BEGIN IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN BEGIN J:=J/10; X:=X+(ORD(INP[I])-ORD('0'))*J END ELSE IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0') END END; IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO); IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X END; PROCEDURE PRINTOUT; VAR TTYOUT,TTYIN:INTERACTIVE; BEAR_D,BEAR_M,J:INTEGER; BEAR_S,DIST:REAL; CR,LF,L1,L2:CHAR; PROCEDURE DECWAIT; {TO PREVENT DATA OVERRUN AT 9600 BAUD} { procedure by: EDWARD J GRUNDLER } VAR HOLD:CHAR; TTYIN:INTERACTIVE; BEGIN {DECWAIT} HOLD:=' '; RESET(TTYIN,'REMIN:'); UNITREAD(7,HOLD,1,,1); IF UNITBUSY(7) THEN UNITCLEAR(7) (*???*) ELSE BEGIN IF HOLD = CHR(19) THEN {CTRL S} REPEAT READ(TTYIN,HOLD) UNTIL HOLD = CHR(17) {CTRL Q} END; END; {DECWAIT} PROCEDURE PRIN_2; BEGIN {PRIN_2} WRITE(TTYOUT,PERIMETER:17:3,' ',DY:10:3,DX:10:3,CR); DECWAIT; FOR I:=1 TO 4 DO WRITE(TTYOUT,LF); WRITE(TTYOUT,'ABOVE DATA ARE IN '); IF FEET THEN WRITE(TTYOUT,'FEET',CR,LF,LF) ELSE WRITE(TTYOUT,'METERS',CR,LF,LF); WRITE(TTYOUT,'TRAVERSE COMPUTATION AND ADJUSTMENT BY THE COMPASS RULE',CR); FOR I:=1 TO 4 DO WRITE(TTYOUT,LF); DECWAIT; WRITE(TTYOUT,'CLOSURE = '); IF FEET THEN WRITE(TTYOUT,CLOSURE:6:4,' FT = ',CLOSURE*F_TO_M:6:4,' M ') ELSE WRITE(TTYOUT,CLOSURE/F_TO_M:6:4,' FT = ',CLOSURE:6:4,' M '); WRITE(TTYOUT,'CLOSURE BEARING IS ',CLOSE_L1,CLOSE_D:2,CLOSE_M:3,CLOSE_S:5:1, CLOSE_L2,CR,LF); DECWAIT; WRITE(TTYOUT,LF,'PRECISION = 1 IN ',PRECISION:8:3,CR,LF,LF); DECWAIT; WRITE(TTYOUT,'AREA = ',FT_SQ:8:3,' SQ. FT. = ',M_SQ:8:3,' SQ. M. = ', ACRES:6:3,' ACRES',CR,LF); PAGE(TTYOUT) END; {PRIN_2} BEGIN {PRINTOUT} CR:=CHR(13); LF:=CHR(10); REWRITE(TTYOUT,'REMOUT:'); RESET(TTYIN,'REMIN:'); CLEARSCREEN; WRITELN('position PAPER to top of page and press RETURN on DECWRITER'); READLN(TTYIN); {The following line contains commands to the printer, presumably to set character widths on the dot matrix DECWRITER. One would guess that TITLE is set in wide char and the text in smaller char.---heb} WRITE(TTYOUT,CHR(27),CHR(91),CHR(53),CHR(119),TITLE,CR,LF,LF,CHR(27),CHR(91), CHR(49),CHR(119)); FOR I:=1 TO 44 DO WRITE(TTYOUT,' '); WRITE(TTYOUT,'UNBALANCED BALANCED ', 'CORRECTED COORDINATES',CR,LF,'COURSE LENGTH ', 'AZIMUTH SLOPE LAT DEP LAT DEP ', 'DISTANCE BEARING STA NORTH EAST',CR,LF,LF); FOR I:=1 TO SIDES DO BEGIN J:=I MOD SIDES+1; DIS_TO_BEAR(XC[I],YC[I],BEAR_D,BEAR_M,BEAR_S,L1,L2); DIST:=SQRT(SQR(XC[I])+SQR(YC[I])); WRITE(TTYOUT,I:2,' -',J:2,SIDE[I]:11:3,ROUND(DEG[I]):5,ROUND(MIN[I]):3, SEC[I]:5:1,SLOPE[I]:8:3,Y[I]:10:3,X[I]:10:3,YC[I]:10:3,XC[I]:10:3, DIST:10:3,' ',L1,BEAR_D:2,BEAR_M:3,BEAR_S:5:1,L2,' |',I:3, NORTH[I]:13:3,EAST[I]:10:3,CR,LF); DECWAIT END; PRIN_2 END; PROCEDURE D_TO_DMS(I:INTEGER); BEGIN SEC[I]:=DIR[I]; DEG[I]:=TRUNC(SEC[I]); SEC[I]:=(SEC[I]-DEG[I])*60; MIN[I]:=TRUNC(SEC[I]+0.00833333); SEC[I]:=ABS((SEC[I]-MIN[I])*60) END; PROCEDURE QUERY(STR:STRING); BEGIN WRITE(STR); REPEAT READ(KEYBOARD,ANSWER) UNTIL ANSWER IN ['Y','y','N','n']; WRITELN END; PROCEDURE DISPLAY; VAR J:INTEGER; PROCEDURE DISP_2; BEGIN {DISP_2} WRITE('CLOSURE = '); IF FEET THEN WRITE(CLOSURE:6:4,' FT = ',CLOSURE*F_TO_M:6:4,' M ') ELSE WRITE(CLOSURE/F_TO_M:6:4,' FT = ',CLOSURE:6:4,' M '); WRITELN('CLOSURE BEARING IS ',CLOSE_L1,CLOSE_D:2,CLOSE_M:3,CLOSE_S:5:1, CLOSE_L2); WRITELN; WRITELN('PRECISION = 1 IN ',PRECISION:8:3); WRITELN; WRITELN('AREA = ',FT_SQ:6:1,' SQ. FT. = ',M_SQ:6:1,' SQ. M. = ',ACRES:6:3, ' ACRES'); WRITELN; WRITELN('press RETURN to continue'); READLN; CLEARSCREEN END; {DISP_2} BEGIN FOR I:=1 TO SIDES DO BEGIN IF (I MOD 18)=1 THEN BEGIN CLEARSCREEN; WRITELN(TITLE); WRITELN; WRITELN('COURSE LENGTH AZIMUTH UNBALANCED BALANCED', ' COORDINATES'); GOTOXY(27,3); WRITELN('LAT DEP LAT DEP STA NORTH EAST'); WRITELN END; J:=I MOD SIDES+1; WRITELN(I:2,'-',J:2,SIDE[I]:8:3,TRUNC(DEG[I]):4,TRUNC(MIN[I]):3, ROUND(SEC[I]):3,Y[I]:9:3,X[I]:9:3,YC[I]:9:3,XC[I]:9:3,I:3, NORTH[I]:9:2,EAST[I]:9:2); IF I=SIDES THEN WRITE(' ',PERIMETER:10:3,' ',DY:9:3,DX:9:3); IF ((I MOD 18)=0) OR (I=SIDES) THEN BEGIN GOTOXY(50,23); WRITE('press RETURN to continue'); READLN; CLEARSCREEN END END; DISP_2 END; PROCEDURE CALCULATE; VAR J:INTEGER; TRUE,AREA:REAL; PROCEDURE CALC_2; BEGIN {CALC_2} FOR I:=1 TO SIDES DO BEGIN TRUE:=SIDE[I]*COS(SLOPE[I]/R_TO_D); X[I]:=TRUE*SIN(DIR[I]); Y[I]:=TRUE*COS(DIR[I]); DX:=DX+X[I]; DY:=DY+Y[I]; PERIMETER:=PERIMETER+TRUE END; CLOSURE:=SQRT(SQR(DX)+SQR(DY)); DIS_TO_BEAR(-DX,-DY,CLOSE_D,CLOSE_M,CLOSE_S,CLOSE_L1,CLOSE_L2); IF CLOSURE=0 THEN PRECISION:=999999.0 ELSE PRECISION:=PERIMETER/CLOSURE; FOR I:=1 TO SIDES DO BEGIN XC[I]:=X[I]-(SIDE[I]*DX)/PERIMETER; YC[I]:=Y[I]-(SIDE[I]*DY)/PERIMETER; IF NOT (I = SIDES) THEN BEGIN NORTH[I+1]:=NORTH[I]+YC[I]; EAST[I+1]:=EAST[I]+XC[I] END END; FOR I:=1 TO SIDES DO BEGIN J:=I MOD SIDES+1; AREA:=AREA+EAST[I]*NORTH[J]-EAST[J]*NORTH[I] END; AREA:=ABS(AREA)/2; IF FEET THEN BEGIN FT_SQ:=AREA; M_SQ:=FT_SQ*SQR(F_TO_M) END ELSE BEGIN M_SQ:=AREA; FT_SQ:=M_SQ/SQR(F_TO_M) END; ACRES:=FT_SQ/SQ_FT_TO_ACRES END; {CALC_2} BEGIN {CALCULATE} IF L1[1] IN ['R','r','L','l','I','i','E','e'] THEN BEGIN REF:=180+REF_D+REF_M/60+REF_S/3600; IF L IN ['B','b'] THEN BEGIN IF LA IN ['S','s'] THEN REF:=180-REF; IF LB IN ['W','w'] THEN REF:=360-REF END END; FOR I:=1 TO SIDES DO BEGIN IF NOT(L1[I] IN ['A','a']) THEN DIR[I]:=DEG[I]+MIN[I]/60+SEC[I]/3600; CASE L1[I] OF 'A','a','D','d':; 'B','b': BEGIN IF L2[I] IN ['S','s'] THEN DIR[I]:=180-DIR[I]; IF L3[I] IN ['W','w'] THEN DIR[I]:=360-DIR[I]; END; 'R','r':IF I=1 THEN DIR[1]:=REF+180+DIR[1] ELSE DIR[I]:=DIR[I-1]+180+DIR[I]; 'L','l':IF I=1 THEN DIR[1]:=REF+180-DIR[1] ELSE DIR[I]:=DIR[I-1]+180-DIR[I]; 'E','e':IF I=1 THEN DIR[1]:=REF-DIR[1] ELSE DIR[I]:=DIR[I-1]-DIR[1]; 'I','i':IF I=1 THEN DIR[1]:=REF+DIR[1] ELSE DIR[I]:=DIR[I-1]+DIR[I]; END; {OF CASE} REPEAT IF DIR[I]>=360 THEN DIR[I]:=DIR[I]-360 ELSE IF DIR[I]<0 THEN DIR[I]:=DIR[I]+360 UNTIL (DIR[I]>=0) AND (DIR[I]<360) END; FOR I:=1 TO SIDES DO BEGIN D_TO_DMS(I); DIR[I]:=DIR[I]/R_TO_D END; DX:=0; DY:=0; PERIMETER:=0; AREA:=0; CALC_2 END; PROCEDURE INITIALIZE; PROCEDURE GET_REF; BEGIN WRITELN('IS REFERENCE A BEARING OR AN AZIMUTH? '); REPEAT READ(KEYBOARD,L) UNTIL L IN ['B','b','A','a']; IF L IN ['B','b'] THEN BEGIN WRITELN('ENTER QUADRANT'); REPEAT READ(KEYBOARD,LA,LB) UNTIL (LA IN ['N','n','S','s']) AND (LB IN ['E','e','W','w']) END; WRITE('ENTER DEGREES '); REF_D:=INPUT_VALUE; WRITE('ENTER MINUTES '); REF_M:=INPUT_VALUE; WRITE('ENTER SECONDS '); REF_S:=INPUT_VALUE END; {GET_REF} PROCEDURE GET_ANGLE(J:INTEGER); BEGIN UNITWRITE(3,I,7); WRITELN('WHICH OPTION FOR ANGLE ',J,'? '); REPEAT READ(KEYBOARD,L1[J]) UNTIL L1[J] IN ['B','b','R','r','L','l','I','i','E','e','D','d','A','a']; IF (J=1) AND (L1[J] IN ['R','r','L','l','I','i','E','e']) THEN BEGIN WRITELN('CURRENT REFERENCE AZIMUTH IS: ',TRUNC(REF_D):4, TRUNC(REF_M):3,REF_S:5:1); QUERY('IS THAT CORRECT? '); IF ANSWER IN ['N','n'] THEN GET_REF END; IF L1[J] IN ['B','b'] THEN BEGIN WRITELN('ENTER QUADRANT'); REPEAT READ(KEYBOARD,L2[J],L3[J]) UNTIL (L2[J] IN ['N','n','S','s']) AND (L3[J] IN ['E','e','W','w']) END; IF L1[J] IN ['A','a'] THEN BEGIN WRITE('ENTER DECIMAL DEGREES '); DIR[J]:=INPUT_VALUE END ELSE BEGIN WRITE('ENTER DEGREES FOR ANGLE ',J,' '); DEG[J]:=INPUT_VALUE; WRITE('ENTER MINUTES '); MIN[J]:=INPUT_VALUE; WRITE('ENTER SECONDS '); SEC[J]:=INPUT_VALUE END; UNITWRITE(3,I,3) END; {GET_ANGLE} PROCEDURE INIT_2; VAR J:INTEGER; PROCEDURE FIX_IT; VAR J:INTEGER; X:REAL; BEGIN {FIX_IT} QUERY('ARE ANY LENGTHS INCORRECT? '); IF ANSWER IN ['Y','y'] THEN BEGIN REPEAT REPEAT WRITE(RLF,'WHICH SIDE IS IN ERROR? ',CEOL); J:=ROUND(INPUT_VALUE) UNTIL (J>((I-1) DIV 12*12)) AND (J<=I); WRITE(RLF,'ENTER NEW VALUE ',CEOL); SIDE[J]:=INPUT_VALUE; GOTOXY(4,(J-1) MOD 12+10); WRITE(SIDE[J]:10:3); GOTOXY(0,I+10); QUERY('ARE THERE ANY MORE LENGTHS THAT ARE INCORRECT? '); UNTIL ANSWER IN ['N','n']; END; WRITE(RLF,CEOL); QUERY('ARE ANY DIRECTIONS IN ERROR? '); IF ANSWER IN ['Y','y'] THEN BEGIN REPEAT REPEAT WRITE(RLF,'WHICH SIDE IS IN ERROR? ',CEOL); J:=ROUND(INPUT_VALUE) UNTIL (J>((I-1) DIV 12*12)) AND (J<=I); GET_ANGLE(J); UNITWRITE(3,I,7); GOTOXY(16,(J-1) MOD 12+10); IF L1[J] IN ['A','a'] THEN WRITE('A ',DIR[J]:10:4) ELSE BEGIN IF L1[J] IN ['B','b'] THEN WRITE(L1[J],' ',L2[J],L3[J]) ELSE WRITE(L1[J],' '); WRITE(TRUNC(DEG[J]):4,TRUNC(MIN[J]):3,SEC[J]:5:1) END; GOTOXY(0,I+10); QUERY('ARE THERE ANY MORE DIRECTIONS IN ERROR? '); WRITE(CEOP) UNTIL ANSWER IN ['N','n']; WRITE(RLF,CEOL) END END; {FIX_IT} PROCEDURE GET_SLOPES; VAR J:INTEGER; INP:REAL; BEGIN {GET_SLOPES} GOTOXY(34,8); WRITE('SLOPE ANGLE'); GOTOXY(0,I+10); REPEAT REPEAT WRITE('WHICH SIDE IS A SLOPE DISTANCE ',CEOL); J:=ROUND(INPUT_VALUE); WRITE(RLF); UNTIL (J>((I-1) DIV 12*12)) AND (J<=I); WRITE('ENTER SLOPE DEGREES ',CEOL); SLOPE[J]:=INPUT_VALUE; GOTOXY(34,(J-1) MOD 12+10); WRITE(ROUND(SLOPE[J]):3); GOTOXY(0,I+10); WRITE('ENTER SLOPE MINUTES ',CEOL); INP:=INPUT_VALUE; GOTOXY(37,(J-1) MOD 12+10); WRITE(ROUND(INP):3); GOTOXY(0,I+10); SLOPE[J]:=SLOPE[J]+INP/60; WRITE('ENTER SLOPE SECONDS ',CEOL); INP:=INPUT_VALUE; GOTOXY(40,(J-1) MOD 12+10); WRITE(INP:5:1); GOTOXY(0,I+10); SLOPE[J]:=(SLOPE[J]+INP/3600); WRITE(CEOL); QUERY('ARE ANY MORE LENGTHS ENTERED AS SLOPE DISTANCES? ') UNTIL ANSWER IN ['N','n'] END; PROCEDURE INIT_3; BEGIN {INIT_3} CLEARSCREEN; REPEAT WRITE('ENTER THE NORTH CO-ORDINATE OF STATION "1" '); NORTH[1]:=INPUT_VALUE; WRITE('NORTH CO-ORDINATE IS ',NORTH[1]:8:3); QUERY(' IS THAT CORRECT? ') UNTIL ANSWER IN ['Y','y']; REPEAT WRITE('ENTER THE EAST CO-ORDINATE OF STATION "1" '); EAST[1]:=INPUT_VALUE; WRITE('EAST CO-ORDINATE IS ',EAST[1]:8:3); QUERY(' IS THAT CORRECT? ') UNTIL ANSWER IN ['Y','y']; END; {INIT_3} BEGIN {INIT_2} IF L1[1] IN ['R','r','L','l','I','i','E','e'] THEN REPEAT GOTOXY(0,8); IF L IN ['A','a'] THEN WRITELN('REFERENCE AZIMUTH IS', TRUNC(REF_D):4,TRUNC(REF_M):4,REF_S:5:1,CEOP) ELSE WRITELN('REFERENCE BEARING IS ', LA,TRUNC(REF_D):2,TRUNC(REF_M):3,REF_S:5:1,LB,CEOP); QUERY('IS THAT CORRECT? '); IF ANSWER IN ['N','n'] THEN GET_REF UNTIL ANSWER IN ['Y','y']; FOR I:=1 TO SIDES DO BEGIN IF ((I MOD 12) = 1) THEN BEGIN UNITWRITE(3,I,7); GOTOXY(0,8); WRITELN(CEOP,'SIDE LENGTH CODE DIRECTION'); WRITELN END; WRITE(I:4,SIDE[I]:10:3,' '); IF L1[I] IN ['A','a'] THEN WRITELN('A ',DIR[I]:10:4) ELSE BEGIN IF L1[I] IN ['B','b'] THEN WRITE(L1[I],' ',L2[I],L3[I]) ELSE WRITE(L1[I],' '); WRITELN(TRUNC(DEG[I]):4,TRUNC(MIN[I]):3,SEC[I]:5:1) END; IF ((I MOD 12)=0) OR (I=SIDES) THEN BEGIN QUERY('ARE ALL OF THE ABOVE DATA CORRECT? '); WRITE(RLF,CEOL); IF ANSWER IN ['N','n'] THEN FIX_IT; FOR J:=1 TO SIDES DO SLOPE[J]:=0; QUERY('WERE ANY LENGTHS ENTERED AS SLOPE DISTANCES? '); IF ANSWER IN ['Y','y'] THEN GET_SLOPES; WRITE(RLF,CEOL) END END; INIT_3 END; {INIT_2} BEGIN {INITIALIZE} DEFINESTRINGS; CLEARSCREEN; REF_D:=0; REF_M:=0; REF_S:=0; REPEAT WRITELN('ENTER THE TITLE OF THE TRAVERSE'); READLN(TITLE); WRITELN(TITLE); QUERY('--IS THAT CORRECT? '); UNTIL ANSWER IN ['Y','y']; REPEAT REPEAT WRITE('ENTER NUMBER OF SIDES '); SIDES:=ROUND(INPUT_VALUE); IF SIDES>MAX_NO_OF_SIDES THEN WRITE('MAXIMUM IS ',MAX_NO_OF_SIDES,' --'); UNTIL SIDES IN [3..MAX_NO_OF_SIDES]; WRITE('TRAVERSE HAS ',SIDES,' SIDES. '); QUERY('IS THAT CORRECT? ') UNTIL ANSWER IN ['Y','y']; REPEAT WRITELN('WILL LENGTHS BE ENTERED IN M(eters OR F(eet? '); READ(KEYBOARD,ANSWER) UNTIL ANSWER IN ['M','m','F','f']; FEET:=ANSWER IN ['F','f']; CLEARSCREEN; UNITWRITE(3,I,3); WRITELN('ENTRY OPTIONS ARE:'); WRITELN; WRITELN('B(earing'); WRITELN('interior angles to the R(ight or L(eft'); WRITELN('deflection angles to the rI(ght or lE(ft'); WRITELN('azimuth in D(egrees, minutes and seconds'); WRITELN('A(zimuth in decimal degrees'); FOR I:=1 TO SIDES DO BEGIN GOTOXY(0,8); WRITE(CEOP,'ENTER HORIZONTAL OR SLOPE LENGTH OF SIDE ',I,' '); SIDE[I]:=INPUT_VALUE; GET_ANGLE(I) END; INIT_2 END; BEGIN {TRAVERSE} REPEAT INITIALIZE; CALCULATE; DISPLAY; QUERY('DO YOU WANT A HARD COPY? '); IF ANSWER IN ['Y','y'] THEN PRINTOUT; PLOT_SCREEN; QUERY('DO YOU WANT A HARD COPY? '); IF ANSWER IN ['Y','y'] THEN PLOT_PAPER; QUERY('IS THAT THE LAST TRAVERSE? ') UNTIL ANSWER IN ['Y','y']; CLEARSCREEN END {TRAVERSE}. ======================================================================================== DOCUMENT :usus Folder:VOL22:triangle.text ======================================================================================== {$L-TRIANGLE.LIST} { TRIANGLE program by: KEN GAAL 15-AUG-79 Changes made by reviewer: Reversed ranges in type SCREENTYPE. Replaced PAGE(OUTPUT) with CLEARSCREEN. Replaced CHR(31) with RLF. Replaced CHR(29) with CEOL. ___Henry E. Baumgarten } PROGRAM TRIANGLE; USES {$U GRAPH.LIBRARY} SCREEN_STUFF; CONST DTR=0.01745329; RTD=57.29578; TYPE SCREENTYPE = PACKED ARRAY [0..239,0..319] OF BOOLEAN; VAR S: SCREENTYPE; VALID,AMBIG,LABEL2,USES_SSAAA: BOOLEAN; AA,AB,AC,AA2,AB2,AC2, { ANGLES } SA,SB,SC,SA2,SB2,SC2, { SIDES } SINA,COSA,SINB,COSB: REAL; KTYP,R : INTEGER; PROCEDURE DRAWLINE(VAR R:INTEGER; S:SCREENTYPE; RW,XSTART,YSTART,DX,DY,INK:INTEGER); EXTERNAL; FUNCTION INPUT_VALUE:REAL; VAR I:INTEGER; INP:STRING; DEC,NEX,EX,NEG,OK:BOOLEAN; EXPO,J,X:REAL; BEGIN REPEAT DEC:=FALSE; EX:=FALSE; READLN(INP); IF LENGTH(INP)=0 THEN INP:='0'; OK:=NOT(INP[1] IN ['E','-'] ); IF LENGTH(INP)>1 THEN OK:=OK AND NOT((INP[1] IN ['+','-','.']) AND (INP[2]='E')); FOR I:=1 TO LENGTH(INP) DO BEGIN OK:=OK AND (INP[I] IN ['.','-','+','E','0'..'9']); IF (I>1) AND NOT EX THEN OK:=OK AND (INP[I] IN ['.','E','0'..'9']); OK:=OK AND NOT(DEC AND(INP[I]='.')); IF NOT DEC THEN DEC:=(INP[I]='.'); OK:=OK AND NOT(EX AND (INP[I]='E')); IF NOT EX THEN EX:=(INP[I]='E'); IF I>1 THEN OK:=OK AND NOT(EX AND (INP[I] IN ['+','-']) AND NOT(INP[I-1]='E')); OK:=OK AND NOT(EX AND (INP[I]='.')) END; OK:=OK AND (INP[LENGTH(INP)] IN ['0'..'9','.']); OK:=OK AND NOT(EX AND NOT(INP[LENGTH(INP)] IN ['0'..'9'])); IF NOT OK THEN WRITE(RLF,'READ ERROR, TRY AGAIN ',CEOL) UNTIL OK; X:=0; DEC:=FALSE; EXPO:=0; NEG:=FALSE; EX:=FALSE; J:=1; FOR I:=1 TO LENGTH(INP) DO BEGIN IF NOT DEC THEN DEC:=(INP[I]='.'); IF NOT NEG THEN NEG:=NOT EX AND (INP[I]='-'); IF NOT NEX THEN NEX:=EX AND (INP[I]='-'); IF NOT EX THEN EX:=(INP[I]='E'); IF EX AND NOT(INP[I] IN ['+','-','E']) THEN EXPO:=EXPO*10+ORD(INP[I])-ORD('0'); IF NOT EX THEN BEGIN IF DEC AND NOT(INP[I] IN ['.','+','-']) THEN BEGIN J:=J/10; X:=X+(ORD(INP[I])-ORD('0'))*J END ELSE IF NOT(INP[I] IN ['.','+','-']) THEN X:=X*10+ORD(INP[I])-ORD('0') END END; IF EX AND NEX THEN EXPO:=-EXPO;X:=X*EXP(LN(10)*EXPO); IF NEG THEN INPUT_VALUE:=-X ELSE INPUT_VALUE:=X END; PROCEDURE DATA_IN; VAR CH: CHAR; BEGIN GOTOXY(0,23); WRITE('enter Q to quit or RETURN to continue'); READ(KEYBOARD,CH); IF CH IN ['q','Q'] THEN EXIT(PROGRAM); CLEARSCREEN; FILLCHAR(S,9600,CHR(0)); UNITWRITE(3,S,63); { CLEAR SCREEN } GOTOXY(0,1); WRITELN('ENTER, AS REQUESTED, VALUES OF SIDES AND ANGLES (DECIMAL DEG.)'); WRITELN(' press RETURN if side or angle is not input'); WRITELN; WRITELN('SIDE a '); SA:=INPUT_VALUE; WRITELN('SIDE b '); SB:=INPUT_VALUE; WRITELN('SIDE c '); SC:=INPUT_VALUE; WRITELN('ANGLE A '); AA:=INPUT_VALUE; WRITELN('ANGLE B '); AB:=INPUT_VALUE; WRITELN('ANGLE C '); AC:=INPUT_VALUE; CLEARSCREEN; UNITWRITE(3,S,63); GOTOXY(0,1); WRITELN('INPUT VALUES'); WRITELN(' SIDES: a = ',SA:8:3,' b = ',SB:8:3,' c = ',SC:8:3); WRITELN(' ANGLES: A = ',AA:8:3,' B = ',AB:8:3,' C = ',AC:8:3); END; { procedure DATA_IN } PROCEDURE PERMUTE; VAR TEMP: REAL; BEGIN TEMP:=AB; AB:=AA; AA:=AC; AC:=TEMP; TEMP:=SB; SB:=SA; SA:=SC; SC:=TEMP; END; { procedure PERMUTE } PROCEDURE XCHG_BC; VAR TEMP: REAL; BEGIN TEMP:=SB; SB:=SC; SC:=TEMP; TEMP:=AB; AB:=AC; AC:=TEMP; END; { procedure XCHG_BC } FUNCTION APPROX(X,Y:real): boolean; var ERR,AX,AXMY: real; begin ERR:=0.001; AX:=ABS(X); AXMY:=ABS(X-Y); APPROX:=(AXMY=0); if (AXMY=0) then EXIT(APPROX); if AX>0 then APPROX:=(AXMY/AX < ERR) else APPROX:=(AXMY/ABS(Y) < ERR); end; { of function APPROX } PROCEDURE SSS; BEGIN WRITE(' SSS'); IF SA >= SB+SC THEN BEGIN VALID:=FALSE; WRITE(' a >= b+c') END; IF SB >= SA+SC THEN BEGIN VALID:=FALSE; WRITE(' b >= a+c') END; IF SC >= SA+SB THEN BEGIN VALID:=FALSE; WRITE(' c >= a+b') END; IF NOT VALID THEN WRITE(' sides do NOT make a triangle'); IF VALID THEN BEGIN COSA:=(SQR(SC)+SQR(SB)-SQR(SA))/(2*SC*SB); SINA:=SQRT(1-COSA*COSA); IF COSA = 0 THEN AA:=90 ELSE AA:=ATAN(SINA/COSA)*RTD; IF AA<0 THEN AA:=AA+180; COSB:=(SQR(SA)+SQR(SC)-SQR(SB))/(2*SA*SC); SINB:=SQRT(1-COSB*COSB); IF COSB = 0 THEN AB:=90 ELSE AB:=ATAN(SINB/COSB)*RTD; IF AB<0 THEN AB:=AB+180; AC := 180-AA-AB END; { if VALID } END; { procedure SSS } PROCEDURE SAS; begin WRITE(' SAS'); CASE KTYP OF { permute SAS so that A = angle a (AA) } 28: ; { A=AA } 42: begin PERMUTE; PERMUTE end; { A=AB } 49: PERMUTE; { A=AC } END; { case KTYP } IF AA >= 180 THEN begin VALID:=FALSE; CASE KTYP OF 28: WRITE(' Angle A >= 180 DEG'); 42: WRITE(' Angle B >= 180 DEG'); 49: WRITE(' Angle C >= 180 DEG'); END; { case KTYP } end; { if AA >= 180 } IF VALID THEN begin SA:=SQRT(SB*SB+SC*SC-2*SB*SC*COS(AA*DTR)); { law of cosines } COSB:=(SQR(SA)+SQR(SC)-SQR(SB))/(2*SA*SC); SINB:=SQRT(1-COSB*COSB); IF COSB = 0 THEN AB:=90 ELSE AB:=ATAN(SINB/COSB)*RTD; IF AB < 0 THEN AB:=AB+180; AC:=180-AA-AB end; { if VALID } CASE KTYP OF { PERMUTE back to original labels } 28: ; 42: PERMUTE; 49: begin PERMUTE; PERMUTE end; END; { of case KTYP } end; { of procedure SAS } PROCEDURE ASA; begin WRITE(' ASA'); CASE KTYP OF { permute ASA so that S = side c (SC) } 14: ; { S = SC } 21: PERMUTE; { S = SB } 35: begin PERMUTE; PERMUTE end; { S = SA } END; { case KTYP } IF AA+AB >= 180 THEN begin VALID:=FALSE; WRITE('Angles '); CASE KTYP OF 14: WRITE('A + B '); 21: WRITE('A + C '); 35: WRITE('B + C '); END; { of case KTYP } WRITE(' >= 180 DEGREES') end; { of IF AA+BB >= 180 } IF VALID THEN { solve for parts of triangle } begin AC:=180-AA-AB; SA:=SC*SIN(AA*DTR)/SIN(AC*DTR); SB:=SC*SIN(AB*DTR)/SIN(AC*DTR) end; { of IF VALID } CASE KTYP OF { permute triangle back to original labels } 14: ; 21: begin PERMUTE; PERMUTE end; 35: PERMUTE; END; { of case KTYP } end; { of procedure ASA } PROCEDURE SAA; begin WRITE(' SAA'); CASE KTYP OF { validity check and 3rd angle computation } 11,19: IF AB+AC >= 180 THEN begin VALID:=FALSE; WRITE(' Angles B + C >= 180') end ELSE AA:=180-AB-AC; 13,37: IF AA+AC >= 180 THEN begin VALID:=FALSE; WRITE(' Angles A + C >= 180') end ELSE AB:=180-AA-AC; 22,38: IF AA+AB >= 180 THEN begin VALID:=FALSE; WRITE(' Angles A + B >= 180') end ELSE AC:=180-AA-AB; END; { case KTYP } IF VALID THEN begin CASE KTYP OF { permute labels so that S = side c (SC) } 11,13: ; { S = SC } 19,22: PERMUTE; { S = SB } 37,38: begin PERMUTE; PERMUTE end; { S = SA } END; { of case KTYP } SA:=SC*SIN(AA*DTR)/SIN(AC*DTR); SB:=SC*SIN(AB*DTR)/SIN(AC*DTR); CASE KTYP OF { permute lables back to original positions } 11,13: ; 19,22: begin PERMUTE; PERMUTE end; 37,38: PERMUTE; END; { of case KTYP } end; { if VALID then } end; { of procedure SAA } PROCEDURE ASS; VAR TEST: real; PROCEDURE CONVERT_BACK; begin CASE KTYP OF { convert back to original labels } 52: ; 44: XCHG_BC; 50: begin XCHG_BC; PERMUTE end; 26: PERMUTE; 41: begin PERMUTE; PERMUTE end; 25: begin XCHG_BC; PERMUTE; PERMUTE end; END; { of case KTYP } end; { procedure CONVERT_BACK } PROCEDURE AMBIG_PERMUTE; VAR TEMP: REAL; BEGIN TEMP:=AB2; AB2:=AA2; AA2:=AC2; AC2:=TEMP; TEMP:=SB2; SB2:=SA2; SA2:=SC2; SC2:=TEMP; END; { procedure AMBIG_PERMUTE } PROCEDURE AMBIG_XCHG_BC; VAR TEMP: REAL; BEGIN TEMP:=SB2; SB2:=SC2; SC2:=TEMP; TEMP:=AB2; AB2:=AC2; AC2:=TEMP; END; { procedure AMBIG_XCHG_BC } PROCEDURE AMBIG_CONVERT_BACK; begin CASE KTYP OF { convert back to original labels } 52: ; 44: AMBIG_XCHG_BC; 50: begin AMBIG_XCHG_BC; AMBIG_PERMUTE end; 26: AMBIG_PERMUTE; 41: begin AMBIG_PERMUTE; AMBIG_PERMUTE end; 25: begin AMBIG_XCHG_BC; AMBIG_PERMUTE; AMBIG_PERMUTE end; END; { of case KTYP } end; { procedure AMBIG_CONVERT_BACK } begin { procedure ASS } WRITE(' ASS'); IF AA+AB+AC >= 180 THEN begin VALID:=FALSE; WRITE(' input angle >= 180 '); EXIT(ASS) end; CASE KTYP OF { convert to ASS type: AA,SB,SA } 52: ; { AA,SB,SA } 44: XCHG_BC; { AA,SC,SA } 50: begin PERMUTE; PERMUTE; XCHG_BC end; { AB,SA,SB } 26: begin PERMUTE; PERMUTE end; { AB,SC,SB } 41: PERMUTE; { AC,SA,SC } 25: begin PERMUTE; XCHG_BC end; { AC,SB,SC } END; { of case KTYP } TEST:=SB*SIN(AA*DTR); IF SA < TEST THEN begin VALID:=FALSE; WRITE(' NO triangle since side '); CASE KTYP OF 44,52: WRITE('a'); 26,50: WRITE('b'); 25,41: WRITE('c'); END; {of case KTYP } WRITE(' WILL NOT reach the opposite side'); EXIT(ASS) end; { of if SA < TEST } IF (SA=TEST) THEN begin WRITE(' a RIGHT triangle'); AB:=90; AC:=90-AA; SC:=SB*COS(AA*DTR) end; IF (SA >= SB) THEN begin WRITE(' one triangle'); SINB:=SIN(AA*DTR)*SB/SA; COSB:=SQRT(1-SINB*SINB); AB:=ATAN(SINB/COSB)*RTD; AC:=180-AA-AB; SC:=SA*SIN(AC*DTR)/SIN(AA*DTR) end; IF (SA > TEST) and (SA < SB) THEN begin WRITE(' AMBIGUOUS CASE 1st solution'); AMBIG:=TRUE; SINB:=SIN(AA*DTR)*SB/SA; COSB:=SQRT(1-SINB*SINB); AB:=ATAN(SINB/COSB)*RTD; AC:=180-AA-AB; SC:=SA*SIN(AC*DTR)/SIN(AA*DTR); AA2:=AA; SB2:=SB; SA2:=SA; AB2:=180-AB; AC2:=180-AA2-AB2; SC2:=SA2*SIN(AC2*DTR)/SIN(AA2*DTR) end; CONVERT_BACK; IF AMBIG THEN AMBIG_CONVERT_BACK; end; { of procedure ASS } PROCEDURE AAA; begin WRITE(' AAA'); IF AA+AB+AC <> 180 THEN begin VALID:=FALSE; WRITE(' NO triangle since then angle sum <> 180'); EXIT(AAA) end; IF NOT USES_SSAAA THEN WRITE(' all solutions are SIMILAR to the following triangle'); SA:=1; SB:=SA*SIN(AB*DTR)/SIN(AA*DTR); SC:=SA*SIN(AC*DTR)/SIN(AA*DTR) end; { of procedure AAA } PROCEDURE SAAA; begin WRITE(' SAAA'); IF AA+AB+AC <> 180 THEN begin VALID:=FALSE; WRITE(' angle sum <> 180'); EXIT(SAAA) end; CASE KTYP OF { convert side S so that S = SA } 15: PERMUTE; { S=SC } 23: begin PERMUTE; PERMUTE end; { S=SB } 39: ; { S=SA } END; { of case KTYP } SB:=SA*SIN(AB*DTR)/SIN(AA*DTR); SC:=SA*SIN(AC*DTR)/SIN(AA*DTR); CASE KTYP OF { restore labels } 15: begin PERMUTE; PERMUTE end; 23: PERMUTE; 39: ; END; { of case KTYP } end; { of procedure SAAA } PROCEDURE SSAA; begin WRITE(' SSAA'); IF AA+AB+AC >= 180 THEN begin VALID:=FALSE; WRITE(' NO TRIANGLE since sum of the two input angles >= 180'); EXIT(SSAA) end; CASE KTYP OF { compute 3rd angle } 27,43,51: AA:=180-AB-AC; 29,45,53: AB:=180-AA-AC; 30,46,54: AC:=180-AA-AB; END; { of case KTYP } CASE KTYP OF { test for consistency; if so, compute 3rd side } 27,29,30: IF APPROX(SIN(AB*DTR)/SB, SIN(AC*DTR)/SC) then SA:=SB*SIN(AA*DTR)/SIN(AB*DTR) else VALID:=FALSE; 43,45,46: IF APPROX(SIN(AA*DTR)/SA, SIN(AC*DTR)/SC) then SB:=SA*SIN(AB*DTR)/SIN(AA*DTR) else VALID:=FALSE; 51,53,54: IF APPROX(SIN(AA*DTR)/SA, SIN(AB*DTR)/SB) then SC:=SA*SIN(AC*DTR)/SIN(AA*DTR) else VALID:=FALSE; END; { of case KTYP } IF NOT VALID THEN WRITE(' NO TRIANGLE since input values inconsistent'); end; { of procedure SSAA } PROCEDURE SSSA; VAR ASAVE: real; begin WRITE(' SSSA'); ASAVE:=AA+AB+AC; SSS; IF VALID then CASE KTYP OF { check for consistent input angle } 57: VALID:=APPROX(AC,ASAVE); 58: VALID:=APPROX(AB,ASAVE); 60: VALID:=APPROX(AA,ASAVE); END; { of case KTYP } IF NOT VALID THEN WRITE(' NO TRIANGLE - inconsistent data'); end; { of procedure SSSA } PROCEDURE SSAAA; VAR SAX,SBX,SCX,RATIO: real; begin WRITE(' SSAAA'); USES_SSAAA:=TRUE; CASE KTYP OF { save sides for consistency comparison tests } 31: begin SBX:=SB; SCX:=SC end; 47: begin SAX:=SA; SCX:=SC end; 55: begin SAX:=SA; SBX:=SB end; END; { of case KTYP } AAA; IF VALID then CASE KTYP OF 31: VALID:=APPROX(SBX*SC,SCX*SB); 47: VALID:=APPROX(SAX*SC,SCX*SA); 55: VALID:=APPROX(SAX*SB,SBX*SA); END; { of case KTYP } IF VALID THEN begin CASE KTYP OF 31: RATIO:=SBX/SB; 47,55: RATIO:=SAX/SA; END; SA:=SA*RATIO; SB:=SB*RATIO; SC:=SC*RATIO end ELSE WRITE(' NO TRIANGLE - inconsistent data') end; { of procedure SSAAA } PROCEDURE SSSAA; VAR AAX,ABX,ACX: REAL; begin WRITE(' SSSAA'); IF AA+AB+AC >= 180 THEN begin VALID:=FALSE; WRITE(' NO TRIANGLE - INPUT ANGLES >= 180'); EXIT(SSSAA) end; CASE KTYP OF { save angles for consistency comparison test } 59: begin ABX:=AB; ACX:=AC end; 61: begin AAX:=AA; ACX:=AC end; 62: begin AAX:=AA; ABX:=AB end; END; SSS; IF VALID then CASE KTYP OF 59: VALID:=APPROX(ABX,AB) and APPROX(ACX,AC); 61: VALID:=APPROX(AAX,AA) and APPROX(ACX,AC); 62: VALID:=APPROX(AAX,AA) and APPROX(ABX,AB); END; IF NOT VALID THEN WRITE(' NO TRIANGLE - inconsistent data'); end; { of procedure SSSAA } PROCEDURE SSSAAA; VAR AAX,ABX,ACX: real; begin WRITE(' SSSAAA'); IF AA+AB+AC <> 180 THEN begin VALID:=FALSE; WRITE(' NO TRIANGLE since angle sum <> 180'); EXIT(SSSAAA) end; AAX:=AA; ABX:=AB; ACX:=AC; SSS; VALID := APPROX(AA,AAX) and APPROX(AB,ABX) and APPROX(AC,ACX); IF NOT VALID THEN WRITE(' NO TRIANGLE - inconsistent data') end; { of procedure SSSAAA } PROCEDURE ANALYZE; BEGIN KTYP:=0; IF AC > 0 THEN KTYP:=KTYP + 1 ; IF AB > 0 THEN KTYP:=KTYP + 2 ; IF AA > 0 THEN KTYP:=KTYP + 4 ; IF SC > 0 THEN KTYP:=KTYP + 8 ; IF SB > 0 THEN KTYP:=KTYP +16 ; IF SA > 0 THEN KTYP:=KTYP +32 ; VALID := TRUE; AMBIG := FALSE; LABEL2:=FALSE; USES_SSAAA:=FALSE; CASE KTYP OF 56: SSS; 28,42,49: SAS; 14,21,35: ASA; 11,13,19,22,37,38: SAA; 25,26,41,44,50,52: ASS; 7: AAA; 0,1,2,3,4,5,6,8,9, 10,12,16,17,18,20, 24,32,33,34,36,40, 48: BEGIN VALID:=FALSE; WRITE(' INSUFFICIENT DATA TO MAKE A TRIANGLE') END; 15,23,39: SAAA; 27,29,30,43,45,46, 51,53,54: SSAA; 57,58,60: SSSA; 31,47,55: SSAAA; 59,61,62: SSSAA; 63: SSSAAA; END; { case KTYP } END; { procedure ANALYZE } PROCEDURE LABEL_TRIANGLE(XA,YA,XB,YB,XC,YC:INTEGER); VAR X,Y: INTEGER; ANG,SIDE,A,PER: REAL; BEGIN X:=XA DIV 4 - 5; Y:=YA DIV 10; IF LABEL2 THEN Y:=Y+1; IF LABEL2 THEN ANG:=AA2 ELSE ANG:=AA; GOTOXY(X,Y); WRITE('A= ',ANG:5:1); X:=((XA+XB) DIV 2) DIV 4 -5; Y:=Y-1; IF LABEL2 THEN SIDE:=SC2 ELSE SIDE:=SC; GOTOXY(X,Y); WRITE('c= ',SIDE:5:1); X:=XB DIV 4 -2; Y:=Y+1; IF LABEL2 THEN ANG:=AB2 ELSE ANG:=AB; GOTOXY(X,Y); WRITE('B= ',ANG:5:1); X:=((XB+XC) DIV 2) DIV 4 -1; Y:=((YB+YC) DIV 2) DIV 10; IF LABEL2 THEN Y:=Y+1; IF LABEL2 THEN SIDE:=SA2 ELSE SIDE:=SA; GOTOXY(X,Y); WRITE('a= ',SIDE:5:1); X:=XC DIV 4 -5; Y:=YC DIV 10; IF LABEL2 THEN Y:=Y+1; IF LABEL2 THEN ANG:=AC2 ELSE ANG:=AC; GOTOXY(X,Y); WRITE('C= ',ANG:5:1); X:=((XA+XC) DIV 2) DIV 4 -5; Y:=((YA+YC) DIV 2) DIV 10 -1; IF LABEL2 THEN Y:=Y+1; IF LABEL2 THEN SIDE:=SB2 ELSE SIDE:=SB; GOTOXY(X,Y); WRITE('b= ',SIDE:5:1); IF LABEL2 THEN X:=42 ELSE X:=3; IF LABEL2 THEN A:=SC2*SB2*SIN(AA2*DTR)/2 ELSE A:=SC*SB*SIN(AA*DTR)/2; IF LABEL2 THEN PER:=SA2+SB2+SC2 ELSE PER:=SA+SB+SC; GOTOXY(X,7); WRITE('AREA=',A:8:3,' PERIMETER=',PER:8:3) END; { procedure LABEL_TRIANGLE } PROCEDURE DISPLAY; var WIDE: boolean; AX,AY,BX,BY,CX,CY, { (x,y) coordinates } AX2,AY2,BX2,BY2,CX2,CY2, { 2nd triangle } XLEFT,YBOT,YDIF: integer; H,H2,W,W2, XC,XC2,XL,XL2,XR,XR2, WMAX,HMAX,SCALE: real; begin GOTOXY(0,5); WRITELN(' a=',SA:8:3,' b=',SB:8:3,' c=',SC:8:3); WRITELN(' A=',AA:8:3,' B=',AB:8:3,' C=',AC:8:3); XLEFT:=41; YBOT:=200; { SW corner of rect for triangle display } YDIF:=1; { downward vertical (dot) displacement for 2nd triangle } WMAX:=240; HMAX:=120; { max width and height of triangle (units=dots) } H:=SB*SIN(AA*DTR); { H is triangle height } XC:=SB*COS(AA*DTR); IF XC < 0 THEN XL:=XC ELSE XL:=0; IF XC > SC THEN XR:=XC ELSE XR:=SC; W:=XR-XL; IF AMBIG THEN { adjust H and W so rect contains both triangles } begin H2:=SB2*SIN(AA2*DTR); IF H2>H THEN H:=H2; XC2:=SB2*COS(AA2*DTR); IF XC2 < XL THEN XL:=XC2; IF XC2 > XR THEN XR:=XC2; IF SC2 > XR THEN XR:=SC2; W:=XR-XL; end; { if AMBIG } IF W/H >= WMAX/HMAX THEN WIDE:=true ELSE WIDE:=false; IF WIDE THEN SCALE:=WMAX/W ELSE SCALE:=HMAX/H; { the following code assigns x,y dot values to the triangle vertices } AY:=YBOT; BY:=YBOT; IF XC >= 0 THEN AX:=XLEFT ELSE AX:=XLEFT-ROUND(XC*SCALE); if AMBIG and (XC2 < XC) and (XC2 < 0) then AX:=XLEFT-ROUND(XC2*SCALE); BX:=AX+ROUND(SC*SCALE); CX:=AX+ROUND(XC*SCALE); CY:=YBOT-ROUND(H*SCALE); DRAWLINE(R,S,20,AX,AY,BX-AX,BY-AY,1); DRAWLINE(R,S,20,BX,BY,CX-BX,CY-BY,1); DRAWLINE(R,S,20,CX,CY,AX-CX,AY-CY,1); LABEL_TRIANGLE(AX,AY,BX,BY,CX,CY); IF AMBIG THEN begin LABEL2:=TRUE; AY2:=YBOT+YDIF; BY2:=YBOT+YDIF; AX2:=AX; BX2:=AX2+ROUND(SC2*SCALE); CY2:=YBOT+YDIF-ROUND(H2*SCALE); CX2:=AX2+ROUND(XC2*SCALE); GOTOXY(50,4); WRITE('2nd solution'); GOTOXY(41,5); WRITE('a=',SA2:8:3,' b=',SB2:8:3,' c=',SC2:8:3); GOTOXY(41,6); WRITE('A=',AA2:8:3,' B=',AB2:8:3,' C=',AC2:8:3); DRAWLINE(R,S,20,AX2,AY2,BX2-AX2,BY2-AY2,1); DRAWLINE(R,S,20,BX2,BY2,CX2-BX2,CY2-BY2,1); DRAWLINE(R,S,20,CX2,CY2,AX2-CX2,AY2-CY2,1); LABEL_TRIANGLE(AX2,AY2,BX2,BY2,CX2,CY2); end { of if AMBIG } end; { of procedure DISPLAY } begin { main program TRIANGLE } REPEAT DATA_IN; ANALYZE; IF VALID THEN DISPLAY UNTIL FALSE; end. { of main program TRIANGLE} ======================================================================================== DOCUMENT :usus Folder:VOL22:vol22.doc.text ======================================================================================== USUS Library Volume 22 Graphics Programs for the Terak (LSI-11) Computer GRAPH.DOC.TEXT 40 Documentation for units and programs on this disk POST.DOC.TEXT 24 Documentation for POST_ENTRY.TEXT REAL_INPUT.TEXT 8 Unit to input real numbers from the console REVIEW.TEXT 14 Unit to facilitate running these programs with a "dumb" Hiplot plotter instead of the Terak POST_ENTRY.TEXT 28 Unit to input functions from the console or a file and to evaluate these functions SCRN_STUFF.TEXT 8 Screen control unit for these programs PLOTTER.TEXT 16 Unit to drive "dumb" Hiplot plotter GRAPHICS.TEXT 28 Fundamental graphics unit for both Terak screen and "dumb" Hiplot plotter FACT_STUFF.TEXT 14 Math unit for factorial, log factorial, and related calculations FUNC.TEXT 24 Plot functions entered from console POLAR.TEXT 22 Plot polar functions entered from console DISTRIB.TEXT 24 Calculate and plot normal, Poisson, and binomial distributions SINES.TEXT 14 Plot sine functions of various types HISTOGRAM.TEXT 20 Plot histograms using data from file or console HISTOGRAM.DATA 2 Sample data file for the above CURVE_FIT.TEXT 28 Polynomial curve fitting and plotting CONTOUR.TEXT 28 Plot contours of 3-dimensional surfaces TRIANGLE.TEXT 40 Constructs triangle with minimum input and plots result TRAVERSE.TEXT 42 A calculating and plotting program for surveyors IVP.TEXT 42 "Solves" differential equations by Euler and 4th order Runge-Kutta techniques and plots solution VOL22.DOC.TEXT 8 You're reading it __________________________________________________________________________ Please transfer the text below to a disk label if you copy this volume. USUS Volume 22 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by Henry Baumgarten from material collected by the Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOL23:df.docum.text ======================================================================================== DF Directory-File utility The Directory-File utility displays a volume directory on a crt screen. The operator can select a file with the cursor and perform functions from a menu with the selected file name. Menu selected options include modification or removal of a file name, moving a file to another volume, entering the SYSTEM.EDITOR, and execution of a code file or initiation of a script file. Operation of the Directory-File utility DF is called into operation by executing the file /DF. The utility will clear the screen and request identification of the volume whose directory is to be displayed. Example: Enter volume id of disk(, to end) [prefix]=> Possible entries in responce to this prompt are: 1) Press the keys labeled and . The utility will relenquish control to the operating system. 2) Press the key labeled . The utility will use the volume identification displayed inside the square brackets. 3) Input a number followed by the key. The number must identify a device which contains a blocked volume. (note: this volume identification will become the default volume in square brackets.) 4) Input a volume identification as defined by the PASCAL operating system. The volume identification may be a volume name, a device name or a device number (prefixed with a # character). (note: this volume identification will become the default volume in square brackets.) With the entry of a volume identification, the utility will display the file names from the directory in order of occurrence. The screen will contain a menu line, the volume name, up to twenty rows in four columns of file names, the number of files defined, and the number of blocks available in the largest contiguous area. Sharing the line with the volume name is the extended directory information for the file pointed to by the cursor. This includes the file name, block length, last modification date, starting block address, number of bytes in the last block of the file, and the file type. The first line of the screen display is a menu list of the functions available. Additional functions are displayed on entry of a ?. The cursor will be on the first character of the first file. Selection of the file to be affected by a function is made with the cursor. Every option is selectable by entering the first character of the option name or the special key indicated in angular brackets. ( i.e. means the key with the word ENTER engraved on it.) 1 The arrow keys move the cursor one file name in the direction indicated by the arrow on the key pressed. The cursor will be positioned on the first character of the file name except when a Change operation is in progress. The left arrow key will move the cursor one column of file names to the left. When in the leftmost column, the cursor will be moved to the rightmost column. The right arrow key or the tab key will move the cursor one column of file names to the right. When in the rightmost column, the cursor will be moved to the leftmost column. The up arrow key will move the cursor up one row in the same column. When on the top row, the cursor will be moved to the bottom row in the same column. The down arrow key will move the cursor down one row in the same column. When on the bottom row, the cursor will be moved to the top row in the same column. The home key will position the cursor on the upper left file name. (i.e. column one, row one) The key will move the cursor down one row in the same column. When on the bottom row, the cursor will be moved to the top row in the next column to the right. When on the last row of the rightmost column, the cursor will be moved to the first row of the leftmost column. 2 Remove Entering the R key marks the file name at the cursor position for removal from the directory. The file will not be removed until the user exits using the , or Quit commands. Directory statistics for the number of files and blocks available are updated as if the file had been removed. This allows the user to perform trial removes without disturbing the volume directory until satisfied with the results of the removal. 3 Change Entering a C key initiates a file name change. Change allows the user to modify the file name at the cursor position. Left and right arrow keys move the cursor across the file name field without disturbing the file name, character keys will replace the character at the cursor position, or accepts the modified name, and the key aborts the change and restores the original file name. Spaces internal to the file name are ignored and may be used to remove unwanted characters. 4 Undo Entering a U key restores the file name at the cursor position to the original name from the volume directory if changed, removed, or moved. If the file has been moved, then only the displayed name is changed and the file on the destination volume is not disturbed. 5 Move Entering the M key moves the file at the cursor position to the destination volume. If the destination volume has not been specified, then a request for the destination volume identification will be made. The destination volume directory is searched for the file name and the user notified if the file name exists on the directory. THE.FILE is on destination volume, remove the old version?(Y/N) If the user enters a , the existing file on the destination will be removed and the file from the source will be copied to the destination. If the entry is an , the destination volume directory is not disturbed and no move takes place. Unlike other functions, the move command is an immediate operation and the file will be moved before continuing. 6 Get Entering the G key initiates the entry of a new destination volume identification. On entry of the volume identification, the new name becomes the destination volume. 7 Edit Entering the E key will call the system editor with the file name pointed to by the cursor. If any file is marked for removal or a file name has been changed, then the utility will request verification of the changes with the prompt: Update the directory? (Yes/No/Return) The response to this prompt must be a , or - all other keys are ignored. A response will cause the updated directory to be written to the blocked volume replacing the original directory. An response prevents the replacement of the orginal directory, and all modifications are ineffective. An response will return to the present directory display. After or is entered, DF will call for the system editor with the file name at the cursor. 8 eXecute Entering the X key will execute a code file or redirect input from a script file. When the cursor points to a file of type code and the X key is entered, the program in the code file will be executed. When the cursor points to a file which is not of type code and the X key is entered, the file will be considered to be a script file and input will be redirected from the file. If any file is marked for removal or a file name has been changed, then the utility will request verification of the changes with the prompt: Update the directory? (Yes/No/Return) The response to this prompt must be a , or - all other keys are ignored. A response will cause the updated directory to be written to the blocked volume replacing the original directory. An response prevents the replacement of the orginal directory, and all modifications are ineffective. An response will return to the present directory display. After or is entered, DF will continue with the execute option. 9 10 The and keys exit the directory display, prompt for update of the disk directory, and prompt for a new volume identification. If any file is marked for removal or a file name has been changed, then the utility will request verification of the changes with the prompt: Update the directory? (Yes/No/Return) The response to this prompt must be a , or - all other keys are ignored. A response will cause the updated directory to be written to the blocked volume replacing the original directory. An response prevents the replacement of the orginal directory, and all modifications are ineffective. An response will return to the present directory display. After or is entered, the prompt for a volume identification will be presented. 11 Quit Entering the Q key will prompt for update of the directory and return to the PASCAL system. If any file is marked for removal or a file name has been changed, then the utility will request verification of the changes with the prompt: Update the directory? (Yes/No/Return) The response to this prompt must be a , or - all other keys are ignored. A response will cause the updated directory to be written to the blocked volume replacing the original directory. An response prevents the replacement of the orginal directory, and all modifications are ineffective. An response returns to the present directory display. After or is entered, DF will exit to the PASCAL system. 12 Help Entering the H key initiates a sequence of single line descriptions for the options available to the user. The user is prompted to press the key to continue for each line displayed. 13 Output Entering the O key moves the volume directory display to a file or device specified by the user in response to the prompt: Enter the output file name : 14 Natural order Entering the N key for natural order will cause the directory file display to be presented in the order of occurrence on the disk. 15 Sorted order Entering the S key for sorted order will cause the directory file display to be presented in alphanumeric order by file name. 16 Logical order Entering the L key for logical order will cause the directory file display to be presented in alphanumeric order by the four character file suffix first and then by the file name. 17 Verify Entering the V key for verify will cause the directory file display to be rewritten. 18 Advance The A key invokes a directory display function which, if the cursor is pointing to a subsidirary volume, will advance to the subsidirary whether the volume is mounted or not. This allows an unmounted subsidirary volume to be displayed and files to be extracted or deleted without requiring the user to mount the volume. 19 Formfeed Entering an F, when the destination is the printer, will emit a formfeed character to the printer. Useful when outputing multiple text files to the printer from DF. ======================================================================================== DOCUMENT :usus Folder:VOL23:df.iv.0.text ======================================================================================== vid(j); end ELSE BEGIN { not unit number - try volume names } LCTOUC ( volstr ); { ensure all upper case alphabetic chars } j := 0; REPEAT { look for the volume name in the unit table } j := j + 1; if volstr=syscom^.unitable^[j].uvid then { match to old name } IF syscom^.UNITABLE^[J].UISBLKD THEN read_vid(j) ; { blk vol } UNTIL (volstr = syscom^.UNITABLE^[j].UVID)OR( j >= MAXUNIT ); IF volstr = syscom^.UNITABLE^[j].UVID THEN unum := j {name is true } ELSE BEGIN { retry all blocked volumes reading volume name } J := 0; REPEAT J := J+1; IF syscom^.UNITABLE^[J].UISBLKD THEN read_vid(j); UNTIL (J>=MAXUNIT)OR (volstr=syscom^.unitable^[j].uvid); IF volstr = syscom^.unitable^[J].UVID THEN unum := J; END; end; get_unit_number := unum ; end; {$P } FUNCTION GOOD_TARGET:BOOLEAN; VAR OK : BOOLEAN ; ABORT : BOOLEAN ; I : INTEGER ; BEGIN OK := TRUE ; ABORT := FALSE ; THE_SAME := FALSE ; repeat IF NOT TARGET_KNOWN THEN REPEAT GOTOXY(0,0); WRITE('Enter volume id of destination disk > ', syscom^.crtctrl.eraseeol ); NEWPROMPT := TRUE; READLN(TNAME); IF TNAME = '' THEN ABORT := TRUE ELSE IF tname[length(tname)]=syscom^.crtinfo.altmode then ABORT := TRUE ; IF NOT ABORT THEN begin tar_unit := get_unit_number( tname ); tname :=concat( syscom^.unitable^[tar_unit].uvid, ':' ); if not(syscom^.unitable^[tar_unit].uisblkd) THEN begin unitclear(tar_unit); dest_is_text := TRUE; end else BEGIN DEST_IS_TEXT := FALSE; {$I-} unitread(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0); {$I+} OK := IORESULT = 0; IF NOT OK THEN DISK_ERROR(TNAME) else BEGIN IF TARGETDIR[0].DLASTBLK > 255 THEN BEGIN TARFLIP := TRUE ; FLIPDIR(TARGETDIR); END ELSE TARFLIP := FALSE ; with targetdir[0] do if ( length(dvid)<=0 ) or ( length(dvid)> 7 ) or ( dnumfiles < 0 ) or ( dnumfiles > 77) or ( dfkind <> untypedfile ) then begin gotoxy(0,0); write('No directory on volume for ',TNAME, ': < press return >',syscom^.crtctrl.eraseeol); read(ch); ok := false ; end else IF dispdir[0].DVID = TARGETDIR[0].DVID THEN BEGIN gotoxy(0,0); write('Destination is not allowed to be the same as source.', ' ',syscom^.crtctrl.eraseeol); read(ch); OK := FALSE; end; END; END; END; UNTIL OK OR ABORT ELSE BEGIN IF NOT dest_is_text then BEGIN {$I-} unitread(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0); {$I+} OK := IORESULT = 0; IF NOT OK THEN DISK_ERROR(TNAME) else with dispdir[0] do if ( length(dvid)<=0 ) or ( length(dvid)> 7 ) or ( dnumfiles < 0 ) or ( dnumfiles > 77) or ( dfkind <> untypedfile ) then ok := false else IF copy(TNAME,1,length(tname)-1) <> TARGETDIR[0].DVID THEN BEGIN repeat GOTOXY(0,0); WRITE('Old destination was ',TNAME, ', new destination is ',targetdir[0].dvid, ' Ok to use new destination? (Y/N) ', syscom^.crtctrl.eraseeol); read(ch); until (ch='N') or (ch='n') or (ch='Y') or (ch='y'); ok := (ch='y') or (ch='Y'); end; END; target_known := ok; END; UNTIL OK OR ABORT ; TARGET_KNOWN := NOT ABORT ; GOOD_TARGET := NOT ABORT ; gotoxy(50,23); IF TARGET_KNOWN THEN write('Destination is ',TNAME ); END; {$P } FUNCTION UNIQUE_TARG( ST : STRING ) : BOOLEAN ; VAR MATCH : BOOLEAN ; CH : CHAR; I : INTEGER ; NFILES : INTEGER ; BEGIN CH := 'Y'; { INITIALIZE CHARACTER TO CAUSE TRUE RETURN } NFILES := TARGETDIR[0].DNUMFILES ; I := 0; MATCH := FALSE ; IF NFILES > 0 THEN REPEAT I := I+1; MATCH := ST = TARGETDIR[I].DTID ; UNTIL MATCH OR ( I>= NFILES ); IF MATCH THEN BEGIN GOTOXY(0,0); WRITE(ST, ' is on destination disk, Remove the old version? (Y/N) ', syscom^.crtctrl.eraseeol); NEWPROMPT := TRUE ; { RESTORE THE PROMPT LINE ON RETURN } REPEAT READ(KEYBOARD,CH) UNTIL (CH='Y')OR(CH='y')or(CH='N')OR(CH='n') OR(CH=syscom^.crtinfo.altmode); IF (CH='Y')OR(CH='y') then BEGIN targetdir[0].dnumfiles := nfiles - 1 ; IF I < NFILES THEN repeat targetdir[i] := targetdir[i+1]; i:= i+1; until i >= nfiles ; END; END; GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } UNIQUE_TARG := ((CH='Y')OR(CH='y')); END; {$P } function room_on_target( VAR DIR : psysdir ; REQUEST : INTEGER; VAR DIRREC : INTEGER; var totalblks: integer; var largest : integer ):BOOLEAN ; var nextlow : integer ; last : integer ; size : integer ; begin { FIND THE LARGEST SET OF CONTIGUOUS BLOCKS } LARGEST := 0; totalblks := 0; NEXTLOW := DIR[0].DNUMFILES + 1; LAST := DIR[0].DEOVBLK ; REPEAT NEXTLOW := NEXTLOW -1 ; SIZE := LAST - DIR[ NEXTLOW ].DLASTBLK ; totalblks := totalblks + size ; IF SIZE > LARGEST THEN BEGIN DIRREC := NEXTLOW+1 ; { ENTRY POSITION FOR LARGEST SPACE } LARGEST := SIZE ; END; LAST := DIR[ NEXTLOW ].DFIRSTBLK ; UNTIL NEXTLOW <= 0 ; ROOM_ON_TARGET := REQUEST <= LARGEST ; END; PROCEDURE MOVE_MESSAGE( WDSIZE: INTEGER ) ; BEGIN {******} GOTOXY(50,22); WRITE('Move buffer is ', WDSIZE ,' blocks.', syscom^.crtctrl.eraseeol ); {******} GOTOXY(0,0); WRITE('One moment please, move in progress. ',syscom^.crtctrl.eraseeol); NEWPROMPT := TRUE; END; {$P } PROCEDURE MOVE_FILE( DIRPOS:INTEGER ) ; VAR error : boolean ; totalblks: integer ; largest : integer ; SIZE : INTEGER ; SOURCE : INTEGER ; DEST : INTEGER ; TEMP : INTEGER ; I : INTEGER ; DIRREC : INTEGER ; BLOCKS :^integer ; { pointer to memory } movblksiz : integer; { size of the move buffer in blocks } { MOVE_FILE } BEGIN i:= varavail( 'DFILE,SCREENOPS,FILEOPS,CALC' ); movblksiz := ( i div 256 - 1 ); if movblksiz > 63 then movblksiz := 63 ; { limit size to less than 32767 } i := varnew ( blocks,movblksiz*256 ) ; if i = 0 then begin pressreturn(' No room for move buffer '); exit(move_file); end; SIZE := dispdir[DIRPOS].DLASTBLK-dispdir[DIRPOS].DFIRSTBLK ; IF GOOD_TARGET THEN IF NOT DEST_IS_TEXT THEN BEGIN IF UNIQUE_TARG( dispdir[DIRPOS].DTID ) THEN IF TARGETDIR[0].DNUMFILES < MAXDIR THEN BEGIN IF ROOM_ON_TARGET( TARGETDIR, SIZE, DIRREC ,totalblks, largest ) THEN BEGIN MOVE_MESSAGE( MOVBLKSIZ ); { OPEN THE DIRECTORY OF THE TARGET VOLUME FOR NEW ENTRY } I := TARGETDIR[0].DNUMFILES + 1; REPEAT TARGETDIR[I] := TARGETDIR[I-1]; I := I-1; UNTIL I <= DIRREC ; { MOVE THE DIRECTORY ENTRY TO THE TARGET } TARGETDIR[DIRREC] := dispdir[DIRPOS]; { SET THE STARTING BLOCK NUMBER FOR THE FILE ON THE TARGET VOLUME } TARGETDIR[DIRREC].DFIRSTBLK := TARGETDIR[DIRREC-1].DLASTBLK ; { SET THE ENDING BLOCK NUMBER FOR THE FILE ON THE TARGET VOLUME } TARGETDIR[DIRREC].DLASTBLK := TARGETDIR[DIRREC].DFIRSTBLK + SIZE ; { INCREASE THE NUMBER OF FILES ON THE TARGET VOLUME } TARGETDIR[0].DNUMFILES := TARGETDIR[0].DNUMFILES + 1; { MOVE THE FILE TO THE TARGET VOLUME } SOURCE := dispdir[DIRPOS].DFIRSTBLK; DEST := TARGETDIR[DIRREC].DFIRSTBLK; REPEAT TEMP := dispdir[DIRPOS].DLASTBLK-SOURCE; IF TEMP > movblksiz THEN TEMP := movblksiz; {$I- } unitread(dir_unit,blocks^,temp*512,source+dir_offs,0); {#I+ } error := ioresult <> 0; IF not error THEN BEGIN IF TARFLIP THEN FLIPDIR(TARGETDIR); TARFLIP := FALSE; SOURCE := SOURCE + TEMP; {$I- } unitwrite(tar_unit,blocks^,temp*512,dest,0); {$I+ } error := ioresult <> 0; IF not error THEN DEST := DEST + TEMP ELSE DISK_ERROR(CONCAT( TNAME,':',dispdir[DIRPOS].DTID ) ); END ELSE DISK_ERROR( CONCAT(INAME,':',dispdir[DIRPOS].DTID) ); WRITE('.'); UNTIL (SOURCE = dispdir[DIRPOS].DLASTBLK) OR error ; IF not error THEN begin {$I- } unitwrite(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0); {$I+ } GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } dir_status[dirpos].moved := true; with_write( dirpos ); end; END ELSE BEGIN GOTOXY(0,0); WRITE( dispdir[dirpos].dtid, ' is ',size,' blocks. ',largest,' contig. ',totalblks,' total avail.', ' ',syscom^.crtctrl.eraseeol); read(ch); newprompt := true; end; end else begin gotoxy(0,0); write( TARGETDIR[0].DVID, ' volume directory is full. ', syscom^.crtctrl.eraseeol); read(ch); newprompt := true; end; END ELSE BEGIN { OUTPUT DEVICE IS FOR TEXT } IF dispdir[DIRPOS].DFKIND = TEXTFILE THEN BEGIN IF tar_unit = 1 THEN WRITE(syscom^.crtctrl.clearscreen); GOTOXY(0,0); WRITE('Output of ',dispdir[dirpos].dtid, ' to ',TNAME,' in progress.',syscom^.crtctrl.eraseeol); IF tar_unit = 1 THEN WRITELN; newprompt := true; { MOVE THE FILE TO THE TARGET VOLUME } SOURCE := dispdir[DIRPOS].DFIRSTBLK+2; REPEAT TEMP := dispdir[DIRPOS].DLASTBLK-SOURCE; IF TEMP > MOVBLKSIZ THEN TEMP := MOVBLKSIZ; {$I- } unitread(dir_unit,blocks^,temp*512,source+dir_offs,0); {#I+ } error := ioresult <> 0; IF not error THEN BEGIN SOURCE := SOURCE + TEMP; {$I- } unitwrite(tar_unit,blocks^,temp*512,dest,0); {$I+ } error := ioresult <> 0; IF not error THEN DEST := DEST + TEMP ELSE DISK_ERROR(CONCAT( TNAME,dispdir[DIRPOS].DTID ) ); END ELSE DISK_ERROR( CONCAT(INAME,dispdir[DIRPOS].DTID) ); WRITE('.'); UNTIL (SOURCE = dispdir[DIRPOS].DLASTBLK) OR error ; GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } dir_status[dirpos].moved := true; if not (tar_unit = 1) then with_write( dirpos ); END else pressreturn('File type is not text'); IF tar_unit = 1 THEN BEGIN PRINTENTRIES; GOTOXY(50,23); WRITE('Destination is CONSOLE:'); END; END; VARDISPOSE( BLOCKS,MOVBLKSIZ*256); { RELEASE MOVE BUFFER } END; {$P } PROCEDURE GET; BEGIN TARGET_KNOWN := FALSE; GOTOXY(50,23); WRITE(syscom^.crtctrl.eraseeol); IF GOOD_TARGET THEN { DUMMY IF TO CARRY THE FUNCTION CALL TO GOOD_TARGET }; end; {$P } PROCEDURE CHANGE_FILE( CU:CHAR ; J:INTEGER ); VAR CH : CHAR ; ST : STRING[15]; FUNCTION UNIQUE_FILE : BOOLEAN ; VAR MATCH : BOOLEAN ; CH : CHAR; NROW,NCOL : INTEGER ; BEGIN CH := 'Y'; { INITIALIZE TO CHARACTER TO CAUSE TRUE RETURN } I := dispdir[0].DNUMFILES + 1; MATCH := FALSE ; IF I > 0 THEN REPEAT I := I-1; IF (J <> INDEX[I])AND(not dir_status[INDEX[I]].removed) THEN MATCH := ST = dispdir[INDEX[I]].DTID ; UNTIL MATCH OR ( I<=1 ); IF MATCH THEN BEGIN NCOL := 5 ; REPEAT NCOL := NCOL - 1 UNTIL I > TOTALTOCOL[NCOL]; NROW := I - TOTALTOCOL[NCOL]; GOTOXY((NCOL-1)*20,Y_BASE+NROW-1); dir_status[index[i]].removed := true ; with_write( index[i] ); dir_status[index[i]].removed := false; GOTOXY(0,0); WRITE('Remove the old version? (Y/N)',syscom^.crtctrl.eraseeol); NEWPROMPT := TRUE ; { RESTORE THE PROMPT LINE ON RETURN } GOTOXY((NCOL-1)*20,Y_BASE+NROW-1); REPEAT READ(KEYBOARD,CH) UNTIL (CH='Y')OR(CH='y')or(CH='N')OR(CH='n') OR(CH=syscom^.crtinfo.altmode); IF (CH='Y')OR(CH='y') then BEGIN NUMFILES := NUMFILES -1; dir_status[index[i]].removed := true ; CALC; PRINTSTATS; END ELSE WITH_WRITE( index[i] ); END; GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } UNIQUE_FILE := ((CH='Y')OR(CH='y')); END; {$P } { CHANGE_FILE } BEGIN CASE CU OF 'C','c':BEGIN IF dir_status[j].removed then begin newprompt := true; pressreturn('cannot change a removed file name '); end else begin ST := dispdir[J].DTID; IF (( LENGTH(ST)>5)AND(LENGTH(ST)<15)) THEN IF ST[LENGTH(ST)-4] = '.' THEN WHILE LENGTH(ST)<15 DO INSERT ( ' ',ST,LENGTH(ST)-4); WHILE LENGTH(ST)< 15 DO ST := CONCAT(ST,' '); WRITE(ST); GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } I := 1; REPEAT READ (KEYBOARD,CH); IF (syscom^.crtinfo.left= CH) AND (I>1) THEN I := I-1; IF (syscom^.crtinfo.right=CH) AND (I<15) THEN I := I+1; IF (CH>='a') AND (CH<='z') THEN CH := CHR( ORD('A')+ORD(CH)-ORD('a') ); IF NOT( (CH='?') OR(CH='=') OR(CH='*') OR (CH=',') OR(CH='$') OR(CH=':') OR (CH=syscom^.crtinfo.etx) OR EOLN(keyboard) OR (ORD(CH)> 127)OR (ORD(CH)< ORD(' ')) ) THEN BEGIN ST[I]:= CH; WRITE(OUTPUT,CH); IF I<15 THEN I:=I+1; END; GOTOXY( (COL-1)*20+I-1 ,Y_BASE+ROW-1); { PLACE THE CURSOR } UNTIL EOLN(keyboard)OR(CH=syscom^.crtinfo.altmode) OR(CH=syscom^.crtinfo.etx); I := POS(' ',ST); WHILE I<>0 DO BEGIN DELETE(ST,I,1); { REMOVE THE SPACE CHARACTER } I := POS(' ',ST) END; IF NOT(CH=syscom^.crtinfo.altmode) THEN IF UNIQUE_FILE THEN BEGIN DIR_STATUS[J].CHANGED := TRUE ; dispdir[J].DTID := ST; END; GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } WITH_WRITE( J ); end; END; {$P } 'U','u':BEGIN ST := ORGDIR[J].DTID; IF UNIQUE_FILE THEN BEGIN IF dir_status[j].removed THEN NUMFILES := NUMFILES +1; dir_status[j].removed := false; { RESTORE FILE TO DIRECTORY } dir_status[j].changed := false; dispdir[J].DTID := ORGDIR[J].DTID ; { RESTORE NAME IF C(hanged } WITH_WRITE( J ); CALC; PRINTSTATS; END; END; END; { OF CASE CU } END; {$P } PROCEDURE DELETEFILES; VAR I,J : INTEGER ; BEGIN J := 0; IF NUMFILES <> 0 THEN FOR I := 1 TO NUMFILES DO BEGIN REPEAT J := J +1 UNTIL not dir_status[j].removed; IF J > I THEN dispdir[I] := dispdir[J]; END; dispdir[0].DNUMFILES := NUMFILES ; if dirflip then BEGIN DIRFLIP := FALSE; flipdir(dispdir); END; {$I-} unitwrite(dir_unit,dispdir,(maxdir+1)*sizeof(direntry),2+dir_offs,0); {$I+} IF IORESULT <>0 THEN DISK_ERROR( INAME ); END; {$P } PROCEDURE MARKENTRIES; VAR COMPLETE : BOOLEAN; MATCH : BOOLEAN; new_extend : boolean ; extension : boolean ; CH : CHAR; ST : STRING ; chartostr : string[1]; I,J,K : INTEGER; NROW,NCOL : INTEGER; rep_factor : integer; {$P } BEGIN { MARKENTRIES } COL := 1; ROW := 1; COMPLETE := FALSE ; NEWPROMPT := TRUE ; extension := false ; NEW_EXTEND := TRUE; chartostr := ' '; REPEAT { UNTIL COMPLETE 1111111 } REPEAT { UNTIL COMPLETE 2222222 } esc_true := false ; IF NEWPROMPT THEN if not extension then PROMPT(0, ' Remove Change Undo Move Get Edit eXecute ENTER ESC Quit Help Output ?' ) else prompt(0, 'Natural Sorted Logical Verify Advance Formfeed 19 Aug 82' ); NEWPROMPT := FALSE ; J := INDEX[ TOTALTOCOL[COL]+ROW ]; {*****} if new_extend then begin if dispdir[0].dnumfiles > 0 then begin GOTOXY(25,1); WITH dispdir[J] DO WRITE(syscom^.crtctrl.eraseeol, DTID,' ':(17-LENGTH(DTID)), DLASTBLK-DFIRSTBLK:5, DACCESS.DAY:4,'-',MONTHNAME[DACCESS.MONTH],'-',DACCESS.YEAR:2, DFIRSTBLK:5, DLASTBYTE:5, FILETYPENAME[dfkind]:10 ); end; new_extend := false; end; {*****} GOTOXY( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } {*** READ THE NEXT COMMAND CHARACTER } rep_factor := 0; READ(KEYBOARD,CH); while ch in digits do begin rep_factor := rep_factor*10+(ord(ch)-ord('0')); read(keyboard,ch); end; repeat with syscom^.crtctrl, syscom^.crtinfo do begin IF CH = UP THEN IF ROW = 1 THEN ROW := COL_LENGTH[COL] ELSE ROW := ROW-1; IF CH = DOWN THEN IF ROW = COL_LENGTH[COL] THEN ROW := 1 ELSE ROW := ROW + 1; IF EOLN(KEYBOARD) THEN IF ROW = COL_LENGTH[COL] THEN BEGIN ROW := 1; IF (COL<4)THEN IF (COL_LENGTH[COL+1]>0)THEN COL := COL + 1 ELSE COL := 1 ELSE COL := 1; END ELSE ROW := ROW + 1; IF CH = LEFT THEN IF COL = 1 THEN IF ROW <= COL_LENGTH[4] THEN COL := 4 ELSE IF ROW <= COL_LENGTH[3] THEN COL := 3 ELSE IF ROW <= COL_LENGTH[2] THEN COL := 2 ELSE COL := 1 ELSE COL := COL - 1; IF (CH = RIGHT) OR (CH = TAB) THEN IF ROW <= COL4 THEN { ROW IS COMPLETE } IF COL = 4 THEN COL := 1 ELSE COL := COL + 1 ELSE { ROW IS A PARTIAL, 1,2 OR 3 COLUMNS ONLY } IF ((COL=1) AND (ROW=COL2)) THEN COL := 2 ELSE IF ((COL=2) AND (ROW=COL3)) THEN COL := 3 ELSE COL := 1; { COLUMN THREE WRAPS TO COLUMN ONE } IF CH = in_home THEN BEGIN ROW := 1; COL := 1 END; new_extend := ( ch = up ) or ( ch = down ) or ( ch = left ) or ( ch = right ) or ( ch = tab ) or ( ch = home ) or ( eoln(keyboard) ); IF (CH = etx) or (CH = altmode) THEN COMPLETE := TRUE; end; rep_factor:=rep_factor-1; until rep_factor<1; {*** END OF CURSOR POSITIONING COMMANDS } {$P } if not(new_extend or ( ch=syscom^.crtinfo.etx ) or ( ch=syscom^.crtinfo.altmode)) then case ch of {*** REMOVE FILE PROCESSING } 'R','r':BEGIN IF not dir_status[j].removed THEN BEGIN NUMFILES := NUMFILES - 1; dir_status[j].removed := true; with_write( j ); END; CALC; PRINTSTATS; END; {*** SORT AND DISPLAY PRESENT VOLUME ***} 'S','s':begin sort := 1; sort_dir ; printentries; new_extend := true; row := 1; col := 1; end; {*** SORT BY FOUR CHARACTER SUFFIX & FILE NAME ***} 'L','l':begin sort := 2; suffixsort; printentries; new_extend := true; row := 1; col := 1; end; {*** MOVE THE FILE TO A TARGET } 'M','m': IF not DIR_STATUS[J].REMOVED THEN MOVE_FILE(J) ELSE begin newprompt := true; pressreturn('A REMOVED FILE CAN NOT BE MOVED. '); end; {*** FORMFEED THE PRINTER ***} 'F','f':begin if target_known then if tar_unit = 6 then unitwrite(tar_unit,formfeed,1); end; {*** SET NATURAL ORDER AND DISPLAY PRESENT VOLUME ***} 'N','n':begin sort := 0; for i:=1 to maxdir do index[i]:= i; printentries; new_extend := true; row := 1; col := 1; end; {*** GET A NEW DESTINATION VOLUME } 'G','g': GET ; {*** UNDO THE ACTION ( IF ANY ) TAKEN TO DATE ON THIS FILE } 'U','u':CHANGE_FILE( CH, J); {*** refresh the present volume display ***} 'V','v':printentries; {*** CHANGE THE FILE NAME } 'C','c':CHANGE_FILE( CH, J); {*** HELP } 'H','h': help ; {*** OUTPUT TO A DEVICE OR FILE } 'O','o':BEGIN DOUTPUT; NEWPROMPT := TRUE END; {*** eXecute the code file, or initiate a monitor input string } 'X','x':begin IF dir_status[j].removed then begin newprompt := true; pressreturn( 'CANNOT EXECUTE A REMOVED FILE.'); end else begin esc_true := true; complete := true; end; end; {*** Edit the file specified } 'E','e':begin if dir_status[j].removed then begin newprompt := true; pressreturn( 'CANNOT EDIT A REMOVED FILE' ); end else begin esc_true := true; complete := true; end; end; {*** Quit the directory utility after update of directory prompt } 'Q','q':begin esc_true := true; complete := true; end; {*** Advance to subsiderary volume } 'A','a':begin if dispdir[j].dfkind =subsvol then begin next_offs := dispdir[j].dfirstblk + dir_offs ; complete := true; end else begin newprompt := true; pressreturn('Selection "A" must point to SVOL type file'); end; end; { of type 'A' } end; { of case } if ( ch = '?' ) or ( ch = '/' ) then begin newprompt := true; extension := not extension ; end else extension := false ; UNTIL COMPLETE; { 11111111 } TARGET_KNOWN := FALSE ; do_marks := true; IF ( dispdir[0].dnumfiles > 0 ) THEN BEGIN I:=1; REPEAT with dir_status[i] do DO_MARKS:= removed or changed ; I:=I+1 UNTIL DO_MARKS OR ( I > dispdir[0].DNUMFILES ); IF DO_MARKS THEN BEGIN REPEAT GOTOXY( 0,0 ); WRITE ('Update directory? (Yes/No/Return)',syscom^.crtctrl.eraseeol); READ ( YESNO ); UNTIL (YESNO = 'Y')OR(YESNO ='y')OR (YESNO = 'N')OR(YESNO ='n')or (yesno = 'R')or(yesno ='r'); newprompt := true ; complete := not( (yesno='R')or(yesno='r') ); DO_MARKS := (YESNO = 'Y')or(YESNO = 'y') ; END; END; until complete; { 222222222 } if do_marks then repeat {$I-} unitread(dir_unit,targetdir,sizeof(dir_entry),2+dir_offs,0); {$I+} OK := IORESULT = 0; IF NOT OK THEN DISK_ERROR(TNAME) else with targetdir[0] do if NOT ( ( length(dvid)<=0 ) or ( length(dvid)> 7 ) ) then begin ok := disp_dir[0].dvid = targetdir[0].dvid ; if not ok then begin ok := false; repeat gotoxy(0,0); write('Return Volume ',disp_dir[0].dvid,' to #',dir_unit, ' Press Space'); read(ch); until ch=' ' ; end end else begin ok := false; repeat gotoxy(0,0); write('Return Volume ',disp_dir[0].dvid,' to #',dir_unit, ' Press Space'); read(ch); until ch=' ' ; end until ok = true; CASE CH OF {*** eXecute the code file, or initiate a monitor input string } 'X','x':begin prompt(0,concat('Execute ',dispdir[0].dvid,':',dispdir[j].dtid)); if dispdir[j].dfkind = codefile then chain( concat('I="x', dispdir[0].dvid,':',dispdir[j].dtid,'."' )) else chain( concat( 'I=',dispdir[0].dvid,':',dispdir[j].dtid)); esc_true := true; complete := true; end; {*** Edit the file specified } 'E','e':begin prompt(0,concat('Edit ',dispdir[0].dvid,':',dispdir[j].dtid)); chartostr[1] := syscom^.crtinfo.linedel; chain( concat( 'I="e',chartostr, dispdir[0].dvid,':', dispdir[j].dtid,'"')); esc_true := true; complete := true; end; END; { of case ch } IF DO_MARKS THEN DELETEFILES; END; {$P } { * ** *** **** ***** PRIMARY BLOCK STARTS HERE **** *** ** * } BEGIN MEMLOCK('SCREENOPS'); INITIALIZE; REPEAT tar_offs := 0; { should always be 0 } {*** ACCEPT A VOLUME ID FROM THE USER ***} REPEAT write( syscom^.crtctrl.clearscreen ); TNAME := iname; if next_offs = 0 then begin { 11111111 } dir_offs := 0 ; { remove the svol offset if present } gotoxy(0,2); writeln('Volumes presently online:'); writeln; i := 0; j := 0; l := 0; { Finds the next blocked volume for output to the screen } while (j < maxunit) and ( i < 60 ) do begin j := j+1; if syscom^.unitable^[j].uisblkd then begin read_vid(j); IF syscom^.unitable^[j].UVID <> '' THEN BEGIN gotoxy( ( i div 20 * 27 ), ( i mod 20 + 4 ) ); WRITE( j:2 ); WRITE( ':' ); (* IF syscom^.unitable^[j].UISBLKD THEN if syscom^.unitable^[j].uvid = syvid then write( ': R ' ) else if syscom^.unitable^[j].uvid = dkvid then write(': P ') else WRITE(': ') ELSE WRITE(': '); *) WRITE(syscom^.unitable^[j].UVID, ' ':8-LENGTH(SYSCOM^.UNITABLE^[J].UVID)); WRITE('[',syscom^.unitable^[J].ueovblk:5,']'); if syscom^.unitable^[j].uvid <> syscom^.unitable^[j].upvid then write(syscom^.unitable^[j].upvid); write(syscom^.crtctrl.eraseeol); i := i +1 ; END; { syscom^.unitable^ <> '' } end; { syscom^.unitable^[j].uisblkd } end; { j< maxunit and i < 80 } ok := false; gotoxy(0,0); WRITE('Enter volume id of disk (, to end) [',TNAME,'] =>', syscom^.crtctrl.eraseeol); READLN(INAME); if iname = '' then iname:=TNAME ; IF INAME[LENGTH(INAME)] = syscom^.crtinfo.altmode THEN EXIT ( dfile ); ok := false; dir_unit := get_unit_number( iname ); end { 111111111 } else begin { next_offs <> 0 is request to display subsiderary volume } dir_offs := next_offs ; { displacement to svol } next_offs:= 0; end; if syscom^.unitable^[dir_unit].uisblkd then begin {$I-} unitread(dir_unit,dispdir,(maxdir+1)*sizeof(direntry),2+dir_offs,0); {$I+} OK := IORESULT = 0; IF NOT OK THEN DISK_ERROR(concat(INAME,':')) else begin if dispdir[0].dlastblk > 255 then begin dirflip := true; flipdir( dispdir ) end else dirflip := false; FOR I := 0 TO DISPDIR[0].DNUMFILES DO ORGDIR[I] := DISPDIR[I]; end; END; if not ok then initentry := false ; UNTIL OK ; if ch<>syscom^.crtinfo.altmode then begin CRT := TRUE ; ALLDONE := FALSE; NUMFILES := DISPDIR[0].DNUMFILES; J := 1; FOR I := 1 TO MAXDIR DO INDEX[I] := I ; case sort of 1: sort_dir; {alphanumeric sort on file name} 2: suffixsort; {alphanumeric sort on four char suffix and file name} end; IF NUMFILES > 0 THEN FOR I := 1 TO NUMFILES DO begin dir_status[i].removed := false; dir_status[i].changed := false; dir_status[i].moved := false; end; FOR I := NUMFILES+1 TO MAXDIR DO begin dir_status[i].removed := true ; dir_status[i].changed := false; dir_status[i].moved := false; end; CALC; {*** OUTPUT THE DIRECTORY TO THE CRT SCREEN } PRINTENTRIES; { PRINT ALL INFORMATION } markentries; end; UNTIL ESC_TRUE ; write( syscom^.crtctrl.clearscreen ); END. a9¯¤‘DFILE INITIALIHELP DOUTPUT CALC €€€€ € €€€€€€€€€€€î( DFILE DFILE DFILE DFILE íòíò&þ2DFðFHFä*7FÚ\r\rBlî þ\r\n9†L@8INITIALIçÌ ¥€‚¥†€± Ëׂ€ë†€± Ëׂ€ë†€± Ëׂ€ë†€± Ëׂ€ë†€± Ëׂ€ 놀± Ëׂ€ 놀± Ëׂ€ë†€± Ëׂ€ †€± Ëׂ€ë†€± Ëׂ€ë†€± Ëׂ€ë†€± Ëׂ€ë†€± Ëׂ€ë†€Ë Ëׂ€ë†€Ë Ëׂ€!ë†€Ë Ëׂ€&ë†€Ë Ëׂ€+ë†€Ë Ëׂ€0ë†€Ë Ëׂ€5ë†€Ë Ëׂ€:ë†€Ë Ëׂ€?ë†€Ë Ëׂ€Dë†€Ë Ëׂ€I놀Ž‚€N놀Žìšç,ÉȆ€‚€O놀¨Ëî È¥¥¥ †›<ëP¥€•¥€—¥€™¥€”€ ¥¥–***JanFebMarAprMayJunJulAugSepOctNovDecUntypedffXdiskfillCodefileeTextfileeInfofileeDatafileeGraffileeFotofileeSecurdirrSubsvol   ®HELP ÑŸššç#Éupvš‚€w pšwpš‚€w pšwpš‚€+w pšwpš‚€Iw pšwpš‚€bw pšwpš‚€xw pšwpš‚€‰w pšwpš‚€™w pšwpš‚€µw pšwpš‚€Ôw pšwpš‚€îw pšwpš‚w pšwpš‚w pšwpš‚<w pšwpš‚Sw pšwpš‚rw pšwpš‚‡w pšwpš‚¥w pšwp‚Ãqq–-, and :move the cursor"Remove :the file under the cursorr;Change :the file name under the cursor to 0Undo :restores the file name under the cursorr+Move :the file to the destination volume!Get :a new destination volumeEdit :the file at the cursor7eXecute :the code file or redirect from the script file< and :update directory and accept new volume idd3Quit :update directory and exit to PASCAL system*Help :displays this page of informationn.Output :moves the display to a device or filee?Natural :displays files in the order of occurance on the volume-Sorted :displays files in alphanumeric order CALC †€ý€MË× y†€ý€MË× x£¥€›†€ý€MË× æ²ŸÕ¸†€ý€MË× æk¥€“…€“#²Ô>†Žx…€“€MË×l$Éñ"…€›†€ý…€“€MË× y¢†€ý…€“€MË× x£¥€›…€“í¥€“Š»¥€œ†€ý€MË× æíh†€ý€MË× i îh†Žx €MË×Éå ³Ÿ Ôè!†€ý €MË× y£j"…€œ²ñ"¥€œ†€ý €MË× xi ³ñ¾Š†€ý€MË× †€ý€MË× y£¥€œ– `DFILE ó¼)`„*¬P¥ p¥€“v…€“‹€š‚€w pš`˜w p‹iš‚€w pš`˜w p‹Oš‚€w pš…€“wpš‚€$w pš`˜w p‹š`˜w pš‚€/w p‹š‚€7w pš`˜w pš‚€:w p‹Üš‚€Hw pš`˜w pš‚€Nw p‹µš‚€Xw pš`˜w pš‚€`w p‹Žš‚€jw pš`˜w pš‚€pw pŠhš‚€xw pš`˜w pŠOš‚€„w pš`˜w pš‚€‡w pŠ)š‚€w pš`˜w pš‚€”w pŠÖ€Ÿ‚€³‘–+Ðvš‚€´w pššç Éupšwp†€ý€MË× æ²ŸÕÔ€Mol$'²Ô†Œý$€MË×$€MËÄ$ílŠæ†€ý€MË× æh ²ŸÕŸ†€ý€MË× æ £jk#l$ ¢i†€ý†Œý$€MË×x€MË× ç†€ý†Œý!€MË×x€MË× çéñA†Œý$€MË×xn†Œý$€MË׆Œý!€MË×x€MËĆŒý!€MË×&€MËÄ$ £l$²ŸmŠm%ñ…#ík#"²ŸÕyÿ h‹Zÿ–±ü†€ý€MË× æ¤*¥€“…€“‡*²Ô}`†€ý…€“€MË× çëP`§¥€…€²ñT`…€£ì§€.ÒH†€ý…€“€MË× ç¤+„+`˜„€«…€£” „€«˜€P” „+`˜„€Ô…€£” „€Ô˜€ ” „+ë…€“í¥€“‹{ÿ‘†€ý€MË× æ¤*¥€“…€“‡*²Ô(†€ý…€“€MË× ç†„ý…€“€MË× çë…€“í¥€“ŠÐ–€üè`Ë!˧€ÿËÈ!Ë!˧€ÿËÈ!Ë`˧€ÿËÈ–G#€MË× i!‘!ç‘!ç‘!ç‘!ç‘!ç ‘!ç ‘€Mih !²Ô%# €MË× j"‘"ç‘"ç‘"ç ‘"ç ‘ íhŠÖ–¨*a„+¬Pa§h¥€“…€“ ²Ô'a…€“짃€ÍÚÔa…€“ìa…€“지€¢È…€“í¥€“ŠÒ‡-vša˜w pššç Éup–-×[„3„\¬Pia„3˜€P” a‚€Õ€`” a˜‘ š`w p–]ç5Ôwvš…€wpš‚€Þw pš…€›wpš‚€èw pvš†€ý€MË× …€›£wpš‚€ïw pš…€œwpš‚€ùw p‹†Kwp†Kwp†K…€wp†K‚€ÿw p†K…€›wp†K‚ w p†Kwp†K†€ý€MË× …€›£wp†K‚w p†K…€œwp†K‚w p†Kwp†Kwp–ý*a„,¬Pša˜w p–-¥†€ý.€MË× l†Žx.€MË×m%É%É %É j$ç§ik!²ñ$ç!£ì§€.Òk#Ô5Ô$ç˜f!£” f˜"‘ Š†K$ç˜f!£” f˜w p!h ³ñ íh5Ô š€ upŠ †K€ upŠÝ5Ô$ç˜f!£” f˜"‘ Š†K$ç˜f!£” f˜w pŠ=5Ô $ç˜"‘ Š †K$ç˜w p!h ³ñ íh5Ô š€ upŠ †K€ upŠÝ"5¡Ôjš€ up%ÉÔ š€RupŠ š€-up%ÉÔ š€CupŠ š€-up%ÉÔ š€MupŠ š€-upš€|upŠ35Ôš$y$x£wpš€|upŠ†K$y$x£wp†K€ up– ú¥ 5ÔBššç#Éupvš‚ w pš†€ý€MË× ç˜w pš€:upŠ,†K‚(w p†K†€ý€MË× ç˜w p†K€:up†€ý€MË× æj†€ý€MË× æâ½Ëi!³Ô"í¥€¢Š"¥€¢!³Ô"í¥€£Š"¥€£!³Ô"í¥€¤Š"¥€¤"¥€¥†€­Ëî×Ć€­Ëî×…€¢Ä†€­Ëî×…€¢…€£¢Ä†€­Ëî×…€¢…€£¢…€¤¢Ä†€©Ëî×…€¢Ä†€©Ëî×…€£Ä†€©Ëî×…€¤Ä†€©Ëî×…€¥Ä†€ý€MË× æ²ŸÕÖ5Ô¥€¦…€¢³ñ¥€¦…€¦¥€§…€¦vŠ†Kwp†Kwp…€¢k¥€“…€“#²Õ˜…€“h†Œý €MË×x‘ …€¢¢h †€­Ëî×x²Ô †Œý €MË×x‘ …€£¢h †€­Ëî×x²Ô †Œý €MË×x‘ …€¤¢h †€ý€MË× æ²Ô †Œý €MË×x‘ 5Ô …€¦…€“¢vŠ†Kwp…€“í¥€“‹`ÿ‘ €2v6Ôš‚0w pš†e˜w p– 1"§ih !²Ô&" 지a³Ÿ" 지z²Ÿ ñ" ì" 지a£€A¢È íhŠÕ– Ò áh-`ppÒw Ò_!€ÿ²ñb‘„ ‘c§²c§²Ÿ „ ˧²Ÿ „ ˧€M²Ÿ bɱ Ôšæ-€Ë× ‚8ëŠ æ-€Ë× c늚æ-€Ë× ‚9늚æ-€Ë× ‚:ë– ¸+¤-i‡,‚;èÔ‡,›<ëP‡,지:Ò‡,›<ëP‡,지*Ò‡,›@ëP‚<‡,˜” ¥€“…€“²ñ‡,‡,˜b…€“î” bëP‡,지#Ò*‡,§¥€“…€“²ñ‡,‡,˜b…€“î” bëPŠ‡,›<ëP‡,§¥€“¥€’¥€‘h…€‘…€“² ¡Ô0‡,…€‘짛ZÐÚÔ…€’ Œ‡,…€‘짢€0£¥€’…€‘í¥€‘ŠhŠÅ …€’š€‡²Ÿ¡Ôp Ô…€’išæ…€’€Ë× |Ô…€’‘‹Ë‡,‘ ¥€’…€’í¥€’‡,šæ…€’€Ë× èÔšæ…€’€Ë× |Ô…€’‘‡,šæ…€’€Ë× è…€’š€‡³ Ô°‡,šæ…€’€Ë× èÔ…€’iŠX¥€’…€’í¥€’šæ…€’€Ë× |Ô…€’‘…€’š€‡³‡,šæ…€’€Ë× è ÔŇ,šæ…€’€Ë× èÔ…€’i!¤-–,Á-hi¥ 6åÕÂvš‚=w pššç Éup¥ š†e€Pw pšw p†e‚QèÔiŠ†e†e§ì§šç,ÉÒi!åÕ\†e‘¥€˜†ekcšæ…€˜€Ë× ˜” c‚R” cëPšæ…€˜€Ë× |ñ …€˜p"¥‹¥…€˜†ˆý€MíŒpp°h ñ†e˜‘‹î†ˆý€MË× y€ÿ²ñ ¥ †ˆý‘Š¥ †ˆý€MË× k#秲#秲Ÿ #泟 #æ€M²Ÿ #çɱ ÔFvš‚Sw pš†e˜w pš‚aw pššç Éupš†w phŠV†€ý€MË× ç†ˆý€MË× çèÔ9vš‚kw pš‚†w pššç Éupš†w ph ! ÕAþ‹7åÕÿ…€˜†ˆý€MíŒpp°h ñ†e˜‘‹Þ†€ý€MË× k#秲#秲Ÿ #泟 #æ€M²Ÿ #çɱ Ôh‹¤†e˜d†e§î” d†ˆý€MË× çèŸÕƒvš‚w pš†e˜w pš‚šw pš†ˆý€MË× ç˜w pš‚¥w pššç Éupš†w p>€N°>€n° >€Y° >€y° Ô‡>€y°>€Y° h ¥ ! Õ,ý!å¥!å¤.€2v6Ôš‚·w pš†e˜w p–- -d„.¬P€Yi†ˆý€MË× ækjh#²ñ"íjd†ˆý"€MË× çèh "#³ Ôå Õ™všd˜w pš‚¿w pššç Éup¥ šaw p!€Y°!€y° !€N° !€n° !šç,É° ÔØ!€Y°!€y° Ô8†ˆý€MË× ç#î€MËÄ"#³ñ †ˆý"€MË× †ˆý"í€MË× Å "íj"#³Ôà…€¡îŒ…€¦…€ ¢îv!€Y°!€y° ¤0–/#Ä$Ä'€MË× æíh'€MË× i îh!' €MË× y£j$$x"¢Ä"#x²ñ% íÄ#"Ä' €MË× xi ²ÔÏ&#x²¤ –v€2vš‚Ûw pš wpš‚ãw pššç Éupvš‚èw pššç Éup¥ –o<‚ü” o'î¤ *€?²ñ€?¤ „ *Œ” o'Ò ‚‚ ‘p†€ý‡=€MË× y†€ý‡=€MË× x£k‘ ‘7åÕÚ†€ý‡=€MË× ç˜‘Õƈý€MË× æ€M³ŸÕn†ˆý#„ ab‘ÕÌ*‘†ˆý€MË× æío†ˆý'€MË× †ˆý'î€MË× Å 'îo'(²Ôà†ˆý(€MË× †€ý‡=€MË× Å †ˆý(€MË× †ˆý(î€MË× yĆˆý(€MË× ç†ˆý(€MË× x#¢Ä†ˆý€MË× ç†ˆý€MË× æí€MËĆ€ý‡=€MË× xl†ˆý(€MË× xm†€ý‡=€MË× y$£n&*²ñ*n…€–)&Œ$…€—¢pp±h ña;Ô†ˆý‘¥ $&¢l…€˜)&Œ%pp±h ñ%&¢mŠ3¤ „ †e˜€P” „ ‚‚€Q” „ †€ý‡=€MË× ç˜€`” „ ˜‘Š3¤ „ †˜€P” „ ‚‚€Q” „ †€ý‡=€MË× ç˜€`” „ ˜‘š€.up$†€ý‡=€MË× y°  Õÿ ñ3…€˜†ˆý€MíŒp…€¡îŒ…€¦…€ ¢îv†Žx‡=€MË×ʇ=‘ ‹’vš†€ý‡=€MË× ç˜w pš‚‚w pš#wpš‚‚w pš"wpš‚‚#w pš!wpš‚‚(w pš‚‚/w pššç Éupš†w p¥ ŠBvš†ˆý€MË× ç˜w pš‚‚7w pššç Éupš†w p¥ ‹²†€ý‡=€MË× çÉ°Õ|…€˜Ò šç#Éupvš‚‚Lw pš†€ý‡=€MË× ç˜w pš‚‚Rw pš†e˜w pš‚‚Uw pššç Éup…€˜Òšwp¥ †€ý‡=€MË× x¢l†€ý‡=€MË× y$£n&*²ñ*n…€–)&Œ$…€—¢pp±h ñJ$&¢l…€˜)&Œ%pp±h ñ%&¢mŠ'¤ „ †e˜€P” „ †€ý‡=€MË× ç˜€_” „ ˜‘Š'¤ „ †˜€P” „ †€ý‡=€MË× ç˜€_” „ ˜‘š€.up$†€ý‡=€MË× y°  ÕAÿ…€¡îŒ…€¦…€ ¢îv†Žx‡=€MË×Ê…€˜°ñ‡=‘ Š‚‚\‘…€˜Ò‘€2vš‚‚gw p„ *Œ” –=“¥€2vššç Éup‘ –?€Yi†€ý€MË× æí¥€“h…€“²ñ\…€““­†Œý…€“€MË×x±†Žx†Œý…€“€MË×x€MË×Éå¡Ôˆ†€ý†Œý…€“€MË×x€MË× çèh …€“² Ô¤ Õj"îj…€“†€­"Ëî×x²ñì…€“†€­"Ëî×x£k"€¦#¢îv†Žx†Œý…€“€MË×x€MË×ʆŒý…€“€MË×x‘ †Žx†Œý…€“€MË×x€MË×Êvš‚‚sw pššç Éup¥ "€¦#¢îvšaw p!€Y°!€y° !€N° !€n° !šç,É° ÔØ!€Y°!€y° Ô(…€î¥€†Žx†Œý…€“€MË×x€MË×Ê” ‘ Š†Œý…€“€MË×x‘ …€¡îŒ…€¦…€ ¢îv!€Y°!€y° l–º‡‹l†Žx‡€MË×ÉÔ ¥ ‚‚‚‘‹Úa†€ý‡€MË× çëa§²Ÿa§³Ÿ¡Ô$aa§£ì§€.Òa§³ñ‚‚”aa§£” Šèa§³ña¤ „ a˜” „ ‚‚• „ ëŠÛša˜w p…€¡îŒ…€¦…€ ¢îv¥€“š`w pšç(É °…€“²Ÿ¡Ô…€““šç(É °…€“³Ÿ¡Ô…€“í¥€“ €a³ €z²¡Ô€A ¢€a£h €?° €=°  €*°  €,°  €$°  €:°  šç-É° šwp  €²Ÿ  € ³Ÿ ña…€“ì Èš up…€“³ñ…€“í¥€“…€¡îŒ…€“¢î…€¦…€ ¢îvšwp šç,É°  šç-É° Õÿ‚‚–a˜” ¥€“…€“Óa…€“” ‚‚—a˜” ¥€“Šâ šç,É°ñ%Ô †Žx‡€MË×ʆ€ý‡€MË× çaë…€¡îŒ…€¦…€ ¢îv‡‘ Šva†„ý‡€MË× çëÔ[†Žx‡€MË×ÉÔ…€í¥€†Žx‡€MË×ʆŽx‡€MË×ʆ€ý‡€MË× ç†„ý‡€MË× ç뇑 ” ‘ ŠÖ‚˜–Dh…€Ó>…€ji!"²Ô3 íh†Žx €MË×Éñî !²ñ†€ý!€MË× †€ý €MË× Å !íiŠÈ†€ý€MË× ç…€€MËÄ:Ô¥ †€ý‘…€–†€ý€M팅€—¢ppÓ†˜‘–#âE¥€¡¥€ h¥ kj„/‚‚Íë¥9Ô#ñ ‚‚Α Š‚‚ö‘ ¥ †Œý†€­…€¡Ëî×x…€ ¢€MË×x¤1"ÕÛ†€ý€MË× æ²ŸÕÇv†€ý‡1€MË× ¤6ššç Éupš‡6ç˜w pš€ ‡6秣upš‡6y‡6x£wpš‡6ç Éwpš€-upš†€±‡6ç É Ëטw pš€-upš‡6ç  Éwpš‡6xwpš‡6æ wpš†€Ë‡6çÉ Ëט w pj…€¡îŒ…€¦…€ ¢îv¤5šdw p$›ZÐÚÔ‡5 Œ$€0£¢¤5šdw pŠášç¤6šç%¤7$‡7çÉÒ…€ Ò†€©…€¡Ëî×x¥€ Š…€ î¥€ $‡7çÉÒ…€ †€©…€¡Ëî×xÒ¥€ Š…€ í¥€ šwpÔK…€ †€©…€¡Ëî×xÒ2¥€ …€¡³ñ!†€©…€¡íËî×x²ñ …€¡í¥€¡Š¥€¡Š¥€¡Š…€ í¥€ $‡7çÉÒX…€¡ÒK…€ †€©Ëî×x²Ô¥€¡Š2…€ †€©Ëî×x²Ô¥€¡Š…€ †€©Ëî×x²Ô¥€¡Š¥€¡Š…€¡î¥€¡$‡7çÉ°$…° ÔL…€ …€¥²Ô…€¡Ò¥€¡Š…€¡í¥€¡Š.…€¡°…€ …€£°¡Ô¥€¡Š…€¡°…€ …€¤°¡Ô¥€¡Š¥€¡$…Ò¥€ ¥€¡$‡7çÉ°$‡7çÉ° $‡7çÉ° $‡7çÉ° $…° $‡6É° šwp j$‡7çÉ°$‡7çÉ° Ôh‡5î¤5‡5³ŸÕþ"$šç-É° $šç,É° åÕƒ$‹|†Žx‡1€MË×Éñ…€î¥€†Žx‡1€MË×ʇ1‘ ” ‘ ‹M¥€”‘‘j¥€ ¥€¡‹8¥€”‘‘j¥€ ¥€¡‹#†Žx‡1€MË×Éñ‡1‘Š ¥ ‚ƒ‘‹6Ô…€˜Ò …€˜†€¨p‹è¥€”€M¤6¤2‡2‡6²Ô†Œý‡2€MËׇ2€MËć2í¤2Šà‘j¥€ ¥€¡‹®‘‹©$‡1‘‹¡‘‹œ$‡1‘‹”t‹” ¥ ‹††Žx‡1€MË×ÉÔ ¥ ‚ƒ.‘Š¥hŠc†Žx‡1€MË×ÉÔ ¥ ‚ƒ>‘Š¥hŠ@¥hŠ9†€ý‡1€MË× çÉ Ò†€ý‡1€MË× x…€—¢¥€•hŠ ¥ ‚ƒL‘ŠÖƒb$€?°$€/° Ô¥ #åkŠk Õû¥¥†€ý€MË× æ²ŸÕ›¤2†Žx‡2€MËפ6‡6ɇ6É ¥‡2í¤24‡2†€ý€MË× æ²Ÿ ÔÍ4Ôbvš‚ƒœw pššç Éupš† p?€Y°?€y° ?€N° ?€n° ?€R° ?€r° Ô·¥ ?€R°?€r° åh?€Y°?€y° ¥ Õ\ú4Õ …€–†ˆý…€—¢pp°¥0ñ†e˜‘‹ø†ˆý€MË× ¤6‡6秲‡6秲Ÿ ñ}†€ý€MË× ç†ˆý€MË× çè¥0ñ[¥vš‚ƒ­w pš†€ý€MË× ç˜w pš‚ƒµw pš…€–wpš‚ƒ¸w pšdw p$€ Ò¨Š[¥vš‚ƒ¿w pš†€ý€MË× ç˜w pš‚ƒÇw pš…€–wpš‚ƒÊw pšdw p$€ Ò¨0°Õàþ$‹«¤6„6‚ƒÑ” „6†€ý€MË× ç˜” „6‚ƒÖ „6†€ý‡1€MË× ç˜” „6˜‘ †€ý‡1€MË× çÉÒR¤6„6‚ƒ×” „6†€ý€MË× ç˜ ” „6‚ƒÚ ” „6†€ý‡1€MË× ç˜” „6‚ƒÛ” „6˜rŠE¤6„6‚ƒÝ” „6†€ý€MË× ç˜ ” „6‚ƒß ” „6†€ý‡1€MË× ç˜” „6˜r¥h‹¶¤6„6‚ƒà” „6†€ý€MË× ç˜ ” „6‚ƒã ” „6†€ý‡1€MË× ç˜” „6˜‘ „/ìšç,ÉȤ6„6‚ƒä” „6„/˜” „6†€ý€MË× ç˜ ” „6‚ƒç ” „6†€ý‡1€MË× ç˜” „6‚ƒè” „6˜r¥hŠÖƒé4Ô‘–E'݆K†Žw” ‚„” s¥€™ššç#Éup†e†ëP…€•°ÕØ¥€—vš‚„$w pšwpšwp¥€“¥€’¥€…€’š€‡³Ÿ…€“€<³Ÿ¡Õ…€’í¥€’šæ…€’€Ë× |Õö…€’‘šæ…€’€Ë× ‚„1èŸÕÙ…€“Œ…€“â½Ë¢vš…€’wpš€:upššæ…€’€Ë× ˜w pš€ šæ…€’€Ë× §£upš€[upššæ…€’€Ë× }wpš€]upšæ…€’€Ë× šæ…€’€Ë× çèñššæ…€’€Ë× ç˜w pššç Éup…€“í¥€“‹Úþ¥vš‚„2w pš†e˜w pš‚„Kw pššç Éupš†€Pw pšw p†‚„NèÔ††eëP††§ì§šç,ÉÒp¥†‘¥€–Š …€•¥€—¥€•šæ…€–€Ë× |ÕŸ…€–†€ý€M팅€—¢pp°¥0ñ$¥ŽÆ†ŽÆ†˜€P” †ŽÆ‚„O€Q” †ŽÆ˜‘Š]†€ý€MË× y€ÿ²ñ ¥ †€ý‘Š¥ †€ý€MË× æ¥ŽÆ¥€“…€“…ŽÆ²Ô$†„ý…€“€MË× †€ý…€“€MË× Å …€“í¥€“ŠÓ0ñ¥ 0ÕDý>šç,ɱÕ¥¥†€ý€MË× æ¥€¥€’€M¥ŽÆ¥€“…€“…ŽÆ²Ô†Œý…€“€MË×…€“€MËÄ…€“í¥€“ŠÚ…€”Š‘Š‘ŠÖ„P…€²ñL…€¥ŽÆ¥€“…€“…ŽÆ²Ô9†Žx…€“€MË×ʆŽx…€“€MË×ʆŽx…€“€MË×Ê…€“í¥€“Š¾…€í€M¥ŽÆ¥€“…€“…ŽÆ²Ô9†Žx…€“€MË×ʆŽx…€“€MË×ʆŽx…€“€MË×Ê…€“í¥€“Š¾” ‘‘2Õ/üššç#Éup†K” –Parity error while reading Can not find device for Error number  while working with  went offline File  is no longer in directory. File name  can not be used. Disk is full,  can not be saved.. Volume for  is not online.Can not find the file File already exists..Volume  is write protected. þ}þ—þ±þ±þãþýÿ$ÿKÿrÿ˜ÿ±þ±þ±þ±þ±ÿ×þ±þ± 1One moment please, directory sort is in progress.ÿþÿ  of 77 files used,, Blocks used  Blocks available,, in largest of 77 files used,, Blocks used  Blocks available,, in largestVolume name is Volume name is Destination is :&Enter volume id of destination disk > :No directory on volume for : < press return >>4Destination is not allowed to be the same as source.. Old destination was , new destination is # Ok to use new destination? (Y/N) Destination is 7 is on destination disk, Remove the old version? (Y/N) Move buffer is  blocks..&One moment please, move in progress. DFILE,SCREENOPS,FILEOPS,CALCC No room for move buffer :: is blocks. contig. total avail. ) volume directory is full. Output of  to in progress.File type is not textDestination is CONSOLE:Remove the old version? (Y/N)"cannot change a removed file name     Cuý‘ÿŠý‘ÿŠ N Remove Change Undo Move Get Edit eXecute ENTER ESC Quit Help Output ??MNatural Sorted Logical Verify Advance Formfee ======================================================================================== DOCUMENT :usus Folder:VOL23:df.iv.1.text ======================================================================================== { DF - Directory/File utility } PROGRAM DFILE ; { UPDATE LOG: 12 Mar 83 RES modified read_vid for byte swapped TIPC 23 Mar 83 : RES - Restore cursor on return from A cmd. 12 Mar 83 RES - Corrected volume changed warning message 12 Jan 83 : RES - Established log entry and release date } USES {$U KERNEL.CODE} KERNEL, {$P }{ COMMANDIO } {$U COMMANDIO.CODE} COMMANDIO , {$P }{ SCREENOPS } {$U SCREENOPS.CODE } SCREENOPS ; {$P } CONST vs = 124; { vertical separator between columns } MAX_SVOL_DEPTH = 9; TYPE word = packed array[0..1] of 0..255 ; dentry = PACKED RECORD case integer of 0:( DFIRSTBLK: INTEGER; { FIRST PHYSICAL DISK ADDR } DLASTBLK: INTEGER; { POINTS AT BLOCK FOLLOWING } CASE DFKIND: FILEKIND OF SECUREDIR, UNTYPEDFILE: { ONLY IN DIR[0]...VOLUME INFO } (filler_1 : 0..2048; {13 bits} DVID: VID; { NAME OF DISK VOLUME } DEOVBLK: INTEGER; { LASTBLK OF VOLUME } DNUMFILES: DIRRANGE; { NUM FILES IN DIR } DLOADTIME: INTEGER; { TIME OF LAST ACCESS } DLASTBOOT: DATEREC); { MOST RECENT DATE SETTING } XDSKFILE,CODEFILE,TEXTFILE,INFOFILE, DATAFILE,GRAFFILE,FOTOFILE,SUBSVOL: (filler_2 : 0..1024; {12 bits} status : BOOLEAN; {Filer kludge temporary} DTID: TID; { TITLE OF FILE } DLASTBYTE: 1..FBLKSIZE; { NUM BYTES IN LAST BLOCK } DACCESS: DATEREC) { LAST MODIFICATION DATE } ); 1:( f1first : word ; f1last : word ; f1kind : word ; f1dvid: string[7]; f1deov: word ; f1dnum: word ; f1load: word ; f1boot: word ); 2:( f2first : word ; f2last : word ; f2kind : word ; f2dtid: string[15]; f2byte: word ; f2aces: word ); end; { of case } psysdir = array [dirrange] of dentry ; INXTYPE = ARRAY [ DIRRANGE ] OF DIRRANGE ; statustype = ARRAY[DIRRANGE] OF PACKED RECORD REMOVED : BOOLEAN ; CHANGED : BOOLEAN ; MOVED : BOOLEAN ; SWAPED : BOOLEAN ; END; { DIR_STATUS } {$P } VAR OK : BOOLEAN ; ALLDONE : BOOLEAN ; ESC_TRUE : BOOLEAN ; ENDOFLINE : BOOLEAN ; DO_MARKS : BOOLEAN ; CRT : BOOLEAN ; TARGET_KNOWN : BOOLEAN ; dest_is_text : boolean ; THE_SAME : BOOLEAN ; NEWPROMPT : BOOLEAN ; dirflip : boolean ; tarflip : boolean ; initentry : boolean ; none_printed : boolean ; going_up : boolean ; CH : CHAR; YESNO : CHAR; TAB : CHAR; home_tv : char; { home char from the televideo 950 crt } home_911 : char; { home char from the TI-911 crt } INAME : STRING ; { FILE NAME INPUT STRING } FNAME : STRING ; { FILE NAME ON WHICH TO WRITE THE DIRECTORY LIST } TNAME : STRING ; { FILE NAME FOR TARGET VOLUME } buildstring : string[1]; I,J,k,L : INTEGER; SORT : integer; SVOLS_ARY : ARRAY[0..MAX_SVOL_DEPTH] OF INTEGER ; { SVOL CNTR AND OFFSET } XY_ARRAY : ARRAY[0..MAX_SVOL_DEPTH] OF INTEGER ; { LAST CURSOR POS.} dir_unit : integer; { displayed directory unit number } dir_offs : integer; { offset in blocks to displayed directory } tar_unit : integer; { target unit number } tar_offs : integer; { target offset in blocks to directory } ICOUNT : INTEGER; TOTBLKS : INTEGER; { TOTAL BLOCKS USED ON VOLUME } MAXCONTIG : INTEGER; { LARGEST CONTIGUOUS SERIES OF BLOCKS ON VOLUME } NUMFILES : INTEGER; { NUMBER OF VALID FILES ON VOLUME } S_HEIGHT, { NUMBER OF LINES ON THE SCREEN LESS ONE } S_WIDTH : INTEGER; { NUMBER OF CHARACTERS PER LINE LESS ONE } ROW : INTEGER; { NUMBER OF PRESENT ROW } COL : INTEGER; { NUMBER OF PRESENT COLUMN } COL1 : INTEGER; { NUMBER OF ROWS IN COLUMN ONE } COL2 : INTEGER; { NUMBER OF ROWS IN COLUMN TWO } COL3 : INTEGER; { NUMBER OF ROWS IN COLUMN THREE } COL4 : INTEGER; { NUMBER OF ROWS IN COLUMN FOUR } Y_BASE : INTEGER; { Y - ADDRESS OF FIRST ROW IN DISPLAY MATRIX } Y_COUNTS : INTEGER; { Y - ADDRESS OF DISK LOGISTICS } formfeed : packed array[1..2] of char ; COL_LENGTHS: ARRAY [1..4] OF INTEGER; TOTALTOCOL : ARRAY [1..4] OF INTEGER; MONTHNAME : ARRAY [0..12] OF STRING[3]; FILETYPENAME:ARRAY [ FILEKIND ] OF STRING[8]; DISPDIR : psysdir ; BUFF1 : ARRAY[0..9] OF INTEGER ; { BRING DIRECTORY BUFFER TO 4 BLKS} ORGDIR : psysdir ; BUFF2 : ARRAY[0..9] OF INTEGER ; { BRING DIRECTORY BUFFER TO 4 BLKS} TARGETDIR : psysdir ; BUFF3 : ARRAY[0..9] OF INTEGER ; { BRING DIRECTORY BUFFER TO 4 BLKS} INDEX : ARRAY[DIRRANGE] OF DIRRANGE; {INDEX INTO DIRECTORY FOR SORT} LIST : INTERACTIVE; { OUTPUT FILE THE DIRECTORY LIST FILE ITSELF } DIR_STATUS : statustype ; key_cmd : sc_key_command ; {$p } procedure printentries; forward ; procedure pressreturn( st : string ); forward; procedure rdline ( var strng : string ); forward; (*$P *) segment PROCEDURE INITIALIZE ; BEGIN (* INITIALIZE *) TAB := CHR( 9 ); home_tv := chr( 30 ); { home char from the televideo 950 crt } home_911:= chr(130 ); { home char from the TI-911 crt } MONTHNAME[ 0] := '***'; MONTHNAME[ 1] := 'Jan'; MONTHNAME[ 2] := 'Feb'; MONTHNAME[ 3] := 'Mar'; MONTHNAME[ 4] := 'Apr'; MONTHNAME[ 5] := 'May'; MONTHNAME[ 6] := 'Jun'; MONTHNAME[ 7] := 'Jul'; MONTHNAME[ 8] := 'Aug'; MONTHNAME[ 9] := 'Sep'; MONTHNAME[10] := 'Oct'; MONTHNAME[11] := 'Nov'; MONTHNAME[12] := 'Dec'; FILETYPENAME[ UNTYPEDFILE ] := 'Untypedf'; FILETYPENAME[ XDSKFILE ] := 'Xdiskfil'; FILETYPENAME[ CODEFILE ] := 'Codefile'; FILETYPENAME[ TEXTFILE ] := 'Textfile'; FILETYPENAME[ INFOFILE ] := 'Infofile'; FILETYPENAME[ DATAFILE ] := 'Datafile'; FILETYPENAME[ GRAFFILE ] := 'Graffile'; FILETYPENAME[ FOTOFILE ] := 'Fotofile'; FILETYPENAME[ SECUREDIR ] := 'Securdir'; filetypename[ subsvol ] := 'Subsvol '; buildstring := ' '; { set string length to one } formfeed[1] := chr(12) ; { ASCII form feed character } TARGET_KNOWN := FALSE ; esc_true := false ; initentry := true; iname := dkvid ; { prefix volume id } svols_ary[0] := 0 ; xy_array[1] := 1 ; dir_offs := 0 ; tar_offs := 0 ; sort := 0 ; ch := ' ' ; ok := false ; END; { OF INITIALIZE } {$P } segment procedure help; begin sc_clr_screen; sc_goto_xy(0,2); writeln(', and :move the cursor'); writeln('Remove :the file under the cursor') ; writeln('Change :the file name under the cursor to '); writeln('Undo :restores the file name under the cursor'); writeln('Move :the file to the destination volume'); writeln('Get :a new destination volume'); writeln('Edit :the file at the cursor'); writeln('eXecute :the code file or redirect from the script file'); writeln(' and :update directory and accept new volume id'); writeln('Quit :update directory and exit to PASCAL system'); writeln('Help :displays this page of information'); writeln('Output :moves the display to a device or file'); writeln('Natural :displays files in the order of occurance on the volume'); writeln('Sorted :displays files in alphanumeric order'); writeln('Logical :displays files in alphanumeric order by suffix name'); writeln('Verify :redisplays the present directory'); writeln('Advance :advance to the subsidiary volume under the cursor'); writeln('Formfeed:Slew to top of page, if printer is the destination'); pressreturn('Help :describes the user options '); printentries; end; {$P } segment PROCEDURE DOUTPUT ; { OUTPUT THE DIRECTORY TO A FILE OR DEVICE } BEGIN newprompt := true; sc_clr_line( 0 ); sc_goto_xy(0,0); WRITE('Enter the output file name '); rdline(FNAME); IF LENGTH(FNAME)<>0 THEN BEGIN {$I-} REWRITE( LIST, FNAME); {$I+} OK := IORESULT = 0; IF NOT OK THEN BEGIN I := IORESULT; close(list); sc_goto_xy(0,0); WRITE('Can not open file ',fname,', error number ',I, ' '); READ(CH); END ELSE BEGIN CRT := FALSE ; PRINTENTRIES; { PRINT ALL INFORMATION } CLOSE( LIST, LOCK ); crt := true; END; END; END; {$P } procedure rdline{ var strng: string }; var exit_rd : boolean ; bell : char ; begin strng := '' ; exit_rd := false; bell := chr(7); repeat read(keyboard,ch); IF not eoln(keyboard) THEN begin key_cmd := sc_map_crt_command( ch ); case key_cmd of sc_del_key, sc_right_key, sc_dc1_key, sc_eof_key, sc_up_key, sc_down_key, sc_insert_key, sc_delete_key :begin write( bell ); end; sc_etx_key : begin exit_rd := true ; end; sc_escape_key: begin exit_rd := true ; strng := '' ; end; sc_backspace_key, sc_left_key : begin if length(strng) > 0 then begin sc_left; write( ' ' ); { replace screen character with space} sc_left; {$R- } strng[0] := chr( ord(strng[0]) - 1 ); {$R+ } end else write( bell ); end; sc_not_legal: begin if ch in sc_printable_chars then begin if length(strng) < 80 then begin {$R- } strng[0] := chr( ord(strng[0]) + 1 ) ; {$R+ } strng[ length( strng ) ] := ch ; write(ch); end else begin write( bell ); end; end else write( bell ); end; { of sc_not_legal } end; { of case key_cmd } end { not eoln } else begin ch := ' ' ;{ eoln so set char to a space } key_cmd := sc_not_legal ; end; until eoln(keyboard) or exit_rd ; end; { of rd_line } {$P } PROCEDURE CALC; VAR NEXTLOW : INTEGER ; LAST : INTEGER ; SIZE : INTEGER ; BEGIN { CALCULATE THE TOTAL BLOCKS USED } { INITIALIZE USED BLOCK COUNT } totblks := dispdir[0].DLASTBLK-dispdir[0].DFIRSTBLK ; IF dispdir[0].DNUMFILES > 0 THEN BEGIN FOR I := 1 TO dispdir[0].DNUMFILES DO with dir_status[i] do IF not removed then totblks := totblks + dispdir[I].DLASTBLK - dispdir[I].DFIRSTBLK ; { FIND THE LARGEST SET OF CONTIGUOUS BLOCKS } maxcontig := 0; NEXTLOW := dispdir[0].DNUMFILES + 1; LAST := dispdir[0].DEOVBLK ; REPEAT REPEAT NEXTLOW := NEXTLOW -1 ; UNTIL ( not dir_status[nextlow].removed ) OR ( NEXTLOW < 1 ); SIZE := LAST - dispdir[ NEXTLOW ].DLASTBLK ; IF SIZE > maxcontig THEN maxcontig := SIZE ; LAST := dispdir[ NEXTLOW ].DFIRSTBLK ; UNTIL NEXTLOW < 1 ; END ELSE maxcontig := dispdir[0].DEOVBLK - dispdir[0].DLASTBLK ; END; { OF CALC } {$P } PROCEDURE DISK_ERROR ( STRN : STRING ); VAR STRNG : STRING ; BEGIN newprompt := true; I := IORESULT; sc_goto_xy(0,0); CASE I OF 1:STRNG := CONCAT('Parity error while reading ',STRN); 2:STRNG := CONCAT('Can not find device for ',STRN); 3,4,12,13,14,15,17,18: BEGIN CASE I OF 3 :STRNG := '3' ; 4 :STRNG := '4' ; 12 :STRNG := '12' ; 13 :STRNG := '13' ; 14 :STRNG := '14' ; 15 :STRNG := '15' ; 17 :STRNG := '17' ; 18 :STRNG := '18' ; END; STRNG := CONCAT('Error number ',STRNG,' while working with ',STRN); END; 5:STRNG := CONCAT(STRN,' went offline '); 6:STRNG := CONCAT('File ',STRN,' is no longer in directory.'); 7:STRNG := CONCAT('File name ',STRN,' can not be used. '); 8:STRNG := CONCAT('Disk is full, ',STRN,' can not be saved.'); 9:STRNG := CONCAT('Volume for ',STRN,' is not online.'); 10:STRNG := CONCAT('Can not find the file ',STRN); 11:STRNG := CONCAT('File ',STRN,' already exists.'); 16:STRNG := CONCAT('Volume ',STRN,' is write protected. '); end; pressreturn( STRNG ); { append press return message and wait for one } end; {$P } PROCEDURE SORT_DIR; { SHELL SORT DIRECTORY INDIRECTLY VIA 'INDEX' ARRAY } VAR i,j,k,l,m : integer ; swap : BOOLEAN ; temp : integer ; BEGIN sc_goto_xy(0,0); WRITELN('One moment please, directory sort is in progress.', syscom^.crtctrl.eraseeol); IF DISPDIR[0].DNUMFILES > 0 THEN { NON-EMPTY DIRECTORY } BEGIN { SET UP INDEX ARRAY FOR SORT } FOR I := 1 TO MAXDIR DO INDEX[I]:=I; m := dispdir[0].dnumfiles div 2; while m > 0 do begin k := dispdir[0].dnumfiles - m ; j := 1 ; repeat i := j ; repeat l := i + m ; if dispdir[index[i]].dtid > dispdir[index[l]].dtid then begin temp := index[i]; index[i] := index[l]; index[l] := temp; i := i - m; swap := i > 0 end else swap := false ; until not swap ; j := j + 1; until j>k; m := m div 2; end; { while m > 0 do } end; end; {$P } { Sort file names giving a four character suffix priority } procedure suffixsort; var newname : string ; begin for i := 1 to dispdir[0].dnumfiles do begin newname := dispdir[i].dtid; l := length(newname); if l > 4 then if newname[l-4]='.' then begin dispdir[i].dtid := concat( copy(newname,l-4,5), copy(newname,1,l-5) ); dir_status[i].swaped := true ; end else dir_status[i].swaped := false else dir_status[i].swaped := false; end; sort_dir; for i:= 1 to dispdir[0].dnumfiles do begin if dir_status[i].swaped then begin newname := dispdir[i].dtid; l := length( newname ); dispdir[i].dtid := concat ( copy(newname,6,l-5), copy(newname,1,5 ) ); end; end; end; {$p } procedure flipword( var flipme : word ); var temp : word ; begin temp[0]:= flipme[0]; flipme[0] := flipme[1]; flipme[1] := temp[0]; end; procedure flipdir( var dir : psysdir ); var entrynum : integer; begin with dir[0] do begin flipword( f1first ); flipword( f1last ); flipword( f1kind ); flipword( f1deov ); flipword( f1dnum ); flipword( f1load ); flipword( f1boot ); end; for entrynum := 1 to maxdir do with dir[entrynum] do begin flipword( f2first ); flipword( f2last ); flipword( f2kind ); flipword( f2byte ); flipword( f2aces ); end; end; {$P } PROCEDURE PROMPT ( L :INTEGER; ST:STRING ); BEGIN {* *** some terminals accept msb on as low intensity display *** * FOR I := 1 TO LENGTH(ST) DO * IF st[i] in [ 'a'..'z'] then ST[I] := CHR( ORD( ST[I])+128); *} sc_clr_line( L ); sc_goto_xy( 0,L ); WRITE(ST); END; PROCEDURE PRESSRETURN { ST : STRING } ; VAR CH : CHAR ; BEGIN PROMPT(0,CONCAT(ST,' ')); READ(CH); END; PROCEDURE PRINTSTATS; BEGIN IF CRT THEN BEGIN sc_goto_xy(0, 22); WRITE(NUMFILES:4,' of 77 files used,', TOTBLKS:5,' Blocks used ' ); sc_goto_xy(0,23); WRITE(DISPDIR[0].DEOVBLK-TOTBLKS:4,' Blocks available,', MAXCONTIG:5,' in largest'); END ELSE BEGIN WRITELN(LIST); WRITELN(LIST); WRITELN(LIST,NUMFILES:4,' of 77 files used,', TOTBLKS:5,' Blocks used '); WRITELN(LIST,DISPDIR[0].DEOVBLK-TOTBLKS:4,' Blocks available,', MAXCONTIG:5,' in largest'); WRITELN(LIST); END END; { PRINTSTATS } {$P } procedure writeit( st:string; bool:boolean); var i : integer ; begin { if terminal has a low intensity display the string should be output in that mode when the boolean is true } { if bool then for i:= 1 to length(st) do st[i] := chr( ord(st[i])+128 ); } write( st ); end; PROCEDURE WITH_WRITE( K : INTEGER ); VAR i,j : INTEGER; low_intensity : boolean; suffix : boolean ; BEGIN with dispdir[k],dir_status[k] do begin low_intensity := removed or changed or moved; i := length(dtid); { length of file name } suffix := false ; if i > 4 then if dtid[i-4] = '.' then suffix := true ; if suffix then begin if crt then writeit( copy(dtid,1,i-5),low_intensity ) else write(list, copy(dtid,1,i-5) ); j:=i; while j<15 do begin j := j + 1 ; if crt then write( ' ' ) else write( list, ' ' ); end; if crt then writeit( copy(dtid,i-4,5),low_intensity ) else write(list, copy(dtid,i-4,5) ); end else begin if crt then writeit( dtid,low_intensity ) else write( list, dtid ); j := i ; while j<15 do begin j := j+1 ; if crt then write(' ') else write(list,' '); end; end; if low_intensity and crt then begin write( ' ' ); if removed then write('R') else write('-'); if changed then write('C') else write('-'); if moved then write('M') else write('-'); write( chr(vs) ); end else if crt then write( dlastblk-dfirstblk:4,chr(vs) ) else write(list, dlastblk-dfirstblk:4,' ' ); end; END; {$P } PROCEDURE PRINTENTRIES; VAR DISP : INTEGER; REM : INTEGER; ROW : INTEGER; BEGIN NEWPROMPT := TRUE; IF CRT THEN BEGIN {*** OUTPUT THE DIRECTORY TO THE CRT SCREEN } sc_clr_screen ; { BLANK OUT THE CRT SCREEN } sc_goto_xy(0,1); WRITE('Volume name is ',DISPDIR[0].DVID,':'); END else WRITE(list,'Volume name is ',DISPDIR[0].DVID,':'); ROW := (DISPDIR[0].DNUMFILES) DIV 4; REM := (DISPDIR[0].DNUMFILES) MOD 4; IF REM >= 1 THEN COL1 := ROW + 1 ELSE COL1 := ROW ; IF REM >= 2 THEN COL2 := ROW + 1 ELSE COL2 := ROW ; IF REM >= 3 THEN COL3 := ROW + 1 ELSE COL3 := ROW ; COL4 := ROW ; TOTALTOCOL[1]:= 0; TOTALTOCOL[2]:= COL1; TOTALTOCOL[3]:= COL1+COL2; TOTALTOCOL[4]:= COL1+COL2+COL3; COL_LENGTH[1]:= COL1; COL_LENGTH[2]:= COL2; COL_LENGTH[3]:= COL3; COL_LENGTH[4]:= COL4; IF DISPDIR[0].DNUMFILES > 0 THEN BEGIN IF CRT THEN BEGIN Y_BASE := 2; IF COL1 < 19 THEN Y_BASE := 3; Y_COUNTS := Y_BASE; sc_goto_xy(0,Y_BASE); END ELSE BEGIN WRITELN(LIST); WRITELN(LIST) END; FOR I := 1 TO COL1 DO BEGIN { PRINT ALL ENTRIES IN THE DIRECTORY } DISP := I; WITH_WRITE(INDEX[DISP]); DISP := DISP + COL1; IF DISP <= ( totaltocol[3] ) THEN WITH_WRITE(INDEX[DISP]); DISP := DISP + COL2; IF DISP <= ( totaltocol[4] ) THEN WITH_WRITE(INDEX[DISP]); DISP := DISP + COL3; IF ( DISP <= DISPDIR[0].DNUMFILES ) THEN WITH_WRITE(INDEX[DISP]); IF CRT THEN sc_goto_xy( 0,y_base+i ) ELSE WRITELN(LIST); END; { FOR/WITH } END; PRINTSTATS; sc_goto_xy(50,23); if target_known then write('Destination is ',tname,':'); END; { PRINTENTRIES } {$P } PROCEDURE LCTOUC( VAR STR:STRING ); var i : integer; BEGIN FOR I := 1 TO LENGTH(STR) DO IF not((STR[I]< 'a') or (str[i] > 'z')) then str[i] := chr( ord(str[i])-ord('a')+ord('A')); end; procedure read_vid( u: integer); var dirent: dentry; dnum_ok : boolean; begin dirent.dfirstblk := -1; { set an illegal value for read check } UNITREAD(u,dirent,sizeof(direntry),2,0); IF IORESULT = 0 THEN begin if dirent.dfirstblk = 0 then begin if dirent.dlastblk > 255 then begin flipword( dirent.f1kind ); flipword( dirent.f1dnum ); end; with dirent do begin {if f1last[1] = 0 then dnum_ok := ( f1dnum[0] = 0 ) and * ( f1dnum[1] <= 77 ) * else dnum_ok := ( f1dnum[0] <= 77 ) and * ( f1dnum[1] = 0 ); } if ( length(dvid)<=0 ) or ( length(dvid)> 7 ) or ( dfkind <> untypedfile ) then syscom^.unitable^[u].UVID := '' else syscom^.unitable^[u].uvid := dirent.dvid ; end; end else syscom^.unitable^[u].uvid := ''; end else syscom^.unitable^[u].uvid := ''; end; {$p } function get_unit_number( var volstr: string ):integer; var ok_num : boolean ; unum : integer ; BEGIN get_unit_number := 0; unum := 0; if volstr='' then volstr := dkvid; IF volstr[1] = ':' THEN volstr := DKVID; {DEFAULT VOLUME ID} IF volstr[1] = '*' THEN volstr := SYVID; {SYSTEM VOLUME ID} I := POS(':',volstr); IF I >0 THEN volstr := COPY(volstr,1,I-1);{ strip all chars following a : } IF volstr[1]='#' THEN BEGIN { Standard specification of unit number } I := LENGTH(volstr); IF I>1 THEN volstr := COPY(volstr,2,I-1) ELSE volstr := dkvid ; END; I := LENGTH(volstr); J := 0; K := 1; ok_num := true; WHILE (K<=I)AND ok_num do if (volstr[k] in digits) then BEGIN J := J*10+ORD(volstr[K])-ord('0'); K := K + 1; END else ok_num := false ; IF ok_num and ( j>maxunit ) THEN exit(get_unit_number); IF ok_num THEN begin unum := J; if syscom^.unitable^[j].uisblkd then read_vid(j); end ELSE BEGIN { not unit number - try volume names } LCTOUC ( volstr ); { ensure all upper case alphabetic chars } j := 0; REPEAT { look for the volume name in the unit table } j := j + 1; if volstr=syscom^.unitable^[j].uvid then { match to old name } IF syscom^.UNITABLE^[J].UISBLKD THEN read_vid(j) ; { blk vol } UNTIL (volstr = syscom^.UNITABLE^[j].UVID)OR( j >= MAXUNIT ); IF volstr = syscom^.UNITABLE^[j].UVID THEN unum := j {name is true } ELSE BEGIN { retry all blocked volumes reading volume name } J := 0; REPEAT J := J+1; IF syscom^.UNITABLE^[J].UISBLKD THEN read_vid(j); UNTIL (J>=MAXUNIT)OR (volstr=syscom^.unitable^[j].uvid); IF volstr = syscom^.unitable^[J].UVID THEN unum := J; END; end; get_unit_number := unum ; end; {$P } FUNCTION GOOD_TARGET:BOOLEAN; VAR OK : BOOLEAN ; ABORT : BOOLEAN ; I : INTEGER ; BEGIN OK := TRUE ; ABORT := FALSE ; THE_SAME := FALSE ; repeat IF NOT TARGET_KNOWN THEN REPEAT sc_clr_line( 0 ); sc_goto_xy(0,0); WRITE('Enter volume id of destination disk > ' ); NEWPROMPT := TRUE; rdline(TNAME); IF TNAME = '' THEN ABORT := TRUE; IF NOT ABORT THEN begin tar_unit := get_unit_number( tname ); tname := syscom^.unitable^[tar_unit].uvid; if not(syscom^.unitable^[tar_unit].uisblkd) THEN begin unitclear(tar_unit); dest_is_text := TRUE; end else BEGIN DEST_IS_TEXT := FALSE; {$I-} unitread(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0); {$I+} OK := IORESULT = 0; IF NOT OK THEN DISK_ERROR(CONCAT(TNAME,':')) else BEGIN IF TARGETDIR[0].DLASTBLK > 255 THEN BEGIN TARFLIP := TRUE ; FLIPDIR(TARGETDIR); END ELSE TARFLIP := FALSE ; with targetdir[0] do if ( length(dvid)<=0 ) or ( length(dvid)> 7 ) or ( dnumfiles < 0 ) or ( dnumfiles > 77) or ( dfkind <> untypedfile ) then begin sc_clr_line( 0 ); sc_goto_xy(0,0); write('No directory on volume for ',TNAME, ': < press return >'); read(ch); ok := false ; end else IF dir_unit = tar_unit then if dir_offs = tar_offs then BEGIN sc_clr_line( 0 ); sc_goto_xy(0,0); write('Destination is not allowed to be the same as source.', ' '); read(ch); OK := FALSE; end; END; END; END; UNTIL OK OR ABORT ELSE BEGIN IF NOT dest_is_text then BEGIN {$I-} unitread(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0); {$I+} OK := IORESULT = 0; IF NOT OK THEN DISK_ERROR(CONCAT(TNAME,':')) else BEGIN IF TARGETDIR[0].DLASTBLK > 255 THEN BEGIN TARFLIP := TRUE ; FLIPDIR(TARGETDIR); END ELSE TARFLIP := FALSE ; with dispdir[0] do if ( length(dvid)<=0 ) or ( length(dvid)> 7 ) or ( dnumfiles < 0 ) or ( dnumfiles > 77) or ( dfkind <> untypedfile ) then ok := false else IF TNAME <> TARGETDIR[0].DVID THEN BEGIN repeat sc_clr_line( 0 ); sc_goto_xy(0,0); WRITE('Old dest. was ',TNAME, ':, new dest. is ',targetdir[0].dvid, ' Ok to use new destination? (Y/N) '); read(ch); until (ch='N') or (ch='n') or (ch='Y') or (ch='y'); ok := (ch='y') or (ch='Y'); if ok then TNAME := TARGETDIR[0].DVID ; end; END; END; target_known := ok; END; UNTIL OK OR ABORT ; TARGET_KNOWN := NOT ABORT ; GOOD_TARGET := NOT ABORT ; sc_goto_xy(50,23); IF TARGET_KNOWN THEN write('Destination is ',TNAME,': ' ); END; {$P } FUNCTION UNIQUE_TARG( ST : STRING ) : BOOLEAN ; VAR MATCH : BOOLEAN ; CH : CHAR; I : INTEGER ; NFILES : INTEGER ; BEGIN CH := 'Y'; { INITIALIZE CHARACTER TO CAUSE TRUE RETURN } NFILES := TARGETDIR[0].DNUMFILES ; I := 0; MATCH := FALSE ; IF NFILES > 0 THEN REPEAT I := I+1; MATCH := ST = TARGETDIR[I].DTID ; UNTIL MATCH OR ( I>= NFILES ); IF MATCH THEN BEGIN sc_clr_line( 0 ); sc_goto_xy(0,0); WRITE(ST, ' is on destination disk, Remove the old version? (Y/N) '); NEWPROMPT := TRUE ; { RESTORE THE PROMPT LINE ON RETURN } REPEAT READ(KEYBOARD,CH) UNTIL (CH='Y')OR(CH='y')or(CH='N')OR(CH='n') OR (sc_map_crt_command(ch)= sc_escape_key) ; IF (CH='Y')OR(CH='y') then BEGIN targetdir[0].dnumfiles := nfiles - 1 ; IF I < NFILES THEN repeat targetdir[i] := targetdir[i+1]; i:= i+1; until i >= nfiles ; END; END; sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } UNIQUE_TARG := ((CH='Y')OR(CH='y')); END; {$P } function room_on_target( VAR DIR : psysdir ; REQUEST : INTEGER; VAR DIRREC : INTEGER; var totalblks: integer; var largest : integer ):BOOLEAN ; var nextlow : integer ; last : integer ; size : integer ; begin { FIND THE LARGEST SET OF CONTIGUOUS BLOCKS } LARGEST := 0; totalblks := 0; NEXTLOW := DIR[0].DNUMFILES + 1; LAST := DIR[0].DEOVBLK ; REPEAT NEXTLOW := NEXTLOW -1 ; SIZE := LAST - DIR[ NEXTLOW ].DLASTBLK ; totalblks := totalblks + size ; IF SIZE > LARGEST THEN BEGIN DIRREC := NEXTLOW+1 ; { ENTRY POSITION FOR LARGEST SPACE } LARGEST := SIZE ; END; LAST := DIR[ NEXTLOW ].DFIRSTBLK ; UNTIL NEXTLOW <= 0 ; ROOM_ON_TARGET := REQUEST <= LARGEST ; END; PROCEDURE MOVE_MESSAGE( WDSIZE: INTEGER ) ; BEGIN {******} sc_erase_to_eol( 50, 22 ); sc_goto_xy(50,22); WRITE('Move buffer is ', WDSIZE ,' blocks.' ); {******} sc_clr_line( 0 ); sc_goto_xy(0,0); WRITE('One moment please, move in progress. '); NEWPROMPT := TRUE; END; {$P } PROCEDURE MOVE_FILE( DIRPOS:INTEGER ) ; VAR error : boolean ; totalblks: integer ; largest : integer ; SIZE : INTEGER ; SOURCE : INTEGER ; DEST : INTEGER ; TEMP : INTEGER ; I : INTEGER ; DIRREC : INTEGER ; BLOCKS :^integer ; { pointer to memory } movblksiz : integer; { size of the move buffer in blocks } { MOVE_FILE } BEGIN i:= varavail( 'DFILE,SCREENOPS,FILEOPS,CALC' ); i:= i - 1024; { leave 2048 bytes of stack } if i < 0 then i:=0; movblksiz := ( i div 256 - 1 ); { if movblksiz > 63 then movblksiz := 63 ;} { limit size to less than 32767 } i := varnew ( blocks,movblksiz*256 ) ; if i = 0 then begin pressreturn(' No room for move buffer '); exit(move_file); end; SIZE := dispdir[DIRPOS].DLASTBLK-dispdir[DIRPOS].DFIRSTBLK ; IF GOOD_TARGET THEN IF NOT DEST_IS_TEXT THEN BEGIN IF UNIQUE_TARG( dispdir[DIRPOS].DTID ) THEN IF TARGETDIR[0].DNUMFILES < MAXDIR THEN BEGIN IF ROOM_ON_TARGET( TARGETDIR, SIZE, DIRREC ,totalblks, largest ) THEN BEGIN MOVE_MESSAGE( MOVBLKSIZ ); { OPEN THE DIRECTORY OF THE TARGET VOLUME FOR NEW ENTRY } I := TARGETDIR[0].DNUMFILES + 1; REPEAT TARGETDIR[I] := TARGETDIR[I-1]; I := I-1; UNTIL I <= DIRREC ; { MOVE THE DIRECTORY ENTRY TO THE TARGET } TARGETDIR[DIRREC] := dispdir[DIRPOS]; { SET THE STARTING BLOCK NUMBER FOR THE FILE ON THE TARGET VOLUME } TARGETDIR[DIRREC].DFIRSTBLK := TARGETDIR[DIRREC-1].DLASTBLK ; { SET THE ENDING BLOCK NUMBER FOR THE FILE ON THE TARGET VOLUME } TARGETDIR[DIRREC].DLASTBLK := TARGETDIR[DIRREC].DFIRSTBLK + SIZE ; { INCREASE THE NUMBER OF FILES ON THE TARGET VOLUME } TARGETDIR[0].DNUMFILES := TARGETDIR[0].DNUMFILES + 1; { MOVE THE FILE TO THE TARGET VOLUME } SOURCE := dispdir[DIRPOS].DFIRSTBLK; DEST := TARGETDIR[DIRREC].DFIRSTBLK; REPEAT TEMP := dispdir[DIRPOS].DLASTBLK-SOURCE; IF TEMP > movblksiz THEN TEMP := movblksiz; {$I- } unitread(dir_unit,blocks^,temp*512,source+dir_offs,0); {#I+ } error := ioresult <> 0; IF not error THEN BEGIN IF TARFLIP THEN FLIPDIR(TARGETDIR); TARFLIP := FALSE; SOURCE := SOURCE + TEMP; {$I- } unitwrite(tar_unit,blocks^,temp*512,dest,0); {$I+ } error := ioresult <> 0; IF not error THEN DEST := DEST + TEMP ELSE DISK_ERROR(CONCAT( TNAME,':',dispdir[DIRPOS].DTID ) ); END ELSE DISK_ERROR( CONCAT(INAME,':',dispdir[DIRPOS].DTID) ); WRITE('.'); UNTIL (SOURCE = dispdir[DIRPOS].DLASTBLK) OR error ; IF not error THEN begin {$I- } unitwrite(tar_unit,targetdir,(maxdir+1)*sizeof(dir_entry),2,0); {$I+ } sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } dir_status[dirpos].moved := true; with_write( dirpos ); end; END ELSE BEGIN sc_clr_line( 0 ); sc_goto_xy(0,0); WRITE( dispdir[dirpos].dtid, ' is ',size,' blocks. ',largest,' contig. ',totalblks,' total avail.', ' '); read(ch); newprompt := true; end; end else begin sc_clr_line( 0 ); sc_goto_xy(0,0); write( TARGETDIR[0].DVID, ' volume directory is full. '); read(ch); newprompt := true; end; END ELSE BEGIN { OUTPUT DEVICE IS FOR TEXT } IF dispdir[DIRPOS].DFKIND = TEXTFILE THEN BEGIN IF tar_unit = 1 THEN sc_clr_screen ; sc_clr_line( 0 ); sc_goto_xy(0,0); WRITE('Output of ',dispdir[dirpos].dtid, ' to ',TNAME,': in progress.'); IF tar_unit = 1 THEN WRITELN; newprompt := true; { MOVE THE FILE TO THE TARGET VOLUME } SOURCE := dispdir[DIRPOS].DFIRSTBLK+2; REPEAT TEMP := dispdir[DIRPOS].DLASTBLK-SOURCE; IF TEMP > MOVBLKSIZ THEN TEMP := MOVBLKSIZ; {$I- } unitread(dir_unit,blocks^,temp*512,source+dir_offs,0); {#I+ } error := ioresult <> 0; IF not error THEN BEGIN SOURCE := SOURCE + TEMP; {$I- } unitwrite(tar_unit,blocks^,temp*512,dest,0); {$I+ } error := ioresult <> 0; IF not error THEN DEST := DEST + TEMP ELSE DISK_ERROR(CONCAT( TNAME,':',dispdir[DIRPOS].DTID ) ); END ELSE DISK_ERROR( CONCAT(INAME,':',dispdir[DIRPOS].DTID) ); WRITE('.'); UNTIL (SOURCE = dispdir[DIRPOS].DLASTBLK) OR error ; sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } dir_status[dirpos].moved := true; if not (tar_unit = 1) then with_write( dirpos ); END else pressreturn('File type is not text'); IF tar_unit = 1 THEN BEGIN PRINTENTRIES; sc_goto_xy(50,23); WRITE('Destination is CONSOLE:'); END; END; VARDISPOSE( BLOCKS,MOVBLKSIZ*256); { RELEASE MOVE BUFFER } END; {$P } PROCEDURE GET; BEGIN TARGET_KNOWN := FALSE; sc_erase_to_eol( 50, 23 ); sc_goto_xy(50,23); IF GOOD_TARGET THEN { DUMMY IF TO CARRY THE FUNCTION CALL TO GOOD_TARGET }; end; {$P } PROCEDURE CHANGE_FILE( CU:CHAR ; J:INTEGER ); VAR CH : CHAR ; ST : STRING[15]; FUNCTION UNIQUE_FILE : BOOLEAN ; VAR MATCH : BOOLEAN ; CH : CHAR; NROW,NCOL : INTEGER ; BEGIN CH := 'Y'; { INITIALIZE TO CHARACTER TO CAUSE TRUE RETURN } I := dispdir[0].DNUMFILES + 1; MATCH := FALSE ; IF I > 0 THEN REPEAT I := I-1; IF (J <> INDEX[I])AND(not dir_status[INDEX[I]].removed) THEN MATCH := ST = dispdir[INDEX[I]].DTID ; UNTIL MATCH OR ( I<=1 ); IF MATCH THEN BEGIN NCOL := 5 ; REPEAT NCOL := NCOL - 1 UNTIL I > TOTALTOCOL[NCOL]; NROW := I - TOTALTOCOL[NCOL]; sc_goto_xy((NCOL-1)*20,Y_BASE+NROW-1); dir_status[index[i]].removed := true ; with_write( index[i] ); dir_status[index[i]].removed := false; sc_clr_line( 0 ); sc_goto_xy(0,0); WRITE('Remove the old version? (Y/N)'); NEWPROMPT := TRUE ; { RESTORE THE PROMPT LINE ON RETURN } sc_goto_xy((NCOL-1)*20,Y_BASE+NROW-1); REPEAT READ(KEYBOARD,CH) UNTIL (CH='Y')OR(CH='y')or(CH='N')OR(CH='n') OR(sc_map_crt_command(ch) = sc_escape_key ); IF (CH='Y')OR(CH='y') then BEGIN NUMFILES := NUMFILES -1; dir_status[index[i]].removed := true ; CALC; PRINTSTATS; END ELSE WITH_WRITE( index[i] ); END; sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } UNIQUE_FILE := ((CH='Y')OR(CH='y')); END; {$P } { CHANGE_FILE } BEGIN CASE CU OF 'C','c':BEGIN IF dir_status[j].removed then begin newprompt := true; pressreturn('cannot change a removed file name '); end else begin ST := dispdir[J].DTID; IF (( LENGTH(ST)>5)AND(LENGTH(ST)<15)) THEN IF ST[LENGTH(ST)-4] = '.' THEN WHILE LENGTH(ST)<15 DO INSERT ( ' ',ST,LENGTH(ST)-4); WHILE LENGTH(ST)< 15 DO ST := CONCAT(ST,' '); WRITE(ST); sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } I := 1; REPEAT READ (KEYBOARD,CH); key_cmd := sc_map_crt_command( ch ); IF ((key_cmd = sc_left_key ) or ( key_cmd = sc_backspace_key )) AND (I>1) THEN I := I-1; IF (key_cmd = sc_right_key) AND (I<15) THEN I := I+1; IF (CH>='a') AND (CH<='z') THEN CH := CHR( ORD('A')+ORD(CH)-ORD('a') ); IF NOT( (CH='?') OR(CH='=') OR(CH='*') OR (CH=',') OR(CH='$') OR(CH=':') OR (key_cmd <> SC_Not_legal ) OR EOLN(keyboard) OR (ORD(CH)> 127)OR (ORD(CH)< ORD(' ')) ) THEN BEGIN ST[I]:= CH; WRITE(OUTPUT,CH); IF I<15 THEN I:=I+1; END; sc_goto_xy( (COL-1)*20+I-1 ,Y_BASE+ROW-1); { PLACE THE CURSOR } UNTIL EOLN(keyboard)OR(key_cmd = sc_escape_key ) OR(key_cmd = sc_etx_key ); I := POS(' ',ST); WHILE I<>0 DO BEGIN DELETE(ST,I,1); { REMOVE THE SPACE CHARACTER } I := POS(' ',ST) END; IF NOT(CH=syscom^.crtinfo.altmode) THEN IF UNIQUE_FILE THEN BEGIN DIR_STATUS[J].CHANGED := TRUE ; dispdir[J].DTID := ST; END; sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } WITH_WRITE( J ); end; END; {$P } 'U','u':BEGIN ST := ORGDIR[J].DTID; IF UNIQUE_FILE THEN BEGIN IF dir_status[j].removed THEN NUMFILES := NUMFILES +1; dir_status[j].removed := false; { RESTORE FILE TO DIRECTORY } dir_status[j].changed := false; dispdir[J].DTID := ORGDIR[J].DTID ; { RESTORE NAME IF C(hanged } WITH_WRITE( J ); CALC; PRINTSTATS; END; END; END; { OF CASE CU } END; {$P } PROCEDURE DELETEFILES; VAR I,J : INTEGER ; BEGIN J := 0; IF NUMFILES <> 0 THEN FOR I := 1 TO NUMFILES DO BEGIN REPEAT J := J +1 UNTIL not dir_status[j].removed; IF J > I THEN dispdir[I] := dispdir[J]; END; dispdir[0].DNUMFILES := NUMFILES ; if dirflip then BEGIN DIRFLIP := FALSE; flipdir(dispdir); END; {$I-} unitwrite(dir_unit,dispdir,(maxdir+1)*sizeof(direntry),2+dir_offs,0); {$I+} IF IORESULT <>0 THEN DISK_ERROR( INAME ); END; {$P } PROCEDURE MARKENTRIES; VAR COMPLETE : BOOLEAN; MATCH : BOOLEAN; new_extend : boolean ; extension : boolean ; CH : CHAR; ST : STRING ; chartostr : string[1]; I,J,K : INTEGER; NROW,NCOL : INTEGER; rep_factor : integer; {$P } BEGIN { MARKENTRIES } COMPLETE := FALSE ; NEWPROMPT := TRUE ; extension := false ; NEW_EXTEND := TRUE; chartostr := ' '; REPEAT { UNTIL COMPLETE 1111111 } REPEAT { UNTIL COMPLETE 2222222 } esc_true := false ; IF NEWPROMPT THEN if not extension then PROMPT(0, ' Remove Change Undo Move Get Edit eXecute ENTER ESC Quit Help Output ?' ) else prompt(0, 'Natural Sorted Logical Verify Advance Formfeed 12 Mar 83' ); NEWPROMPT := FALSE ; J := INDEX[ TOTALTOCOL[COL]+ROW ]; XY_ARRAY[ SVOLS_ARY[0] ] := J ; {*****} if new_extend then begin if dispdir[0].dnumfiles > 0 then begin sc_erase_to_eol(25,1); sc_goto_xy(25,1); WITH dispdir[J] DO WRITE(DTID,' ':(17-LENGTH(DTID)), DLASTBLK-DFIRSTBLK:5, DACCESS.DAY:4,'-',MONTHNAME[DACCESS.MONTH],'-',DACCESS.YEAR:2, DFIRSTBLK:5, DLASTBYTE:5, FILETYPENAME[dfkind]:10 ); end; new_extend := false; end; {*****} sc_goto_xy( (COL-1)*20,Y_BASE+ROW-1); { PLACE THE CURSOR } {*** READ THE NEXT COMMAND CHARACTER } rep_factor := 0; READ(KEYBOARD,CH); while ch in digits do begin rep_factor := rep_factor*10+(ord(ch)-ord('0')); read(keyboard,ch); end; key_cmd := sc_map_crt_command( ch ); repeat IF key_cmd = sc_up_key THEN IF ROW = 1 THEN ROW := COL_LENGTH[COL] ELSE ROW := ROW-1; IF key_cmd = sc_down_key THEN IF ROW = COL_LENGTH[COL] THEN ROW := 1 ELSE ROW := ROW + 1; IF EOLN(KEYBOARD) THEN IF ROW = COL_LENGTH[COL] THEN BEGIN ROW := 1; IF (COL<4)THEN IF (COL_LENGTH[COL+1]>0)THEN COL := COL + 1 ELSE COL := 1 ELSE COL := 1; END ELSE ROW := ROW + 1; IF (key_cmd = sc_backspace_key) or (key_cmd = sc_left_key) THEN IF COL = 1 THEN IF ROW <= COL_LENGTH[4] THEN COL := 4 ELSE IF ROW <= COL_LENGTH[3] THEN COL := 3 ELSE IF ROW <= COL_LENGTH[2] THEN COL := 2 ELSE COL := 1 ELSE COL := COL - 1; IF (key_cmd = sc_right_key) OR (CH = TAB) THEN IF ROW <= COL4 THEN { ROW IS COMPLETE } IF COL = 4 THEN COL := 1 ELSE COL := COL + 1 ELSE { ROW IS A PARTIAL, 1,2 OR 3 COLUMNS ONLY } IF ((COL=1) AND (ROW=COL2)) THEN COL := 2 ELSE IF ((COL=2) AND (ROW=COL3)) THEN COL := 3 ELSE COL := 1; { COLUMN THREE WRAPS TO COLUMN ONE } IF ( KEY_CMD = SC_NOT_LEGAL ) THEN IF ( CH = HOME_TV ) OR ( CH = HOME_911 ) THEN BEGIN ROW := 1; COL := 1; END; new_extend := ( key_cmd <> sc_not_legal ) or ( ch = home_tv ) or ( ch = home_911 ) or ( ch = tab ) or ( eoln(keyboard) ); COMPLETE := ( key_cmd = sc_etx_key ) or ( key_cmd = sc_escape_key); rep_factor:=rep_factor-1; until (rep_factor<1) or complete ; {*** END OF CURSOR POSITIONING COMMANDS } {$P } if not(new_extend or ( key_cmd = sc_etx_key ) or ( key_cmd = sc_escape_key )) then case ch of {*** REMOVE FILE PROCESSING } 'R','r':BEGIN IF not dir_status[j].removed THEN BEGIN NUMFILES := NUMFILES - 1; dir_status[j].removed := true; with_write( j ); END; CALC; PRINTSTATS; END; {*** SORT AND DISPLAY PRESENT VOLUME ***} 'S','s':begin sort := 1; sort_dir ; printentries; new_extend := true; row := 1; col := 1; end; {*** SORT BY FOUR CHARACTER SUFFIX & FILE NAME ***} 'L','l':begin sort := 2; suffixsort; printentries; new_extend := true; row := 1; col := 1; end; {*** MOVE THE FILE TO A TARGET } 'M','m': IF not DIR_STATUS[J].REMOVED THEN MOVE_FILE(J) ELSE begin newprompt := true; pressreturn('A REMOVED FILE CAN NOT BE MOVED. '); end; {*** FORMFEED THE PRINTER ***} 'F','f':begin if target_known then if tar_unit = 6 then unitwrite(tar_unit,formfeed,1); end; {*** SET NATURAL ORDER AND DISPLAY PRESENT VOLUME ***} 'N','n':begin sort := 0; for i:=1 to maxdir do index[i]:= i; printentries; new_extend := true; row := 1; col := 1; end; {*** GET A NEW DESTINATION VOLUME } 'G','g': GET ; {*** UNDO THE ACTION ( IF ANY ) TAKEN TO DATE ON THIS FILE } 'U','u':CHANGE_FILE( CH, J); {*** refresh the present volume display ***} 'V','v':printentries; {*** CHANGE THE FILE NAME } 'C','c':CHANGE_FILE( CH, J); {*** HELP } 'H','h': help ; {*** OUTPUT TO A DEVICE OR FILE } 'O','o':BEGIN DOUTPUT; NEWPROMPT := TRUE END; {*** eXecute the code file, or initiate a monitor input string } 'X','x':begin IF dir_status[j].removed then begin newprompt := true; pressreturn( 'CANNOT EXECUTE A REMOVED FILE.'); end else begin esc_true := true; complete := true; end; end; {*** Edit the file specified } 'E','e':begin if dir_status[j].removed then begin newprompt := true; pressreturn( 'CANNOT EDIT A REMOVED FILE' ); end else begin esc_true := true; complete := true; end; end; {*** Quit the directory utility after update of directory prompt } 'Q','q':begin esc_true := true; complete := true; end; {*** Advance to subsiderary volume } 'A','a':begin if dispdir[j].dfkind =subsvol then begin if svols_ary[0] < max_svol_depth then begin SVOLS_ARY[0] := SVOLS_ARY[0] +1 ; SVOLS_ARY[ svols_ary[0] ] := dispdir[j].dfirstblk + dir_offs ; xy_array[ svols_ary[0]] := 1; going_up := true ; complete := true; svols_ary[0] := svols_ary[0] + 1 ; { defeat decrement on exit } end else begin pressreturn(' Exceeds SVOL nest depth ' ); newprompt := true; end; end else begin newprompt := true; pressreturn('Selection "A" must point to SVOL type file'); end; end; { of type 'A' } end; { of case } if ( ch = '?' ) or ( ch = '/' ) then begin newprompt := true; extension := not extension ; end else extension := false ; UNTIL COMPLETE; { 11111111 } TARGET_KNOWN := FALSE ; do_marks := dispdir[0].dnumfiles> 0 ; { do marks only if files on original} IF ( dispdir[0].dnumfiles > 0 ) THEN BEGIN I:=1; REPEAT with dir_status[i] do DO_MARKS:= removed or changed ; I:=I+1 UNTIL DO_MARKS OR ( I > dispdir[0].DNUMFILES ); IF DO_MARKS THEN BEGIN REPEAT sc_clr_line( 0 ); sc_goto_xy( 0,0 ); WRITE ('Update directory? (Yes/No/Return)'); READ ( YESNO ); UNTIL (YESNO = 'Y')OR(YESNO ='y')OR (YESNO = 'N')OR(YESNO ='n')or (yesno = 'R')or(yesno ='r'); newprompt := true ; complete := not( (yesno='R')or(yesno='r') ); DO_MARKS := (YESNO = 'Y')or(YESNO = 'y') ; END; END; until complete; { 222222222 } if do_marks then repeat {$I-} unitread(dir_unit,targetdir,sizeof(dir_entry),2+dir_offs,0); {$I+} OK := IORESULT = 0; IF NOT OK THEN DISK_ERROR(CONCAT(TNAME,':')) else with targetdir[0] do if NOT ( ( length(dvid)<=0 ) or ( length(dvid)> 7 ) ) then begin ok := disp_dir[0].dvid = targetdir[0].dvid ; if not ok then begin ok := false; repeat sc_clr_line( 0 ); sc_goto_xy(0,0); write('Return Volume ',disp_dir[0].dvid,' to #',dir_unit, ' Press Space'); read(ch); until ch=' ' ; end end else begin ok := false; repeat sc_clr_line( 0 ); sc_goto_xy(0,0); write('Return Volume ',disp_dir[0].dvid,' to #',dir_unit, ' Press Space'); read(ch); until ch=' ' ; end until ok = true; CASE CH OF {*** eXecute the code file, or initiate a monitor input string } 'X','x':begin prompt(0,concat('Execute ',dispdir[0].dvid,':',dispdir[j].dtid)); if dispdir[j].dfkind = codefile then chain( concat('I="x', dispdir[0].dvid,':',dispdir[j].dtid,'."' )) else chain( concat( 'I=',dispdir[0].dvid,':',dispdir[j].dtid)); esc_true := true; complete := true; end; {*** Edit the file specified } 'E','e':begin prompt(0,concat('Edit ',dispdir[0].dvid,':',dispdir[j].dtid)); chartostr[1] := syscom^.crtinfo.linedel; chain( concat( 'I="e',chartostr, dispdir[0].dvid,':', dispdir[j].dtid,'"')); esc_true := true; complete := true; end; END; { of case ch } IF DO_MARKS THEN DELETEFILES; END; {$P } { * ** *** **** ***** PRIMARY BLOCK STARTS HERE **** *** ** * } BEGIN MEMLOCK('SCREENOPS'); INITIALIZE; REPEAT tar_offs := 0; { should always be 0 } {*** ACCEPT A VOLUME ID FROM THE USER ***} REPEAT sc_clr_screen ; TNAME := iname; if SVOLS_ARY[0] = 0 then begin { 11111111 } dir_offs := 0 ; { remove the svol offset if present } going_up := true; sc_goto_xy(0,2); writeln('Volumes presently online:'); writeln; i := 0; j := 0; l := 0; { Finds the next blocked volume for output to the screen } while (j < maxunit) and ( i < 60 ) do begin j := j+1; if syscom^.unitable^[j].uisblkd then begin read_vid(j); IF syscom^.unitable^[j].UVID <> '' THEN BEGIN sc_erase_to_eol( (i div 20 * 27 ), ( i mod 20 + 4 ) ); sc_goto_xy( ( i div 20 * 27 ), ( i mod 20 + 4 ) ); WRITE( j:2 ); WRITE( ':' ); (* IF syscom^.unitable^[j].UISBLKD THEN if syscom^.unitable^[j].uvid = syvid then write( ': R ' ) else if syscom^.unitable^[j].uvid = dkvid then write(': P ') else WRITE(': ') ELSE WRITE(': '); *) WRITE(syscom^.unitable^[j].UVID, ' ':8-LENGTH(SYSCOM^.UNITABLE^[J].UVID)); WRITE('[',syscom^.unitable^[J].ueovblk:5,']'); if syscom^.unitable^[j].uvid <> syscom^.unitable^[j].upvid then write(syscom^.unitable^[j].upvid); i := i +1 ; END; { syscom^.unitable^ <> '' } end; { syscom^.unitable^[j].uisblkd } end; { j< maxunit and i < 80 } ok := false; sc_clr_line( 0 ); sc_goto_xy(0,0); WRITE('Enter volume id of disk (, to end) [',TNAME,'] =>'); rdline(INAME); if iname = '' then iname:=TNAME ; IF key_cmd = sc_escape_key THEN EXIT ( dfile ); ok := false; dir_unit := get_unit_number( iname ); end ; { 111111111 } dir_offs := SVOLS_ARY[ svols_ary[0] ] ; { displacement to svol } if ((syscom^.unitable^[dir_unit].uvid <> '' ) and syscom^.unitable^[dir_unit].uisblkd ) then begin {$I-} unitread(dir_unit,dispdir,(maxdir+1)*sizeof(direntry),2+dir_offs,0); {$I+} OK := IORESULT = 0; IF NOT OK THEN DISK_ERROR(concat(INAME,':')) else begin if dispdir[0].dlastblk > 255 then begin dirflip := true; flipdir( dispdir ) end else dirflip := false; FOR I := 0 TO DISPDIR[0].DNUMFILES DO ORGDIR[I] := DISPDIR[I]; end; END; if not ok then initentry := false ; UNTIL OK ; IF SVOLS_ARY[0] = 0 THEN BEGIN SVOLS_ARY[0] := 1 ; { FIRST ENTRY IS ALWAYS THE PHYSICAL VOL } SVOLS_ARY[1] := 0 ; { OFFSET TO PHYSICAL IS ALWAYS ZERO } END; if key_cmd <> sc_escape_key then begin CRT := TRUE ; ALLDONE := FALSE; NUMFILES := DISPDIR[0].DNUMFILES; J := 1; FOR I := 1 TO MAXDIR DO INDEX[I] := I ; case sort of 1: sort_dir; {alphanumeric sort on file name} 2: suffixsort; {alphanumeric sort on four char suffix and file name} end; IF NUMFILES > 0 THEN FOR I := 1 TO NUMFILES DO begin dir_status[i].removed := false; dir_status[i].changed := false; dir_status[i].moved := false; dir_status[i].swaped := false; end; FOR I := NUMFILES+1 TO MAXDIR DO begin dir_status[i].removed := true ; dir_status[i].changed := false; dir_status[i].moved := false; dir_status[i].swaped := false; end; CALC; {*** OUTPUT THE DIRECTORY TO THE CRT SCREEN } PRINTENTRIES; { PRINT ALL INFORMATION } if going_up then begin going_up := false; col := 1; row := 1; end else begin i := XY_ARRAY[ SVOLS_ARY[0] ] ; j:=0; repeat j:=j+1 until i = index[j] ; COL := 5 ; REPEAT COL := COL - 1; UNTIL J > TOTALTOCOL[COL] ; ROW := J - TOTALTOCOL[COL] ; end; markentries; key_cmd := sc_not_legal ; { insure key not reused } IF SVOLS_ARY[0] > 0 THEN SVOLS_ARY[0] := SVOLS_ARY[0] - 1 ; end; UNTIL ESC_TRUE ; END. ======================================================================================== DOCUMENT :usus Folder:VOL23:dict.text ======================================================================================== a abandoning abbreviated abbreviation abbreviations abilities ability able abnormally aboard about above absence absolute absurd accent accept acceptable accepted accepting access accessed accesses accessible accessing accidental accomodate accomplish accordance according accordingly account accounted accounts accumulate accumulator accurate accurately accused achieve achievements acid acknowledged acquainted acquires acronym across act acted acting action actions activate activated activities acts actual actually ad adapt add added adding addition additional address addressed addresses addressing adds adequate adequately adjacent adjust adjustable adjusted adjusting adjustment adjustments administrative admiring admitted admittedly adopt adored advance advanced advantage advantages advent adventure advertisement advice affect affected affecting affects afflictions africa after afternoon again against age ages agitatedly ago agreed agreement ahead aid aided aids air airport airsick alarm alarmed algebra algebraic algorithm algorithms alienated alike all allocated allow allowed allowing allows almost alone along alphabet alphabetic alphabetical alphanumeric already also alter alterable altered alternate alternately alternative alternatively alternatives alters although alu aluminium always am ambiguous american among amortized amount amounting amounts ample amplifier amplitude amuck an analog analogous analogy analysis analytical analyze analyzed analyzing anchor and and'ed anding anger animations annihilated announces annoyances annoying annual anomalies anomaly another answer answered any anyone anything anyway anywhere apart apparent apparently appeal appear appearance appeared appearing appears appended appendix apple appliance appliances application applications applied applies apply applying appreciable approach approaches appropriate appropriately appropriates april apt aqueduct arbitrarily arbitrary arc archaic architectural architecture architectures are area areas aren't arises arising arithmetic arm armor around arrange arranged arrangement array arrays arrival arrive arrived arrow art article articles artifice as ascertained ascribe ashamed aside ask asked asks aspects assemble assembled assembler assemblers assembling assembly assert asserted assertion assigned assigning assignment assigns associated assorted assume assumed assuming assumption assumptions astable astray asynchronous at ate atom atoms attained attempt attempted attempting attempts attention attributed auburn audience aunt aunts author authoritative authors auto automatic automatically automobile automotive availability available average averaged averages avoid avoided avoiding avoids await awaited awaits aware away axial baby bacillus back background backplane backward backwards bacteria bad bag bakery ball bane bar bare barely base based bases basic basically basics basis batch batches bathed bathroom bathtub battery battle battles bc bcd be bear bears beautiful became because become becomes becoming bed bedraggled bedtime beef been before began begin beginning begins begun behave behaved behavior behind being believe believed belong belongs below bench benefit benevolently benign beside besides best better between beyond biased bibliography big billion billionths bin binary biographies biography biological bipolar birds birth birthday bishop bistable bit bite bites biting bits bizarre black blamed blank blighted block blocks blond blood bloodthirsty blowing blown blue blunders blurted board boards boats body boils bologna bolts bond bonded bonding book books boolean boomed boots boring boron both bother bottom boule bounce bounced bounces bouncing box boxes braced branch branches branching bread break breakfast breaking breaks breakwater breeze bribes bridge brief briefly bright brightness bring brings britain broad broke broken brother brought brown brushed bubble bubonic buffer buffers bugs build building built bulk bulky bureaucratic buried burn burned burnish burst bus buses bushes business but button buy buying by byte bytes byzantine byzantium c-d cafe cafes calculate calculated calculation calculations calculator calculators call called caller calling calls came can can't canal cannot canopy cans canvas capabilities capability capable capacitance capacitor capacitors capacity captured car card cards care careful carefully careless carelessness carriage carried carries carry carrying cars carthage cascaded case cases cash cassette cat catch categories catering catholic caught cause caused causes causing caution ccd cease ceased celebrations center centers centimeter central century ceramics certain certainly certainty chain chance change changed changes changing channel channels chapter chapters character characteristic characterized characterizes characters charge charged chariot charles chatter cheap check checked checker checkers checking checkout checks cheerfully chemicals children chip chips choice choices chopped chore chores chose chosen christ christianity christians chunk chunks church circle circles circuit circuitry circuits circumstances cities citizenship city civilization claim claimed clamped class classed classes classification classified classify classroom clean cleaned cleaner cleanliness clear cleared clearing clearly clears cleaver clerk cliffs climbed clock clocked clocking clocks close closed closely closes closets closing closure cloth clutter coast coat coated coats code coded codes coding coffee coil coincidental coined collection collector college color colors column columns comb combination combinations combine combined combining come comes comfort comfortable comfortably coming command commands comment commented commenting comments commercial committed committing common commoners commonly communication communications company comparator compare compared compares comparing comparison comparisons compatible compensated compiler compiles complain complement complementary complemented complete completed completely completes completing completion complex complexity complicate complicated comply component components composed compounds comprehensive compression compromise computation computational computer computerized computers computing concealing concentrate concentration concept conceptual conceptually concern concerned concert concerts concise conclusion conclusions concrete condition conditional conditionally conditions conduct conducting conduction conductive conductivity conductor conductors conference confide confidence configuration configurations configure configured confine confined conflict conflicts confuses confusing confusion conjunction connect connected connecticut connecting connection connections connector connects consequence consequential conservative consider considerable considerably consideration considered consigning consist consistent consisting consists console constant constantinople constantly constants constraints construct constructed consultant consumed consumes consuming consumption contact contacts contagion contain contained containing contains contamination contemplated contended contention contents context contingent continual continually continue continued continues continuing continuous continuously contradiction contrast contributes control controlled controller controllers controlling controls convenience convenient conveniently convention conventional conventions conversation conversing conversion convert converted converting converts convey conveys convinced cookbooks cooked cookies cooking cooks cope copied copies coping copious copy copying core corn corner corpses correct corrected correcting correction corrections correctly correspond correspondence corresponding corresponds corrupt cosmopolitan cost costs could couldn't count counter counterpart counters counting country counts coupled coupling course court cover coverage covered covers cpu crane crash creased create created creating creature credits crepes cried criminal crimping critical crooked crop crops cross crosses crowd crowded crowds cruel cruelly crusades crusts crystal crystals cultural culture cultures cumbersome cup cure cured curiosity current currently currents curses curtain customer customs cut cute cutting cycle cycles cycling cylindrical damage damaged dark darkness data date daughter day days dead deadly deal dealing deals dear death debounce debouncing debris debugging december decide decided decimal decision decisions decline declining decode decoded decoder decoders decodes decrease decreased decreasing decrement decremented decrementing decrements dedicated default defect defective defects deferred deficiencies define defined defines defining definition definitions degrades degree delay delayed delays delete deleted deleting deletions deliberate demeanor demodulating demonstrate demonstrated demultiplexer demultiplexers denotes denoting departed department departure depend dependent depending depends depletion depositing depth derived describe described describing description descriptions descriptive deserves design designate designated designates designation designations designed designer designer's designers designing designs desirable desire desired desperation despite destination destinations destroyed destroying destroys destruction detail detailed details detect detected detecting detection determine determined determines determining devastating develop developed developer developing development device devices devised devoured devouring diagnose diagnosis diagnostic diagonal diagram diameter diameters diamond dictate dictates dictionary did didn't differ difference differences different differs difficult difficulties difficulty dig digit digital digits digression dim dime dimmer dinner dip dip's direct direction directional directly directory directs dirt disadvantage disadvantages disagree disagreeable disagreed disagreement disappear disappeared disappears disassembled disaster discarded discernible discharge disclosing disconnected discontinued discovered discrete discrimination discuss discussed discussing discussion discussions disease diseases dishes disk disks disparity display displayed displaying displays dispose disposed dissent dissimilar dissipation dissolve distance distantly distinct distinction distinctions distinguish distinguished distinguishing distorted distractedly distributed diversion divide divided divides dividing division divisor dma dmux do documented does doesn't doing dollar dollars don't done door doped doping dopings dormant dot dots double doubled doubles doubling doubly doubt down downstairs downtown downward dozen dozens draft dragged dragon dragons drain drained dramatic drastic drastically draw drawing drawn draws dread dress dressed dresser dressers dried drilled drink drive driven driver drivers driving drop dropped dropping drops droughts drudgery drudges dual dual-rank dubious due duplicate duplication duration durations during duty dye dyed dying dynamic dynamics each eaprom eaprom's earlier early ease easier easily east eastern easy eat eaten eating economy edge edge-triggered edges edit edited editing editor editor's editors effect effective effectively effects efficient effort eight eight-input eighteen either elapsed electric electrical electrically electron electronic electronics electrons element elements elevated elicit eliminate eliminated eliminating else elsewhere embraced emotional emperor emphasize emphasized emphasizes empire empires employed employing employs empty emulate enable enabled enables enabling enclosed encompasses encountered encountering encounters end endemic ending endlessly ends enemies energies energy engine engineering english enhance enhancement enough ensued ensure ensures ensuring entail enter entered entering enters enthusiasm entire entirely entity entrant entries entry enumerate enumeration environment epidemic epidemics eprom eprom's equal equality equally equipment equivalent equivalents erasable erased erratic error errors escapist especially essential essentially establish estimated etc etch etched europe evaluating even evening evenly event events eventually ever every everybody everyone everything evil evolution evolved exact exactly examine examined examines examining example examples exceed exceeded exceeds except exception exceptions excess excessive excessively exchange exchanged excited excitement excluding exclusive excused excuses executable execute executed executes executing execution exempt exercise exercised exerted exhausted exhaustedly exhibit exhibits exist existing exists exit exited exotic expand expect expected expend expensive expertise explain explained explains explanation explanations explicit explicitly exponentially exponents exposed exposition exposure expressed expression expressions expunged extend extended extension extensively extent extermination external externally extinction extra extraneous extreme extremely extremes eye eyes fabricate fabricated fabricating fabrication face faced fact factor factories factors fade faded fades fail failed failing fails failure failures fair fairly fallen falling false familiar familiarity families family famines famished famous fans fantasy far farads farm farming farthest fashion fast faster fastest father fault favorite favorites fear fears feature features february feed feedback feeding feeds feel feelings feet fell fellow felt fet's fetch fetched fetches fetching feudal fever few fewer field fields fiendishly fifth fifty fight figure figures file files fill filled filling film final finally find finding finds fine fingers finish finished finishes finite fire firmware first fish fit fits five fixed fixedly fixture flag flagged flags flaw flawless flea fleas fled flee flew flexibility flexible flight flip flip-flop flip-flops flipped floating flop floppy flops flotilla flourished flow flowed flowing flows flu focused fold follow followed following follows food footnotes for force forced forcibly forcing foreign forgery forget forgetful forgot forgotten forking form formal formalized format formats formatting former formerly forming forms forth fortified fortunately forum forward found four four-bit four-input fourteen fourteenth fourth fraction fragment fragments frame france free free-running freed freeing freeway french frequency frequent frequently fresh from front fruit fruitless frying fulfilled full fully fun function functional functioning functions fundamental fundamentals furnish furnishes furnishing further furthermore fuse fuses future gains game games garden gas gate gated gates gathered gating gauge gave general generality generalized generally generate generated generates generating generation generations generator gently geometric geometrically germanic get gets getting giggle giggling girl girls give given gives giving glad glanced glances glaringly glass glitch glitches glory go goal goals god goes going gold gone good goods got govern government governmental grabs gradually graduating graduation grain granaries grandchildren grapes graphic graphics graphs grating great greater greatest greatly greedy greek grew grid grocery gross ground group grouping groups grow growing grows growth grudgingly guarantees guess guest guilford guilty guys habit habitually hacked had hadn't hair half hall hallucinations halt halting halve halves halving hamburger hamburgers hand handcrafted handing handle handled handles hands handsome hang happen happens happy hard harden hardened hardly hardware harm harmless harsher harvard harvest has hash hastened hated have haven't having hazardous he head headache headaches headed heads heard heart heat heating heavier heavily heavy heels height held help helped helpfully helping helpings helps hence her herd here here's heresy herself hertz hesitate hesitated hesitation hex hexadecimal hey hi hidden high higher highest highly him himself hints his historical history hobbyist hog hold holders holding holds hole holes home homesick homework honest honey honor hope hoped hopefully hopeless horrible host hosts hot hour hours house household how however huge hugged human humanitarian humans humorous hundred hundreds hung hungry hunt hunting hurried hurriedly hurry hurt hurtling husband hush hydraulic hypothesis hypothesize hypothetical hysteresis i i'd i'll i'm i've i/o ibm ic ic's idea ideal ideally identical identically identified identifies identify idiosyncrasies idolized if ignition ignorance ignore ignored ignores ignoring illness illusion illustrated illustrates illustrating illustration image images immediate immediately immense immune immunity impact impasse imperative imperial imperiously implement implementation implemented implementing implication implicit implicitly implied implies import importance important impose impossible imprinting improvement improvements impulse impulsive impunity impure impurities impurity in inaccurate inadequate inadequately inadvertently inappropriate inch inches incident incidental incidentally incidents incisively include included includes including inclusive inconvenience incorporated incorrect incorrectly increase increased increases increasing increment incremented incrementing increments incubation indeed indefinitely independent independently indeterminate index indexed indexing india indicate indicated indicates indicating indication indications indirect indirectly individual individually inductor industrial industry inequalities inevitable inexpensive infect infected inflexible informal information informative informed informs inhabitants inherent initial initialization initialize initialized initially initiate initiated injected injury inner inoperable input inputs insert inserted inserting insertion insertions insidious insight insignificant inspection instability instant instantaneous instantly instead institution instruction instructions instruments insulated insulating insulation intake integer integers integral integrated integration intended intensifies intent intentions interactions interactive interconnect interconnected interesting interface interfaced interfacing interior intermediate internal internally international interpretation interpreted interpreter interrelated interrupt interrupted interrupts intertwined interval intervals intervening into introduce introduced introduces introducing introduction invasion invention inventory inversion inverted inverter inverters inverting involve involved involves involving ironed irregular irrelevant irretrievably is isn't isolate isolated isolates isolating isolation issue issues it it's italy item items iterations its itself j-k jeans jersey jews job jobs joined journal judge jump jumping jumps junk jury just justice keep keeping kept key keyboard keyboards keypad keys kid killed killing kind kinds kingdoms kitchen knew knight knights knit knitted knitter knitters knitting knob knock know knowing known kohm label labeled labels labor laboratories laboratory lack lacking lacks lacquer laden ladies lady lag lame lamp lamps land landing lands language languages large largely larger largest last lasted lasting lasts latch latched latches latching late lately later latter laugh law layer layers lead leads leak leakage leaned leans least leave leaves leaving left legal legally legends legislative legitimate length lengths lengthy lesions less let let's letter letters letting level levels lies life lifetimes lifo lifts light lightly lightning lights like likely liking limit limitation limitations limited limits line linear lines lingered linked list listed listen listening listing lists lit literal literally litters little live lived lives living load loaded loader loading loads local localize localizing located location locations lock locked locking locks logic logical logically long long-distance longer look looked looking looks loop looping loops loose loosely loosing lord loses losing loss losses lost lot loud louder loved low lower lowest lsi luck luggage lunch lymph machine machinery machines macro made magic magistrate magistrates magnetic magnetically magnitude maidens mailing mails main mainframe maintain maintained maintaining major majority make makes making malfunction mall man manage managed mandated mandates manifold manipulate manipulated manner manorial manorialism manors manual manufacture manufactured manufacturer manufacturing manuscript many map mapped maps mark marked market markets marks marshes mask masked masking mass master master-slave match matches material materials mathematical mathematics matter matters mature maximum may maybe me meagre meal mealtimes mean meandering meaning meaningful meaningless means meant meantime meanwhile measure measured measurement measurements measures measuring mechanical mechanism mediterranean medium meet meeting meets member members memorable memories memory men mental mention mentioned mentioning menu merchant mercifully merged merits message messages met metal metalization metallic method methods micro microcode microcoding microcomputer microcomputers microfarad microprocessor microsecond microseconds middle midway might miles military milk million millions millionths millisecond milliseconds mimic mind mindlessly minds mine mineral minicomputer minicomputers minimize minimized minimum minor minus minuscule minute minutes mirror miscellaneous miserably miss missed missing misspelled mistake mistakes mitten mixed mnemonic mnemonics mob mode model models moderately modern modes modification modifications modified modify modulating moment momentary moments monday money monitor monitoring monitors monostable monotonous monstrosity months monuments more morning mortality mos most mostly mother motion motions motive motors mound mounted mouth move moved movement moves movies moving mph msi much mulled multi multiple multiplexed multiplexer multiplexers multiplexing multiplication multiplied multiply multiplying murmured museums musical musicians must muttering mux my myriad myself mythology name named namely names nand nand's nanosecond nanoseconds narrow nasty natural nature near nearby nearest nearly nears neatly necessarily necessary necessitate neck need needed needles needs negative neighboring neither nerve nerves nervous nested nesting net network networks neumann never nevertheless new newer next nice nicely nicer night nightgown nil nine ninth no nobles nod nodded nodes nods noise noisy nominal nonconducting nonconductive none nonetheless noninverted noninverting nonresistant nonsense noodles nor normal normally north northern nose not notable notation notations note noted nothing notice noticing notified notify nouns novel novels novice now nowhere npn nuclear number numbered numbering numbers numeral numerals numeric numerically numerous nursery o'clock obey obeyed object objectionable objects obscures observed obsolete obtain obtained obtaining obtains obvious obviously occasional occasionally occupied occupies occupy occur occurrence occurrences occurring occurs octal october odd of off offended offending offered offers offices offset offshoot often oh ohm ohms ok old older omens omitted on once one one's onion only onset onto opcode open opened opening opens operand operands operate operated operates operating operation operational operations operator opinion opinions opportunity opposed opposing opposite optical optimized optimum option optional or ordained order ordered orderly orders ordinary organization organized orientation oriented origin original originally originated originates oscillating oscillator oscillators oscilloscope ostensibly other others otherwise ouch ought our out outbreak outbreaks outcome outdoor outer outlet outline outlined outliving outlook output outputs outside outskirts oven over overall overcome overflow overpopulated overseer oversimplified overtook overview overwritten own owner owning oxide paces package packaged packages packaging packet pad pads pagan pagans page paged pages painstaking pair pairs palace palm pancakes panel panels pantheon pants paper paperwork paragraph paragraphs parallel parallel-in parallel-out parameters parents paris parity park parlance part partially participation particular particularly particulars partition partitioning parts pascal pass passed passes passing past pastries patently path paths patience pattern patterns pay pc peace peak peas peasant peculiar peg pelted penal penalty pencil pencils penguin people peoples per perceived percent percentage perceptible perfectly perform performance performed performing performs perfume perhaps period periods peripheral permanent permanently permit permits permitted perpetuate perpetuation persia persistent person personal personalities personality perspective pestilence phase philosophies philosophy phosphorus photo photographic phrase physical physically physician physicist physics pick picked picks picky picture pictures piece pieces piled pin pink pins pipelining pitfalls pizza pla's place placed places placing plague plagues plan plane planned planning plans plant play playing plays plaza please plot plotted plotter plug plus pneumatic pneumonic pnp pocket pocketbook point pointed pointer pointers pointing points polarities pole polish political polled poor poorer poorly pop popped popping pops populace popular popularity population populations port portion portions portrayed ports posing position positional positions positive possibilities possibility possible post pot potatoes potential pour poured powder power powerful powers practical practically practice prairie praise preceding precise precisely precision preclude precludes predecessor predecessors predetermined predict predicted prediction predominant preempted preferred prefixed prefixes preliminary prepare preparing presence present presentation presented presents preserved preset presetting press pressed presses pressure presumably pretty prevailing prevalent prevent preventative prevented previous previously price priced prices primarily primary prime primitive princess princeton principle principles print printable printed printer printers printing prints prior priority private prizes probability probable probably probe probing problem problems procedure procedures proceeds process processed processes processing processor processors procrastinator produce produced produces product production productively program programmable programmed programmer programmer's programmers programming programs progress progressed project prolonged prom promising prompted prompts prone proofreading propagate propagation proper properly properties property proportion proportional propose protect protected protection protocol prototype proud proved provide provided provides providing provision pseudo psw public published publishing pull pulled pulling pulse pulsed pulses punch punching punishment puppet purchase pure purified purl purpose purposes purse pursuing push pushed pushes pushing pustules put puzzled quad quadrupled qualify quality quantities quantity quarter quartz question questioned questioningly questions quiche quickly quiet quit quite quits quotient r-s rabbit race races radio raging raised raises raising ram ran random randomly range ranged ranges ranging rank ranking rapid rapidly rare rarely rat rate rates rather ratio rats raw rays reach reached reaching react read read-only readable reader readers reading readings reads ready real reality realize realized really reaper reason reasonable reasonably reasoning reasons reassembled rebelling rebirth rebuilding rebuke recall recaptured recapturing received receiver recent recently reception reciprocal reclaim recognition recognizable recognize recognizes reconfiguring recorders recording records recover recovered recreate recreated rectangles rectangular rectify recuperated recursion recursive red redesign redisplay redrawn reduce reduced reduces reduction redundancy redundant reels refer reference referenced references referred referring reflect reflected reflecting reflects reformation refresh refreshed refreshment refute regaining regarded regarding regardless region regions register registers regular reign reinforces related relation relationship relative relatively relax relaxes relay relays relegated relevant reliability reliable reliably relies religion religions reloaded remain remainder remained remaining remains remarkably remarking remember remembering remove removed removes removing renaissance repaired repeat repeated repeatedly repeats repels repetitive replace replaced replacement replaces replacing replica replied replying report reporting represent representation representative represented representing represents repressed reproduced reproduction reprogram reprogrammed reprogramming request requested require required requirement requirements requires requiring requisite rescues research reserve reserved reset resets resetting reside resides resist resistance resisted resistor resistors resolved resonant resorting respectively respond responding response responses responsible rest restricted restriction restrictions result resulted resulting results resume retained retested retraced retrieved retrieves return returned returning returns revenue reverse reversed reviewer's revising revitalize revolution rewrite rewriting rewritten ridden right ring rinsed ripple ripple-carry rippled ripples rise rising river robot robots rockwell rodent rodents role roll rolls rom rom's roman romance romantic roof room roommate rooms rooted roots roster rotten rough roughly round rounds route routes routine routinely routines row rows rudimentary ruffled rule ruled rules rummages run running runs rush safely safer safety said sailors sake sale salutary same sample sampled sanctity sandwich sandy sanitation sat satellite save saved saves saving saw say says scale scandalous scanners scarcity scarf scattering scene schematic scheme schmidt school schottky sciences scope score scores scraping scratch scratched screamed screen scribed sea search searched searches searching season seated seats secluded second seconds secret secretary section sections security see seeing seem seemed seemingly seems seen seesaw segment segments seldom select selected selecting selection selector sell selling semblance semicolon semiconductor senator senatorial send sends senior sense sensitive sensors sent sentence sentences separate separated separation sequence sequences sequential sequentially serial serial-in serial-out serially series servants serve serves services serving set sets setting settle setup seven seventeen several severe sex shadow shakes shaking shall shape share shared shares sharing sharp she she'll sheer shelf shepherding shift shifted shifts shining ship shipment shipped shirt shirts shock shocked shone shop shopping short shortages shorted shorter shorting shorts should shouldn't shouted show showed showing shown shows shrinks shuffled shut shyly sick side sighed sightseeing sign signal signaling signals signed significant significantly silence silicon silver similar similarities similarly simple simplest simplified simplify simply simultaneous simultaneously since sincerely singer single sipped sit sits sitting situation situations six sixteen sixteen-bit sixteenth sixth size sized sizes skew skewed skilled skim skin skipped skirt skirts slammed slash sleep sleeping sleeplessness slice sliced slices slid slight slightest slightly slobbering slop sloth slow slowdown slowed slower slowest slowing slowly slows small smaller smile smoothly snack so soaked sobbing social sock socket soda softly software solder soldered soldering solely solution solved solvent some somehow someone someplace something sometime sometimes somewhat somewhere son sons soon sorcery sorry sort sorted sorting sorts sound sounding soup source sources souvenir space spacing spain span spare sparse speak speaker speaking speaks special specialized specially specialties specific specifically specified specifies specify specifying speech speed spell spelled speller spelling spend spending spends spent spike spikes spite splash split splitting spoke spoken spot spotlight spread spring spurring square squarely squeeze ssi stability stable stack stacks stadium stage stages stale stammer stand standard standardized standards standing stands star stared staring stark start started starting startling starts starved starving state statement statements states static station statistical stature status staying steady steak step stepped steps still stitch stitches stop stopped storage store stored stores storing stove straight straightaway strangle stray stream streets strengthen stress stretches stricken strict strictly strike strikes string stringent stripping strobe strobes stroke strokes strong structure structures student study stuff stuffed stupid style subject subjects submit subroutine subroutines subscript subsequent substantially substitute substitutes subsystem subtle subtopic subtract subtracted subtracting subtraction subtractions subtracts succeed succeeding success successful successfully succession successive successively succinct succumbed such suede suffer suffered suffers sufficient suffixes suggested suggestion suggestions suitable suitcase suitcases suited suits sum summarized summarizes summary summer superstitions supervision supervisor supervisors supplied supplies supply supplying support supported supporting suppose supposed sure surface surmised surplus surprise surprisingly surrounded surrounding survive suspect suspicion swallow swallows swapped swapping sweater swelling switch switched switches switching symbol symbolic symbolically symbolize symbols symmetric symphony symptoms synchronize synchronized synchronous synonymous synthesis system systematic systems tab table tables tabular tabulated tabulation tail tailored take taken takes taking tale talk talked talkers tall taller tape target tarry task tasks tax taxation taxes taxi tea teacher teachers tears teased teasing technical technically technique techniques technology tedious teenagers teens telephone teletypewriter television tell telling temperature temperatures temporary ten ten's tend tens tenth term termed terminal terminals terminate terminated terminates terminating terminology terms terrific terse test tested tester testers testing text textbook texts than thank thankless thanks that that's the their them themselves then theorized theory therapeutic therapy there there's therefore thermally these they they're thin thing things think thinks third thirds this thoroughly those though thought thoughts thousand thousands threat three three-input threshold thresholds threw through throughout throwing thrown thumb tic tie tied ties tight time timed timeliness times timing tiny tip tipped tirade tired title to today together toggle toggled told tomography tomorrow tone too took tool tools top topic topics tops torture tosses total totem touch touches touring toward tower town towns toy trade trading trailing train traits transactions transducer transfer transferred transferring transfers transform transformed transformer transforming transistor transistors transition transitions translate translated translates translating translation translator transmission transmits transmitted transmitter transmitting transparent transportation trapped trash traumatic travel traveled travels traversed traverses treat treated treating treats treaty tree trees triangle tribes tribute tricky tried tries trigger triggered triggering triggers trio trip triple trips trivial trot trouble troubleshoot troublesome true truncated truth try trying ttl tube tubes turbulence turn turned turning turns twelve twenty twice twitch two two-input tying type typed types typewriter typewriters typewritten typical typically typing typist typographical uart uart's ubiquitous ultimate ultimately ultra unable unaffected unaltered unambiguous unambiguously unattractive unblown unburied unchanged uncivilized uncluttered uncommon uncomplicated unconditional uncontrolled undefined under understand understanding understood undertaken undertaking undesirable undetected undisturbed uneconomical unexposed unfavorable unfortunately unicorn unicorns unidirectional unified unique uniquely unit unite united units universal universally universe unjust unknown unless unlike unlikely unpacked unpredictable unpredictably unquestionably unrelated unruly unsigned unsuccessful until untouched unused unusual unwanted unwary unwholesome up up-down updated upon upper upraised upstairs upward us usable usage use used useful usefulness user user's users uses using usual usually utilized utilizes utter vacuum vague vaguely valid valuable value values valves vandals variable variables variance variation variations varied varieties variety various vary vast vegetable velocity verbiage verification verified vermin versa version versions very vessel vessels via vice victim video view viewed viewpoint vih vil villas vineyard vintage violates violence violet virtual virtually virulence virulent visible visibly vital voh voice voices vol volatile volition voltage voltages volume volumes wafer wafers wait waited waiting walk walked walking walks walls want wanted wants warm was washed washstands wasn't waste wasted watching water watt wave waveform waveforms way ways we we'll we're we've weak wealth wealthy wear wearing weather weekend weeks weight weights welcome welded welfare well went were western what what's whatever when where whether which while whim whispered white who whole whom whose why wide widely wider widespread widgets width wife wild will win winding window winter wire wires wiring wisdom wish with within without withstanding woman won't wonder wondered word wording words wore work worked workers working works world worried worry worse worst would wouldn't wow writable write writes writing written wrong wrote xnor xor xor's yarn yawning yea year yearly years yelled yelling yes yesterday yet yield yields you you'll you're your yours yourself zero zero's zoom zoomed ======================================================================================== DOCUMENT :usus Folder:VOL23:iodoc.text ======================================================================================== IOUNIT and IOTEST IOUNIT is intended to read and write text files. It includes replacements for the standard procedures READ, WRITE, READLN, and WRITELN which run 5 to 10 times faster than the standard procedures. IOTEST illustrates the use of IOUNIT and allows a direct comparison to be made between the fast procedures and the standard procedures. Before using IOUNIT, use IOTEST to send a text file to disk using both the fast and standard procedures, then run a source compare to ensure that the files are identical. Note that the input and output file lengths may not be equal; WRITECHAR and WRITELINE minimize file length by packing and by using DLE expansions only if required. OPENING FILES IOUNIT includes the functions RESETFILE and REWRITEFILE, which provide a minimal user interface for opening files. Both functions expect a string containing a filename and assume a text file is to be opened. The default volume is assumed unless otherwise specified. A "dot" (".") is assumed to delimit a file extension. If the filename does not contain a dot, and a colon (":") is not the last character in the filename (as in PRINTER:), then ".TEXT" is appended to the filename. I/O checking is turned off while an attempt is made to open the file. If the attempt is successful, the functions return TRUE. If the attempt fails, a new filename is requested and the process repeats. If no filename is supplied (just a return was entered) the functions return FALSE and it is up to the calling procedure to take appropriate action. In any case, the filename is updated to reflect the latest filename to be entered. PRINTER: and CONSOLE: are both legal. If drive #5 contains volume WRK: with the files TRIER.TEXT and TRIER.BACK then #5:TRIER.TEXT, and WRK:TRIER.BACK are both legal. If the prefix is WRK: then TRIER.TEXT, TRIER.BACK, and TRIER are also legal, but TRIER will get TRIER.TEXT. SYSTEM.WRK.TEXT must be entered in its entirety, and a filename with no extension cannot be accessed. READING FILES The procedure READLINE returns the next string in a textfile. It also sets EOFFLAG to TRUE if the string is the last string in the file. The textfile is read using BLOCKREAD. A string is isolated from the blockread buffer, a DLE sequence is expanded to the required number of spaces, and the string is placed in a buffer. Subsequent calls to READLINE get the string from the buffer and refill the buffer with the next string from the file. The procedure READCHAR returns the next character from the string buffer. It also sets EOLNFLAG to true if the character is the last character in the line. READLINE must be called in order to refill the buffer with the next string from the file. WRITING FILES The procedure WRITECHAR simply places the character to be written in a buffer and returns. The procedure WRITELINE converts any leading spaces to a DLE sequence and places the resulting string in a blockwrite buffer. If the string will overflow the blockwrite buffer then the blockwrite buffer is padded with nulls and written to the destination before the new string is added. The procedure CLOSEOUTFILE pads the blockwrite buffer with nulls, writes it to the destination, then closes and locks the destination file. Because the output file is written a block at a time, output to the CONSOLE: or PRINTER: comes in block-sized chunks. This could be avoided by using a UNITWRITE on each string that is going to these destinations, at the expense of slowing output to a disk file because of the additional overhead involved in testing for the destination type. CR ======================================================================================== DOCUMENT :usus Folder:VOL23:iotest.text ======================================================================================== PROGRAM IOTEST; { Author: Charles Rockwell, Microlog, Box 116, Guilford CT, 06437. } USES IOUNIT; (* This construct assumes IOUNIT.CODE resides in SYSTEM.LIBRARY *) VAR SOURCE: STRING[20]; (* INPUT TEXT FILE NAME *) INTEXT: TEXT; (* INPUT TEXT FILE *) DEST: STRING[20]; (* OUTPUT TEXT FILE NAME *) OUTTEXT: TEXT; (* OUTPUT TEXT FILE *) CH: CHAR; S: STRING; OKFILE: BOOLEAN; BEGIN (* IOTEST *) WRITELN; WRITELN; WRITELN('IOUNIT benchmark'); WRITELN; WRITELN; WRITE('Input file name ? '); READLN(SOURCE); WRITELN; OKFILE := RESETFILE(SOURCE); IF NOT OKFILE THEN EXIT(PROGRAM); WRITELN('Test of fast character I/O'); WRITE('Output file name ? '); READLN(DEST); WRITELN; OKFILE := REWRITEFILE(DEST); IF OKFILE THEN BEGIN WRITE('Using READCHAR'); WRITE(CHR(7)); WHILE NOT EOFFLAG DO BEGIN WHILE NOT EOLNFLAG DO BEGIN READCHAR(CH); WRITECHAR(CH) END; READLINE(S); WRITELINE(S) END; WRITE(CHR(7)); CLOSEOUTFILE; WRITELN; WRITELN END ELSE CLOSEINFILE; WRITELN('Test of standard character I/O'); WRITE('Output file name ? '); READLN(DEST); WRITELN; IF DEST<>'' THEN BEGIN RESET(INTEXT,SOURCE); REWRITE(OUTTEXT,DEST); WRITE('Using READ'); WRITE(CHR(7)); WHILE NOT EOF(INTEXT) DO BEGIN WHILE NOT EOLN(INTEXT) DO BEGIN READ(INTEXT,CH); WRITE(OUTTEXT,CH) END; READLN(INTEXT); WRITELN(OUTTEXT) END; WRITE(CHR(7)); CLOSE(INTEXT,LOCK); CLOSE(OUTTEXT,LOCK); WRITELN; WRITELN END; WRITELN('Test of fast line I/O'); WRITE('Output file name ? '); READLN(DEST); WRITELN; OKFILE := RESETFILE(SOURCE); IF NOT OKFILE THEN BEGIN WRITELN('Fatal error -- lost input file'); EXIT(PROGRAM) END; OKFILE := REWRITEFILE(DEST); IF OKFILE THEN BEGIN WRITE('Using READLINE'); WRITE(CHR(7)); WHILE NOT EOFFLAG DO BEGIN READLINE(S); WRITELINE(S) END; WRITE(CHR(7)); CLOSEOUTFILE; WRITELN; WRITELN END ELSE CLOSEINFILE; WRITELN('Test of standard line I/O'); WRITE('Output file name ? '); READLN(DEST); WRITELN; IF DEST <>'' THEN BEGIN RESET(INTEXT,SOURCE); REWRITE(OUTTEXT,DEST); WRITE('Using READLN'); WRITE(CHR(7)); WHILE NOT EOF(INTEXT) DO BEGIN READLN(INTEXT,S); WRITELN(OUTTEXT,S) END; WRITE(CHR(7)); CLOSE(INTEXT,LOCK); CLOSE(OUTTEXT,LOCK); WRITELN; WRITELN END; CLOSEINFILE END. (* IOTEST *) ======================================================================================== DOCUMENT :usus Folder:VOL23:iounit.text ======================================================================================== UNIT IOUNIT; { (c) Copyright 1983 by Charles Rockwell. All rights reserved. } { Permission is granted only for not-for-profit use by USUS members.} { Author: Charles Rockwell, Microlog, Box 116, Guilford CT, 06437. } INTERFACE TYPE LONGSTR = STRING[255]; FILNAME = STRING[20]; VAR EOLNFLAG, EOFFLAG: BOOLEAN; PROCEDURE READLINE(VAR ST:LONGSTR); PROCEDURE READCHAR(VAR C:CHAR); FUNCTION RESETFILE(VAR FNAME:FILNAME): BOOLEAN; PROCEDURE CLOSEINFILE; PROCEDURE WRITELINE(ST:LONGSTR); PROCEDURE WRITECHAR(C:CHAR); FUNCTION REWRITEFILE(VAR GNAME:FILNAME): BOOLEAN; PROCEDURE CLOSEOUTFILE; IMPLEMENTATION CONST NULL = 0; CR = 13; DLE = 16; SP = 32; VAR (* VARIABLES FOR READCHAR *) INFILE: FILE; (* BLOCKREAD FILE *) INDISKBUF: PACKED ARRAY[0..1025] OF CHAR; (* BLOCKREAD BUFFER +2 *) INDISKPTR: INTEGER; (* BUFFER POINTER *) INLINEBUF: LONGSTR; (* INPUT STRING BUFFER *) INLINEPTR: INTEGER; (* INPUT STRING POINTER *) INLINELEN: INTEGER; (* INPUT STRING LENGTH *) (* VARIABLES FOR WRITECHAR *) OUTFILE: FILE; (* BLOCKWRITE FILE *) OUTDISKBUF: PACKED ARRAY[0..1025] OF CHAR;(* BLOCKWRITE BUFFER +2 *) OUTDISKPTR: INTEGER; (* BUFFER POINTER *) OUTLINEBUF: LONGSTR; (* OUTPUT STRING BUFFER *) OUTLINEPTR: INTEGER; (* OUTPUT STRING POINTER *) (*---------------------------------------------------------------------*) PROCEDURE READBUF; (* BLOCKREAD THE DISK FILE *) VAR R: INTEGER; BEGIN (* READBUF *) IF EOF(INFILE) THEN BEGIN EOFFLAG := TRUE; CLOSE(INFILE,LOCK); EXIT(READBUF) END ELSE EOFFLAG := FALSE; R := BLOCKREAD(INFILE, INDISKBUF, 2); IF R<>2 THEN BEGIN WRITELN; WRITELN('Error reading file'); CLOSE(INFILE,LOCK); EXIT(PROGRAM) END; INDISKPTR := 0 END; (* READBUF *) PROCEDURE READLINE(* VAR ST:LONGSTR *); (* ST := INLINEBUF; INLINEBUF := NEXT LINE FROM DISKBUF *) VAR J,K,L: INTEGER; BEGIN (* READLINE *) IF EOLNFLAG THEN (* INLINEBUF IS PRESUMED EMPTY *) ST := '' ELSE (* ST:=INLINEBUF *) BEGIN L := INLINELEN-INLINEPTR+1; (*$R- *) MOVELEFT(INLINEBUF[INLINEPTR],ST[1],L); ST[0] := CHR(L) (*$R+ *) END; IF ((INDISKPTR > 1023) OR (INDISKBUF[INDISKPTR] = CHR(NULL))) THEN (* INDISKBUF IS PRESUMED EMPTY *) BEGIN READBUF; IF EOFFLAG THEN EXIT(READLINE) END; IF INDISKBUF[INDISKPTR]=CHR(DLE) THEN (* GET BLANK COUNT *) BEGIN J := ORD(INDISKBUF[INDISKPTR+1])-32; INDISKPTR := INDISKPTR+2; IF (J>0) AND (J<127) THEN begin FILLCHAR(INLINEBUF,J+1,CHR(32)) ; fillchar ( inlinebuf, 1, chr ( j ) ); end ELSE J:=0 END ELSE (* BLANK COUNT IS ZERO *) J := 0; (* FIND LENTH OF NEXT LINE IN INDISKBUF *) K := SCAN(1024-INDISKPTR, =CHR(CR), INDISKBUF[INDISKPTR]); (* INSERT NEXT LINE INTO INLINEBUF STARTING AT BLANK COUNT SPACES *) (*$R- range checking off to allow moveleft into arbitrary length string-gws*) MOVELEFT(INDISKBUF[INDISKPTR],INLINEBUF[J+1],K); (*$R+*) FILLCHAR ( INLINEBUF, 1, CHR ( J + K ) ); {set length byte - gws} INLINELEN := J+K; INLINEPTR := 1; INDISKPTR := INDISKPTR+K+1; EOLNFLAG := (INLINEPTR>INLINELEN) END; (* READLINE *) PROCEDURE READCHAR(* VAR C:CHAR *); (* GET NEXT CHARACTER FROM INPUT STRING *) BEGIN (* READCHAR *) (*$R- *) C := INLINEBUF[INLINEPTR]; (*$R+ *) INLINEPTR := INLINEPTR+1; EOLNFLAG := (INLINEPTR>INLINELEN) END; (* READCHAR *) FUNCTION RESETFILE(* VAR FNAME:FILNAME ) :BOOLEAN *); VAR R: INTEGER; TRASH: LONGSTR; BEGIN (* RESETFILE *) (*$I- *) REPEAT IF FNAME='' THEN BEGIN RESETFILE := FALSE; EXIT(RESETFILE) END ELSE RESETFILE := TRUE; IF ((POS('.',FNAME)=0) AND (POS(':',FNAME) <> LENGTH(FNAME))) THEN FNAME := CONCAT(FNAME,'.TEXT'); RESET(INFILE,FNAME); R := IORESULT; IF R<>0 THEN BEGIN WRITELN ('Cannot open ',FNAME); WRITELN; WRITE ('Filename: '); READLN(FNAME) END UNTIL R=0; (*$I+ *) READBUF; (* READ TEXT FILE HEADER *) INDISKPTR := 1024; (* FORCE NEXT READBUF *) EOLNFLAG := TRUE; READLINE(TRASH) END; (* RESETFILE *) PROCEDURE CLOSEINFILE; BEGIN CLOSE(INFILE,LOCK) END; (*---------------------------------------------------------------------*) PROCEDURE WRITEBUF; (* BLOCKWRITE THE DISK FILE *) VAR E: INTEGER; BEGIN (* WRITEBUF *) E := BLOCKWRITE(OUTFILE,OUTDISKBUF,2); IF E<>2 THEN BEGIN WRITELN('Error writing file'); CLOSE(OUTFILE,LOCK); EXIT(PROGRAM) END; OUTDISKPTR:=0 END; (* WRITEBUF *) PROCEDURE WRITELINE(* ST:LONGSTR *); (* OUTLINEBUF := CONCAT OUTLINEBUF,ST; OUTDISKBUF := OUTLINEBUF *) VAR BLANKS,CHARS,STLEN: INTEGER; BEGIN (* WRITELINE *) CHARS := LENGTH(ST); (*$R-*) IF CHARS>0 THEN (* CONCAT OUTLINEBUF,ST *) MOVELEFT(ST[1],OUTLINEBUF[OUTLINEPTR+1],CHARS); (* CONCAT OUTLINEBUF,CHR(CR) *) CHARS := CHARS+OUTLINEPTR+1; OUTLINEBUF[CHARS] := CHR(CR); BLANKS := SCAN(CHARS,<>CHR(SP),OUTLINEBUF[1]); (*$R+*) STLEN:=CHARS-BLANKS; IF (OUTDISKPTR + STLEN) >1020 THEN (* WRITE BLOCK *) BEGIN FILLCHAR(OUTDISKBUF[OUTDISKPTR],1024-OUTDISKPTR,CHR(NULL)); WRITEBUF END; IF BLANKS>0 THEN (* INSERT DLE COUNT *) BEGIN OUTDISKBUF[OUTDISKPTR] := CHR(DLE); OUTDISKBUF[OUTDISKPTR+1] := CHR(BLANKS+32); OUTDISKPTR := OUTDISKPTR+2 END; (*$R-*) (* COPY OUTLINEBUF TO OUTDISKBUF *) MOVELEFT(OUTLINEBUF[BLANKS+1],OUTDISKBUF[OUTDISKPTR],STLEN); OUTLINEPTR := 0; (*$R+*) OUTDISKPTR := OUTDISKPTR+STLEN END; (* WRITELINE *) PROCEDURE WRITECHAR(* C:CHAR *); (* OUTLINEBUF := CONCAT OUTLINEBUF,CH *) BEGIN (* WRITECHAR *) OUTLINEPTR := OUTLINEPTR+1; (*$R- *) OUTLINEBUF[OUTLINEPTR] := C (*$R+ *) END; (* WRITECHAR *) FUNCTION REWRITEFILE(* VAR GNAME:FILNAME *) (* :BOOLEAN *); VAR E,R: INTEGER; BEGIN (* REWRITEFILE *) (*$I- *) REPEAT IF GNAME='' THEN BEGIN REWRITEFILE := FALSE; EXIT(REWRITEFILE) END ELSE REWRITEFILE := TRUE; IF ((POS('.',GNAME)=0) AND (POS(':',GNAME) <> LENGTH(GNAME))) THEN GNAME := CONCAT(GNAME,'.TEXT'); REWRITE(OUTFILE,GNAME); R := IORESULT; IF R<>0 THEN BEGIN WRITELN ('Cannot open ',GNAME); WRITELN; WRITE ('Filename: '); READLN(GNAME) END UNTIL R=0; (*$I+ *) IF (POS(':',GNAME)<>LENGTH(GNAME)) THEN (* DESTINATION IS PRESUMED TO BE A DISK FILE *) BEGIN FILLCHAR(OUTDISKBUF,SIZEOF(OUTDISKBUF),CHR(NULL)); WRITEBUF END; OUTDISKPTR:=0; OUTLINEPTR := 0 END; (* REWRITEFILE *) PROCEDURE CLOSEOUTFILE; BEGIN (* CLOSEOUTFILE *) IF OUTDISKPTR>0 THEN (* WRITE OUT LAST BLOCK *) BEGIN FILLCHAR(OUTDISKBUF[OUTDISKPTR],1024-OUTDISKPTR,CHR(NULL)); WRITEBUF END; CLOSE(OUTFILE,LOCK) END (* CLOSEOUTFILE *) END. (* IOUNIT *) ======================================================================================== DOCUMENT :usus Folder:VOL23:rnddoc.text ======================================================================================== RNDTEST RND is a random number generator that gives reasonably random results without crashing my LSI-11 system. RNDTEST includes four versions of RND, along with a few simple tests for randomness. The first three versions of RND are included for those who are interested in the detailed operation of the basic algorithm. The final version should run on any UCSD (TM) system, and is a clear candidate for inclusion in SYSTEM.LIBRARY. The basic algorithm for RND is Meekings' Algorithm A-1 in Pascal News #12, which is a Pascal version of Kendall's algorithm for a Tausworthe (or shift register) random sequence generator. Each call to a Tausworthe generator gets the next integer in a fixed pseudorandom sequence of integers. In RND, the sequence includes one and only one copy of each of the integers between 1 and 32767 inclusive, arranged in an order that many statistical tests cannot distinguish from a true random order. Starting with the 32768th call to the generator (or multiples thereof) the original sequence will repeat itself exactly. The random number generators in RNDTEST are written as: FUNCTION RND(LO,HI:INTEGER):INTEGER; Each uses a different version of a Tausworthe generator to maintain an integer "seed", and uses the real fraction (seed-1)/32767 to return an integer that is between LO and HI inclusive. The initial seed can be any positive nonzero integer. Changing seeds changes the starting point in the sequence, but does not change the sequence itself. The first version of RND uses a brute force Pascal bit manipulation version of the LSI-11 assembly language Tausworthe generator that appeared in Camp and Lewis, "Implementing a Pseudorandom Number Generator on a Minicomputer", IEEE Transactions on Software Engineering, May 1977, Page 259. Pascal does not flip bits with a great deal of alacrity, and this version is lethargic, if not moribund. However, it does show exactly what should be happening, bit by bit, and it will probably run on any UCSD (TM) system. The second and third versions of RND use what is essentially Meekings' algorithm from Pascal News #12. The second version uses arithmetic to generate a logical complement, while the third version uses NOT. Although these versions do run on my LSI-11 system, they do so only because AND, OR, and NOT are implemented as 16-bit operations, and booleans are treated as 16-bit words. These versions may or may not work on other systems. The fourth version of RND is similar to the second version, but reflects Miner's comments in PN #12, and Meekings' comments in PN #13. The changes prevent an integer multiply overflow, clear the sign bit of the seed (Note: this is not necessarily the same thing as taking the absolute value of the seed!), and implement the logical XOR function with set operations. This version is reasonably fast, and should work on any UCSD (TM) system. RNDTEST also includes three simple tests for random number generators. The first test is to generate 10,000 random integers between 1 and 10 inclusive and count the number of times that each of the integers between 0 and 11 appear. Neither 0 nor 11 should appear at all, and each of the other integers should appear roughly 1000 +/- 70 times. The second test is to generate 1000 random positions on the system (79 x 23) screen, GOTOXY there, and display an asterisk. The resulting display should not show a pronounced pattern, and should be roughly half full of asterisks by the time the test terminates. The third test is to generate random integers until the initial seed reappears. A count is kept of the number of times that each integer (positive, negative, or zero) crops up, as well as the total number of integers that have been generated. The count of each integer is then checked to ensure that no negative integers have been generated, that zero has not been generated, and that each positive integer has been generated once and only once. RANDOMIZE Each time a program using RND is executed, the seed must be initialized. In programs such as sorting benchmarks it is useful to use the same initial seed so that each sorting routine uses the same sequence of integers. In programs such as arithmetic drills it is useful to use a different seed each time the program is executed in order to avoid an identical sequence of problems. It is conventional to initialize a random number seed to a single, fixed value. If desired, a subsequent call to RANDOMIZE replaces the initial seed with a randomized seed. Obvious candidates for a randomized seed include using ABS(LOTIME) for those systems with a real time clock, or ORD(CH) where CH is the response to "Type any character". Other alternatives include using ABS(PEEK(loc)) where "loc" is a fixed memory location known to have a highly variable content, or ABS(DATE) where DATE is the system date that is maintained on the system disk. A final alternative that is practical under the IV UCSD (TM) system is to use the termination code of the UNIT construct to write the last value of seed out to disk. RANDOMIZE then reads this value back and uses it for the new value of seed. RANDOMIZE is not included in RNDTEST because of the system specific nature of the beast. CR ======================================================================================== DOCUMENT :usus Folder:VOL23:rndtest.text ======================================================================================== program randomtest; { Author: Charles Rockwell, Microlog, Box 116, Guilford CT, 06437. } (* Variations on Meekings' Algorithm A1, PN #12, and *) (* a few simple tests for random number generators *) var seed:integer; num:integer; test:char; procedure blankscr; (* clear the screen *) begin write(chr(26)); end; function rnd0(lo,hi:integer):integer; (* A Tausworthe generator, using Kendall's algorithm, done bit by bit *) (* Runtime is 30 min for 10000 randoms *) var a,b:record case boolean of true:(int:integer); false:(bol:packed array[0..15] of boolean); end; i,j,range:integer; q:real; begin a.int:=seed; for i:=0 to 15 do (* b:=a shifted right by 4 *) begin j:=(i+4)mod 16; if i<12 then b.bol[i]:=a.bol[j] else b.bol[i]:=false; end; for i:=0 to 15 do (* a:=a xor b *) a.bol[i]:=(a.bol[i]<>b.bol[i]); for i:=0 to 15 do (* b:=a shifted left by 11 *) begin j:=(i+11)mod 16; if j>10 then b.bol[j]:=a.bol[i] else b.bol[j]:=false; end; for i:=0 to 15 do (* a:=a xor b *) a.bol[i]:=(a.bol[i]<>b.bol[i]); a.bol[15]:=false; (* must clear the sign bit *) seed:=a.int; q:=(a.int-1)/32767; (* modified for a range of [0,1) *) range:=hi-lo+1; rnd0:=trunc(q*range)+lo; end; function rnd1(lo,hi:integer):integer; (* Meekings' Pascal version, from PN #12 *) (* This may or may not run *) const pshift=2048; qshift=16; big=32767; type dual=record case boolean of true:(int:integer); false:(bol:boolean); end; var a,b,acomp,bcomp:dual; range:integer; q:real; begin a.int:=seed; b.int:=a.int div qshift; (* b:=a shifted right by 4 *) acomp.int:=big-a.int; bcomp.int:=big-b.int; a.bol:=(a.bol and bcomp.bol)or(acomp.bol and b.bol); (* a:=a xor b *) b.int:=a.int * pshift; (* b:=a shifted left by 11 *) acomp.int:=big-a.int; bcomp.int:=big-b.int; a.bol:=(a.bol and bcomp.bol)or(acomp.bol and b.bol); (* a:=a xor b *) seed:=a.int; (* result is always positive *) q:=(a.int-1)/32767; (* modified for a range of [0,1) *) range:=hi-lo+1; rnd1:=trunc(q*range)+lo; end; function rnd2(lo,hi:integer):integer; (* Meekings' Pascal version, using boolean XOR *) (* This may or may not run *) const pshift=2048; qshift=16; pmod=16; (* Modified to clear sign bit *) big=32767; type dual=record case boolean of true:(int:integer); false:(bol:boolean); end; var a,b:dual; range:integer; q:real; begin a.int:=seed; b.int:=a.int div qshift; (* b:=a shifted right by 4 *) a.bol:=(a.bol and not b.bol)or(not a.bol and b.bol); (* a:=a xor b *) b.int:=a.int mod pmod * pshift; (* b:=a shifted left by 11, sign cleared *) a.bol:=(a.bol and not b.bol)or(not a.bol and b.bol); (* a:=a xor b *) seed:=a.int; (* result is always positive *) q:=(a.int-1)/32767; (* modified for a range of [0,1) *) range:=hi-lo+1; rnd2:=trunc(q*range)+lo; end; function rnd3 (lo,hi:integer):integer; (* Meekings' Pascal version, using Miner's XOR *) (* This should run *) const pshift=2048; pmod=16; (* modified to clear sign bit *) qshift=16; var q:real; range:integer; a,b:record case boolean of true:(int:integer); false:(bitset:packed set of 0..15); end; begin a.int:=seed; b.int:=a.int div qshift; (* b:=a shifted right by 4 *) a.bitset:=(a.bitset-b.bitset)+(b.bitset-a.bitset); (* a:=a xor b *) b.int:=a.int mod pmod * pshift; (* b:=a shifted left by 11, sign cleared *) a.bitset:=(a.bitset-b.bitset)+(b.bitset-a.bitset); (* a:=a xor b *) seed:=a.int; (* result is always positive *) q:=(a.int-1)/32767; (* modified for a range of [0,1) *) range:=hi-lo+1; rnd3:=trunc(q*range)+lo; end; procedure sort; (* Generate a random integer from 1 to 10, and *) (* increment the corresponding array member *) var a:array[0..11] of integer; j,k,m:integer; r:real; begin write('Testing '); for j:=0 to 11 do a[j]:=0; for j:=1 to 10000 do begin if j mod 1000 = 0 then write('.'); case num of (* use the specified RND function *) 0:k:=rnd0(1,10); 1:k:=rnd1(1,10); 2:k:=rnd2(1,10); 3:k:=rnd3(1,10); end; a[k]:=a[k]+1; end; writeln; writeln('0 expected in a[0] and a[11], 930 to 1070 in a[1]..a[10]') ; for j:=0 to 11 do writeln(' a[',j,']=',a[j]); end; procedure display; (* Generate a random screen position, *) (* gotoxy there, and write a marker *) var i,x,y:integer; begin blankscr; for i:=1 to 1000 do begin case num of 0: begin x:=rnd0(0,78); y:=rnd0(0,22) end; 1: begin x:=rnd1(0,78); y:=rnd1(0,22) end; 2: begin x:=rnd2(0,78); y:=rnd2(0,22) end; 3: begin x:=rnd3(0,78); y:=rnd3(0,22) end; end; gotoxy(x,y); write('*'); end; end; procedure check; (* Check for run length, no zero or negative integers, *) (* and no duplicate positive integers *) type cnt=0..3; byte=0..255; rec=packed record case boolean of true:(x:byte; y:byte); false:(z:integer); end; var j,k,m,n,t:integer; count:packed array[0..255,0..255] of cnt; alias:rec; (* compiler will not allow 65536 x 2 array *) begin n:=0; write('Zeroing array '); for j:=0 to 255 do for k:=0 to 255 do begin if k=0 then if j mod 10 = 0 then write('.'); count[j,k]:=0; end; writeln; write('Filling array '); repeat case num of (* use the specified RND function, *) 0:t:=rnd0(0,1); 1:t:=rnd1(0,1); 2:t:=rnd2(0,1); 3:t:=rnd3(0,1); end; alias.z:=seed; (* but check the seed *) if n mod 2560 = 0 then write('.'); n:=n+1; count[alias.x,alias.y]:=count[alias.x,alias.y]+1; until ((alias.z=12345) or (count[alias.x,alias.y]=3)); (* seed has come full circle, or generator is repeating *) writeln; writeln; writeln('Run length: ',n); writeln; writeln('Checking negative integers'); n:=0; for j:=0 to 255 do for k:=128 to 255 do if count[j,k]<>0 then n:=n+1; writeln; if n=0 then write('No ') else write(n,' '); writeln('negative integers generated'); writeln; if count[0,0]=0 then writeln('Zero was not generated') else writeln('Zero was generated'); writeln; writeln('Checking positive integers'); n:=0; m:=0; for j:=0 to 255 do for k:=0 to 127 do if count[j,k]<>1 then begin if count[j,k]=0 then if ((j=0) and (k=0)) then (* don't count zero as missing *) else m:=m+1 else n:=n+1; end; writeln; if m=0 then write('No ') else write(m,' '); writeln('missing positive integers'); writeln; if n=0 then write('No ') else write(n,' '); writeln('duplicate positive integers'); end; begin (* randomtest *) repeat seed :=12345; blankscr; repeat gotoxy(0,0); write('S(ort, D(isplay, C(heck, Q(uit ? '); read(test); until test in ['S','s','D','d','C','c','Q','q']; if test in ['Q','q'] then exit(program); repeat gotoxy(0,1); write('Generator number [0..3] ? '); readln(num); until num in [0..3]; case test of 'S','s': sort; 'D','d': display; 'C','c':check; end; gotoxy(0,23); write('Hit SPACE to continue: '); read(test); until false end. ======================================================================================== DOCUMENT :usus Folder:VOL23:spelldoc.text ======================================================================================== SPELLDOC Speller is a simple spelling checker. Speller reads an input text file and sorts it into an alphabetical list of unique words. This list of words is then checked against a dictionary, and all words that are found in the dictionary are removed from the list. The remaining list consists of "flagged", or potentially misspelled words. This list can be displayed, printed, sent to a file, or simply ignored. An optional second pass can then be made through the text file. During the second pass, each text word is looked up in the list of flagged words. If a text word is found, a flag ("<") is inserted in the text file. The editor is then used to find each of the flags and correct the error. A practical spelling checker must check a text file of reasonable length against a large dictionary in a reasonable amount of time. Speller uses memory only for the list of unique text words, which is considerably shorter than the text file itself. This allows a reasonably long text file to be checked against a dictionary file that is limited only by disk space. Speller spends the vast majority of its run time in reading text and looking up words. The time spent in reading text is minimized by using routines from IOUNIT in place of the standard constructs. The time spent in looking up words is minimized by using a binary tree search algorithm from Niklaus Wirth's program "Cross Reference Generator" in his book Algorithms + Data Structures = Programs. Running Speller Speller announces its presence by displaying "Speller", and then prompts for the name of the input text file, which can be any UCSD text file. If only a name is entered then ".text" is appended to the name. I/O checking is turned off while an attempt is made to access the file on the default disk drive. If there is a problem, the name is displayed and the process repeats. If no name is entered, it is assumed that the program was entered by mistake, and Speller terminates. After the text file is successfully opened, the program displays "Sorting text" and begins to sort the input text. An indication of progress is provided by displaying a "." as each tenth line is read from the input text file. After the sort has been completed, the program prompts for the name of the input dictionary file. The dictionary file is an alphebetical list of correctly spelled words, one to a line, in an otherwise standard UCSD text file. The process of opening the dictionary file is the same as that of opening the text file. If no name is entered, the word list is not checked and the program goes directly to the output procedure. After the input dictionary file is successfully opened, the program prompts for the name of a new (output) dictionary file. An attempt is made to open this file in the same way as the previous files. If the file can be opened, each word from the input dictionary file is copied to the output dictionary file, and text words that were not found in the dictionary can be added. If no file name is entered, the option of adding words to the dictionary is not available. In either case, the program displays "Checking text" and begins to check the word list against the dictionary. If the option of adding words to the dictionary has not been exercised, the indications of progress are the same as when reading a text file. If words are being added to the dictionary, the only indication of progress is an occasional message that goes something like: "Line 338: snurf not found. Enter it (Y) ? ". Either "Y" or "y" will cause the word to be added to the dictionary. If the answer is any other character, the message continues with: " Flag it (Y) ? " Either "Y" or "y" will cause the word to be added to the list of flagged words, any other character will cause the word to be removed from the list of flagged words. After the entire list of words has been checked, (or if no dictionary file name was entered), the program prompts for the name of the output list file, which can be CONSOLE:, PRINTER:, etc, as well as a disk file. The process of opening the output file is the same as before. If the output file is successfully opened, the program displays "Writing output list", and the output list is sent to its destination. The output is a sorted list of the flagged words, along with the line number of the first appearance and a count of the total number of appearances in the original text file. If no file name is entered, the word list is not written. The program then prompts for the name of the marked text file. After this file is successfully opened, the input text file is copied to the output text file, with a "<" inserted at the end of each flagged word. If no file name is entered, the marked text file is not written. The program finishes by displaying the number of lines, words, and unique words that were found in the text file, the number of unique words that were flagged, and the number of words of memory still available. Implementation Notes Speller converts all text to lower case, so that neither "pascal" nor "PASCAL" is flagged as a potential spelling error. Words are defined as beginning with a..z or 0..9, and as continuing with a..z, 0..9, "-","'", or "/". Words beginning with 0..9 increment the word count but are not checked. Byte- flipped is two words: "byte-" and "flipped". Byte-flipped, ain't, and I/O are all words, but M(unched is two words: "m" and "unched". The maximum length of a word is defined by the constant MAXCHAR as 14 characters. Words up to and including maxchar characters in length are accepted as is. Words longer than this are truncated, and the last character is changed to a "-". Words are defined in the procedure GETTOKEN, and the definition can be changed as desired. Speller uses a "literal dictionary", which means that the dictionary is just a long list of words. The dictionary is formatted as one word per line, in alphabetical order, with no leading or trailing spaces. (Using GETTOKEN rather than READLINE to read the dictionary removes the formatting restrictions at the cost of doubling the time to read the dictionary). The dictionary can be edited just as any other text file. Speller's dictionary is defined as a sorted list of words known to be spelled correctly. Considerable care should be used in adding words to the dictionary; a spelling check using a corrupt dictionary is of little value. Performance Speller runs a complete check at a rate of roughly 300 text words per minute, depending on the specific system, the length of the files, etc. The sorting method used by Speller is recursive, which means that the procedure includes a call to itself. Because of this recursion, both the memory and the time required to sort a text file depend on the order of the words in the input text. If the file contains normal English text, the performance of the sort is roughly equivalent to the performance of a binary search. If the input text is already sorted, or nearly so, the performance of the sort degrades to that of a linear search. The result is a slow sort requiring copious memory. Replying to "Input text file" with "dict.text" will probably cause "*STACK OVERFLOW*" many minutes later. The maximum length of the input text file is determined primarily by the number of unique words encountered, and is limited to roughly three times the capacity of the screen editor. The length of the dictionary file is limited by the disk capacity and the user's patience. If the dictionary is to be edited, the editor's limitations on file length become important. However, note that it is relatively easy to modify the procedure CHECKDICT to read several dictionary files in sequence. CR ======================================================================================== DOCUMENT :usus Folder:VOL23:speller.text ======================================================================================== PROGRAM SPELLER; { (c) Copyright 1983 by Charles Rockwell. All rights reserved. } { Permission is granted only for not-for-profit use by USUS members.} { Author: Charles Rockwell, Microlog, Box 116, Guilford CT, 06437. } USES (*$U IOUNIT.CODE *) IOUNIT; { This construct assumes IOUNIT.CODE resides in SYSTEM.LIBRARY } { changed to look for IOUNIT in a code file called IOUNIT.CODE - gws } CONST MAXCHAR = 14; (* CHARACTERS PER TOKEN *) MAXDIGITS = 5; (* DIGITS IN LINE NUMBER *) MAXSTR = 132; (* CHARACTERS IN STRING *) TYPE ALPHA = STRING[MAXCHAR]; FILENAME = STRING[20]; WORDREF = ^WORD; WORD = RECORD KEY: ALPHA; (* A WORD *) FIRST: INTEGER; (* FIRST LINE NUMBER *) COUNT: INTEGER; (* OCCURRENCES *) LEFT: WORDREF; (* POINTERS TO LEFT AND *) RIGHT: WORDREF; (* RIGHT WORDS IN TREE *) END; VAR OUT:BOOLEAN; FILEOK: BOOLEAN; (* FILE IS OPEN *) DOTS: BOOLEAN; (* WRITE DOTS TO SCREEN *) LBUF: STRING[MAXSTR]; (* INPUT LINE BUFFER *) LPTR: INTEGER; (* INPUT LINE POINTER *) MARK: BOOLEAN; (* WRITING MARKED TEXT FILE *) ROOT: WORDREF; (* START OF THE TREE *) DICTWRITE: BOOLEAN; (* ADDING ENTRIES TO DICT *) LCOUNT: INTEGER; (* RUNNING LINE COUNT *) LINECOUNT: INTEGER; (* LINES IN TEXT *) WCOUNT: INTEGER; (* RUNNING WORD COUNT *) WORDCOUNT: INTEGER; (* TOKENS IN TEXT *) DICTCOUNT: INTEGER; (* UNIQUE WORDS IN TEXT *) FLAGCOUNT: INTEGER; (* WORDS FLAGGED FOR OUTPUT *) CORECOUNT: INTEGER; (* MINIMUM WORDS OF MEMORY *) TOKEN: ALPHA; (* A WORD *) SPACES: ALPHA; (* A BLANK WORD *) CH: CHAR; SOURCE: FILENAME; (* INPUT FILE NAME *) DEST: FILENAME; (* OUTPUT FILE NAME *) TITLE: FILENAME; (* FILE NAME FOR HEADER *) (*---------------------------------------------------------------------*) PROCEDURE REPORT; (* SEND PROGRESS REPORT TO SCREEN *) BEGIN IF DOTS THEN WRITE('.'); IF CORECOUNT>VARAVAIL('speller') (* MEMAVAIL *) THEN CORECOUNT := VARAVAIL('speller') END; PROCEDURE GETTOKEN; (* READ A WORD *) VAR K: INTEGER; DONE: BOOLEAN; PROCEDURE READCH(VAR C:CHAR); BEGIN IF LPTR>LENGTH(LBUF) THEN BEGIN IF MARK THEN BEGIN DELETE(LBUF,LENGTH(LBUF),1); WRITELINE(LBUF) END; IF EOFFLAG THEN BEGIN OUT:=TRUE; EXIT(GETTOKEN) END; READLINE(LBUF); LBUF := CONCAT(LBUF,' '); LPTR := 1; IF LCOUNT MOD 10 = 0 THEN REPORT; LCOUNT := LCOUNT+1 END; C := LBUF[LPTR]; LPTR := LPTR+1; IF C IN ['A'..'Z'] THEN C := CHR(ORD(C)+32) END; (* READCH *) BEGIN (* GETTOKEN *) REPEAT DONE := TRUE; K := 0; TOKEN := SPACES; REPEAT READCH(CH) UNTIL CH IN ['a'..'z','0'..'9']; (* A WORD STARTS WITH THESE *) (*$R- *) REPEAT K := K+1; IF K<= MAXCHAR THEN TOKEN[K] := CH; READCH(CH) UNTIL NOT(CH IN ['a'..'z','0'..'9','''','/','-']); (* AND CONTINUES WITH THESE *) IF (TOKEN[1] IN ['0'..'9']) THEN (* COUNT AND IGNORE *) BEGIN WCOUNT := WCOUNT+1; DONE := FALSE END UNTIL DONE; IF K > MAXCHAR THEN BEGIN TOKEN[MAXCHAR] := '-'; K := MAXCHAR END; TOKEN[0] := CHR(ORD(K)) (*$R+ *) END; (* GETTOKEN *) (*---------------------------------------------------------------------*) PROCEDURE INIT; VAR K: INTEGER; BEGIN (* INIT *) LBUF := ' '; LPTR := LENGTH(LBUF)+1; MARK := FALSE; ROOT := NIL; LCOUNT := 0; WCOUNT := 0; WORDCOUNT := 0; DICTCOUNT := 0; CORECOUNT := VARAVAIL('speller'); (* MEMAVAIL *) SPACES := ''; FOR K:=1 TO MAXCHAR DO SPACES := CONCAT(SPACES,' '); WRITELN('Speller'); WRITELN END; (* INIT *) (*---------------------------------------------------------------------*) PROCEDURE SORTTEXT; (* SORT THE TEXT *) PROCEDURE SORTTREE(VAR W1:WORDREF); (* TRAVERSE THE TREE *) VAR W: WORDREF; BEGIN (* SORTTREE *) W := W1; IF W=NIL THEN (* PLACE FOR NEW WORD FOUND *) BEGIN NEW(W); WITH W^ DO BEGIN KEY := TOKEN; (* ENTER THE WORD *) COUNT := 1; LEFT := NIL; RIGHT := NIL; FIRST := LCOUNT END; W1 := W; WCOUNT := WCOUNT+1; DICTCOUNT := DICTCOUNT+1 END ELSE IF TOKENW^.KEY THEN SORTTREE(W^.RIGHT) ELSE BEGIN (* OLD WORD FOUND *) W^.COUNT := W^.COUNT+1; WCOUNT := WCOUNT+1 END END; (* SORTTREE *) BEGIN (* SORTTEXT *) WRITELN; WRITE('Input text file: '); READLN(SOURCE); FILEOK := RESETFILE(SOURCE); IF NOT FILEOK THEN EXIT(PROGRAM); OUT:=FALSE; TITLE := SOURCE; WRITELN; WRITE('Reading text '); DOTS := TRUE; GETTOKEN; WHILE NOT OUT DO BEGIN SORTTREE(ROOT); GETTOKEN END; WRITELN END; (* SORTTEXT *) (*---------------------------------------------------------------------*) PROCEDURE CHECKDICT; (* CHECK THE WORD LIST *) VAR ENTRY: ALPHA; PROCEDURE GETENTRY; BEGIN IF DICTWRITE THEN WRITELINE(ENTRY); READLINE(ENTRY); IF LCOUNT MOD 100 = 0 THEN REPORT; LCOUNT := LCOUNT+1 END; PROCEDURE CHECKTREE (W:WORDREF); (* TRAVERSE THE TREE *) PROCEDURE CHECKWORD(VAR W:WORDREF); (* LOOKUP THE WORD *) BEGIN (* CHECKWORD *) WHILE ENTRY < W^.KEY DO GETENTRY; IF ENTRY = W^.KEY THEN BEGIN W^.COUNT := 0; FLAGCOUNT := FLAGCOUNT-1 END ELSE (* ENTRY > W^.KEY *) IF DICTWRITE THEN BEGIN WRITELN; WRITE('Line ',W^.FIRST:MAXDIGITS, ' : ',W^.KEY:14, ' not found. Enter it (Y) ?'); READ(CH); IF CH IN ['Y','y'] THEN BEGIN WRITELN; IF DICTWRITE THEN WRITELINE(W^.KEY); W^.COUNT := 0; FLAGCOUNT := FLAGCOUNT-1 END ELSE (* NOT CH IN Y,y *) BEGIN WRITE(' Flag for output (Y) ?'); READ(CH); WRITELN; IF NOT (CH IN ['Y','y']) THEN BEGIN W^.COUNT := 0; FLAGCOUNT := FLAGCOUNT-1 END END END END; (* CHECKWORD *) BEGIN (* CHECKTREE *) IF W<>NIL THEN BEGIN CHECKTREE(W^.LEFT); CHECKWORD(W); CHECKTREE(W^.RIGHT) END END; (* CHECKTREE *) BEGIN (* CHECKDICT *) LINECOUNT := LCOUNT; LCOUNT := 0; WORDCOUNT := WCOUNT; FLAGCOUNT := DICTCOUNT; WRITELN; WRITE('Input dict file: '); READLN(SOURCE); FILEOK := RESETFILE(SOURCE); WRITELN; IF FILEOK THEN BEGIN WRITE('New dict file: '); READLN(DEST); DICTWRITE := REWRITEFILE(DEST); DOTS := NOT DICTWRITE; WRITELN; WRITE('Checking text '); IF DICTWRITE THEN WRITELN; READLINE(ENTRY); CHECKTREE(ROOT); WHILE NOT EOFFLAG DO GETENTRY; IF DICTWRITE THEN BEGIN WRITELINE(ENTRY); CLOSEOUTFILE END; IF DOTS THEN WRITELN END END; (* CHECKDICT *) (*---------------------------------------------------------------------*) PROCEDURE PRINTLIST; (* WRITE THE ERROR FILE *) PROCEDURE HEADER; (* WRITE TOP OF OUTPUT FILE *) BEGIN (* HEADER *) WRITELINE(''); WRITELINE(CONCAT('Spelling check of file ',TITLE)); WRITELINE(''); WRITELINE(''); WRITELINE('Word Count Line'); WRITELINE('') END; (* HEADER *) PROCEDURE PRINTTREE(W:WORDREF); (* TRAVERSE THE TREE *) PROCEDURE WRITEIT; VAR S1: STRING; S2:ALPHA; K:INTEGER; PROCEDURE CONV(X:INTEGER; VAR S:ALPHA); VAR D:INTEGER; J:INTEGER; L:INTEGER; BEGIN (*$R- *) L:=X; FOR J:=1 TO MAXDIGITS DO S[J]:='0'; S[0]:=CHR(MAXDIGITS); J:=1; IF X > 9999 THEN BEGIN D := L DIV 10000; L:=L-D*10000; S[J]:=CHR(D+48); END ELSE S[J]:=' '; J:=J+1; IF X > 999 THEN BEGIN D := L DIV 1000; L:=L-D*1000; S[J]:=CHR(D+48); END ELSE S[J]:=' '; J:=J+1; IF X > 99 THEN BEGIN D := L DIV 100; L:=L-D*100; S[J]:=CHR(D+48); END ELSE S[J]:=' '; J:=J+1; IF X > 9 THEN BEGIN D := L DIV 10; L:=L-D*10; S[J]:=CHR(D+48); END ELSE S[J]:=' '; J:=J+1; S[J]:=CHR(L+48) (*$R+ *) END; BEGIN (* CONVERT INTEGERS TO STRINGS FOR WRITELINE *) S1 := W^.KEY; (*$R- *) FOR K:=(LENGTH(S1)+1) TO MAXCHAR DO S1[K]:=' '; S1[0]:=CHR(MAXCHAR); (*$R+ *) CONV(W^.COUNT,S2); S1:=CONCAT(S1,' ',S2); CONV(W^.FIRST,S2); S1:=CONCAT(S1,' ',S2); WRITELINE(S1); IF LCOUNT MOD 10 = 0 THEN REPORT; LCOUNT := LCOUNT+1 END; BEGIN (*PRINTTREE*) IF W<>NIL THEN BEGIN PRINTTREE(W^.LEFT); IF W^.COUNT<>0 THEN WRITEIT; PRINTTREE(W^.RIGHT) END END; (* PRINTTREE *) BEGIN (*PRINTLIST*) IF FLAGCOUNT>0 THEN BEGIN WRITELN; WRITE('Output list file: '); READLN(DEST); FILEOK := REWRITEFILE(DEST); WRITELN; IF FILEOK THEN BEGIN DOTS := (POS(':',DEST)<>LENGTH(DEST)); WRITE('Writing output list '); HEADER; LCOUNT := 0; PRINTTREE(ROOT); CLOSEOUTFILE; WRITELN END END END; (* PRINTLIST *) (*---------------------------------------------------------------------*) PROCEDURE MARKTREE(W:WORDREF); BEGIN IF TOKENW^.KEY THEN MARKTREE(W^.RIGHT) ELSE BEGIN (* FOUND A TOKEN *) IF W^.COUNT<>0 THEN (* INSERT FLAG INTO LINE BUFFER *) BEGIN LPTR := LPTR-1; INSERT('<',LBUF,LPTR); LPTR := LPTR+2 END END END; PROCEDURE MARKTEXT; BEGIN IF FLAGCOUNT>0 THEN BEGIN WRITELN; FILEOK := RESETFILE(TITLE); IF NOT FILEOK THEN BEGIN WRITELN('Fatal error -- input file lost'); EXIT(PROGRAM) END; WRITE('Marked text file: '); READLN(DEST); FILEOK := REWRITEFILE(DEST); WRITELN; IF FILEOK THEN BEGIN WRITE('Marking text '); OUT:=FALSE; LCOUNT := 0; DOTS := (POS(':',DEST)<>LENGTH(DEST)); READLINE(LBUF); LBUF:=CONCAT(LBUF,' '); LPTR:=1; MARK := TRUE; GETTOKEN; WHILE NOT OUT DO BEGIN MARKTREE(ROOT); GETTOKEN END; CLOSEOUTFILE; WRITELN END END END; (* MARKTEXT *) (*---------------------------------------------------------------------*) PROCEDURE WRAPUP; BEGIN (* WRAPUP *) WRITELN; WRITELN('Input lines: ',LINECOUNT:8); WRITELN('Input words: ',WORDCOUNT:8); WRITELN('Unique words: ',DICTCOUNT:8); WRITELN('Flagged words:',FLAGCOUNT:8); WRITELN('Free memory: ',CORECOUNT:8) END; (* WRAPUP *) (*---------------------------------------------------------------------*) BEGIN (* SPELLER *) INIT; SORTTEXT; CHECKDICT; PRINTLIST; MARKTEXT; WRAPUP END. ======================================================================================== DOCUMENT :usus Folder:VOL23:stargame.text ======================================================================================== { (*$L-PRINTER:*) } (****STARGAME.TEXT****) (****4/1/83****) (* Original autor is not known to me. This version executes only on the *) (* Heathkit H-19 terminal. Revised by Hays Busch. For more information *) (* call 303-238-7227 or write 3071 Oak St., Lakewood, CO. 80215 *) { Modified (kludged) for terminal independence. If you have an H-19, you can put back all the code that I commented out, and the game will look a little nicer, but it will work the same - gws } PROGRAM THE_STAR_GAME; CONST T_SID_HORZ = 3; {top side horizontal} T_MID_HORZ = 9; {top middle horizontal} B_MID_HORZ = 15; {bottom etc.} B_SID_HORZ = 21; L_SID_VERT = 30; {left side vertical} L_MID_VERT = 36; R_MID_VERT = 42; {right etc.} R_SID_VERT = 48; VAR star : ARRAY [1..9] OF 0..1; move_numb : INTEGER; rand_seed : REAL; u_r_c, l_r_c, {upper right corner, etc.} l_l_c, u_l_c, {lower left corner, etc.} h_ln, v_ln, {horiz and vert line} dn_t, lf_t, {down & left T} up_t, rt_t, {up & right T} crs : CHAR; {cross} star_top, star_mid, star_bot : STRING[3]; PROCEDURE BELL; BEGIN WRITE(CHR(7)); END; {alarm} PROCEDURE CLEAR_SCREEN; var buf : packed array [ 0..23 ] of char; BEGIN (**WRITE(CHR(27),'E'); {H-19 clearscreen}*) fillchar ( buf, sizeof ( buf ) , chr ( 10 ) ); gotoxy ( 0, 23 ); unitwrite ( 2, buf, sizeof ( buf ) ); END; {clear screen} PROCEDURE CLR_LINE_RIGHT(clr_col,clr_row:INTEGER); var buf : packed array [ 0..79 ] of char; BEGIN fillchar ( buf, sizeof( buf ), chr ( 32 ) ); GOTOXY(clr_col,clr_row); (**WRITE(CHR(27),'K'); {H-19 command}*) unitwrite ( 2, buf, 80-clr_col ); END; {clear line right} PROCEDURE START_GRAPHICS; BEGIN (*WRITE(CHR(27),'F'); {graphics on} write(CHR(27),'x5');{cursor off}*) END; {start graphics and cursor off} PROCEDURE END_GRAPHICS; BEGIN (*WRITE(CHR(27),'G'); {graphics mode off} write(CHR(27),'y5');{cursor on}*) END; {end graphics and cursor on} FUNCTION REPLY_CHAR:CHAR; VAR rc_char : CHAR; BEGIN READ(KEYBOARD,rc_char); REPLY_CHAR := rc_char; END; {reply char} PROCEDURE INITIALIZE; VAR i_go_ahead : CHAR; i_continue : BOOLEAN; BEGIN GOTOXY(30,2);WRITE('THE STAR GAME'); GOTOXY(15,4);WRITE('The object of the game is to fill all boxes in'); GOTOXY(15,5);WRITE('the rectangle...EXCEPT #5...with a star. The'); GOTOXY(15,6);WRITE('problem is, when you change one star, you change'); GOTOXY(15,7);WRITE('several other stars as well!'); GOTOXY(15,9);WRITE('To change a star, type its box number. Typing'); GOTOXY(15,10);WRITE('an empty box number will just add one count to'); GOTOXY(15,11);WRITE('your score...which is not good!'); GOTOXY(15,13);WRITE('If you erase all stars, you lose right away.'); GOTOXY(15,15);WRITE('Player who fills all boxes...EXCEPT #5...with a'); GOTOXY(15,16);WRITE('star, in the least number of turns, wins.'); GOTOXY(15,18);WRITE('There is a pattern to the play...try to find'); GOTOXY(15,19);WRITE('it and you can win every time. GOOD LUCK!'); REPEAT BELL; GOTOXY(15,22);WRITE('Type "C" to continue -> '); i_go_ahead := REPLY_CHAR; GOTOXY(40,22);WRITE(i_go_ahead); i_continue := FALSE; IF i_go_ahead IN ['C','c'] THEN i_continue := TRUE; UNTIL i_continue; CLEAR_SCREEN; (** u_r_c := 'c'; {Heath H-19 termainal graphics} l_r_c := 'd'; l_l_c := 'e'; u_l_c := 'f'; h_ln := 'a'; v_ln := '`'; dn_t := 's'; lf_t := 't'; up_t := 'u'; rt_t := 'v'; crs := 'b'; star_top := 'y`x'; star_mid := 'aia'; star_bot := 'x`y'; *) u_r_c := '+'; {ASCII character graphics - gws } l_r_c := '+'; l_l_c := '+'; u_l_c := '+'; h_ln := '-'; v_ln := '|'; dn_t := '+'; lf_t := '+'; up_t := '+'; rt_t := '+'; crs := '+'; star_top := '* *'; star_mid := ' * '; star_bot := '* *'; BELL; GOTOXY(20,10); WRITE('Enter a number between 1 and 100 -> '); READLN(rand_seed); END; {initialize} PROCEDURE DRAW_FIELD; VAR df_x, df_y : INTEGER; PROCEDURE DRAW_LINE(dl_x_start,dl_x_end,dl_y_start,dl_y_end:INTEGER); VAR dl_x_axis, dl_y_axis : INTEGER; PROCEDURE DRAW_DIAG; BEGIN END_GRAPHICS; WRITE('LINE COORDINATES YIELD DIAGONAL'); START_GRAPHICS; END; {draw diagonal} BEGIN {draw_line} IF (dl_x_end <> dl_x_start) AND (dl_y_end <> dl_y_start) THEN DRAW_DIAG ELSE IF dl_x_end <> dl_x_start THEN {draw a horizontal line} BEGIN IF dl_x_start < dl_x_end THEN FOR dl_x_axis := dl_x_start TO dl_x_end DO BEGIN GOTOXY(dl_x_axis,dl_y_start); WRITE(h_ln); END ELSE FOR dl_x_axis := dl_x_start DOWNTO dl_x_end DO BEGIN GOTOXY(dl_x_axis,dl_y_start); WRITE(h_ln); END; END ELSE {draw a vertical line} BEGIN IF dl_y_start < dl_y_end THEN FOR dl_y_axis := dl_y_start TO dl_y_end DO BEGIN GOTOXY(dl_x_start,dl_y_axis); WRITE(v_ln); END ELSE FOR dl_y_axis := dl_y_start DOWNTO dl_y_end DO BEGIN GOTOXY(dl_x_start,dl_y_axis); WRITE(v_ln); END; END; END; {draw line} BEGIN {draw field} CLEAR_SCREEN; START_GRAPHICS; {first draw the box} DRAW_LINE((L_SID_VERT + 1),(R_SID_VERT - 1),T_SID_HORZ,T_SID_HORZ); GOTOXY(R_SID_VERT,T_SID_HORZ); WRITE(u_r_c); DRAW_LINE(R_SID_VERT,R_SID_VERT,(T_SID_HORZ + 1),(B_SID_HORZ - 1)); GOTOXY(R_SID_VERT,B_SID_HORZ); WRITE(l_r_c); DRAW_LINE((R_SID_VERT - 1),(L_SID_VERT + 1),B_SID_HORZ,B_SID_HORZ); GOTOXY(L_SID_VERT,B_SID_HORZ); WRITE(l_l_c); DRAW_LINE(L_SID_VERT,L_SID_VERT,(B_SID_HORZ - 1),(T_SID_HORZ + 1)); GOTOXY(L_SID_VERT,T_SID_HORZ); WRITE(u_l_c); {next the high middle line} GOTOXY(L_SID_VERT,T_MID_HORZ); WRITE(rt_t); DRAW_LINE((L_SID_VERT + 1),(R_SID_VERT - 1),T_MID_HORZ,T_MID_HORZ); GOTOXY(R_SID_VERT,T_MID_HORZ); WRITE(lf_t); {next low middle line} GOTOXY(L_MID_VERT,T_SID_HORZ); WRITE(dn_t); DRAW_LINE(L_MID_VERT,L_MID_VERT,(T_SID_HORZ + 1),(T_MID_HORZ - 1)); GOTOXY(L_MID_VERT,T_MID_HORZ); WRITE(crs); DRAW_LINE(L_MID_VERT,L_MID_VERT,(T_MID_HORZ + 1),(B_SID_HORZ - 1)); GOTOXY(L_MID_VERT,B_SID_HORZ); WRITE(up_t); {next low middle line} GOTOXY(L_SID_VERT,B_MID_HORZ); WRITE(rt_t); DRAW_LINE((L_SID_VERT + 1),(L_MID_VERT - 1),B_MID_HORZ,B_MID_HORZ); GOTOXY(L_MID_VERT,B_MID_HORZ); WRITE(crs); DRAW_LINE((L_MID_VERT + 1),(R_SID_VERT - 1),B_MID_HORZ,B_MID_HORZ); GOTOXY(R_SID_VERT,B_MID_HORZ); WRITE(lf_t); {finally right middle line} GOTOXY(R_MID_VERT,T_SID_HORZ); WRITE(dn_t); DRAW_LINE(R_MID_VERT,R_MID_VERT,(T_SID_HORZ + 1),(T_MID_HORZ - 1)); GOTOXY(R_MID_VERT,T_MID_HORZ); WRITE(crs); DRAW_LINE(R_MID_VERT,R_MID_VERT,(T_MID_HORZ + 1),(B_MID_HORZ - 1)); GOTOXY(R_MID_VERT,B_MID_HORZ); WRITE(crs); DRAW_LINE(R_MID_VERT,R_MID_VERT,(B_MID_HORZ + 1),(B_SID_HORZ - 1)); GOTOXY(R_MID_VERT,B_SID_HORZ); WRITE(up_t); {then number the boxes} GOTOXY((L_SID_VERT + 1),(T_SID_HORZ + 1)); WRITE('1'); GOTOXY((L_MID_VERT + 1),(T_SID_HORZ + 1)); WRITE('2'); GOTOXY((R_MID_VERT + 1),(T_SID_HORZ + 1)); WRITE('3'); GOTOXY((L_SID_VERT + 1),(T_MID_HORZ + 1)); WRITE('4'); GOTOXY((L_MID_VERT + 1),(T_MID_HORZ + 1)); WRITE('5'); GOTOXY((R_MID_VERT + 1),(T_MID_HORZ + 1)); WRITE('6'); GOTOXY((L_SID_VERT + 1),(B_MID_HORZ + 1)); WRITE('7'); GOTOXY((L_MID_VERT + 1),(B_MID_HORZ + 1)); WRITE('8'); GOTOXY((R_MID_VERT + 1),(B_MID_HORZ + 1)); WRITE('9'); END_GRAPHICS; END; {draw field} PROCEDURE DRAW_STAR(ds_star:INTEGER); VAR ds_x, ds_y : INTEGER; BEGIN START_GRAPHICS; CASE ds_star OF {first find out which star} 1: BEGIN ds_x := L_SID_VERT + 2; ds_y := T_SID_HORZ + 2; END; 2: BEGIN ds_x := L_MID_VERT + 2; ds_y := T_SID_HORZ + 2; END; 3: BEGIN ds_x := R_MID_VERT + 2; ds_y := T_SID_HORZ + 2; END; 4: BEGIN ds_x := L_SID_VERT + 2; ds_y := T_MID_HORZ + 2; END; 5: BEGIN ds_x := L_MID_VERT + 2; ds_y := T_MID_HORZ + 2; END; 6: BEGIN ds_x := R_MID_VERT + 2; ds_y := T_MID_HORZ + 2; END; 7: BEGIN ds_x := L_SID_VERT + 2; ds_y := B_MID_HORZ + 2; END; 8: BEGIN ds_x := L_MID_VERT + 2; ds_y := B_MID_HORZ + 2; END; 9: BEGIN ds_x := R_MID_VERT + 2; ds_y := B_MID_HORZ + 2; END; END; {case} IF star[ds_star] <> 0 THEN {build the star} BEGIN GOTOXY(ds_x,ds_y + 0); WRITE(star_top); { \|/ } GOTOXY(ds_x,ds_y + 1); WRITE(star_mid); { -*- } GOTOXY(ds_x,ds_y + 2); WRITE(star_bot); { /|\ } END ELSE BEGIN GOTOXY(ds_x,ds_y + 0); WRITE(' '); GOTOXY(ds_x,ds_y + 1); WRITE(' '); GOTOXY(ds_x,ds_y + 2); WRITE(' '); END; END_GRAPHICS; {shut off the graphics} END; {draw star} PROCEDURE GEN_BOARD; VAR gb_index : INTEGER; FUNCTION RANDOM:INTEGER; VAR r_ptr :^REAL; r_int :INTEGER; BEGIN REPEAT NEW(r_ptr); UNTIL r_ptr^ <> 0; IF r_ptr^ < 0 THEN r_ptr^ := 0 - r_ptr^; rand_seed := rand_seed * r_ptr^; REPEAT WHILE rand_seed > 1 DO rand_seed := rand_seed / 10; WHILE rand_seed < 0.1 DO rand_seed := rand_seed * 10; r_int := TRUNC(rand_seed * 10.0); UNTIL (r_int >= 1) AND (r_int <= 9); RANDOM := r_int; END; {random} BEGIN {gen_board} DRAW_FIELD; FOR gb_index := 1 TO 9 DO star[gb_index] := 0; star[RANDOM] := 1; FOR gb_index := 1 TO 9 DO DRAW_STAR(gb_index); move_numb := 1; END; {generate board} PROCEDURE PLAY; VAR p_move : CHAR; p_index : INTEGER; PROCEDURE FLIP(fstar:INTEGER); BEGIN IF star[fstar] = 0 THEN star[fstar] := 1 ELSE star[fstar] := 0; DRAW_STAR(fstar); END; {flip} FUNCTION FINISHED:BOOLEAN; VAR f_sum, f_index : INTEGER; BEGIN f_sum := 0; FOR f_index := 1 to 9 DO f_sum := f_sum + star[f_index]; IF (f_sum = 0) OR ((f_sum = 8) AND (star[5] = 0)) THEN FINISHED := TRUE ELSE FINISHED := FALSE; END; {finished} BEGIN {play} REPEAT GOTOXY(60,0); WRITE('MOVE -> ',move_numb:3); GOTOXY(0,0); WRITE('Enter move -> '); IF move_numb = 35 THEN BEGIN BELL; GOTOXY(0,24); WRITE('Give up ??? Type "Q" instead of box number'); GOTOXY(15,0); END; p_move := REPLY_CHAR; IF p_move IN ['Q','q'] THEN BEGIN CLEAR_SCREEN; EXIT(PROGRAM); END; IF p_move IN ['1'..'9'] THEN BEGIN p_index := ORD(p_move) - ORD('0'); IF star[p_index] = 1 THEN CASE p_index OF 1: BEGIN FLIP(1); FLIP(5); FLIP(4); FLIP(2); END; 2: BEGIN FLIP(2); FLIP(1); FLIP(3); END; 3: BEGIN FLIP(3); FLIP(5); FLIP(2); FLIP(6); END; 4: BEGIN FLIP(4); FLIP(7); FLIP(1); END; 5: BEGIN FLIP(5); FLIP(2); FLIP(6); FLIP(8); FLIP(4); END; 6: BEGIN FLIP(6); FLIP(3); FLIP(9); END; 7: BEGIN FLIP(7); FLIP(5); FLIP(8); FLIP(4); END; 8: BEGIN FLIP(8); FLIP(9); FLIP(7); END; 9: BEGIN FLIP(9); FLIP(5); FLIP(6); FLIP(8); END; END; {case} move_numb := move_numb + 1; END ELSE BEGIN FOR p_index := 1 TO 10 DO BELL; END; UNTIL FINISHED; IF star[1] = 1 {test for win vs loss} THEN BEGIN GOTOXY(0,23); WRITE('You won in -> ',(move_numb - 1):3,' moves. '); BELL; END ELSE BEGIN GOTOXY(0,23); WRITE('You lost in -> ',(move_numb - 1):3,' moves. '); FOR p_index := 1 TO 250 DO BELL; END; END; {play} BEGIN {star game} CLEAR_SCREEN; INITIALIZE; REPEAT GEN_BOARD; PLAY; CLR_LINE_RIGHT(0,24); WRITE('Another game? '); UNTIL NOT(REPLY_CHAR IN ['y','Y']); CLEAR_SCREEN; END. {program} ======================================================================================== DOCUMENT :usus Folder:VOL23:vol23.doc.text ======================================================================================== USUS Volume 23 A Spelling Checker, a IV.x menu driven Filer and some other stuff VOL23: STARGAME.TEXT 28 A simple, but captivating game RNDTEST.TEXT 16 A random number generator and some simple tests RNDDOC.TEXT 14 Documentation for RNDTEST IOUNIT.TEXT 16 A unit to quickly read and write characters and strings IOTEST.TEXT 8 A program to test and benchmark IOUNIT IODOC.TEXT 10 Documentation for IOUNIT and IOTEST SPELLER.TEXT 24 A Pascal spelling checker that uses IOUNIT DICT.TEXT 78 A small literal dictionary for SPELLER SPELLDOC.TEXT 18 Documentation for SPELLER and DICT DF.DOCUM.TEXT 26 The Display Filer Documentation DF.IV.0.TEXT 86 Display Filer for IV.0 DF.IV.1.TEXT 96 Display Filer for IV.1 VOL23.DOC.TEXT 8 You're reading it ----------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 23 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOL24:adv.miscinfo ======================================================================================== 24 80 ======================================================================================== DOCUMENT :usus Folder:VOL24:advx.doc.text ======================================================================================== ADVENTURE The history of this version of Adventure has been lost, and I am unable to credit the originator. This program was converted to UCSD Pascal from a PL/1 version found on our local computer system. This version was obviously converted from a Fortran version (it said so in the comments) but any history was not indicated. If you need assistance with this program, you can write me. My address is: Michael R. Turner 1622 Colonial Way Frederick, Md. 21701 (301)-663-9181 Extended by Ted Beck. The changes to make the 500-point version were converted from a CDC CYBER 74 FORTRAN program written by Tony Jarrett and Paul Zemlin. It in turn was modified from an early DEC PDP-11 FORTRAN version of Adventure. Some bugs fixed by George Schreyer. In particular, the data files ADVXxx.TEXT are VERY sensitive to a blank line at the end of the file. There should NOT be a blank line. Also, the initialization procedure would eat both of my machines alive. It was reading an even number of blocks onto a space on the heap not large enough to hold the data, causing damage to whatever was just above that space, usually the code pool. I padded the data spaces to make room. Also, the entire program was one segment of 10,000+ words. This is too big to run on the LSI-11 extended memory system and probably some others. I segmented the program (in no particularly readonable fashion) to allow the program to run on smaller machines. If you don't like it, just comment out the 'segment's. GETTING STARTED. The steps required to run Adventure are: 1). Compile ADVxINIT. Files needed are: ADVxINIT.TEXT ADVxCONS.TEXT 2). Compile ADVx. Files needed are: ADVx.TEXT ADVxCONS.TEXT ADVxSUBS.TEXT ADVxVERB.TEXT ADVxSEGS.TEXT 3). Run ADVxINIT to build the run-time data files for Adventure. Files needed are: ADVxS1.TEXT ADVxS2.TEXT ADVxS3.TEXT ADVxS4.TEXT ADVxS5.TEXT ADVxS6.TEXT ADVxS7.TEXT ADVxS8.TEXT ADVxS9.TEXT ADVxS10.TEXT ADVxS11.TEXT ADVxINIT.CODE There are two output files produced by ADVxINIT: ADVxMSGS[95] ADVxDATA[24] Insure that there are at least 119 free contiguous blocks on the default disk. ADVxINIT creates the message file completely before opening the data file. That way ADVxINIT will complete execution successfully even if only 119 free blocks are available. 4). Build an ADV.MISCINFO file. This is nothing more than a text file with two numbers in it. The format is HEIGHT WIDTH (e.g. 24 80). If you are an APPLE user using the 24x40 screen, this file is not needed (see Notes, below). 5). The only files needed to run Adventure are: ADVxDATA ADVxMSGS ADVx.CODE ADV.MISCINFO (optional) 6). Be prepared to spend hours exploring the cave. Try not to look at the source or the data files until all of Adventuredom pays tribute to you, O Grand Master Adventurer! Notes: There is a save game feature. Try SAVE. You might like it. The program asks for your name, but any identifier can be used as long as it is valid for a filename. Each save file requires 6 blocks. The system clock is used to initialize the random number generator. If the value returned by the TIME function is zero, then the user is prompted for a number to start the random number generator. The system MISCINFO is not used because the APPLE sets the screen width to 80 on the 40 character screen. Flipping side to side may be OK during editing, but not during Adventure. Also, The program defaults are such that APPLE users do not need an ADV.MISCINFO. ADVx.TEXT has {$S+} to allow it to compile on most machines. ========================================================================= PROGRAM-SECTION. ADVx.TEXT............The Adventure program. ADVxCONS.TEXT........Include file of constants for array dimensions. ADVxSUBS.TEXT........Include file of Adventure subprograms. ADVxVERB.TEXT........Include file of Adventure subprograms. ADVxINIT.TEXT........Initialization program. This program reads ADVxS1 through ADVxS11 and produces ADVxDATA and ADVxMSGS. ========================================================================= DATA-FILES-SECTION. ADVx.MISCINFO........Miscellaneous information for Adventure. ADVxS1.TEXT..........Long form descriptions. Each line contains a location number, a space, and a line of text. The set of adjacent lines whose numbers are X form the long description of location X. ADVxS2.TEXT..........Short form descriptions. Same format as ADVxS1. Not all places have short descriptions. ADVxS3.TEXT..........Travel Table. Each line contains a location number (X), a condition value (M), a second location number (N), and a list of motion numbers from ADVxS4. Each motion represents a verb which will take you to N if you are at X. M and N are interpreted as follows: If N<=300 location to go to. If 300500 Message N-500 is to be issued. Meanwhile, M specifies the condition of motion: If M=0 Unconditional. If 0 0. If 400 1. If 500 2. Etc. If the condition is not met, then the next *DIFFERENT* 'destination' value is used (Unless it fails to meet *IT'S* conditions, in which case the next is found, etc.). Typically, the next destination will be for one of the same verbs, so that its only use is as the alternate destination for those verbs. For instance: 15 110 22 29 31 34 35 23 43 15 0 14 45 says that from location 15, any of the verbs (29, 31, ..., 43) will take you to 22 if you are carrying object 10. Otherwise, they or verb 45 will take you to location 14. And: 11 303 8 49 11 0 9 50 says that from 11, 49 takes him to 8 unless the PROP(3)=0. In that case, 49 takes you to 9. Verb 50 always takes you to 9. ADVxS4.TEXT..........Vocabulary Each line contains a number and a five letter word. Let M=N DIV 1000. If M=0. The word is a motion verb used in ADVxS3. If M=1. The word is an object. If M=2. The word is an action word (e.g. ATTACK). If M=3. Special case word. N MOD 1000 is an index into ADVxS6 messages. ADVxS5.TEXT..........Object descriptions. Each line contains a number and a message. If 1<=N<=100, it is the 'INVENTORY' message for object N. Otherwise N should be 000, 100, 200 etc. and the message is the description of the preceding object when it's property value is N DIV 100. The N DIV 100 is used to distinguish multiple messages from multi-line messages. Properties that produce no message must be given a null message. ADVxS6.TEXT..........Miscellaneous messages. Same format as ADVxS1, ADVxS2 and ADVxS5, except that the numbers are not related to anything. (Except for special verbs in ADVxS4). ADVxS7.TEXT..........Object locations. Each line contains an object number and its initial location (zero if none) and a second location (also zero if none). If the object is immovable, the second location is set to -1. If the object has two locations (e.g. GRATE), the second location field is set to the second location and is assumed to be immovable. ADVxS8.TEXT..........Action defaults. Each line contains an 'ACTION-VERB' number and the index (into ADVxS6) of the default message for the verb. ADVxS9.TEXT..........Liquid Assetts, etc. Each line contains a number (N) and up to 20 location numbers. Bit N (where 0 is the units bit) is set in COND(LOC) for each loc given. The bits currently assigned are: 0 Location is not dark. 1 If bit 2 is on; 1=oil, 0=water. 2 Liquid asset, set bit 1. 3 Pirate doesn't go here unless following player. The other bits are used to indicate areas of interest to the hint routines: 4 Trying to get into the cave. 5 Trying to catch the bird. 6 Trying to deal with the snake. 7 Lost in a maze. 8 Pondering the dark room. 9 At Witt's end. COND(LOC) is set to 2, overriding all other bits, if LOC has forced motion. ADVxS10.TEXT.........Player class messages. Each line contains a number N and a message describing the classification of the player. The scoring section selects the appropriate message. A message applies to a players whose scores are higher than the previous N but not higher than this N. ADVxS11.TEXT.........Hints. Each line contains a hint number corresponding to the COND(LOC) bits (see ADVxS9), the number of turns he must be at the right LOC(s) before triggering the hint, the points deducted for the hint, the message number of the question (from ADVxS6) and the message number of the hint (also from ADVxS6). Hint numbers 1-3 are not usable as the COND(LOC) bits 1-3 are otherwise assigned. ADVxDATA and ADVxMSGS.....Run-time data files. These files are produced by ADVxINIT from ADVxS1..ADVxS11. They must be on the default disk in order to run the Adventure program. ========================================================================= ======================================================================================== DOCUMENT :usus Folder:VOL24:advx.text ======================================================================================== {$S+} PROGRAM ADVENTURE; CONST {$I advxcons.text } VERSION = 500; KEYS = 1; LAMP = 2; GRATE = 3; CAGE = 4; ROD = 5; ROD2 = 6; STEPS = 7; BIRD = 8; DOOR = 9; PILLOW = 10; SNAKE = 11; FISSURE = 12; TABLET = 13; CLAM = 14; OYSTER = 15; MAGAZINE = 16; DWARF = 17; KNIFE = 18; FOOD = 19; BOTTLE = 20; WATER = 21; OIL = 22; MIRROR = 23; PLANT = 24; PLANT2 = 25; AXE = 28; DRAGON = 31; CHASM = 32; TROLL = 33; TROLL2 = 34; BEAR = 35; MESSAGE = 36; VEND_MACHINE = 38; BATTERY = 39; wizard = 41; door2 = 42; ball = 43; NUGGET = 50; COINS = 54; CHEST = 55; EGGS = 56; TRIDENT = 57; VASE = 58; EMERALD = 59; PYRAMID = 60; PEARL = 61; RUG = 62; SPICES = 63; CHAIN = 64; jade = 68; scroll = 70; BACK = 8; NULL = 21; LOOK = 57; DEPRESSION = 63; ENTRANCE = 64; CAVE = 67; SAY = 3; LOCK = 6; THROW = 17; FIND = 19; INVENTORY = 20; MAXTRS = 73; MAXDIE = 3; MAXHLD = 6; DALTLC = 18; TYPE CH512 = PACKED ARRAY[1..512] OF CHAR; CHAR6 = PACKED ARRAY[1..6] OF CHAR; ARYS = RECORD CASE BOOLEAN OF FALSE : (DBLK : CH512); TRUE : (TRAVEL : ARRAY[1..trvsiz] OF INTEGER; TRAVEL2 : ARRAY[1..trvsiz] OF INTEGER; TRAVEL3 : ARRAY[1..trvsiz] OF INTEGER; ATAB : ARRAY[1..tabsiz] OF STRING[5]; KTAB : ARRAY[1..tabsiz] OF INTEGER; LTEXT : ARRAY[1..locsiz] OF INTEGER; STEXT : ARRAY[1..locsiz] OF INTEGER; KEY : ARRAY[1..locsiz] OF INTEGER; PLAC : ARRAY[1..100] OF INTEGER; FIXD : ARRAY[1..100] OF INTEGER; PTEXT : ARRAY[1..100] OF INTEGER; ACTSPK : ARRAY[1..vrbsiz] OF INTEGER; RTEXT : ARRAY[1..rtxsiz] OF INTEGER; CTEXT : ARRAY[1..clsmax] OF INTEGER; CVAL : ARRAY[1..clsmax] OF INTEGER; HINTS : ARRAY[1..hntmax, 1..4] OF INTEGER; pad : packed array [ 1..70 ] of char) {round out 19 blocks - gws } END; VARYS = RECORD CASE BOOLEAN OF FALSE : (DBLK : CH512); TRUE : (COND : ARRAY[1..locsiz] OF INTEGER; ABB : ARRAY[1..locsiz] OF INTEGER; ATLOC : ARRAY[1..locsiz] OF INTEGER; PLACE : ARRAY[1..100] OF INTEGER; FIXED : ARRAY[1..100] OF INTEGER; LINK : ARRAY[1..200] OF INTEGER; PROP : ARRAY[1..100] OF INTEGER; HINTLC : ARRAY[1..hntmax] OF INTEGER; HINTED : ARRAY[1..hntmax] OF BOOLEAN; DSEEN : ARRAY[1..6] OF BOOLEAN; DLOC : ARRAY[1..6] OF INTEGER; ODLOC : ARRAY[1..6] OF INTEGER; TK : ARRAY[1..20] OF INTEGER; PADDER : PACKED ARRAY [ 1..444 ] OF CHAR) {round out 5 blocks - gws} END; VBLS = RECORD CASE BOOLEAN OF FALSE : (DBLK : CH512); TRUE : (HLDING, LOC, OLDLOC : INTEGER; OLDLC2, CLOCK1, CLOCK2 : INTEGER; CHLOC,CHLOC2, TALLY, TALLY2 : INTEGER; DFLAG, DTOTAL, FOOBAR, TURNS : INTEGER; VERB, OBJ, LIMIT, IWEST, KNFLOC : INTEGER; ABBNUM, DKILL, NUMDIE, DETAIL : INTEGER; PANIC, CLOSING, CLOSED, WZDARK : BOOLEAN; wizflg, stflag, VERSION : INTEGER; PASSWORD : STRING[20]) END; VAR NEWLOC, RESTART, I, J, K, KK, K2 : INTEGER; MAXSCORE, TVCOND, ATTACK, STICK : INTEGER; FOO, SCORE, HINT, SPK : INTEGER; wizbo, BONUS, SEED : INTEGER; RESUME, OK, SKIPIT, STEAL : BOOLEAN; GAVEUP, YEA, SKIPDWARF, ALLDONE, HE_DIED, PIT : BOOLEAN; NEWLOCSET, LMWARN, SKIPDESCRIBE : BOOLEAN; HNTSIZ, CLSSES : INTEGER; ARY : ^ARYS; VARY : ^VARYS; VBL : ^VBLS; LINE, TERMWIDTH, TERMHIGHT : INTEGER; KKWORD, WD1, WD2 : STRING[5]; WD1X, WD2X : STRING; ACHAR : STRING[1]; TESTPW : STRING[20]; NAMEOFUSER : STRING[40]; INFILE : FILE; MSGFILE : FILE OF CHAR6; PROCEDURE READINIT(VAR BFR : CH512; NUM : INTEGER); forward; segment PROCEDURE INITIALIZE; VAR I, J, K, X : INTEGER; ININFO : TEXT; PROCEDURE INITP2; VAR I, J : INTEGER; BEGIN { INITP2 } TIME(I, J); IF J = 0 THEN J := I; WHILE J = 0 DO BEGIN WRITELN('No clock.'); WRITELN('Please enter a number from 1 to 32767 '); READ(J); WRITELN END; IF (J MOD 2) = 0 THEN J := J + 1; SEED := J; LINE := 1; VARY^.DLOC[1] := 19; VARY^.DLOC[2] := 27; VARY^.DLOC[3] := 33; VARY^.DLOC[4] := 44; VARY^.DLOC[5] := 64; VARY^.DLOC[6] := 114; vbl^.wizflg := 0; vbl^.stflag := 0; VBL^.CHLOC := 86; VBL^.CHLOC2 := 140; VBL^.ABBNUM := 5; BONUS := 0; VBL^.OLDLOC := 0; VBL^.OLDLC2 := 0; RESTART := 0; KK := 0; VBL^.TALLY := 0; VBL^.TALLY2 := 0; TVCOND := 0; VBL^.DKILL := 0; VBL^.DFLAG := 0; VBL^.DTOTAL := 0; ATTACK := 0; STICK := 0; VBL^.KNFLOC := 0; MAXSCORE := 0; VBL^.FOOBAR := 0; VBL^.TURNS := 0; VBL^.VERB := 0; VBL^.OBJ := 0; VBL^.IWEST := 0; FOO := 0; VBL^.NUMDIE := 0; SCORE := 0; VBL^.DETAIL := 0; VBL^.HLDING := 0; SPK := 0; OK := FALSE; SKIPIT := FALSE; STEAL := FALSE; VBL^.PANIC := FALSE; VBL^.CLOSING := FALSE; VBL^.CLOSED := FALSE; VBL^.WZDARK := FALSE; GAVEUP := FALSE; SKIPDWARF := FALSE; ALLDONE := FALSE; LMWARN := FALSE; SKIPDESCRIBE := FALSE; ALLDONE := FALSE; HE_DIED := FALSE; PIT := FALSE; NEWLOCSET := FALSE; KKWORD := ''; WD1 := ''; WD2 := ''; WD1X := ''; WD2X := ''; ACHAR := ' ' END; { INITP2 } BEGIN { INITIALIZE } { READ IN ARRAYS } {$I-} RESET(ININFO, 'ADV.MISCINFO'); {$I+} IF IORESULT = 0 THEN BEGIN READ(ININFO, TERMHIGHT, TERMWIDTH); CLOSE(ININFO) END ELSE BEGIN TERMHIGHT := 24; { DEFAULT FOR APPLE } TERMWIDTH := 40 END; RESET(INFILE, 'ADVxDATA'); RESET(MSGFILE, 'ADVxMSGS'); NEW(ARY); READINIT(ARY^.DBLK, SIZEOF(ARYS)); NEW(VARY); READINIT(VARY^.DBLK, SIZEOF(VARYS)); CLOSE(INFILE); NEW(VBL); INITP2; CLSSES := 0; FOR I := 1 TO clsmax DO IF ARY^.CTEXT[I] <> 0 THEN CLSSES := I; FOR I := 4 TO hntmax DO IF ARY^.HINTS[I, 1] <> 0 THEN HNTSIZ := I; FOR X := 50 TO 100 DO IF ARY^.PTEXT[X] <> 0 THEN VBL^.TALLY := VBL^.TALLY - VARY^.PROP[X]; FOR I := 1 TO tabsiz DO IF ARY^.ATAB[I] = '' THEN BEGIN ARY^.ATAB[I] := ' '; ARY^.ATAB[I, 1] := CHR(255); ARY^.ATAB[I, 2] := CHR(I DIV 256); ARY^.ATAB[I, 3] := CHR(I MOD 256) END END; { INITIALIZE } {$I ADVXSEGS .TEXT } SEGMENT PROCEDURE DOWHATHESAYS; {$I ADVxVERB.TEXT } PROCEDURE ANALANOBJ; PROCEDURE ASKWHATTODO; BEGIN IF WD2 <> '' THEN BEGIN RESTART := 1; EXIT(ANALANOBJ) END; IF VBL^.VERB <> 0 THEN BEGIN ANALATVERB; EXIT(ANALANOBJ) END; WRITELN('What do you want to do with the ', WD1, WD1X, '.'); RESTART := 1; EXIT(DOWHATHESAYS) END; { ASKWHATTODO } BEGIN { ANALANOBJ } VBL^.OBJ := K; IF (VARY^.FIXED[K] = VBL^.LOC) OR HERE(K) THEN ASKWHATTODO; IF K = GRATE THEN BEGIN IF (VBL^.LOC = 1) OR (VBL^.LOC = 4) OR (VBL^.LOC = 7) THEN K := DEPRESSION; IF (VBL^.LOC > 9) AND (VBL^.LOC < 15) THEN K := ENTRANCE; IF K <> GRATE THEN BEGIN SET_NEW_LOC; EXIT(ANALANOBJ) END END; IF K = DWARF THEN FOR I := 1 TO 5 DO IF (VARY^.DLOC[I] = VBL^.LOC) AND (VBL^.DFLAG >= 2) THEN ASKWHATTODO; IF ((LIQ = K) AND HERE(BOTTLE)) OR (K = LIQLOC(VBL^.LOC)) THEN ASKWHATTODO; IF (VBL^.OBJ = PLANT) AND AT(PLANT2) AND (VARY^.PROP[PLANT2] = 0) THEN BEGIN VBL^.OBJ := PLANT2; ASKWHATTODO END; if ( vbl^.obj = door ) and at ( door2 ) then begin vbl^.obj := door2; askwhattodo; end; IF (VBL^.OBJ = KNIFE) AND (VBL^.KNFLOC = VBL^.LOC) THEN BEGIN VBL^.KNFLOC := -1; SPEAK(ARY^.RTEXT[116]) END ELSE IF (VBL^.OBJ = ROD) AND HERE(ROD2) THEN BEGIN VBL^.OBJ := ROD2; ASKWHATTODO END ELSE IF ((VBL^.VERB = FIND) OR (VBL^.VERB = INVENTORY)) AND (WD2 = '') THEN ASKWHATTODO ELSE WRITELN('I see no ', WD1, WD1X, ' here.'); SKIPDWARF := TRUE; SKIPDESCRIBE := TRUE; EXIT(DOWHATHESAYS) END; { ANALANOBJ } PROCEDURE ANALAVERB; BEGIN VBL^.VERB := K; SPK := ARY^.ACTSPK[VBL^.VERB]; IF (WD2 <> '') AND (VBL^.VERB <> SAY) THEN BEGIN RESTART := 1; EXIT(ANALAVERB) END; IF VBL^.VERB = SAY THEN IF WD2 = '' THEN ANALANITVERB ELSE ANALATVERB ELSE IF VBL^.OBJ = 0 THEN ANALANITVERB ELSE ANALATVERB END; { ANALAVERB } PROCEDURE CLOSE1; BEGIN VARY^.PROP[GRATE] := 0; VARY^.PROP[FISSURE] := 0; FOR I := 1 TO 6 DO VARY^.DSEEN[I] := FALSE; MOVE(TROLL,0); MOVE(TROLL + 100, 0); MOVE(TROLL2, ARY^.PLAC[TROLL]); MOVE(TROLL2 + 100, VARY^.FIXED[TROLL]); JUGGLE(CHASM); IF VARY^.PROP[BEAR] <> 3 THEN DESTROY(BEAR); VARY^.PROP[CHAIN] := 0; VARY^.FIXED[CHAIN] := 0; VARY^.PROP[AXE] := 0; VARY^.FIXED[AXE] := 0; SPEAK(ARY^.RTEXT[129]); VBL^.CLOCK1 := -1; VBL^.CLOSING := TRUE END; { CLOSE1 } PROCEDURE CLOSE2; BEGIN VARY^.PROP[BOTTLE] := PUT(BOTTLE, 115, 1); VARY^.PROP[PLANT] := PUT(PLANT, 115, 0); VARY^.PROP[OYSTER] := PUT(OYSTER, 115, 0); VARY^.PROP[LAMP] := PUT(LAMP, 115, 0); VARY^.PROP[ROD] := PUT(ROD, 115, 0); VARY^.PROP[DWARF] := PUT(DWARF, 115, 0); VBL^.LOC := 115; VBL^.OLDLOC := 115; NEWLOC := 115; FOO := PUT(GRATE, 116, 0); VARY^.PROP[SNAKE] := PUT(SNAKE, 116, 1); VARY^.PROP[BIRD] := PUT(BIRD, 116, 1); VARY^.PROP[CAGE] := PUT(CAGE, 116, 0); VARY^.PROP[ROD2] := PUT(ROD2, 116, 0); VARY^.PROP[PILLOW] := PUT(PILLOW, 116, 0); VARY^.PROP[MIRROR] := PUT(MIRROR, 115, 0); VARY^.FIXED[MIRROR] := 116; FOR I := 1 TO 100 DO IF TOTING(I) THEN DESTROY(I); SPEAK(ARY^.RTEXT[132]); VBL^.CLOSED := TRUE; EXIT(DOWHATHESAYS) END; { CLOSE2 } BEGIN { DOWHATHESAYS } IF VBL^.FOOBAR > 0 THEN VBL^.FOOBAR := -VBL^.FOOBAR ELSE VBL^.FOOBAR := 0; VBL^.TURNS := VBL^.TURNS + 1; if wd1 = 'DESCR' then begin speak(ary^.ltext[vbl^.loc]); restart := 1; exit(dowhathesays) end; K := SAY; IF (VBL^.VERB = SAY) AND (WD2 <> '') THEN VBL^.VERB := 0; IF VBL^.VERB <> SAY THEN BEGIN IF (VBL^.TALLY = 0) AND (VBL^.LOC >= 15) AND (VBL^.LOC <> 33) and (vbl^.loc <= 140 ) THEN VBL^.CLOCK1 := VBL^.CLOCK1 - 1; IF VBL^.CLOCK1 = 0 THEN CLOSE1 ELSE IF VBL^.CLOCK1 < 0 THEN VBL^.CLOCK2 := VBL^.CLOCK2 - 1; IF VBL^.CLOCK2 = 0 THEN CLOSE2 ELSE BEGIN IF VARY^.PROP[LAMP] = 1 THEN VBL^.LIMIT := VBL^.LIMIT - 1; IF (VBL^.LIMIT <= 30) AND HERE(BATTERY) AND (VARY^.PROP[BATTERY] = 0) AND HERE(LAMP) THEN BEGIN SPEAK(ARY^.RTEXT[188]); VARY^.PROP[BATTERY] := 1; IF TOTING(BATTERY) THEN DROP(BATTERY, VBL^.LOC); VBL^.LIMIT := VBL^.LIMIT + 2500; LMWARN := FALSE END ELSE IF VBL^.LIMIT = 0 THEN BEGIN VBL^.LIMIT := -1; VARY^.PROP[LAMP] := 0; IF HERE(LAMP) THEN SPEAK(ARY^.RTEXT[184]) END ELSE IF (VBL^.LIMIT < 0) AND (VBL^.LOC <= 8) THEN BEGIN SPEAK(ARY^.RTEXT[185]); ALLDONE := TRUE; GAVEUP := TRUE; EXIT(DOWHATHESAYS) END ELSE IF VBL^.LIMIT <= 30 THEN BEGIN IF NOT LMWARN AND HERE(LAMP) THEN BEGIN LMWARN := TRUE; SPK := 187; IF VARY^.PLACE[BATTERY] = 0 THEN SPK := 183; IF VARY^.PROP[BATTERY] = 1 THEN SPK := 189; SPEAK(ARY^.RTEXT[SPK]) END END; K := 43; { WHERE? } IF LIQLOC(VBL^.LOC) = WATER THEN K := 70; IF (WD1 = 'ENTER') AND ((WD2 = 'STREA') OR (WD2 = 'WATER')) THEN BEGIN SPEAK(ARY^.RTEXT[K]); SKIPDWARF := TRUE; SKIPDESCRIBE := TRUE END ELSE REPEAT RESTART := 0; IF (WD1 = 'ENTER') AND (WD2 <> '') THEN BEGIN WD1 := WD2; WD1X := WD2X; if (wd1 = 'DOOR') and at(door2) then wd1 := 'DOOR2'; WD2 := '' END ELSE BEGIN IF ((WD1 = 'WATER') OR (WD1 = 'OIL')) AND ((WD2 = 'PLANT') OR (WD2 = 'DOOR')) THEN IF AT(VOCAB(WD2,1)) THEN WD2 := 'POUR' END; IF WD1 = 'WEST' THEN BEGIN VBL^.IWEST := VBL^.IWEST + 1; IF VBL^.IWEST = 10 THEN SPEAK(ARY^.RTEXT[17]) END; I := VOCAB(WD1, -1); IF I = -1 THEN BEGIN SPK := 60; IF PERCENT(20) THEN SPK := 61; IF PERCENT(20) THEN SPK := 13; SPEAK(ARY^.RTEXT[SPK]); RESTART := 1; EXIT(DOWHATHESAYS) END ELSE BEGIN K := I MOD 1000; CASE (I DIV 1000) OF 0 : SET_NEW_LOC; 1 : ANALANOBJ; 2 : ANALAVERB; 3 : BEGIN SKIPDWARF := TRUE; SKIPDESCRIBE := TRUE; IF K <> 0 THEN SPEAK(ARY^.RTEXT[K]) END END; IF RESTART <> 0 THEN BEGIN WD1 := WD2; WD1X := WD2X; WD2 := '' END END UNTIL RESTART = 0 { SHORT RESTART } END END END; { DOWHATHESAYS } (*$I ADVXSUBS.TEXT *) PROCEDURE REINCARNATION; BEGIN IF HE_DIED THEN BEGIN IF PIT THEN BEGIN SPEAK(ARY^.RTEXT[23]); VBL^.OLDLC2 := VBL^.LOC END; IF VBL^.CLOSING THEN BEGIN SPEAK(ARY^.RTEXT[131]); VBL^.NUMDIE := VBL^.NUMDIE + 1 END ELSE BEGIN YEA := YES(81 + (VBL^.NUMDIE * 2), 82 + (VBL^.NUMDIE * 2), 54); VBL^.NUMDIE := VBL^.NUMDIE + 1; IF (VBL^.NUMDIE <> MAXDIE) AND YEA THEN BEGIN HE_DIED := FALSE; { SAVED! } SKIPDWARF := TRUE; VARY^.PLACE[WATER] := 0; VARY^.PLACE[OIL] := 0; IF TOTING(LAMP) THEN VARY^.PROP[LAMP] := 0; FOR J := 100 DOWNTO 1 DO IF TOTING(J) THEN BEGIN K := VBL^.OLDLC2; IF J = LAMP THEN K := 1; DROP(J, K) END; VBL^.LOC := 3; VBL^.OLDLOC := VBL^.LOC END END END END; { REINCARNATION } PROCEDURE ENDGAME; BEGIN SCORE := GETSCORE(FALSE); WRITELN; WRITE('You scored ', SCORE, ' out of a possible ', MAXSCORE); IF TERMWIDTH < 64 THEN WRITELN; IF VBL^.TURNS = 1 THEN KKWORD := '.' ELSE KKWORD := 's.'; WRITELN(' using ', VBL^.TURNS, ' turn', KKWORD); FOR I := 1 TO CLSSES DO IF ARY^.CVAL[I] >= SCORE THEN BEGIN SPEAK(ARY^.CTEXT[I]); IF I = CLSSES THEN BEGIN WRITE('To achieve the next higher rating would '); IF TERMWIDTH < 64 THEN WRITELN; WRITELN('be a neat trick!'); WRITELN; WRITELN('Congratulations.') END ELSE BEGIN K := ARY^.CVAL[I] + 1 - SCORE; KKWORD := 's.'; IF K = 1 THEN KKWORD := '.'; WRITE('To achieve the next higher rating, you need '); IF TERMWIDTH < 64 THEN WRITELN; WRITELN(K, ' more point', KKWORD) END; I := CLSSES { EXIT THIS MESS } END END; { ENDGAME } PROCEDURE READINIT{VAR BFR : CH512; NUM : INTEGER}; BEGIN NUM := (NUM + 511) DIV 512; IF NUM <> BLOCKREAD(INFILE, BFR, NUM) THEN BEGIN WRITE('Error reading array file.'); EXIT(ADVENTURE) END END; { READINIT } PROCEDURE GETNEWCOMMAND; VAR W1FLAG, DONE : BOOLEAN; INLINE : STRING; BEGIN { GETNEWCOMMAND } IF VBL^.CLOSED THEN BEGIN IF (VARY^.PROP[OYSTER] < 0) AND TOTING(OYSTER) THEN PSPEAK(OYSTER, 1); FOR I := 1 TO 100 DO IF TOTING(I) AND (VARY^.PROP[I] < 0) THEN VARY^.PROP[I] := -1 - VARY^.PROP[I] END; LINE := 1; WD1 := ''; WD2 := ''; WD1X := ''; WD2X := ''; VBL^.WZDARK := DARK; IF (VBL^.KNFLOC > 0) AND (VBL^.KNFLOC <> VBL^.LOC) THEN VBL^.KNFLOC := 0; I := RAN(1); REPEAT repeat READLN(INLINE); until length ( inline ) > 0; {no null strings - gws} INLINE := CONCAT(INLINE, ' : '); WHILE INLINE[1] = ' ' DO DELETE(INLINE, 1, 1) UNTIL INLINE <> ' : '; W1FLAG := FALSE; DONE := FALSE; REPEAT ACHAR := COPY(INLINE, 1, 1); if achar[1] in ['a'..'z'] then achar[1] := chr(ord(achar[1]) - 32); DELETE(INLINE, 1, 1); IF ACHAR = ' ' THEN BEGIN DONE := W1FLAG; W1FLAG := TRUE END ELSE IF W1FLAG THEN IF LENGTH(WD2) = 5 THEN WD2X := CONCAT(WD2X, ACHAR) ELSE WD2 := CONCAT(WD2, ACHAR) ELSE IF LENGTH(WD1) = 5 THEN WD1X := CONCAT(WD1X, ACHAR) ELSE WD1 := CONCAT(WD1, ACHAR) UNTIL DONE END; { GETNEWCOMMAND } BEGIN { ADVENTURE } INITIALIZE; VARY^.HINTED[3] := YES(65, 1, 0); IF VARY^.HINTED[3] THEN RESUME := FALSE ELSE RESUME := YES(201, 0, 0); IF RESUME THEN BEGIN NAMEANDPW; {$I-} RESET(INFILE, NAMEOFUSER); {$I+} IF IORESULT <> 0 THEN BEGIN WRITELN('Sorry, you do not have a saved game.'); RESUME := FALSE END ELSE BEGIN READINIT(VARY^.DBLK, SIZEOF(VARYS)); READINIT(VBL^.DBLK, SIZEOF(VBLS)); CLOSE(INFILE); IF TESTPW <> VBL^.PASSWORD THEN BEGIN WRITE('Incorrect password.'); EXIT(ADVENTURE) END; IF VERSION <> VBL^.VERSION THEN BEGIN IF VERSION > VBL^.VERSION THEN WRITE('Old save file - new') ELSE WRITE('New save file - old'); WRITE(' Adventure. Sorry.'); EXIT(ADVENTURE) END END; VBL^.LIMIT := MAX(VBL^.LIMIT, 150); { GIVE HIM SOME TIME } END; IF NOT RESUME THEN BEGIN VBL^.LOC := 1; VBL^.CLOCK1 := 30; VBL^.CLOCK2 := 25; IF VARY^.HINTED[3] THEN VBL^.LIMIT := 1000 ELSE VBL^.LIMIT := 330 END; NEWLOC := VBL^.LOC; REPEAT REPEAT IF SKIPDWARF THEN SKIPDWARF := FALSE ELSE BEGIN TESTCLOSE; VBL^.LOC := NEWLOC; if (vbl^.loc = 149) and (vary^.prop[wizard] <> 1) then begin wizbo := ran(100); if wizbo <= 76 then begin speak(ary^.rtext[211]); if (wizbo >= 50) and (vbl^.wizflg <> 0) then begin speak(ary^.rtext[53]); vbl^.oldlc2 := vbl^.loc; he_died := true end else begin speak(ary^.rtext[52]); vbl^.wizflg := 1 end end end; IF not he_died and (VBL^.LOC <> 0) THEN IF NOT FORCED(VBL^.LOC) AND NOT BITSET(NEWLOC, 3) THEN IF VBL^.DFLAG = 0 THEN IF VBL^.LOC >= 15 THEN VBL^.DFLAG := 1 ELSE ELSE DWARFSTUFF END; NEWLOCSET := FALSE; IF NOT HE_DIED THEN BEGIN IF SKIPDESCRIBE THEN SKIPDESCRIBE := FALSE ELSE BEGIN WRITELN; DESCRIBE_CURRENT_LOCATION END; IF NOT HE_DIED AND NOT NEWLOCSET THEN BEGIN VBL^.VERB := 0; VBL^.OBJ := 0; RESTART := 0; REPEAT IF RESTART <> 2 THEN BEGIN CHECKHINTS; GETNEWCOMMAND END; RESTART := 0; DOWHATHESAYS UNTIL RESTART = 0; { LONG RESTART } END END UNTIL HE_DIED OR ALLDONE; { MAIN LOOP } REINCARNATION UNTIL HE_DIED OR ALLDONE; { NO MORE RE-INCARNATIONS } ENDGAME END. ======================================================================================== DOCUMENT :usus Folder:VOL24:advx1.text ======================================================================================== 1 You are standing at the end of a road before a small brick building. 1 Around you is a forest. A small stream flows out of the building and 1 down a gully. 2 You have walked up a hill, still in the forest. The road slopes back down 2 the other side of the hill. There is a building in the distance. 3 You are inside a building, a well house for a large spring. 4 You are in a valley in the forest beside a stream tumbling along a rocky 4 bed. 5 You are in open forest, with a deep valley to one side. 6 You are in open forest near both a valley and a road. 7 At your feet all the water of the stream splashes into a 2-inch slit in the 7 rock. Downstream the streambed is bare rock. 8 You are in a 20-foot depression floored with bare dirt. Set into the dirt 8 is a strong steel grate mounted in concrete. A dry streambed leads into 8 the depression. 9 You are in a small chamber beneath a 3x3 steel grate leading to the 9 surface. A low crawl over cobbles leads inward to the west. 10 You are crawling over cobbles in a low passage. There is a dim light at 10 the east end of the passage. 11 You are in a debris room filled with stuff washed in from the surface. A 11 low wide passage with cobbles becomes plugged with mud and debris here, 11 but an awkward canyon leads upward and to the west. A note on the wall 11 says: 'Magic word XYZZY'. 12 You are in an awkward sloping east/west canyon. 13 You are in a splendid chamber thirty feet high. The walls are frozen 13 rivers of orange stone. An awkward canyon and a good passage exit from 13 the east and west sides of the chamber. 14 At your feet is a small pit breathing traces of white mist. An east 14 passage ends here except for a small crack leading on. 15 You are at one end of a vast hall stretching forward out of sight to the 15 west. There are openings to either side. Nearby, a wide stone staircase 15 leads downward. The hall is filled with wisps of white mist swaying to 15 and fro almost as if alive. A cold wind blows up the staircase. There is 15 a passage at the top of a dome behind you. 16 The crack is far too small for you to follow. 17 You are on the east bank of a fissure slicing clear across the hall. The 17 mist is quite thick here, and the fissure is too wide to jump. 18 This is a low room with a crude note on the wall. The note says: 'You 18 won't get it up the steps'. 19 You are in the hall of the mountain king, with passages off in all 19 directions. 20 You are at the bottom of the pit with a broken neck. 21 You didn't make it. 22 The dome is unclimbable. 23 You are at the west end of the twopit room. There is a large hole in the 23 wall above the pit at this end of the room. 24 You are at the bottom of the eastern pit in the twopit room. There is a 24 small pool of oil in one corner of the pit. 25 You are at the bottom of the western pit in the twopit room. There is a 25 large hole in the wall about 25 feet above you. 26 You clamber up the plant and scurry through the hole at the top. 27 You are on the west side of the fissure in the hall of mists. 28 You are in a low north/south passage at a hole in the floor. The hole goes 28 down to an east/west passage. 29 You are in the south side chamber. 30 You are in the west side chamber of the hall of the mountain king. A 30 passage continues west and up here. 31 32 You can't get by the snake. 33 You are in a large room, with a passage to the south, a passage to the 33 west, and a wall of broken rock to the east. There is a large 'Y2' on a 33 rock in the room's center. 34 You are in a jumble of rock, with cracks everywhere. 35 You're at a low window overlooking a huge pit, which extends up out of 35 sight. A floor is indistinctly visible over 50 feet below. Traces of 35 white mist cover the floor of the pit, becoming thicker to the right. 35 Marks in the dust around the window would seem to indicate that someone 35 has been here recently. Directly across the pit from you and 25 feet away 35 there is a similar window looking into a lighted room. A shadowy figure 35 can be seen there peering back at you. 36 You are in a dirty broken passage. To the east is a crawl. To the west is 36 a large passage. Above you is a hole to another passage. 37 You are on the brink of a small clean climbable pit. A crawl leads west. 38 You are in the bottom of a small pit with a little stream, which enters and 38 exits through tiny slits. 39 You are in a large room full of dusty rocks. There is a big hole in the 39 floor. There are cracks everywhere, and a passage leading east. 40 You have crawled through a very low wide passage parallel to and north of 40 the hall of mists. 41 You are at the west end of hall of mists. A low wide crawl continues west 41 and another goes north. To the south is a little passage 6 feet off the 41 floor. 42 You are in a maze of twisty little passages, all alike. 43 You are in a maze of twisty little passages, all alike. 44 You are in a maze of twisty little passages, all alike. 45 You are in a maze of twisty little passages, all alike. 46 Dead end. 47 Dead end. 48 Dead end. 49 You are in a maze of twisty little passages, all alike. 50 You are in a maze of twisty little passages, all alike. 51 You are in a maze of twisty little passages, all alike. 52 You are in a maze of twisty little passages, all alike. 53 You are in a maze of twisty little passages, all alike. 54 Dead end. 55 You are in a maze of twisty little passages, all alike. 56 Dead end. 57 You are on the brink of a thirty foot pit with a massive orange column down 57 one wall. You could climb down here but you could not get back up. The 57 maze continues at this level. 58 Dead end. 59 You have crawled through a very low wide passage parallel to and north of 59 the hall of mists. 60 You are at the east end of a very long hall apparently without side 60 chambers. To the east a low wide crawl slants up. To the north a round 60 two foot hole slants down. 61 You are at the west end of a very long featureless hall. The hall joins up 61 with a narrow north/south passage. 62 You are at a crossover of a high north/south passage and a low east/west 62 one. 63 Dead end. 64 You are at a complex junction. A low hands and knees passage from the 64 north joins a higher crawl from the east to make a walking passage going 64 west. There is also a large room above. The air is damp here. 65 You are in bedquilt, a long east/west passage with holes everywhere. To 65 explore at random select NORTH, SOUTH, UP, or DOWN. 66 You are in a room whose walls resemble swiss cheese. Obvious passages go 66 west, east, northeast, and northwest. Part of the room is occupied by a 66 large bedrock block. 67 You are at the east end of the twopit room. The floor here is littered 67 with thin rock slabs, which make it easy to descend the pits. There is a 67 path here bypassing the pits to connect passages from east and west. 67 There are holes all over, but the only big one is on the wall directly 67 over the west pit where you can't get to it. 68 You are in a large low circular chamber whose floor is an immense slab 68 fallen from the ceiling (slab room). East and west there once were large 68 passages, but they are now filled with boulders. Low small passages go 68 north and south, and the south one quickly bends west around the boulders. 69 You are in a secret north/south canyon above a large room. 70 You are in a secret north/south canyon above a sizable passage. 71 You are in a secret canyon at a junction of three canyons, bearing north, 71 south, and southeast. The north one is as tall as the other two combined. 72 You are in a large low room. Crawls lead north, southeast, and southwest. 73 You are in the Egyptian room. Your lamp reveals ancient hieroglyphics 73 carved into the stone walls. A passage once went east but is now filled 73 with massive marble blocks. There is a crawl to the south and a larger 73 passage to the west. 74 You are in a secret canyon which here runs east/west. It crosses over a 74 very tight canyon 15 feet below. If you go down you may not be able to 74 get back up. 75 You are at a wide place in a very tight north/south canyon. 76 The canyon here becomes too tight to go further south. 77 You are in a tall east/west canyon. A low tight crawl goes three feet 77 north and seems to open up. 78 The canyon runs west into a massive iron door set in granite. A path 78 continues to the south. 79 The stream flows out through a pair of 1 foot diameter sewer pipes. It 79 would be advisable to use the exit. 80 You are in a maze of twisty little passages, all alike. 81 Dead end. 82 Dead end. 83 You are in a maze of twisty little passages, all alike. 84 You are in a maze of twisty little passages, all alike. 85 Dead end. 86 Dead end. 87 You are in a maze of twisty little passages, all alike. 88 You are in a long, narrow corridor stretching out of sight to the west. At 88 the eastern end is a hole through which you can see a profusion of leaves. 89 There is nothing here to climb. Use 'UP' or 'OUT' to leave the pit. 90 You have climbed up the plant and out of the pit. 91 You are at the top of a steep incline above a large room. You could climb 91 down here, but you would not be able to climb back up. There is a passage 91 leading back to the north. 92 You are in the giant room. The ceiling here is too high up for your lamp 92 to show it. Cavernous passages lead east, north, and south. On the west 92 wall is scrawled the inscription: 'FEE FIE FOE FOO' [sic]. 93 The passage here is blocked by a recent cave-in. 94 You are at one end of an immense north/south passage. 95 You are in a magnificent cavern with a rushing stream, which cascades over 95 a sparkling waterfall into a roaring whirlpool which disappears through 95 some stairs in the floor. Passages exit to the south and west. 96 You are in the soft room. The walls are covered with heavy curtains, the 96 floor with a thick pile carpet. Moss covers the ceiling. 97 This is the oriental room. Ancient oriental cave drawings cover the walls. 97 A gently sloping passage leads upward to the north, another passage leads 97 southeast, and a hands and knees crawl leads west. 98 You are following a wide path around the outer edge of a large cavern. Far 98 below, through a heavy white mist, strange splashing noises can be heard. 98 The mist rises up through a fissure in the ceiling. The path exits to 98 the south and west. 99 You are in an alcove. A small northwest path seems to widen after a short 99 distance. An extremely tight tunnel leads east. It looks like a very 99 tight squeeze. An eerie light can be seen at the other end. 100 You're in a small chamber lit by an eerie green light. An extremely narrow 100 tunnel exits to the west. A dark corridor leads northeast. 101 You're in the dark-room. There is a corridor exiting to the south and a 101 similar one leading east. 102 You are in an arched hall. A coral passage once continued up and east from 102 here, but is now blocked by debris. The air smells of sea water. 103 You're in a large room carved out of sedimentary rock. The floor and walls 103 are littered with bits of shells imbedded in the stone. A shallow passage 103 proceeds downward, and a somewhat steeper one leads up. A low hands and 103 knees passage enters from the south. 104 You are in a long sloping corridor with ragged sharp walls. 105 You are in a cul-de-sac about eight feet across. 106 You are in an anteroom leading to a large passage to the east. Small 106 passages go west and up. The remnants of recent digging are evident. A 106 sign in midair here says: 'Cave under construction beyond this point. 106 Proceed at your own risk. [Witt Construction Company]'. 107 You are in a maze of twisty little passages, all different. 108 You are at Witt's end. Passages lead off in *all* directions. 109 You are in a north/south canyon about 25 feet across. The floor is covered 109 by white mist seeping in from the north. The walls extend upward for well 109 over 100 feet. Suspended from some unseen point far above you, an 109 enormous two-sided mirror is hanging parallel to and midway between the 109 canyon walls. (The mirror is obviously provided for the use of the 109 dwarves, who as you know, are extremely vain.) A small window can be seen 109 in either wall, some fifty feet up. 110 You're at a low window overlooking a huge pit, which extends up out of 110 sight. A floor is indistinctly visible over 50 feet below. Traces of 110 white mist cover the floor of the pit, becoming thicker to the left. 110 Marks in the dust around the window would seem to indicate that someone 110 has been here recently. Directly across the pit from you and 25 feet away 110 there is a similar window looking into a lighted room. A shadowy figure 110 can be seen there peering back at you. 111 A large stalactite extends from the roof and almost reaches the floor 111 below. You could climb down it, and jump from it to the floor, but having 111 done so you would be unable to reach it to climb back up. 112 You are in a little maze of twisting passages, all different. 113 You are at the edge of a large underground reservoir. An opaque cloud of 113 white mist fills the room and rises rapidly upward. The lake is fed by a 113 stream, which tumbles out of a hole in the wall about 10 feet overhead and 113 splashes noisily into the water somewhere within the mist. The only 113 passage goes back toward the south. 114 Dead end. 115 You are at the northeast end of an immense room, even larger than the giant 115 room. It appears to be a repository for the 'Adventure' program. Massive 115 torches far overhead bathe the room with smoky yellow light. Scattered 115 about you can be seen a pile of bottles (all of them empty), a nursery of 115 young beanstalks murmuring quietly, a bed of oysters, a bundle of black 115 rods with rusty stars on their ends, and a collection of brass lanterns. 115 Off to one side a great many dwarves are sleeping on the floor, snoring 115 loudly. A sign nearby reads: 'Do not disturb the dwarves!' An immense 115 mirror is hanging against one wall, and stretches to the other end of the 115 room, where various other sundry objects can be glimpsed dimly in the 115 distance. 116 You are at the southwest end of the repository. To one side is a pit full 116 of fierce green snakes. On the other side is a row of small wicker cages, 116 each of which contains a little sulking bird. In one corner is a bundle 116 of black rods with rusty marks on their ends. A large number of velvet 116 pillows are scattered about on the floor. A vast mirror stretches off to 116 the northeast. At your feet is a large steel grate, next to which is a 116 sign which reads: 'Treasure vault. Keys in main office.' 117 You are on one side of a large, deep chasm. A heavy white mist rising up 117 from below obscures all view of the far side. A southwest path leads away 117 from the chasm into a winding corridor. 118 You are in a long winding corridor sloping out of sight in both directions. 119 You are in a secret canyon which exits to the north and east. 120 You are in a secret canyon which exits to the north and east. 121 You are in a secret canyon which exits to the north and east. 122 You are on the far side of the chasm. A northeast path leads away from the 122 chasm on this side. 123 You're in a long east/west corridor. A faint rumbling noise can be heard 123 in the distance. 124 The path forks here. The left fork leads northeast. A dull rumbling seems 124 to get louder in that direction. The right fork leads southeast down a 124 gentle slope. The main corridor enters from the west. 125 The walls are quite warm here. From the north can be heard a steady roar, 125 so loud that the entire cave seems to be trembling. Another passage leads 125 south, and a low crawl goes east. 126 You are on the edge of a breath-taking view. Far below you is an active 126 volcano, from which great gouts of molten lava come surging out, cascading 126 back down into the depths. The glowing rock fills the farthest reaches of 126 the cavern with a blood-red glare, giving everything an eerie, macabre 126 appearance. The air is filled with flickering sparks of ash and a heavy 126 smell of brimstone. The walls are hot to the touch, and the thundering of 126 the volcano drowns out all other sounds. Embedded in the jagged roof far 126 overhead are myriad twisted formations composed of pure white alabaster, 126 which scatter the murky light into sinister apparitions upon the walls. 126 To one side is a deep gorge, filled with a bizarre chaos of tortured rock 126 which seems to have been crafted by the devil himself. An immense river 126 of fire crashes out from the depths of the volcano, burns its way through 126 the gorge, and plummets into a bottomless pit far off to your left. To 126 the right, an immense geyser of blistering steam erupts continuously from 126 a barren island in the center of a sulfurous lake, which bubbles 126 ominously. The far right wall is aflame with an incandescence of its own, 126 which lends an additional infernal splendor to the already hellish scene. 126 A dark, foreboding passage exits to the south. 127 You are in a small chamber filled with large boulders. The walls are very 127 warm, causing the air in the room to be almost stifling from the heat. 127 The only exit is a crawl heading west, through which is coming a low 127 rumbling. 128 You are walking along a gently sloping north/south passage lined with oddly 128 shaped limestone formations. 129 You are standing at the entrance to a large, barren room. A sign posted 129 above the entrance reads: 'Caution! Bear in room!' 130 You are inside a barren room. The center of the room is completely empty 130 except for some dust. Marks in the dust lead away toward the far end of 130 the room. The only exit is the way you came in. 131 You are in a maze of twisting little passages, all different. 132 You are in a little maze of twisty passages, all different. 133 You are in a twisting maze of little passages, all different. 134 You are in a twisting little maze of passages, all different. 135 You are in a twisty little maze of passages, all different. 136 You are in a twisty maze of little passages, all different. 137 You are in a little twisty maze of passages, all different. 138 You are in a maze of little twisting passages, all different. 139 You are in a maze of little twisty passages, all different. 140 Dead end. 141 You are in a deep rocky depression. To the north are the remains of a once 141 magnificent castle. A path leads north and there is a retreat to the 141 southwest. 142 You are standing at the edge of a moat. The water is deep and stagnant, 142 but a tree has fallen across which you could cross. 143 You are standing in the rubble strewn courtyard of the castle. Corridors 143 lead east, west, north, and south. 144 You are in the waiting room of the east spire. Some very dangerous looking 144 stairs lead up. There is an exit to the west. 145 You are at the base of the west spire. A headsmans block, notched and 145 stained, stands in the center. Stairs lead up and down. There is an exit 145 to the east. 146 You have entered into the banquet room. Old bones and broken glass litter 146 the floor. An immense granite table fills most of the room. Passages 146 lead north, south, east, and west. 147 You are at the top of the east spire. It is a clear day and you can see 147 for miles with blinding clarity. Far below you and to the south, a vast 147 forest of trees blankets the ground. A small brook is also visible, 147 wandering aimlessly throughout the forest. In all other directions stark, 147 grey, innaccesable mountains arise. Heavy snow caps most of these peaks, 147 and winds can be seen whipping loose snow particles throughout the crags. 148 The stairs ahead have collapsed. The only way out is back down the stairs. 148 A sign hanging here says: 'Too bad...there used to be a nice view here. 148 Try the east spire.'. 149 You are in the dungeon. Smokey torches are set into the walls. Old prison 149 cells, many containing distorted skeletons line the south side. Stairs 149 lead up and a tunnel leads east. 150 You are standing before a heavy iron door in a muddy little room. 150 Instruments of torture clutter the floor. A passage leads west. 151 You appear to be in the barracks. A thick layer of dust covers the floor. 151 A passage leads east. 152 You are in the servants quarters. Cobwebs hang eerily from the ceiling. 152 An exit leads west. 153 You are at the south end of the throne room. A beautifully mosaiced 153 floor is littered with leaves and debris. A doorway leads south. 154 You are at the north end of the throne room. Cockroaches run for cover on 154 a massive marble throne. Passages lead east and west. 155 You have entered the royal suite but much has been destroyed by a cave in. 155 The sky can be seen from a hole in the roof. There are some stairs close 155 by leading down. 156 You are in the knights quarters. Some broken weapons are scattered on the 156 floor along with some empty wine kegs. Stairs lead down and there is a 156 passage to the south. 157 You are in a secret passage behind the throne. The only way out is down. 158 You are in a large chamber with a marble floor. A window once covered the 158 east wall but was broken long ago. A cold wind blows in. There is a hall 158 leading north. 159 It is freezing cold here. Ice has formed on the walls from the spray of 159 water rushing into a hole in the floor. Awkward looking stairs lead up. 160 You are in a high bastillion overlooking the courtyard. Snow and ice has 160 gathered here and been packed by the wind. A hole in the floor leads 160 down. ======================================================================================== DOCUMENT :usus Folder:VOL24:advx10.text ======================================================================================== 35 You are obviously a rank amateur. Better luck next time. 100 Your score qualifies you as a Novice Class Adventurer. 130 You have achieved the rating: 'Experienced Adventurer'. 200 You may now consider yourself a 'Seasoned Adventurer'. 250 You have reached 'Junior Master' status. 300 Your score puts you in Master Adventurer class C. 330 Your score puts you in Master Adventurer class B. 350 Your score puts you in Master Adventurer class A. 400 Your score puts you in the Apprentice Wizard class. 450 Your score puts you in the Sub-Wizard class. 499 You may now consider yourself a Wizard!! 500 All of Adventuredom gives tribute to you, Adventurer Grandwizard! ======================================================================================== DOCUMENT :usus Folder:VOL24:advx11.text ======================================================================================== 4 4 2 62 63 5 5 2 18 19 6 8 2 20 21 7 75 4 176 177 8 25 5 178 179 9 20 3 180 181 ======================================================================================== DOCUMENT :usus Folder:VOL24:advx2.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL24:advx2.text ======================================================================================== 1 You're at end of road again. 2 You're at hill in road. 3 You're inside building. 4 You're in valley. 5 You're in forest. 6 You're in forest. 7 You're at slit in streambed. 8 You're outside grate. 9 You're below the grate. 10 You're in cobble crawl. 11 You're in debris room. 13 You're in bird chamber. 14 You're at top of small pit. 15 You're in hall of mists. 17 You're on east bank of fissure. 18 You're in nugget of gold room. 19 You're in hall of mountain king. 23 You're at west end of twopit room. 24 You're in east pit. 25 You're in west pit. 33 You're at 'Y2'. 35 You're at window on pit. 36 You're in dirty passage. 39 You're in dusty rock room. 41 You're at west end of hall of mists. 57 You're at brink of pit. 60 You're at east end of long hall. 61 You're at west end of long hall. 64 You're at complex junction. 66 You're in swiss cheese room. 67 You're at east end of twopit room. 68 You're in slab room. 71 You're at junction of three secret canyons. 73 You're in Egyptian room. 74 You're in secret east/west canyon above tight canyon. 88 You're in narrow corridor. 91 You're at steep incline above large room. 92 You're in giant room. 95 You're in cavern with waterfall. 96 You're in soft room. 97 You're in oriental room. 98 You're in misty cavern. 99 You're in alcove. 100 You're in plover room. 101 You're in dark-room. 102 You're in arched hall. 103 You're in shell room. 106 You're in anteroom. 108 You're at Witt's end. 109 You're in mirror canyon. 110 You're at window on pit. 111 You're at top of stalactite. 113 You're at reservoir. 115 You're at NE end. 116 You're at SW end. 117 You're on SW side of chasm. 118 You're in sloping corridor. 122 You're on NE side of chasm. 123 You're in corridor. 124 You're at fork in path. 125 You're at junction with warm walls. 126 You're at breath-taking view. 127 You're in chamber of boulders. 128 You're in limestone passage. 129 You're in front of barren room. 130 You're in barren room. 141 You're at view of castle. 142 You're at moat. 143 You're in castle courtyard. 144 You're in east waiting room. 145 You're in execution room. 146 You're in banquet room. 147 You're at top of east spire. 148 Dead end. 149 You're in the dungeon. 150 You're in muddy little chamber. 151 You're in barracks. 152 You're in servants quarters. 153 You're at south end of throne room. 154 You're at north end of throne room. 155 You're in royal suite. 156 You're in knights quarters. 157 You're in secret passage. 158 You're in large marble chamber. 159 You're in polar room. 160 You're in high bastillion. ======================================================================================== DOCUMENT :usus Folder:VOL24:advx3.text ======================================================================================== 1 0 2 2 44 29 1 0 3 3 12 19 43 1 0 4 5 13 14 46 30 1 0 5 6 45 1 0 8 63 2 0 1 2 12 7 43 45 30 2 0 5 6 45 46 3 0 1 3 11 32 44 3 0 11 62 3 0 33 65 3 0 79 5 14 4 0 1 4 12 45 4 0 5 6 43 44 29 4 0 7 5 46 30 4 0 8 63 5 0 4 9 43 30 5 0 141 47 5 50 5 6 7 45 5 0 6 6 5 0 5 44 46 6 0 1 2 45 6 0 4 9 43 44 30 6 0 5 6 46 7 0 1 12 7 0 4 4 45 7 0 5 6 43 44 7 0 8 5 15 16 46 63 7 0 595 60 14 30 8 0 5 6 43 44 46 8 0 1 12 8 0 7 4 13 45 8 303 9 3 19 30 8 0 593 3 9 303 8 11 29 9 0 593 11 9 0 10 17 18 19 44 9 0 14 31 9 0 11 51 10 0 9 11 20 21 43 64 10 0 11 19 22 44 51 10 0 14 31 11 303 8 63 11 0 9 64 11 0 10 17 18 23 24 43 11 0 12 25 19 29 44 11 0 3 62 11 0 14 31 12 303 8 63 12 0 9 64 12 0 11 30 43 51 12 0 13 19 29 44 12 0 14 31 13 303 8 63 13 0 9 64 13 0 11 51 13 0 12 25 43 13 0 14 23 31 44 14 303 8 63 14 0 9 64 14 0 11 51 14 0 13 23 43 14 150 20 30 31 34 14 0 15 30 14 0 16 33 44 15 0 18 36 46 15 0 17 7 38 44 15 0 19 10 30 45 15 150 22 29 31 34 35 23 43 15 0 14 29 15 0 34 55 16 0 14 1 17 0 15 38 43 17 312 596 39 17 412 21 7 17 412 597 41 42 44 69 17 0 27 41 18 0 15 38 11 45 19 0 15 10 29 43 19 311 28 45 36 19 311 29 46 37 19 311 30 44 7 19 0 32 45 19 35 74 49 19 211 32 49 19 0 74 66 20 0 0 1 21 0 0 1 22 0 15 1 23 0 67 43 42 23 0 68 44 61 23 0 25 30 31 23 0 648 52 24 0 67 29 11 25 0 23 29 11 25 724 31 56 25 0 26 56 26 0 88 1 27 312 596 39 27 412 21 7 27 412 597 41 42 43 69 27 0 17 41 27 0 40 45 27 0 41 44 28 0 19 38 11 46 28 0 33 45 55 28 0 36 30 52 29 0 19 38 11 45 30 0 19 38 11 43 30 0 62 44 29 31 524 89 1 31 0 90 1 32 0 19 1 33 0 3 65 33 0 28 46 33 0 34 43 53 54 33 0 35 44 33 159 302 71 33 0 100 71 34 0 33 30 55 34 0 15 29 35 0 33 43 55 35 0 20 39 36 0 37 43 17 36 0 28 29 52 36 0 39 44 36 0 65 70 37 0 36 44 17 37 0 38 30 31 56 38 0 37 56 29 11 38 0 595 60 14 30 4 5 39 0 36 43 23 39 0 64 30 52 58 39 0 65 70 40 0 41 1 41 0 42 46 29 23 56 41 0 27 43 41 0 59 45 41 0 60 44 17 42 0 41 29 42 0 42 45 42 0 43 43 42 0 45 46 42 0 80 44 43 0 42 44 43 0 44 46 43 0 45 43 44 0 43 43 44 0 48 30 44 0 50 46 44 0 82 45 45 0 42 44 45 0 43 45 45 0 46 43 45 0 47 46 45 0 87 29 30 46 0 45 44 11 47 0 45 43 11 48 0 44 29 11 49 0 50 43 49 0 51 44 50 0 44 43 50 0 49 44 50 0 51 30 50 0 52 46 51 0 49 44 51 0 50 29 51 0 52 43 51 0 53 46 52 0 50 44 52 0 51 43 52 0 52 46 52 0 53 29 52 0 55 45 52 0 86 30 53 0 51 44 53 0 52 45 53 0 54 46 54 0 53 44 11 55 0 52 44 55 0 55 45 55 0 56 30 55 0 57 43 56 0 55 29 11 57 0 13 30 56 57 0 55 44 57 0 58 46 57 0 83 45 57 0 84 43 58 0 57 43 11 59 0 27 1 60 0 41 43 29 17 60 0 61 44 60 0 62 45 30 52 61 0 60 43 61 0 62 45 61 100 107 46 62 0 60 44 62 0 63 45 62 0 30 43 62 0 61 46 63 0 62 46 11 64 0 39 29 56 59 64 0 65 44 70 64 0 103 45 74 64 0 106 43 65 0 64 43 65 0 66 44 65 80 556 46 65 0 68 61 65 80 556 29 65 50 70 29 65 0 39 29 65 60 556 45 65 75 72 45 65 0 71 45 65 80 556 30 65 0 106 30 66 0 65 47 66 0 67 44 66 80 556 46 66 0 77 25 66 0 96 43 66 50 556 50 66 0 97 72 67 0 66 43 67 0 23 44 42 67 0 24 30 31 68 0 23 46 68 0 69 29 56 68 0 65 45 69 0 68 30 61 69 331 120 46 69 0 119 46 69 0 109 45 69 0 113 75 70 0 71 45 70 0 65 30 23 70 0 111 46 71 0 65 48 71 0 70 46 71 0 110 45 72 0 65 70 72 0 118 49 72 0 73 45 72 0 97 48 72 73 0 72 46 73 0 111 44 74 0 19 43 74 331 120 44 74 0 121 44 74 0 75 30 75 0 76 46 75 0 77 45 76 0 75 45 77 0 75 43 77 0 78 44 77 0 66 45 17 78 0 77 46 78 342 150 44 78 0 706 44 79 0 3 1 80 0 42 45 80 0 80 44 46 80 0 81 43 81 0 80 44 11 82 0 44 46 11 83 0 57 46 83 0 84 43 83 0 85 44 84 0 57 45 84 0 83 44 84 0 114 50 85 0 83 43 11 86 0 52 29 11 87 0 45 29 30 88 0 25 30 56 43 88 0 20 39 88 0 92 44 27 89 0 25 1 90 0 23 1 91 0 95 45 73 23 91 0 72 30 56 92 0 88 46 92 0 93 43 92 0 94 45 93 0 92 46 27 11 94 0 92 46 27 23 94 309 95 45 3 73 94 0 611 45 95 0 94 46 11 95 0 92 27 95 0 91 44 95 0 159 30 96 0 66 44 11 97 0 66 48 97 0 72 44 17 97 0 98 29 45 73 98 0 97 46 72 98 0 99 44 99 0 98 50 73 99 0 301 43 23 99 0 100 43 100 0 301 44 23 11 100 0 99 44 100 159 302 71 100 0 33 71 100 0 101 47 22 101 0 100 46 71 11 101 0 51 43 102 0 103 30 74 11 103 0 102 29 38 103 0 104 30 103 114 618 46 103 115 619 46 103 0 64 46 104 0 103 29 74 104 0 105 30 105 0 104 29 11 105 0 103 74 106 0 64 29 106 0 65 44 106 0 108 43 107 0 131 46 107 0 132 49 107 0 133 47 107 0 134 48 107 0 135 29 107 0 136 50 107 0 137 43 107 0 138 44 107 0 139 45 107 0 61 30 108 95 556 43 45 46 47 48 49 50 29 30 108 0 106 43 108 0 626 44 109 0 69 46 109 0 113 45 75 110 0 71 44 110 0 20 39 111 0 73 43 111 0 70 45 111 40 50 30 39 56 111 50 53 30 111 0 45 30 112 0 131 49 112 0 132 45 112 0 133 43 112 0 134 50 112 0 135 48 112 0 136 47 112 0 137 44 112 0 138 30 112 0 139 29 112 0 140 46 113 0 109 46 11 114 0 84 48 115 0 116 49 116 0 115 47 116 0 593 30 117 0 118 49 117 233 660 41 42 69 47 117 332 661 41 117 0 303 41 117 332 21 39 117 0 596 39 118 0 72 30 118 0 117 29 119 0 69 45 11 119 0 653 43 7 120 0 69 45 120 0 74 43 121 0 74 43 11 121 0 653 45 7 122 0 123 47 122 233 660 41 42 69 49 122 0 303 41 122 0 596 39 122 0 124 77 122 0 126 28 122 0 129 40 123 0 122 44 123 0 124 43 77 123 0 126 28 123 0 129 40 124 0 123 44 124 0 125 47 36 124 0 128 48 37 30 124 0 126 28 124 0 129 40 125 0 124 46 77 125 0 126 45 28 125 0 127 43 17 126 0 125 46 23 11 126 0 124 77 126 0 610 30 39 127 0 125 44 11 17 127 0 124 77 127 0 126 28 128 0 124 45 29 77 128 0 129 46 30 40 128 0 126 28 129 0 128 44 29 129 0 124 77 129 0 130 43 19 40 3 129 0 126 28 130 0 129 44 11 130 0 124 77 130 0 126 28 131 0 107 44 131 0 132 48 131 0 133 50 131 0 134 49 131 0 135 47 131 0 136 29 131 0 137 30 131 0 138 45 131 0 139 46 131 0 112 43 132 0 107 50 132 0 131 29 132 0 133 45 132 0 134 46 132 0 135 44 132 0 136 49 132 0 137 47 132 0 138 43 132 0 139 30 132 0 112 48 133 0 107 29 133 0 131 30 133 0 132 44 133 0 134 47 133 0 135 49 133 0 136 43 133 0 137 45 133 0 138 50 133 0 139 48 133 0 112 46 134 0 107 47 134 0 131 45 134 0 132 50 134 0 133 48 134 0 135 43 134 0 136 30 134 0 137 46 134 0 138 29 134 0 139 44 134 0 112 49 135 0 107 45 135 0 131 48 135 0 132 30 135 0 133 46 135 0 134 43 135 0 136 44 135 0 137 49 135 0 138 47 135 0 139 50 135 0 112 29 136 0 107 43 136 0 131 44 136 0 132 29 136 0 133 49 136 0 134 30 136 0 135 46 136 0 137 50 136 0 138 48 136 0 139 47 136 0 112 45 137 0 107 48 137 0 131 47 137 0 132 46 137 0 133 30 137 0 134 29 137 0 135 50 137 0 136 45 137 0 138 49 137 0 139 43 137 0 112 44 138 0 107 30 138 0 131 43 138 0 132 47 138 0 133 29 138 0 134 44 138 0 135 45 138 0 136 46 138 0 137 48 138 0 139 49 138 0 112 50 139 0 107 49 139 0 131 50 139 0 132 43 139 0 133 44 139 0 134 45 139 0 135 30 139 0 136 48 139 0 137 29 139 0 138 46 139 0 112 47 140 0 112 45 11 141 0 5 49 141 0 142 45 141 0 3 12 142 0 143 7 41 42 45 69 142 0 141 46 142 0 5 6 43 44 143 100 142 42 46 69 143 0 144 43 143 0 145 44 143 0 146 45 144 0 147 29 144 0 143 44 145 0 143 43 145 0 148 29 145 0 149 30 146 0 151 44 146 0 152 43 146 0 153 45 146 0 143 46 147 0 144 30 148 0 145 30 149 0 145 29 149 0 150 43 150 0 149 44 150 342 78 43 150 0 706 43 151 0 146 43 152 0 146 44 153 0 154 45 153 0 146 46 154 0 153 46 154 0 155 44 154 0 156 43 154 0 157 30 155 0 154 43 30 155 0 157 78 155 0 156 79 155 0 160 29 156 0 154 44 30 156 0 158 46 156 0 157 79 156 0 155 78 157 0 149 30 158 0 156 45 159 0 95 29 159 0 103 74 160 0 155 30 ======================================================================================== DOCUMENT :usus Folder:VOL24:advx4.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL24:advx4.text ======================================================================================== 1016 'SPEL 3051 ? 29 ABOVE 3050 ABRA 3050 ABRAC 42 ACROS 29 ASCEN 2012 ATTAC 26 AWKWA 1028 AXE 8 BACK 1069 BAG 1043 BALL 40 BARRE 1052 BARS 1039 BATTE 1024 BEANS 1035 BEAR 16 BED 70 BEDQU 1008 BIRD 2023 BLAST 2023 BLOWU 1020 BOTTL 1055 BOX 2028 BREAK 2026 BRIEF 54 BROKE 12 BUILD 1004 CAGE 2010 CALM 25 CANYO 2001 CAPTU 1040 CARPE 2001 CARRY 2001 CATCH 67 CAVE 73 CAVER 1064 CHAIN 2003 CHANT 1032 CHASM 1055 CHEST 1014 CLAM 56 CLIMB 2006 CLOSE 18 COBBL 1054 COINS 7 CONTI 2011 CONTI 33 CRACK 17 CRAWL 69 CROSS 1072 CROWN 30 D 22 DARK 51 DEBRI 63 DEPRE 30 DESCE 57 DESCR 2023 DETON 2014 DEVOU 1051 DIAMO 3066 DIG 2002 DISCA 2029 DISTU 35 DOME 1009 DOOR 1166 DOOR2 30 DOWN 5 DOWNS 30 DOWNW 1031 DRAGO 1029 DRAWI 2015 DRINK 2002 DROP 2002 DUMP 1017 DWARF 1017 DWARV 43 E 43 EAST 2014 EAT 1056 EGG 1056 EGGS 1059 EMERA 3 ENTER 64 ENTRA 1071 ERMIN 57 EXAMI 3066 EXCAV 11 EXIT 2011 EXPLO 2008 EXTIN 2025 FEE 3001 FEE 2021 FEED 2025 FIE 3002 FIE 2012 FIGHT 1027 FIGUR 2022 FILL 2019 FIND 1012 FISSU 58 FLOOR 2025 FOE 3003 FOE 2011 FOLLO 2025 FOO 3004 FOO 1019 FOOD 6 FORES 77 FORK 7 FORWA 2002 FREE 3079 FUCK 2025 FUM 3005 FUM 2001 GET 1037 GEYSE 27 GIANT 1043 GLASS 2011 GO 1050 GOLD 2011 GOTO 1003 GRATE 13 GULLY 1021 H2O 38 HALL 1002 HEADL 3051 HELP 2 HILL 2012 HIT 3050 HOCUS 52 HOLE 12 HOUSE 2023 IGNIT 19 IN 3142 INFO 3142 INFOR 19 INSID 2020 INVEN 19 INWAR 1016 ISSUE 1067 IVORY 1068 JADE 1020 JAR 1053 JEWEL 1020 JUG 39 JUMP 2001 KEEP 1001 KEY 1001 KEYS 2012 KILL 1018 KNIFE 79 KNIGH 1018 KNIVE 1002 LAMP 1002 LANTE 11 LEAVE 36 LEFT 2007 LIGHT 2006 LOCK 57 LOOK 3068 LOST 24 LOW 1038 MACHI 1016 MAGAZ 76 MAIN 1036 MESSA 1058 MING 1023 MIRRO 3069 MIST 1040 MOSS 2003 MUMBL 45 N 47 NE 1056 NEST 45 NORTH 2005 NOTHI 21 NOWHE 1050 NUGGE 21 NULL 50 NW 2008 OFF 76 OFFIC 1022 OIL 2007 ON 7 ONWAR 1069 OPALS 2004 OPEN 3050 OPENS 72 ORIEN 11 OUT 32 OUTDO 11 OUTSI 41 OVER 1015 OYSTE 1066 PAINT 23 PASSA 2030 PAUSE 1061 PEARL 1062 PERSI 2027 PERUS 1010 PILLO 1030 PIRAT 31 PIT 2010 PLACA 1024 PLANT 1025 PLANT 1060 PLATI 71 PLOVE 65 PLUGH 3050 POCUS 1058 POTTE 2013 POUR 2011 PROCE 2027 PURUS 2002 PUT 1060 PYRAM 2018 QUIT 1019 RATIO 2027 READ 2002 RELEA 75 RESER 8 RETRE 8 RETUR 37 RIGHT 2 ROAD 1071 ROBE 15 ROCK 1005 ROD 1006 ROD 59 ROOM 78 ROYAL 2016 RUB 1065 RUBY 1062 RUG 2011 RUN 46 S 1069 SACK 2030 SAVE 2003 SAY 2024 SCORE 1073 SCEPT 1070 SCROL 48 SE 66 SECRE 3050 SESAM 1027 SHADO 2009 SHAKE 1058 SHARD 2028 SHATT 3050 SHAZA 74 SHELL 1052 SILVE 2003 SING 61 SLAB 61 SLABR 2012 SLAY 60 SLIT 2028 SMASH 1011 SNAKE 46 SOUTH 1016 SPELU 1063 SPICE 10 STAIR 1026 STALA 1068 STATU 2001 STEAL 34 STEPS 1007 STEPS 1073 STERL 3139 STOP 14 STREA 2012 STRIK 20 SURFA 2030 SUSPE 49 SW 3147 SWIM 2009 SWING 1013 TABLE 2001 TAKE 1067 TALIS 2010 TAME 2017 THROW 2017 TOSS 2001 TOTE 57 TOUCH 2011 TRAVE 1055 TREAS 3064 TREE 3064 TREES 1057 TRIDE 1033 TROLL 1034 TROLL 23 TUNNE 2011 TURN 29 U 2004 UNLOC 29 UP 4 UPSTR 29 UPWAR 2003 UTTER 9 VALLE 1058 VASE 1010 VELVE 1038 VENDI 28 VIEW 1037 VOLCA 44 W 2029 WAKE 2011 WALK 53 WALL 1021 WATER 2009 WAVE 44 WEST 2019 WHERE 1041 WIZAR 62 XYZZY 55 Y2 ======================================================================================== DOCUMENT :usus Folder:VOL24:advx5.text ======================================================================================== 1 Set of keys 0 There are some keys on the ground here. 2 Brass lantern 0 There is a shiny brass lamp nearby. 100 There is a lamp shining nearby. 3 *grate 0 The grate is locked. 100 The grate is open. 4 wicker cage 0 There is a small wicker cage discarded nearby. 5 black rod 0 A three foot black rod with a rusty star on an end lies nearby. 6 black rod 0 A three foot black rod with a rusty mark on an end lies nearby. 7 *steps 0 Rough stone steps lead down the pit. 100 Rough stone steps lead up the dome. 8 little bird in cage 0 A cheerful little bird is sitting here singing. 100 There is a little bird in the cage. 9 *rusty door 0 The way north is barred by a massive, rusty, iron door. 100 The way north leads through a massive, rusty, iron door. 10 velvet pillow 0 A small velvet pillow lies on the floor. 11 *snake 0 A huge green fierce snake bars the way! 100 12 *fissure 0 100 A crystal bridge now spans the fissure. 200 The crystal bridge has vanished! 13 *stone tablet 0 A massive stone tablet imbedded in the wall reads: 'Congratulations on 0 bringing light into the dark-room!' 14 giant clam >grunt!< 0 There is an enormous clam here with its shell tightly closed. 15 giant oyster >groan!< 0 There is an enormous oyster here with its shell tightly closed. 100 Interesting. There seems to be something written on the underside of the 100 oyster. 16 'Spelunker Today' 0 There are a few recent issues of 'Spelunker Today' magazine lying here. 19 tasty food 0 There is food here. 20 small bottle 0 There is a bottle of water here. 100 There is an empty bottle here. 200 There is a bottle of oil here. 21 water in the bottle 22 oil in the bottle 23 *mirror 0 24 *plant 0 There is a tiny little plant in the pit, murmuring: 'water, water, ...' 100 The plant spurts into furious growth for a few seconds. 200 A 12-foot plant now grows out of the pit, bellowing: 'WATER! WATER!!' 300 The plant grows explosively, almost filling the bottom of the pit. 400 There is a gigantic beanstalk stretching all the way up to the hole. 500 You've over-watered the plant! It's shriveling up! It's, it's... 25 *phony plant (seen in twopit room only when tall enough) 0 100 The top of a 12-foot-tall beanstalk is poking out of the west pit. 200 A huge beanstalk stretches out of the west pit up to the hole. 26 *stalactite 0 27 *shadowy figure 0 The shadowy figure seems to be trying to attract your attention. 28 dwarf's axe 0 There is a little axe here. 100 There is a little axe lying beside the bear. 29 *cave drawings 0 30 *pirate 0 31 *dragon 0 A huge green fierce dragon bars the way! 100 Congratulations! You have just vanquished a dragon with your bare hands! 100 (Unbelievable, isn't it?) 200 The body of a huge green dead dragon is lying off to one side. 32 *chasm 0 A rickety wooden bridge extends across the chasm, vanishing into the mist. 0 A sign posted on the bridge reads: 'Stop! Pay troll!' 100 The wreckage of a bridge (and a dead bear) can be seen at the bottom of the 100 chasm. 33 *troll 0 A burly troll blocks the bridge and demands a treasure to cross!! 100 The troll steps out from beneath the bridge and blocks your way. 200 34 *phony troll 0 The troll is nowhere to be seen. 35 0 There is a ferocious cave bear eying you from the far end of the room! 100 There is a gentle cave bear sitting placidly in one corner. 200 There is a contented-looking bear wandering about nearby. 300 36 *message in second maze 0 There is a message scrawled in the dust in a flowery script, reading: 'This 0 is not the maze where the pirate leaves his treasure chest.' 37 *volcano and/or geyser 0 38 *vending machine 0 There is a massive vending machine here. The instructions on it read: 0 'Drop coins here to receive fresh batteries.' 39 batteries 0 There are fresh batteries here. 100 Some worn-out batteries have been discarded nearby. 40 *carpet and/or moss 0 41 *evil wizard 0 There is an evil looking wizard here eying you darkly!!! 100 42 *castle-cave door 0 The great iron door is locked. 100 The great iron door is unlocked. 43 curiously shaped glass ball 0 There is an oddly shaped glass ball here!!! 50 large gold nugget 0 There is a large sparkling nugget of gold here! 51 several diamonds 0 There are diamonds here! 52 bars of silver 0 There are bars of silver here! 53 precious jewelry 0 There is precious jewelry here! 54 rare coins 0 There are many coins here! 55 treasure chest 0 The pirate's treasure chest is here! 56 golden eggs 0 There is a large nest here, full of golden eggs! 100 The nest of golden eggs has vanished! 200 Done! 57 jeweled trident 0 There is a jewel-encrusted trident here! 58 ming vase 0 There is a delicate, precious, ming vase here! 100 The vase is now resting, delicately, on a velvet pillow. 200 The floor is littered with worthless shards of pottery. 300 The ming vase drops with a delicate crash. 59 egg-sized emerald 0 There is an emerald here the size of a plover's egg! 60 platinum pyramid 0 There is a platinum pyramid here, 8 inches on a side! 61 glistening pearl 0 Off to one side lies a glistening pearl! 62 Persian rug 0 There is a Persian rug spread out on the floor! 100 The dragon is sprawled out on a Persian rug!! 63 rare spices 0 There are rare spices here! 64 golden chain 0 There is a golden chain lying in a heap on the floor! 100 The bear is locked to the wall with a golden chain! 200 There is a golden chain locked to the wall! 65 large flawless ruby 0 A large flawless ruby lies on the dirt floor!! 66 priceless oil paintings 0 There are some priceless oil paintings hanging here!!! 67 carved ivory talisman 0 There is a carved ivory talisman here!!! 68 mysterious jade statue 0 There is a small jade statue here!!! 69 small bag of black opals 0 There is a small bag of black opals here!!! 70 ancient Dead Sea scrolls 0 There are some ancient Dead Sea scrolls here!!! 71 plush ermine robe 0 There is a plush ermine robe lying here!!! 72 heavily jeweled crown 0 There is a heavily jeweled crown lying here!!! 73 sterling scepter 0 There is a sterling scepter here!!! ======================================================================================== DOCUMENT :usus Folder:VOL24:advx6.text ======================================================================================== 1 Somewhere nearby is colossal cave, where others have found fortunes in 1 treasure and gold, though it is rumored that some who enter are never seen 1 again. Magic is said to work in the cave. I will be your eyes and hands. 1 Direct me with commands of one or two words. I should warn you that I 1 look at only the first five letters of each word, so you'll have to enter 1 'northeast' as 'NE' to distinguish it from 'north'. (Should you get 1 stuck, type 'HELP' for some general hints. For information on how to end 1 your adventure, etc., type: 'INFO'.) 2 A little dwarf with a big knife blocks your way. 3 A little dwarf just walked around a corner, saw you, threw a little axe at 3 you which missed, cursed, and ran away. 4 There is a threatening little dwarf in the room with you! 5 One sharp nasty knife is thrown at you! 6 None of them hit you! 7 One of them gets you! 8 A hollow voice says: 'PLUGH'. 9 There is no way to go that direction. 10 I am unsure how you are facing. Use compass points or nearby objects. 11 I don't know in from out here. Use compass points or name something in the 11 general direction you want to go. 12 I don't know how to apply that word here. 13 I don't understand that! 14 I'm game. Would you care to explain how? 15 Sorry, but I am not allowed to give more detail. I will repeat the long 15 description of your location. 16 It is now pitch dark. If you proceed you will probably fall into a pit. 17 If you prefer, simply type W rather than WEST. 18 Are you trying to catch the bird? 19 The bird is frightened right now and you cannot catch it no matter what you 19 try. Perhaps you might try later. 20 Are you trying to somehow deal with the snake? 21 You can't kill the snake, or drive it away, or avoid it, or anything like 21 that. There is a way to get by, but you don't have the necessary 21 resources right now. 22 Do you really want to quit now? 23 You fell into a pit and broke every bone in your body! 24 You are already carrying it! 25 You can't be serious! 26 The bird was unafraid when you entered, but as you approach it becomes 26 disturbed and you cannot catch it. 27 You can catch the bird, but you cannot carry it. 28 There is nothing here with a lock! 29 You aren't carrying it! 30 The little bird attacks the green snake, and in an astounding flurry drives 30 the snake away. 31 You have no keys! 32 It has no lock. 33 I don't know how to lock or unlock such a thing. 34 It was already locked. 35 The grate is now locked. 36 The grate is now unlocked. 37 It was already unlocked. 38 You have no source of light. 39 Your lamp is now on. 40 Your lamp is now off. 41 There is no way to get past the bear to unlock the chain, which is probably 41 just as well. 42 Nothing happens. 43 Where? 44 There is nothing here to attack. 45 The little bird is now dead. Its body disappears. 46 Attacking the snake both doesn't work and is very dangerous. 47 You killed a little dwarf. 48 You attack a little dwarf, but he dodges out of the way. 49 With what? Your bare hands? 50 Good try, but that is an old worn-out magic word. 51 I know of places, actions, and things. Most of my vocabulary describes 51 places and is used to move you there. To move, try words like FOREST, 51 BUILDING, DOWNSTREAM, ENTER, EAST, WEST, NORTH, SOUTH, UP, or DOWN. I 51 know about a few special objects, like a black rod hidden in the cave. 51 These objects can be manipulated using some of the action words that I 51 know. Usually you will need to give both the object and action words (in 51 either order), but sometimes I can infer the object from the verb alone. 51 Some objects also imply verbs; in particular, 'INVENTORY' implies 'TAKE 51 INVENTORY', which causes me to give you a list of what you're carrying. 51 The objects have side effects; for instance, the rod scares the bird. 51 Usually people having trouble moving just need to try a few more words. 51 Usually people trying unsuccessfully to manipulate an object are 51 attempting something beyond their (or my!) capabilities and should try a 51 completely different tack. To speed the game you can sometimes move long 51 distances with a single word. For example, 'BUILDING' usually gets you to 51 the building from anywhere above ground except when lost in the forest. 51 Also, note that cave passages turn a lot, and that leaving a room to the 51 north does not guarantee entering the next from the south. Good luck! 52 It misses! 53 It gets you! 54 Ok. 55 You can't unlock the keys. 56 You have crawled around in some little holes and wound up back in the main 56 passage. 57 I don't know where the cave is, but hereabouts no stream can run on the 57 surface for long. I would try the stream. 58 I need more detailed instructions to do that. 59 I can only tell you what you see as you move about and manipulate things. 59 I cannot tell you where remote things are. 60 I don't know that word. 61 What? 62 Are you trying to get into the cave? 63 The grate is very solid and has a hardened steel lock. You cannot enter 63 without a key, and there are no keys nearby. I would recommend looking 63 elsewhere for the keys. 64 The trees of the forest are large hardwood oak and maple, with an 64 occasional grove of pine or spruce. There is quite a bit of undergrowth, 64 largely birch and ash saplings plus nondescript bushes of various sorts. 64 This time of year visibility is quite restricted by all the leaves, but 64 travel is quite easy if you detour around the spruce and berry bushes. 65 Welcome to Adventure!! Would you like instructions? 66 Digging without a shovel is quite impractical. Even with a shovel progress 66 is unlikely. 67 Blasting requires dynamite. 68 I'm as confused as you are. 69 Mist is a white vapor, usually water, seen from time to time in caverns. 69 It can be found anywhere but is frequently a sign of a deep pit leading 69 down to water. 70 Your feet are now wet. 71 I think I just lost my appetite. 72 Thank you, it was delicious! 73 You have taken a drink from the stream. The water tastes strongly of 73 minerals, but is not unpleasant. It is extremely cold. 74 The bottle of water is now empty. 75 Rubbing the electric lamp is not particularly rewarding. Anyway, nothing 75 exciting happens. 76 Peculiar. Nothing unexpected happens. 77 Your bottle is empty and the ground is wet. 78 You can't pour that. 79 Watch it! 80 Which way? 81 Oh dear, you seem to have gotten yourself killed. I might be able to help 81 you out, but I've never really done this before. Do you want me to try to 81 reincarnate you? 82 All right. But don't blame me if something goes wr...... 82 --- Poof!! --- You 82 are engulfed in a cloud of orange smoke. Coughing and gasping, you emerge 82 from the smoke and find.... 83 You clumsy oaf, you've done it again! I don't know how long I can keep 83 this up. Do you want me to try reincarnating you again? 84 Okay, now where did I put my orange smoke?.... >Poof!< Everything 84 disappears in a dense cloud of orange smoke. 85 Now you've really done it! I'm out of orange smoke! You don't expect me 85 to do a decent reincarnation without any orange smoke, do you? 86 Okay, if you're so smart, do it yourself! I'm leaving! 90 All of a sudden, you hear a high pitched sound coming from the darkness 90 behind you. You turn and see three shimmering shapes start to materialize 90 into humanoid form. The light and sound surrounding the figures begins to 90 dim as their features become clearer. Suddenly the middle shape shouts 90 out: 'Dammit, Scotty!! You got the wrong coordinates!! Beam us up!!!' 90 The sound and light spring up in renewed intensity for a few seconds and 90 then fade away as the figures disappear. 91 Sorry, but I no longer seem to remember how it was you got here. 92 You can't carry anything more. You'll have to drop something first. 93 You can't go through a locked steel grate! 94 I believe what you want is right here with you. 95 You don't fit through a two-inch slit! 96 I respectfully suggest you go across the bridge instead of jumping. 97 There is no way across the fissure. 98 You're not carrying anything. 99 You are currently holding the following: 100 It's not hungry (it's merely pinin' for the fjords). Besides, you have no 100 bird seed. 101 The snake has now devoured your bird. 102 There's nothing here it wants to eat (except perhaps you). 103 You fool, dwarves eat only coal! Now you've made him *really* mad!! 104 You have nothing in which to carry it. 105 Your bottle is already full. 106 There is nothing here with which to fill the bottle. 107 Your bottle is now full of water. 108 Your bottle is now full of oil. 109 You can't fill that. 110 Don't be ridiculous! 111 The door is extremely rusty and refuses to open. 112 The plant indignantly shakes the oil off its leaves and asks: 'water?' 113 The hinges are quite thoroughly rusted now and won't budge. 114 The oil has freed up the hinges so that the door will now move, although it 114 requires some effort. 115 The plant has exceptionally deep roots and cannot be pulled free. 116 The dwarves' knives vanish as they strike the walls of the cave. 117 Something you're carrying won't fit through the tunnel with you. You'd 117 best take inventory and drop something. 118 You can't fit this five-foot clam through that little passage! 119 You can't fit this five-foot oyster through that little passage! 120 I advise you to put down the clam before opening it. >Strain!< 121 I advise you to put down the oyster before opening it. >Wrench!< 122 You don't have anything strong enough to open the clam. 123 You don't have anything strong enough to open the oyster. 124 A glistening pearl falls out of the clam and rolls away. Goodness, this 124 must really be an oyster. (I never was very good at identifying 124 bivalves.) Whatever it is, it has now snapped shut again. 125 The oyster creaks open, revealing nothing but oyster inside. It promptly 125 snaps shut again. 126 You have crawled around in some little holes and found your way blocked by 126 a recent cave-in. You are now back in the main passage. 127 There are faint rustling noises from the darkness behind you. 128 Out from the shadows behind you pounces a bearded pirate! 'Har, har ' he 128 chortles, 'I'll just take all this booty and hide it away with me chest 128 deep in the maze!' He snatches your treasure and vanishes into the gloom. 129 A sepulchral voice reverberating through the cave says: 'Cave closing soon. 129 All adventurers must exit immediately through the main office.' 130 A mysterious recorded voice groans into life and announces: 'This exit is 130 closed. Please leave via main office.' 131 It looks as though you're dead. Well, seeing as how it's so close to 131 closing time anyway, I think we'll just call it a day. 132 The sepulchral voice entones: 'The cave is now closed.' As the echoes 132 fade, there is a blinding flash of light (and a small puff of orange 132 smoke). . . . As your eyes refocus, you look around and find... 133 There is a loud explosion, and a twenty-foot hole appears in the far wall, 133 burying the dwarves in the rubble. You march through the hole and find 133 yourself in the main office, where a cheering band of friendly elves carry 133 the conquering adventurer off into the sunset. 134 There is a loud explosion, and a twenty-foot hole appears in the far wall, 134 burying the snakes in the rubble. A river of molten lava pours in through 134 the hole, destroying everything in its path, including you! 135 There is a loud explosion, and you are suddenly splashed across the walls 135 of the room. 136 The resulting ruckus has awakened the dwarves. There are now several 136 threatening little dwarves in the room with you! Most of them throw 136 knives at you! All of them get you! 137 Oh, leave the poor unhappy bird alone. 138 I daresay whatever you want is around here somewhere. 139 I don't know the word 'STOP'. Use 'QUIT' if you want to give up. 140 You can't get there from here. 141 You are being followed by a very large, tame bear. 142 If you want to end your adventure early, say 'QUIT'. To see how well 142 you're doing, say 'SCORE'. To get full credit for a treasure, you must 142 have left it safely in the building, though you get partial credit just 142 for locating it. You lose points for getting killed, or for quitting, 142 though the former costs you more. There are also points based on how much 142 (if any) of the cave you've managed to explore; in particular, there is a 142 large bonus just for getting in (to distinguish the beginners from the 142 rest of the pack), and there are other ways to determine whether you've 142 been through some of the more harrowing sections. If you think you've 142 found all the treasures, just keep exploring for a while. If nothing 142 interesting happens, you haven't found them all yet. If something 142 interesting *does* happen, it means you're getting a bonus and have an 142 opportunity to garner many more points in the master's section. I may 142 occasionally offer hints if you seem to be having trouble. If I do, I'll 142 warn you in advance how much it will affect your score to accept the 142 hints. Finally, to save time, you may specify 'BRIEF', which tells me 142 never to repeat the full description of a place unless you explicitly 142 request it. 143 Do you indeed wish to quit now? 144 There is nothing here with which to fill the vase. 145 The sudden change in temperature has delicately shattered the vase. 146 It is beyond your power to do that. 147 I don't know how. 148 It is too far up for you to reach. 149 You killed a little dwarf. The body vanishes in a cloud of greasy black 149 smoke. 150 The shell is very strong and is impervious to attack. 151 What's the matter, can't you read? Now you'd best start over. 152 The axe bounces harmlessly off the dragon's thick scales. 153 The dragon looks rather nasty. You'd best not try to get by. 154 The little bird attacks the green dragon, and in an astounding flurry gets 154 burnt to a cinder. The ashes blow away. 155 On what? 156 Okay, from now on I'll only describe a place in full the first time you 156 come to it. To get the full description, say 'LOOK'. 157 Trolls are close relatives with the rocks and have skin as tough as that of 157 a rhinoceros. The troll fends off your blows effortlessly. 158 The troll deftly catches the axe, examines it carefully, and tosses it 158 back, declaring: 'Good workmanship, but it's not valuable enough.' 159 The troll catches your treasure and scurries away out of sight. 160 The troll refuses to let you cross. 161 There is no longer any way across the chasm. 162 Just as you reach the other side, the bridge buckles beneath the weight of 162 the bear, which was still following you around. You scrabble desperately 162 for support, but as the bridge collapses you stumble back and fall into 162 the chasm. 163 The bear lumbers toward the troll, who lets out a startled shriek and 163 scurries away. The bear soon gives up the pursuit and wanders back. 164 The axe misses and lands near the bear where you can't get at it. 165 With what? Your bare hands? Against *his* bear hands?? 166 The bear is confused; he only wants to be your friend. 167 For crying out loud, the poor thing is already dead! 168 The bear eagerly wolfs down your food, after which he seems to calm down 168 considerably and even becomes rather friendly. 169 The bear is still chained to the wall. 170 The chain is still locked. 171 The chain is now unlocked. 172 The chain is now locked. 173 There is nothing here to which the chain can be locked. 174 There is nothing here to eat. 175 Do you want the hint? 176 Do you need help getting out of the maze? 177 You can make the passages look less alike by dropping things. 178 Are you trying to explore beyond the plover room? 179 There is a way to explore that region without having to worry about falling 179 into a pit. None of the objects available is immediately useful in 179 discovering the secret. 180 Do you need help getting out of here? 181 Don't go west. 182 Gluttony is not one of the troll's vices. Avarice, however, is. 183 Your lamp is getting dim. You'd best start wrapping this up, unless you 183 can find some fresh batteries. I seem to recall there's a vending machine 183 in the maze. Bring some coins with you. 184 Your lamp has run out of power. 185 There's not much point in wandering around out here, and you can't explore 185 the cave without a lamp. So let's just call it a day. 186 There are faint rustling noises from the darkness behind you. As you turn 186 toward them, the beam of your lamp falls across a bearded pirate. He is 186 carrying a large chest. 'Shiver me timbers!' he cries, 'I've been 186 spotted! I'd best hie meself off to the maze to hide me chest!' With 186 that, he vanishes into the gloom. 187 Your lamp is getting dim. You'd best go back for those batteries. 188 Your lamp is getting dim. I'm taking the liberty of replacing the 188 batteries. 189 Your lamp is getting dim, and you're out of spare batteries. You'd best 189 start wrapping this up. 190 I'm afraid the magazine is written in dwarvish. 191 'This is not the maze where the pirate leaves his treasure chest.' 192 Hmmm, this looks like a clue, which means it'll cost you ten points to read 192 it. Should I go ahead and read it anyway? 193 It says: 'There is something strange about this place, such that one of the 193 words I've always known now has a new effect.' 194 It says the same thing it did before. 195 I'm afraid I don't understand. 196 'Congratulations on bringing light into the dark-room!' 197 You strike the mirror a resounding blow, whereupon it shatters into a 197 myriad of tiny fragments. 198 You have taken the vase and hurled it delicately to the ground. 199 You prod the nearest dwarf, who wakes up grumpily, takes one look at you, 199 curses, and grabs for his axe. 200 Is this acceptable? 201 Are you resuming an earlier Adventure? 202 It was already locked. 203 The door is now locked. 204 The door is now unlocked. 205 It was already unlocked. 206 You can't get past a locked, heavy iron door. 207 The wizard shrieks as he recognizes the ball. Unbelievably, he begins to 207 shrink. The glass pulsates, growing hotter and brighter as the wizard 207 runs around in circles growing smaller and smaller until he is no larger 207 than an ant. The ball begins to move on its own, toward the wizard who 207 vainly attempts to move away. As contact is made, both wizard and glass 207 ball disappear in a cloud of smoke and and a clap of thunder. 208 The wizard is now salivating on your arm. 209 Physical violence is useless against the powers of magic. 210 A sign nearby says: 'Keys in main office'. 211 A lightening bolt is hurled at you!!! 212 The wizard gags heartily and slaps your face. 213 The wizard laughs as the axe bounces off an invisible shield!! 214 Unfortunately, the scrolls have been written in Babylonian. ======================================================================================== DOCUMENT :usus Folder:VOL24:advx7.text ======================================================================================== 1 3 0 2 3 0 3 8 9 4 10 0 5 11 0 6 0 0 7 14 15 8 13 0 9 94 -1 10 96 0 11 19 -1 12 17 27 13 101 -1 14 103 0 15 0 0 16 106 0 17 0 -1 18 0 0 19 3 0 20 3 0 21 0 0 22 0 0 23 109 -1 24 25 -1 25 23 67 26 111 -1 27 35 110 28 0 0 29 97 -1 30 0 0 31 119 121 32 117 122 33 117 122 34 0 0 35 130 -1 36 0 -1 37 126 -1 38 140 -1 39 0 0 40 96 -1 41 149 -1 42 78 150 43 157 0 44 0 0 45 0 0 46 0 0 47 0 0 48 0 0 49 0 0 50 18 0 51 27 0 52 35 0 53 29 0 54 30 0 55 0 0 56 92 0 57 95 0 58 97 0 59 100 0 60 101 0 61 0 0 62 119 121 63 127 0 64 130 -1 65 73 0 66 155 0 67 158 0 68 0 0 69 148 0 70 150 0 71 159 0 72 160 0 73 126 0 74 0 0 75 0 0 76 0 0 77 0 0 78 0 0 79 0 0 80 0 0 81 0 0 82 0 0 83 0 0 84 0 0 85 0 0 86 0 0 87 0 0 88 0 0 89 0 0 90 0 0 91 0 0 92 0 0 93 0 0 94 0 0 95 0 0 96 0 0 97 0 0 98 0 0 99 0 0 100 0 0 ======================================================================================== DOCUMENT :usus Folder:VOL24:advx8.text ======================================================================================== 1 24 2 29 3 0 4 33 5 0 6 33 7 38 8 38 9 42 10 14 11 43 12 110 13 29 14 110 15 73 16 75 17 29 18 13 19 59 20 59 21 174 22 109 23 67 24 13 25 147 26 155 27 195 28 146 29 110 30 13 31 13 32 0 33 0 34 0 35 0 ======================================================================================== DOCUMENT :usus Folder:VOL24:advx9.text ======================================================================================== 0 1 2 3 4 5 6 7 8 9 10 0 141 142 143 144 145 146 147 148 149 150 0 151 152 153 154 155 156 157 158 0 100 115 116 126 160 1 16 20 21 22 24 26 31 32 40 59 1 79 89 90 2 1 3 4 7 24 38 95 113 3 46 47 48 54 56 58 82 85 86 122 3 123 124 125 126 127 128 129 130 4 8 5 13 6 19 7 42 43 44 45 46 47 48 49 50 51 7 52 53 54 55 56 80 81 82 86 87 8 99 100 101 9 108 ======================================================================================== DOCUMENT :usus Folder:VOL24:advxcons.text ======================================================================================== clsmax = 12; hntmax = 20; locsiz = 160; rtxsiz = 215; tabsiz = 320; trvsiz = 805; vrbsiz = 35; ======================================================================================== DOCUMENT :usus Folder:VOL24:advxinit.text ======================================================================================== PROGRAM ADVINIT; const {$I advxcons.text} TYPE CHAR6 = PACKED ARRAY[1..6] OF CHAR; ARYS = RECORD CASE BOOLEAN OF FALSE : ( DBLK : PACKED ARRAY[1..512] OF CHAR); TRUE : (TRAVEL : ARRAY[1..trvsiz] OF INTEGER; TRAVEL2 : ARRAY[1..trvsiz] OF INTEGER; TRAVEL3 : ARRAY[1..trvsiz] OF INTEGER; ATAB : ARRAY[1..tabsiz] OF STRING[5]; KTAB : ARRAY[1..tabsiz] OF INTEGER; LTEXT : ARRAY[1..locsiz] OF INTEGER; STEXT : ARRAY[1..locsiz] OF INTEGER; KEY : ARRAY[1..locsiz] OF INTEGER; PLAC : ARRAY[1..100] OF INTEGER; FIXD : ARRAY[1..100] OF INTEGER; PTEXT : ARRAY[1..100] OF INTEGER; ACTSPK : ARRAY[1..vrbsiz] OF INTEGER; RTEXT : ARRAY[1..rtxsiz] OF INTEGER; CTEXT : ARRAY[1..clsmax] OF INTEGER; CVAL : ARRAY[1..clsmax] OF INTEGER; HINTS : ARRAY[1..hntmax, 1..4] OF INTEGER) END; VARYS = RECORD CASE BOOLEAN OF FALSE : ( DBLK : PACKED ARRAY[1..512] OF CHAR); TRUE : (COND : ARRAY[1..locsiz] OF INTEGER; ABB : ARRAY[1..locsiz] OF INTEGER; ATLOC : ARRAY[1..locsiz] OF INTEGER; PLACE : ARRAY[1..100] OF INTEGER; FIXED : ARRAY[1..100] OF INTEGER; LINK : ARRAY[1..200] OF INTEGER; PROP : ARRAY[1..100] OF INTEGER; HINTLC : ARRAY[1..hntmax] OF INTEGER; HINTED : ARRAY[1..hntmax] OF BOOLEAN; DSEEN : ARRAY[1..6] OF BOOLEAN; DLOC : ARRAY[1..6] OF INTEGER; ODLOC : ARRAY[1..6] OF INTEGER; TK : ARRAY[1..20] OF INTEGER) END; VAR MSGNDX, SEG, CLASSES, RECNUM, I, J, COUNT : INTEGER; ACHAR : CHAR; ARY : ^ARYS; VARY : ^VARYS; MSGFILE : FILE OF CHAR6; SAVEMSG : STRING[10]; INFILE : TEXT; OUTFILE : FILE; PROCEDURE DROP(OBJECT, WHERE : INTEGER); BEGIN WITH VARY^ DO BEGIN IF OBJECT > 100 THEN FIXED[OBJECT - 100] := WHERE ELSE PLACE[OBJECT] := WHERE; IF WHERE > 0 THEN BEGIN LINK[OBJECT] := ATLOC[WHERE]; ATLOC[WHERE] := OBJECT END END END; { DROP } PROCEDURE BLIP; BEGIN IF COUNT = 50 THEN BEGIN COUNT := 0; WRITELN; WRITE(' .') END ELSE WRITE('.'); COUNT := COUNT + 1 END; {BLIP} PROCEDURE BLIPER(MSG : STRING); BEGIN COUNT := 0; WRITELN; WRITE(MSG) END; { BLIPER } PROCEDURE PUTMSG(MSG : STRING;SAME : BOOLEAN); VAR I : INTEGER; BEGIN { PUTMSG } IF LENGTH(MSG) = 0 THEN MSG := ' '; IF SAME THEN BEGIN IF LENGTH(SAVEMSG) <> 0 THEN RECNUM := RECNUM - 1; MSG := CONCAT(SAVEMSG, MSG); SAVEMSG := '' END ELSE BEGIN IF SAVEMSG <> '' THEN BEGIN WHILE LENGTH(SAVEMSG) < 5 DO SAVEMSG := CONCAT(SAVEMSG, ' '); PUTMSG(' ', TRUE) END; MSGFILE^[1] := CHR(ORD(MSGFILE^[1]) + 128) END; WHILE LENGTH(MSG) >= 6 DO BEGIN PUT(MSGFILE); { PUT LAST MESSAGE } FOR I := 1 TO 6 DO MSGFILE^[I] := MSG[I]; DELETE(MSG, 1, 6); RECNUM := RECNUM + 1 END; SAVEMSG := MSG; IF LENGTH(SAVEMSG) <> 0 THEN RECNUM := RECNUM + 1 END; { PUTMSG } PROCEDURE TXTREAD; VAR LAST, I : INTEGER; MSGTXT : STRING[128]; BEGIN {TXTREAD} LAST := 32761; REPEAT READ(INFILE, MSGNDX); BLIP; IF NOT EOF(INFILE) THEN BEGIN IF NOT EOLN(INFILE) THEN READ(INFILE, ACHAR); { ONE BLANK DELIMITER } if (SEG <> 5) and (msgndx <= 0) then begin write('Bad message number!'); exit(ADVINIT) end; CASE SEG OF 1 : if MSGNDX > locsiz then begin write('Too many locations!'); exit(ADVINIT) end else IF ARY^.LTEXT[MSGNDX] = 0 THEN ARY^.LTEXT[MSGNDX] := RECNUM; 2 : if MSGNDX > locsiz then begin write('Too many locations!'); exit(ADVINIT) end else IF ARY^.STEXT[MSGNDX] = 0 THEN ARY^.STEXT[MSGNDX] := RECNUM; 5 : IF (MSGNDX > 0) AND (MSGNDX <= 100) THEN IF ARY^.PTEXT[MSGNDX] = 0 THEN ARY^.PTEXT[MSGNDX] := RECNUM; 6 : if MSGNDX > rtxsiz then begin write('Too many messages!'); exit(ADVINIT) end else IF ARY^.RTEXT[MSGNDX] = 0 THEN ARY^.RTEXT[MSGNDX] := RECNUM; 10 : BEGIN if CLASSES >= clsmax then begin write('Too many classes!'); exit(ADVINIT) end; CLASSES := CLASSES + 1; IF ARY^.CTEXT[CLASSES] = 0 THEN ARY^.CTEXT[CLASSES] := RECNUM; ARY^.CVAL[CLASSES] := MSGNDX END END; READLN(INFILE, MSGTXT); PUTMSG(MSGTXT, MSGNDX = LAST); LAST := MSGNDX END UNTIL EOF(INFILE); IF LENGTH(SAVEMSG) > 0 THEN BEGIN WHILE LENGTH(SAVEMSG) < 5 DO SAVEMSG := CONCAT(SAVEMSG, ' '); PUTMSG(' ', TRUE) END; CLOSE(INFILE) END; { TXTREAD } PROCEDURE SEGMENT1; BEGIN BLIPER(''); RESET(INFILE, 'ADVx1.TEXT'); SEG := 1; TXTREAD END; { SEGMENT1 } PROCEDURE SEGMENT2; BEGIN BLIPER(''); RESET(INFILE, 'ADVx2.TEXT'); SEG := 2; TXTREAD END; { SEGMENT2 } PROCEDURE SEGMENT3; VAR TVINDEX, INDEX, TRVL, TVCOND, VOIB : INTEGER; BEGIN { SEGMENT3 } TVINDEX := 1; BLIPER(''); RESET(INFILE, 'ADVx3.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE, INDEX); BLIP; IF NOT EOLN(INFILE) THEN BEGIN READ(INFILE, TVCOND, TRVL); IF ARY^.KEY[INDEX] = 0 THEN ARY^.KEY[INDEX] := TVINDEX ELSE ARY^.TRAVEL[TVINDEX - 1] := -ARY^.TRAVEL[TVINDEX - 1]; WHILE NOT EOLN(INFILE) DO BEGIN if TVINDEX > trvsiz then begin write('Too many travel options!'); exit(ADVINIT) end; READ(INFILE, VOIB); ARY^.TRAVEL[TVINDEX] := VOIB; ARY^.TRAVEL2[TVINDEX] := TRVL; ARY^.TRAVEL3[TVINDEX] := TVCOND; TVINDEX := TVINDEX + 1 END; ARY^.TRAVEL[TVINDEX - 1] := -ARY^.TRAVEL[TVINDEX - 1]; READLN(INFILE) END END; CLOSE(INFILE) END; { SEGMENT3 } PROCEDURE SEGMENT4; VAR WORDNUM, NUMBER : INTEGER; BEGIN { SEGMENT4 } WORDNUM := 0; BLIPER(''); RESET(INFILE, 'ADVx4.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE, NUMBER); BLIP; IF NOT EOLN(INFILE) THEN BEGIN READ(INFILE, ACHAR); if WORDNUM >= tabsiz then begin write('Too many vocabulary words!'); exit(ADVINIT) end; WORDNUM := WORDNUM + 1; READLN(INFILE, ARY^.ATAB[WORDNUM]); ARY^.KTAB[WORDNUM] := NUMBER END END; CLOSE(INFILE) END; { SEGMENT4 } PROCEDURE SEGMENT5; BEGIN BLIPER(''); RESET(INFILE, 'ADVx5.TEXT'); SEG := 5; TXTREAD END; { SEGMENT5 } PROCEDURE SEGMENT6; BEGIN BLIPER(''); RESET(INFILE, 'ADVx6.TEXT'); SEG := 6; TXTREAD END; { SEGMENT6 } PROCEDURE SEGMENT7; VAR ILOC1, ILOC2, OBJECT : INTEGER; BEGIN { SEGMENT7 } BLIPER(''); RESET(INFILE, 'ADVx7.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE, OBJECT); if OBJECT > 100 then begin write('Too many objects!'); exit(ADVINIT) end; BLIP; IF NOT EOLN(INFILE) THEN BEGIN READLN(INFILE, ILOC1, ILOC2); ARY^.PLAC[OBJECT] := ILOC1; ARY^.FIXD[OBJECT] := ILOC2 END END; CLOSE(INFILE) END; { SEGMENT7 } PROCEDURE SEGMENT8; VAR VOIB, MSGNUM : INTEGER; BEGIN { SEGMENT8 } BLIPER(''); RESET(INFILE, 'ADVx8.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE, VOIB); if VOIB > vrbsiz then begin write('Too many action verbs!'); exit(ADVINIT) end; BLIP; IF NOT EOLN(INFILE) THEN BEGIN READLN(INFILE, MSGNUM); ARY^.ACTSPK[VOIB] := MSGNUM END END; CLOSE(INFILE) END; { SEGMENT8 } PROCEDURE SEGMENT9; VAR I, TEMP, COND, LOC : INTEGER; BEGIN { SEGMENT9 } BLIPER(''); RESET(INFILE, 'ADVx9.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE, COND); if COND > 15 then begin write('Too many conditions!'); exit(ADVINIT) end; BLIP; TEMP := 1; FOR I := 1 TO COND DO TEMP := TEMP * 2; WHILE NOT EOLN(INFILE) DO BEGIN READ(INFILE, LOC); if LOC > locsiz then begin write('Too many locations!'); exit(ADVINIT) end; VARY^.COND[LOC] := VARY^.COND[LOC] + TEMP END; READLN(INFILE) END; CLOSE(INFILE) END; { SEGMENT9 } PROCEDURE SEGMENTA; BEGIN BLIPER(''); RESET(INFILE, 'ADVx10.TEXT'); SEG := 10; TXTREAD END; { SEGMENTA } PROCEDURE SEGMENTB; VAR HINT, TURNS, POINTS, QUES, ANS : INTEGER; BEGIN { SEGMENTB } BLIPER(''); RESET(INFILE, 'ADVx11.TEXT'); WHILE NOT EOF(INFILE) DO BEGIN READ(INFILE, HINT); if HINT > hntmax then begin write('Too many hints!'); exit(ADVINIT) end; BLIP; IF NOT EOLN(INFILE) THEN BEGIN READLN(INFILE, TURNS, POINTS, QUES, ANS); ARY^.HINTS[HINT, 1] := TURNS; ARY^.HINTS[HINT, 2] := POINTS; ARY^.HINTS[HINT, 3] := QUES; ARY^.HINTS[HINT, 4] := ANS END END; CLOSE(INFILE) END; { SEGMENTB } PROCEDURE LINKUP; VAR K, I : INTEGER; BEGIN {LINKUP} BLIP; WITH ARY^, VARY^ DO FOR I := 1 TO locsiz DO IF ((LTEXT[I] <> 0) AND (KEY[I] <> 0)) THEN IF TRAVEL[KEY[I]] = 1 THEN COND[I] := 2; BLIP; WITH ARY^ DO FOR I := 100 DOWNTO 1 DO IF FIXD[I] > 0 THEN BEGIN DROP(I + 100, FIXD[I]); DROP(I, PLAC[I]) END; BLIP; WITH ARY^ DO FOR I := 100 DOWNTO 1 DO BEGIN VARY^.FIXED[I] := FIXD[I]; IF (PLAC[I] <> 0) AND (FIXD[I] <= 0) THEN DROP(I, PLAC[I]) END; BLIP; WITH ARY^, VARY^ DO FOR I := 50 TO 100 DO IF PTEXT[I] <> 0 THEN PROP[I] := -1 END; {LINKUP} BEGIN { ADVINIT } NEW(ARY); FILLCHAR(ARY^.DBLK, SIZEOF(ARYS), CHR(0)); { ZERO ARRAYS } NEW(VARY); FILLCHAR(VARY^.DBLK, SIZEOF(VARYS), CHR(0)); { ZERO ARRAYS } CLASSES := 0; RECNUM := 1; COUNT := 0; REWRITE(MSGFILE, 'ADVxMSGS'); MSGFILE^ := 'MSGFIL'; {WILL BE PUT } SAVEMSG := ''; SEGMENT1; {LONG DESCRIPTIONS} SEGMENT2; {SHORT DESCRIPTIONS} SEGMENT3; {TRAVEL OPTIONS} SEGMENT4; {WORD TABLE} SEGMENT5; {OBJECT PROPERTIES} SEGMENT6; {MISC MESSAGES} SEGMENT7; {OBJECT LOCATIONS} SEGMENT8; {VERB DEFAULT ACTIONS} SEGMENT9; {LIQUID ASSETS} SEGMENTA; {PLAYER CLASS MESSAGES} SEGMENTB; {HINTS} LINKUP; {BUILD MISC ARRAYS} PUTMSG('EXTMSG', FALSE); PUT(MSGFILE); {PURGE LAST BUFFER} CLOSE(MSGFILE, LOCK); WRITELN; writeln('ADVXMSGS created.'); REWRITE(OUTFILE, 'ADVxDATA'); I := (SIZEOF(ARYS) + 511) DIV 512; IF I <> BLOCKWRITE(OUTFILE, ARY^.DBLK, I) THEN BEGIN WRITELN('Error writing file.'); EXIT(ADVINIT) END; I := (SIZEOF(VARYS) + 511) DIV 512; IF I <> BLOCKWRITE(OUTFILE, VARY^.DBLK, I) THEN BEGIN WRITELN('Error writing file.'); EXIT(ADVINIT) END; CLOSE(OUTFILE, LOCK); WRITELN('ADVXDATA created.') END. ======================================================================================== DOCUMENT :usus Folder:VOL24:advxinit2.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL24:advxinit4.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL24:advxsegs.text ======================================================================================== PROCEDURE NAMEANDPW; FORWARD; FUNCTION GETSCORE(SCORECMD : BOOLEAN ) : INTEGER; FORWARD; FUNCTION TOTING(OBJECT : INTEGER) : BOOLEAN; FORWARD; FUNCTION AT(OBJECT : INTEGER) : BOOLEAN; FORWARD; FUNCTION MIN(I, J : INTEGER) : INTEGER; FORWARD; FUNCTION MAX(I, J : INTEGER) : INTEGER; FORWARD; FUNCTION RAN(NUM : INTEGER) : INTEGER; FORWARD; FUNCTION PERCENT(I : INTEGER) : BOOLEAN; FORWARD; FUNCTION HERE(OBJECT : INTEGER) : BOOLEAN; FORWARD; FUNCTION DARK : BOOLEAN; FORWARD; FUNCTION FORCED(LOC : INTEGER) : BOOLEAN; FORWARD; FUNCTION BITSET(I, J : INTEGER) : BOOLEAN; FORWARD; FUNCTION LIQ2(PBOTL : INTEGER) : INTEGER; FORWARD; FUNCTION LIQ : INTEGER; FORWARD; FUNCTION LIQLOC(LOC : INTEGER) : INTEGER; FORWARD; FUNCTION VOCAB(WORD : STRING;WHAT : INTEGER) : INTEGER; FORWARD; PROCEDURE CARRY(OBJECT, WHERE : INTEGER); FORWARD; PROCEDURE DROP(OBJECT, WHERE : INTEGER); FORWARD; PROCEDURE MOVE(OBJECT, WHERE : INTEGER); FORWARD; PROCEDURE JUGGLE(OBJECT : INTEGER); FORWARD; PROCEDURE DESTROY(OBJECT : INTEGER); FORWARD; FUNCTION PUT(OBJECT, WHERE, PVAL : INTEGER) : INTEGER; FORWARD; PROCEDURE SPEAK(MSG : INTEGER); FORWARD; PROCEDURE PSPEAK(MSG, SKIP : INTEGER); FORWARD; FUNCTION YES(MSG, SPKYES, SPKNO : INTEGER) : BOOLEAN; FORWARD; PROCEDURE ERRORHALT(I : INTEGER); FORWARD; PROCEDURE TESTCLOSE; FORWARD; { SUBROUTINES FOR ADVENTURE } SEGMENT PROCEDURE SET_NEW_LOC; VAR T1, T2, T3 : BOOLEAN; PROCEDURE PLOVERALCOVE; BEGIN NEWLOC := 199 - VBL^.LOC; IF (VBL^.HLDING = 0) OR ((VBL^.HLDING = 1) AND TOTING(EMERALD)) THEN ELSE BEGIN NEWLOC := VBL^.LOC; SPEAK(ARY^.RTEXT[117]) END; EXIT(SET_NEW_LOC) END; { PLOVERALCOVE } PROCEDURE TROLLBRIDGE; BEGIN IF VARY^.PROP[TROLL] = 1 THEN BEGIN PSPEAK(TROLL, 1); VARY^.PROP[TROLL] := 0; MOVE(TROLL2, 0); MOVE(TROLL2 + 100, 0); MOVE(TROLL, ARY^.PLAC[TROLL]); MOVE(TROLL + 100, ARY^.FIXD[TROLL]); JUGGLE(CHASM); NEWLOC := VBL^.LOC END ELSE BEGIN NEWLOC := ARY^.PLAC[TROLL] + ARY^.FIXD[TROLL] - VBL^.LOC; IF VARY^.PROP[TROLL] = 0 THEN VARY^.PROP[TROLL] := 1; IF TOTING(BEAR) THEN BEGIN SPEAK(ARY^.RTEXT[162]); VARY^.PROP[CHASM] := 1; VARY^.PROP[TROLL] := 2; DROP(BEAR, NEWLOC); VARY^.FIXED[BEAR] := -1; VARY^.PROP[BEAR] := 3; IF VARY^.PROP[SPICES] < 0 THEN VBL^.TALLY2 := VBL^.TALLY2 + 1; VBL^.OLDLC2 := NEWLOC; HE_DIED := TRUE END END; EXIT(SET_NEW_LOC) END; { TROLLBRIDGE } BEGIN { SET_NEW_LOC } KK := ARY^.KEY[VBL^.LOC]; IF KK = 0 THEN ERRORHALT(26); NEWLOC := VBL^.LOC; IF K = NULL THEN EXIT(SET_NEW_LOC); SKIPIT := FALSE; IF K = BACK THEN BEGIN SKIPIT := TRUE; IF FORCED(K) THEN K := VBL^.OLDLC2 ELSE K := VBL^.OLDLOC; VBL^.OLDLC2 := VBL^.OLDLOC; VBL^.OLDLOC := VBL^.LOC; K2 := 0; IF K = VBL^.LOC THEN BEGIN SPEAK(ARY^.RTEXT[91]); EXIT(SET_NEW_LOC) END; OK := FALSE; KK := KK - 1; REPEAT KK := KK + 1; IF K = ARY^.TRAVEL2[KK] THEN BEGIN K := ABS(ARY^.TRAVEL[KK]); KK := ARY^.KEY[VBL^.LOC]; OK := TRUE END ELSE BEGIN IF ARY^.TRAVEL2[KK] <= 300 THEN BEGIN J := ARY^.KEY[ARY^.TRAVEL2[KK]]; IF FORCED(ARY^.TRAVEL2[KK]) AND (ARY^.TRAVEL2[J] = K) THEN K2 := KK END; IF ARY^.TRAVEL[KK] < 0 THEN BEGIN KK := K2; IF KK = 0 THEN BEGIN SPEAK(ARY^.RTEXT[140]); EXIT(SET_NEW_LOC) END; K := ABS(ARY^.TRAVEL[KK]); KK := ARY^.KEY[VBL^.LOC]; OK := TRUE END END UNTIL OK OR (ARY^.TRAVEL2[KK] = K) END; { BACK } IF K = LOOK THEN BEGIN IF VBL^.DETAIL < 3 THEN SPEAK(ARY^.RTEXT[15]); VBL^.DETAIL := VBL^.DETAIL + 1; VBL^.WZDARK := FALSE; VARY^.ABB[VBL^.LOC] := 0 END ELSE IF K = CAVE THEN BEGIN IF VBL^.LOC < 8 THEN SPEAK(ARY^.RTEXT[57]) ELSE SPEAK(ARY^.RTEXT[58]) END ELSE BEGIN { NOT SPECIAL } IF NOT SKIPIT THEN BEGIN VBL^.OLDLC2 := VBL^.OLDLOC; VBL^.OLDLOC := VBL^.LOC END; { TRAVEL = VERB } { TRAVEL2 = WHERE TO GO } { TRAVEL3 = CONDITION (IF ANY) } KK := KK - 1; REPEAT KK := KK + 1; OK := (ABS(ARY^.TRAVEL[KK]) = 1) OR (ABS(ARY^.TRAVEL[KK]) = K) UNTIL OK OR (ARY^.TRAVEL[KK] < 0); IF NOT OK THEN BEGIN SPK := 12; CASE K OF 43, 44, 45, 46, 47, 48, 49, 50, 29, 30 : SPK := 9; 7, 36, 37 : SPK := 10; 11, 19 : SPK := 11; 62, 65 : SPK := 42; 17 : SPK := 80 END; IF (VBL^.VERB = FIND) OR (VBL^.VERB = INVENTORY) THEN SPK := 59; SPEAK(ARY^.RTEXT[SPK]); EXIT(SET_NEW_LOC) END; REPEAT NEWLOC := ARY^.TRAVEL2[KK]; TVCOND := ARY^.TRAVEL3[KK]; K := TVCOND MOD 100; IF K = 0 THEN BEGIN T1 := FALSE; T2 := FALSE; T3 := FALSE END ELSE BEGIN T1 := TOTING(K); T2 := AT(K); T3 := VARY^.PROP[K] <> (TVCOND DIV 100 - 3) END; IF ((TVCOND <= 100) AND ((TVCOND = 0) OR PERCENT(TVCOND))) OR ((TVCOND > 100) AND (TVCOND <= 300) AND (T1 OR ((TVCOND > 200) AND T2))) OR ((TVCOND > 300) AND T3) THEN BEGIN IF NEWLOC <= 300 THEN EXIT(SET_NEW_LOC); IF NEWLOC <= 500 THEN BEGIN NEWLOC := NEWLOC - 300; IF NEWLOC = 1 THEN PLOVERALCOVE ELSE IF NEWLOC = 2 THEN DROP(EMERALD, VBL^.LOC) ELSE IF NEWLOC = 3 THEN TROLLBRIDGE ELSE ERRORHALT(20) END ELSE BEGIN SPEAK(ARY^.RTEXT[NEWLOC - 500]); NEWLOC := VBL^.LOC; EXIT(SET_NEW_LOC) END END; REPEAT IF ARY^.TRAVEL[KK] < 0 THEN ERRORHALT(25); KK := KK + 1 UNTIL (TVCOND <> ARY^.TRAVEL3[KK]) AND (NEWLOC <> ARY^.TRAVEL2[KK]) UNTIL FALSE { EXIT IS BY EXIT PROC } END { NOT SPECIAL } END; { SET_NEW_LOC } SEGMENT PROCEDURE DWARFSTUFF; VAR LASTLOC : INTEGER; TBITSET, TFORCED : BOOLEAN; PROCEDURE PIRATESTUFF; BEGIN { PIRATESTUFF } K := 0; STEAL := FALSE; FOR J := 50 TO MAXTRS DO BEGIN IF (J = PYRAMID) AND ((VBL^.LOC = ARY^.PLAC[PYRAMID]) OR (VBL^.LOC = ARY^.PLAC[EMERALD])) THEN { NOTHING } ELSE BEGIN STEAL := STEAL OR TOTING(J); IF VARY^.PLACE[J] = VBL^.LOC THEN K := 1 END END; IF STEAL THEN BEGIN SPEAK(ARY^.RTEXT[128]); IF VARY^.PLACE[MESSAGE] = 0 THEN MOVE(CHEST, VBL^.CHLOC); MOVE(MESSAGE, VBL^.CHLOC2); FOR J := 50 TO MAXTRS DO BEGIN IF (J = PYRAMID) AND ((VBL^.LOC = ARY^.PLAC[PYRAMID]) OR (VBL^.LOC = ARY^.PLAC[EMERALD])) THEN { NOTHING } ELSE BEGIN IF (VARY^.PLACE[J] = VBL^.LOC) AND (VARY^.FIXED[J] = 0) THEN CARRY(J, VBL^.LOC); IF TOTING(J) THEN DROP(J, VBL^.CHLOC) END END; VARY^.DLOC[6] := VBL^.CHLOC; VARY^.ODLOC[6] := VBL^.CHLOC; VARY^.DSEEN[6] := FALSE END ELSE BEGIN IF (VBL^.TALLY = (VBL^.TALLY2 + 1)) AND (K = 0) AND HERE(LAMP) AND (VARY^.PLACE[CHEST] = 0) AND (VARY^.PROP[LAMP] = 1) THEN BEGIN SPEAK(ARY^.RTEXT[186]); MOVE(CHEST, VBL^.CHLOC); MOVE(MESSAGE, VBL^.CHLOC2); VARY^.DLOC[6] := VBL^.CHLOC; VARY^.ODLOC[6] := VBL^.CHLOC; VARY^.DSEEN[6] := FALSE END ELSE IF (VARY^.ODLOC[6] <> VARY^.DLOC[6]) AND PERCENT(20) THEN SPEAK(ARY^.RTEXT[127]) END END; { PIRATESTUFF } BEGIN { DWARFSTUFF } IF VBL^.DFLAG = 1 THEN IF (VBL^.LOC >= 15) AND PERCENT(95) THEN BEGIN VBL^.DFLAG := 2; FOR I := 1 TO 2 DO IF PERCENT(50) THEN VARY^.DLOC[1 + RAN(5)] := 0; FOR I := 1 TO 5 DO BEGIN IF VARY^.DLOC[I] = VBL^.LOC THEN VARY^.DLOC[I] := DALTLC; VARY^.ODLOC[I] := VARY^.DLOC[I] END; SPEAK(ARY^.RTEXT[3]); DROP(AXE, VBL^.LOC) END ELSE ELSE BEGIN VBL^.DTOTAL := 0; ATTACK := 0; STICK := 0; FOR I := 1 TO 6 DO IF VARY^.DLOC[I] <> 0 THEN BEGIN J := 1; KK := ARY^.KEY[VARY^.DLOC[I]]; IF KK <> 0 THEN REPEAT NEWLOC := ARY^.TRAVEL2[KK]; IF (J > 1) AND (J <= 21) THEN LASTLOC := VARY^.TK[J - 1]; IF NEWLOC <= locsiz THEN BEGIN TBITSET := BITSET(NEWLOC, 3); TFORCED := FORCED(NEWLOC) END ELSE BEGIN TBITSET := FALSE; TFORCED := FALSE END; IF (NEWLOC > 300) OR (NEWLOC = VARY^.ODLOC[I]) OR (NEWLOC < 15) OR ((J > 1) AND (NEWLOC = LASTLOC)) OR (NEWLOC = VARY^.DLOC[I]) OR ((I = 6) AND TBITSET) OR (ARY^.TRAVEL3[KK] = 100) OR TFORCED OR (J >= 20) THEN { nothing } ELSE BEGIN VARY^.TK[J] := NEWLOC; J := J + 1 END; KK := KK + 1 UNTIL ARY^.TRAVEL[KK - 1] < 0; VARY^.TK[J] := VARY^.ODLOC[I]; IF J >= 2 THEN J := J - 1; J := 1 + RAN(J); VARY^.ODLOC[I] := VARY^.DLOC[I]; VARY^.DLOC[I] := VARY^.TK[J]; VARY^.DSEEN[I] := (VARY^.DSEEN[I] AND (VBL^.LOC >= 15)) OR (VARY^.DLOC[I] = VBL^.LOC) OR (VARY^.ODLOC[I] = VBL^.LOC); IF VARY^.DSEEN[I] THEN BEGIN VARY^.DLOC[I] := VBL^.LOC; IF I = 6 THEN IF (VBL^.LOC <> VBL^.CHLOC) AND (VARY^.PROP[CHEST] < 0) THEN PIRATESTUFF ELSE ELSE BEGIN VBL^.DTOTAL := VBL^.DTOTAL + 1; IF VARY^.ODLOC[I] = VARY^.DLOC[I] THEN BEGIN ATTACK := ATTACK + 1; IF VBL^.KNFLOC >= 0 THEN VBL^.KNFLOC := VBL^.LOC; IF RAN(1000) < (95 * (VBL^.DFLAG - 2)) THEN STICK := STICK + 1 END END END END END; IF VBL^.DTOTAL <> 0 THEN BEGIN IF VBL^.DTOTAL = 1 THEN SPEAK(ARY^.RTEXT[4]) ELSE BEGIN WRITE('There are ', VBL^.DTOTAL, ' threatening '); WRITELN('little dwarves in the room with you.') END; IF ATTACK <> 0 THEN BEGIN IF VBL^.DFLAG = 2 THEN VBL^.DFLAG := 3; IF ATTACK = 1 THEN BEGIN SPEAK(ARY^.RTEXT[5]); K := 52 END ELSE BEGIN K := 6; WRITEln(ATTACK, ' of them throw knives at you.') END; IF STICK > 1 THEN WRITELN(STICK, ' of them get you!') ELSE SPEAK(ARY^.RTEXT[K + STICK]); IF STICK <> 0 THEN BEGIN VBL^.OLDLC2 := VBL^.LOC; HE_DIED := TRUE END END END END; { DWARFSTUFF } segment PROCEDURE DESCRIBE_CURRENT_LOCATION; BEGIN IF VBL^.LOC = 0 THEN BEGIN HE_DIED := TRUE; EXIT(DESCRIBE_CURRENT_LOCATION) END; KK := ARY^.STEXT[VBL^.LOC]; IF ((VARY^.ABB[VBL^.LOC] MOD VBL^.ABBNUM) = 0) OR (KK = 0) THEN KK := ARY^.LTEXT[VBL^.LOC]; IF (NOT FORCED(VBL^.LOC)) AND DARK THEN BEGIN IF VBL^.WZDARK AND PERCENT(35) THEN BEGIN HE_DIED := TRUE; PIT := TRUE; EXIT(DESCRIBE_CURRENT_LOCATION) END; KK := ARY^.RTEXT[16] END; IF TOTING(BEAR) THEN SPEAK(ARY^.RTEXT[141]); SPEAK(KK); K := 1; IF FORCED(VBL^.LOC) THEN BEGIN SET_NEW_LOC; NEWLOCSET := TRUE; EXIT(DESCRIBE_CURRENT_LOCATION) END; IF (VBL^.LOC = 33) AND PERCENT(25) AND NOT VBL^.CLOSING THEN SPEAK(ARY^.RTEXT[8]); if (vbl^.loc = 36) and percent(30) and (vbl^.stflag = 0) then begin speak(ary^.rtext[90]); vbl^.stflag := 1 end; IF NOT DARK THEN BEGIN VARY^.ABB[VBL^.LOC] := VARY^.ABB[VBL^.LOC] + 1; I := VARY^.ATLOC[VBL^.LOC]; WHILE I <> 0 DO BEGIN VBL^.OBJ := I; IF VBL^.OBJ > 100 THEN VBL^.OBJ := VBL^.OBJ - 100; IF (VBL^.OBJ <> STEPS) OR (NOT TOTING(NUGGET)) THEN BEGIN IF VARY^.PROP[VBL^.OBJ] < 0 THEN IF NOT VBL^.CLOSED THEN BEGIN VARY^.PROP[VBL^.OBJ] := 0; IF (VBL^.OBJ = RUG) OR (VBL^.OBJ = CHAIN) THEN VARY^.PROP[VBL^.OBJ] := 1; VBL^.TALLY := VBL^.TALLY - 1; IF (VBL^.TALLY = VBL^.TALLY2) AND (VBL^.TALLY <> 0) THEN VBL^.LIMIT := MIN(35, VBL^.LIMIT) END; IF NOT VBL^.CLOSED THEN BEGIN KK := VARY^.PROP[VBL^.OBJ]; IF (VBL^.OBJ = STEPS) AND (VBL^.LOC = VARY^.FIXED[STEPS]) THEN KK := 1; PSPEAK(VBL^.OBJ, KK) END END; I := VARY^.LINK[I] END { WHILE I <> 0 DO } END END; { DESCRIBE_CURRENT_LOCATION } segment PROCEDURE CHECKHINTS; PROCEDURE GIVEHINT; BEGIN VARY^.HINTLC[HINT] := 0; IF YES(ARY^.HINTS[HINT, 3], 0, 54) THEN BEGIN WRITE('I am prepared to give you a hint, but '); WRITELN(' it will cost you ', ARY^.HINTS[HINT, 2], ' points.'); VARY^.HINTED[HINT] := YES(175, ARY^.HINTS[HINT, 4], 54); IF VARY^.HINTED[HINT] AND (VBL^.LIMIT > 30) THEN VBL^.LIMIT := VBL^.LIMIT + 30 * ARY^.HINTS[HINT, 2] END END; { GIVEHINT } PROCEDURE CAVEHINT; BEGIN IF (VARY^.PROP[GRATE] = 0) AND NOT HERE(KEYS) THEN GIVEHINT ELSE VARY^.HINTLC[HINT] := 0 END; { CAVEHINT } PROCEDURE BIRDHINT; BEGIN IF HERE(BIRD) AND TOTING(ROD) AND (VBL^.OBJ = BIRD) THEN GIVEHINT END; { BIRDHINT } PROCEDURE SNAKEHINT; BEGIN IF HERE(SNAKE) AND NOT HERE(BIRD) THEN GIVEHINT ELSE VARY^.HINTLC[HINT] := 0 END; { SNAKEHINT } PROCEDURE MAZEHINT; BEGIN IF (VARY^.ATLOC[VBL^.LOC] = 0) AND (VARY^.ATLOC[VBL^.OLDLOC] = 0) AND (VARY^.ATLOC[VBL^.OLDLC2] = 0) AND (VBL^.HLDING > 1) THEN GIVEHINT ELSE VARY^.HINTLC[HINT] := 0 END; { MAZEHINT } PROCEDURE DARKHINT; BEGIN IF (VARY^.PROP[EMERALD] <> -1) AND (VARY^.PROP[PYRAMID] = -1) THEN GIVEHINT ELSE VARY^.HINTLC[HINT] := 0 END; { DARKHINT } PROCEDURE WITTHINT; BEGIN GIVEHINT END; { WITTHINT } BEGIN { CHECKHINTS } FOR HINT := 4 TO HNTSIZ DO BEGIN IF NOT VARY^.HINTED[HINT] THEN BEGIN IF BITSET(VBL^.LOC, HINT) THEN VARY^.HINTLC[HINT] := VARY^.HINTLC[HINT] + 1 ELSE VARY^.HINTLC[HINT] := 0; IF VARY^.HINTLC[HINT] >= ARY^.HINTS[HINT, 1] THEN CASE HINT OF 4 : CAVEHINT; 5 : BIRDHINT; 6 : SNAKEHINT; 7 : MAZEHINT; 8 : DARKHINT; 9 : WITTHINT END { CASE OF HINT } END END END; { CHECKHINTS } ======================================================================================== DOCUMENT :usus Folder:VOL24:advxsubs.text ======================================================================================== { SUBROUTINES FOR ADVENTURE } PROCEDURE NAMEANDPW; VAR ACHR : CHAR; ACHAR : STRING[1]; BEGIN { NAMEANDPW } WRITELN('Enter your name please.'); READLN(NAMEOFUSER); WRITELN('Enter your password.'); READ(KEYBOARD, ACHR); if ACHR in ['a'..'z'] then ACHR := chr(ord(ACHR) - 32); ACHAR := ' '; TESTPW := ''; WHILE NOT EOLN(KEYBOARD) DO BEGIN ACHAR[1] := ACHR; IF ACHR = CHR(8) THEN IF LENGTH(TESTPW) > 0 THEN BEGIN DELETE(TESTPW, LENGTH(TESTPW), 1); WRITE(CHR(8), ' ', CHR(8)) END ELSE ELSE BEGIN WRITE('X'); TESTPW := CONCAT(TESTPW, ACHAR) END; READ(KEYBOARD, ACHR); if ACHR in ['a'..'z'] then ACHR := chr(ord(ACHR) - 32) END; NAMEOFUSER := CONCAT(NAMEOFUSER, '.AVSV') END; { NAMEANDPW } FUNCTION GETSCORE{SCORECMD : BOOLEAN) : INTEGER}; VAR I, K, SCORE : INTEGER; BEGIN { GETSCORE } MAXSCORE := 0; SCORE := 0; FOR I := 50 TO MAXTRS DO IF ARY^.PTEXT[I] <> 0 THEN BEGIN IF I = CHEST THEN K := 20 ELSE IF I > CHEST THEN K := 16 ELSE K := 12; IF (VARY^.PROP[I] >= 0) THEN SCORE := SCORE + 2; IF (VARY^.PLACE[I] = 3) AND (VARY^.PROP[I] = 0) THEN SCORE := SCORE + K - 2; MAXSCORE := MAXSCORE + K END; SCORE := SCORE + (MAXDIE - VBL^.NUMDIE) * 10; MAXSCORE := MAXSCORE + MAXDIE * 10; IF VBL^.DFLAG <> 0 THEN SCORE := SCORE + 25; MAXSCORE := MAXSCORE + 25; IF NOT (GAVEUP OR SCORECMD) THEN SCORE := SCORE + 4; MAXSCORE := MAXSCORE + 4; IF VBL^.CLOSING THEN SCORE := SCORE + 25; MAXSCORE := MAXSCORE + 25; CASE BONUS OF 0 : SCORE := SCORE + 10; 135 : SCORE := SCORE + 25; 134 : SCORE := SCORE + 30; 133 : SCORE := SCORE + 45 END; MAXSCORE := MAXSCORE + 45; IF VARY^.PLACE[MAGAZINE] = 108 THEN SCORE := SCORE + 1; MAXSCORE := MAXSCORE + 1; SCORE := SCORE + 2; MAXSCORE := MAXSCORE + 2; FOR I := 1 TO HNTSIZ DO IF VARY^.HINTED[I] THEN SCORE := SCORE - ARY^.HINTS[I, 2]; GETSCORE := SCORE END; { GETSCORE } FUNCTION TOTING{OBJECT : INTEGER) : BOOLEAN}; BEGIN TOTING := (VARY^.PLACE[OBJECT] = -1) END; { TOTING } FUNCTION AT{OBJECT : INTEGER) : BOOLEAN}; BEGIN AT := (VARY^.PLACE[OBJECT] = VBL^.LOC) OR (VARY^.FIXED[OBJECT] = VBL^.LOC) END; { AT } FUNCTION MIN{I, J : INTEGER) : INTEGER}; BEGIN { MIN } IF J < I THEN MIN := J ELSE MIN := I END; { MIN } FUNCTION MAX{I, J : INTEGER) : INTEGER}; BEGIN { MAX } IF J > I THEN MAX := J ELSE MAX := I END; { MAX } FUNCTION RAN{NUM : INTEGER) : INTEGER}; VAR TEMP : INTEGER; TEMP2 : REAL; BEGIN { RAN } TEMP := SEED * 899; IF TEMP < 0 THEN TEMP := TEMP + 32767 + 1; TEMP2 := (TEMP - 1) / 32767.0; RAN := TRUNC(TEMP2 * NUM); SEED := TEMP END; { RAN } FUNCTION PERCENT{I : INTEGER) : BOOLEAN}; BEGIN PERCENT := (RAN(100) < I) END; { PERCENT } FUNCTION HERE{OBJECT : INTEGER) : BOOLEAN}; BEGIN HERE := (VARY^.PLACE[OBJECT] = VBL^.LOC) OR TOTING(OBJECT) END; { HERE } FUNCTION DARK {: BOOLEAN}; BEGIN DARK := ((VARY^.COND[VBL^.LOC] MOD 2) = 0) AND ((VARY^.PROP[LAMP] = 0) OR NOT HERE(LAMP)) END; { DARK } FUNCTION FORCED{LOC : INTEGER) : BOOLEAN}; BEGIN FORCED := VARY^.COND[LOC] = 2 END; { FORCED } FUNCTION BITSET{I, J : INTEGER) : BOOLEAN}; VAR K, TEMP : INTEGER; BEGIN { BITSET } TEMP := VARY^.COND[I]; FOR K := 1 TO J DO TEMP := TEMP DIV 2; BITSET := (TEMP MOD 2) = 1 END; { BITSET } FUNCTION LIQ2{PBOTL : INTEGER) : INTEGER}; VAR TEMP : INTEGER; BEGIN { LIQ2 } TEMP := PBOTL DIV 2; LIQ2 := ((1 - PBOTL) * WATER + TEMP * (WATER + OIL)) END; { LIQ2 } FUNCTION LIQ {: INTEGER}; BEGIN LIQ := LIQ2(MAX(VARY^.PROP[BOTTLE], -1 - VARY^.PROP[BOTTLE])) END; { LIQ } FUNCTION LIQLOC{LOC : INTEGER) : INTEGER}; VAR TEMP1, TEMP2 : INTEGER; BEGIN { LIQLOC } TEMP1 := (VARY^.COND[LOC] DIV 2) * 2; { EVEN COND ONLY } TEMP2 := VARY^.COND[LOC] DIV 4; LIQLOC := LIQ2((TEMP1 MOD 8 - 5) * (TEMP2 MOD 2) + 1) END; { LIQLOC } FUNCTION VOCAB{WORD : STRING;WHAT : INTEGER) : INTEGER}; VAR I, J, K : INTEGER; BEGIN { VOCAB } I := 1; J := tabsiz; REPEAT K := (I + J) DIV 2; IF ARY^.ATAB[K] <= WORD THEN I := K + 1; IF ARY^.ATAB[K] >= WORD THEN J := K - 1 UNTIL I > J; IF K > 1 THEN IF ARY^.ATAB[K - 1] = WORD THEN K := K - 1; { FIND FIRST WORD } VOCAB := -1; IF ARY^.ATAB[K] = WORD THEN VOCAB := ARY^.KTAB[K]; IF WHAT >= 0 THEN BEGIN WHILE (ARY^.ATAB[K] = WORD) AND (WHAT <> (ARY^.KTAB[K] DIV 1000)) DO K := K + 1; IF ARY^.ATAB[K] = WORD THEN VOCAB := ARY^.KTAB[K] MOD 1000 END END; { VOCAB } PROCEDURE CARRY{OBJECT, WHERE : INTEGER}; VAR TEMP : INTEGER; PROCEDURE LINKUP; BEGIN { LINKUP } TEMP := VARY^.ATLOC[WHERE]; WHILE (VARY^.LINK[TEMP] <> OBJECT) DO TEMP := VARY^.LINK[TEMP]; VARY^.LINK[TEMP] := VARY^.LINK[OBJECT] END; { LINKUP } BEGIN { CARRY } IF OBJECT <= 100 THEN IF VARY^.PLACE[OBJECT] <> -1 THEN BEGIN VARY^.PLACE[OBJECT] := -1; VBL^.HLDING := VBL^.HLDING + 1; IF VARY^.ATLOC[WHERE] = OBJECT THEN VARY^.ATLOC[WHERE] := VARY^.LINK[OBJECT] ELSE LINKUP END ELSE ELSE IF VARY^.ATLOC[WHERE] = OBJECT THEN VARY^.ATLOC[WHERE] := VARY^.LINK[OBJECT] ELSE LINKUP END; { CARRY } PROCEDURE DROP{OBJECT, WHERE : INTEGER}; BEGIN IF OBJECT > 100 THEN VARY^.FIXED[OBJECT - 100] := WHERE ELSE BEGIN IF VARY^.PLACE[OBJECT] = -1 THEN VBL^.HLDING := VBL^.HLDING - 1; VARY^.PLACE[OBJECT] := WHERE END; IF WHERE > 0 THEN BEGIN VARY^.LINK[OBJECT] := VARY^.ATLOC[WHERE]; VARY^.ATLOC[WHERE] := OBJECT END END; { DROP } PROCEDURE MOVE{OBJECT, WHERE : INTEGER}; VAR FROM : INTEGER; BEGIN { MOVE } IF OBJECT > 100 THEN FROM := VARY^.FIXED[OBJECT - 100] ELSE FROM := VARY^.PLACE[OBJECT]; IF (FROM > 0) AND (FROM <= 300) THEN CARRY(OBJECT, FROM); DROP(OBJECT, WHERE) END; { MOVE } PROCEDURE JUGGLE{OBJECT : INTEGER}; BEGIN MOVE(OBJECT, VARY^.PLACE[OBJECT]); MOVE(OBJECT + 100, VARY^.FIXED[OBJECT]) END; { JUGGLE } PROCEDURE DESTROY{OBJECT : INTEGER}; BEGIN MOVE(OBJECT, 0) END; { DESTROY } FUNCTION PUT{OBJECT, WHERE, PVAL : INTEGER) : INTEGER}; BEGIN MOVE(OBJECT, WHERE); PUT := -1 - PVAL END; { PUT } PROCEDURE SPEAK{MSG : INTEGER}; VAR I : INTEGER; MTEMP : STRING[6]; MTEMP2 : STRING; MTEXT : STRING[255]; PROCEDURE HOLDUP; BEGIN { HOLDUP } LINE := LINE + 1; IF LINE >= (TERMHIGHT - 1) THEN BEGIN LINE := 1; WRITE(CHR(7), ' Press to continue.'); READLN END END; { HOLDUP } BEGIN { SPEAK } MTEMP := ' '; MTEXT := ''; IF MSG > 0 THEN BEGIN SEEK(MSGFILE, MSG); REPEAT GET(MSGFILE); FOR I := 1 TO 6 DO MTEMP[I] := MSGFILE^[I]; IF ORD(MTEMP[1]) > 128 THEN MTEMP[1] := CHR(ORD(MTEMP[1]) - 128); IF ORD(MTEMP[2]) > 128 THEN MTEMP[2] := CHR(ORD(MTEMP[2]) - 128); MTEXT := CONCAT(MTEXT, MTEMP); IF LENGTH(MTEXT) > TERMWIDTH THEN BEGIN I := TERMWIDTH; WHILE MTEXT[I] <> ' ' DO I := I - 1; MTEMP2 := COPY(MTEXT, 1, I - 1); DELETE(MTEXT, 1, I); WRITELN(MTEMP2); HOLDUP END UNTIL ORD(MSGFILE^[1]) > 128; IF MTEXT <> ' ' THEN { DONT PRINT DUMMY MSG } BEGIN WRITELN(MTEXT); HOLDUP END END END; { SPEAK } PROCEDURE PSPEAK{MSG, SKIP : INTEGER}; VAR I, M : INTEGER; BEGIN { PSPEAK } M := ARY^.PTEXT[MSG]; SEEK(MSGFILE, M); FOR I := 0 TO SKIP DO BEGIN REPEAT GET(MSGFILE); M := M + 1 UNTIL ORD(MSGFILE^[1]) > 128 END; GET(MSGFILE); { INSURE GET BETWEEN SEEKS } SPEAK(M) END; { PSPEAK } FUNCTION YES{MSG, SPKYES, SPKNO : INTEGER) : BOOLEAN}; VAR i : integer; INLINE : STRING; BEGIN { YES } YEA := FALSE; SKIPIT := FALSE; IF MSG <> 0 THEN SPEAK(ARY^.RTEXT[MSG]); LINE := 1; REPEAT IF SKIPIT THEN WRITELN('Please answer the question with yes or no.'); SKIPIT := TRUE; READLN(INLINE); for i := 1 to length(INLINE) do if INLINE[i] in ['a'..'z'] then INLINE[i] := chr(ord(INLINE[i]) - 32) UNTIL (INLINE = 'YES') OR (INLINE = 'Y') OR (INLINE = 'NO') OR (INLINE = 'N'); YEA := (INLINE = 'YES') OR (INLINE = 'Y'); IF YEA THEN SPKNO := SPKYES; IF SPKNO <> 0 THEN SPEAK(ARY^.RTEXT[SPKNO]); YES := YEA END; { YES } PROCEDURE ERRORHALT{I : INTEGER}; BEGIN WRITELN; WRITELN('Fatal error # ', I, ' ---- Bye!'); HALT END; { ERRORHALT } PROCEDURE TESTCLOSE; VAR I : INTEGER; BEGIN { TESTCLOSE } IF (NEWLOC IN [1..8]) AND VBL^.CLOSING THEN BEGIN SPEAK(ARY^.RTEXT[130]); NEWLOC := VBL^.LOC; IF NOT VBL^.PANIC THEN VBL^.CLOCK2 := 15; VBL^.PANIC := TRUE END; IF (NEWLOC <> VBL^.LOC) AND NOT FORCED(VBL^.LOC) AND NOT BITSET(VBL^.LOC, 3) THEN FOR I := 1 TO 5 DO IF (VARY^.ODLOC[I] = NEWLOC) AND VARY^.DSEEN[I] THEN BEGIN NEWLOC := VBL^.LOC; SPEAK(ARY^.RTEXT[2]); I := 5 END END; { TESTCLOSE } ======================================================================================== DOCUMENT :usus Folder:VOL24:advxverb.text ======================================================================================== PROCEDURE LEAVE; BEGIN { LEAVE } SKIPDWARF := TRUE; SKIPDESCRIBE := TRUE; IF SPK <> 0 THEN SPEAK(ARY^.RTEXT[SPK]); EXIT(DOWHATHESAYS) END; { LEAVE } PROCEDURE MISCXIT; BEGIN IF (VBL^.OBJ= COINS) AND HERE(VEND_MACHINE) THEN BEGIN DESTROY(COINS); DROP(BATTERY, VBL^.LOC); PSPEAK(BATTERY, 0); SPK := 0; LEAVE END ELSE IF (VBL^.OBJ = BIRD) AND AT(DRAGON) AND (VARY^.PROP[DRAGON] = 0) THEN BEGIN SPK := 154; DESTROY(BIRD); VARY^.PROP[BIRD] := 0; IF VARY^.PLACE[SNAKE] = ARY^.PLAC[SNAKE] THEN VBL^.TALLY2 := VBL^.TALLY2 + 1; LEAVE END ELSE IF (VBL^.OBJ = BEAR) AND AT(TROLL) THEN BEGIN SPK := 163; MOVE(TROLL, 0); MOVE(TROLL + 100, 0); MOVE(TROLL2, ARY^.PLAC[TROLL]); MOVE(TROLL2 + 100, ARY^.FIXD[TROLL]); JUGGLE(CHASM); VARY^.PROP[TROLL] := 2 END ELSE IF (VBL^.OBJ = VASE) AND (VBL^.LOC <> ARY^.PLAC[PILLOW]) THEN BEGIN SPK := 0; IF AT(PILLOW) THEN VARY^.PROP[VASE] := 0 ELSE BEGIN VARY^.PROP[VASE] := 2; VARY^.FIXED[VASE] := -1 END; PSPEAK(VASE, VARY^.PROP[VASE] + 1) END ELSE SPK := 54 END; { MISCXIT } PROCEDURE ASKWHATTODOITTO; BEGIN WRITELN(WD1, WD1X, ' what?'); VBL^.OBJ := 0; RESTART := 1; EXIT(DOWHATHESAYS) END; { ASKWHATTODOITTO } PROCEDURE FILL_IT; BEGIN IF VBL^.OBJ = VASE THEN BEGIN SPK := 29; IF LIQLOC(VBL^.LOC) = 0 THEN SPK := 144; IF (LIQLOC(VBL^.LOC) = 0) OR TOTING(VASE) THEN LEAVE; SPEAK(ARY^.RTEXT[145]); VARY^.PROP[VASE] := 2; VARY^.FIXED[VASE] := -1; MISCXIT; LEAVE END; IF (VBL^.OBJ <> 0) AND (VBL^.OBJ <> BOTTLE) THEN LEAVE; IF (VBL^.OBJ = 0) AND NOT HERE(BOTTLE) THEN ASKWHATTODOITTO; SPK := 107; IF LIQLOC(VBL^.LOC) = 0 THEN SPK := 106; IF LIQ <> 0 THEN SPK := 105; IF SPK <> 107 THEN LEAVE; VARY^.PROP[BOTTLE] := ((VARY^.COND[VBL^.LOC] MOD 4) DIV 2) * 2; K := LIQ; IF TOTING(BOTTLE) THEN VARY^.PLACE[K] := -1; IF K = OIL THEN SPK := 108; LEAVE END; { FILL_IT } PROCEDURE CARRY_IT; BEGIN IF TOTING(VBL^.OBJ) THEN LEAVE; SPK := 25; IF (VBL^.OBJ = PLANT) AND (VARY^.PROP[PLANT] <= 0) THEN SPK := 115; IF (VBL^.OBJ = BEAR) AND (VARY^.PROP[BEAR] = 1) THEN SPK := 169; IF (VBL^.OBJ = CHAIN) AND (VARY^.PROP[BEAR] <> 0) THEN SPK := 170; IF VARY^.FIXED[VBL^.OBJ] <> 0 THEN LEAVE; IF (VBL^.OBJ = WATER) OR (VBL^.OBJ = OIL) THEN BEGIN IF HERE(BOTTLE) AND (LIQ = VBL^.OBJ) THEN VBL^.OBJ := BOTTLE ELSE BEGIN VBL^.OBJ := BOTTLE; IF VARY^.PROP[BOTTLE] <> 1 THEN SPK := 105 ELSE IF TOTING(BOTTLE) THEN FILL_IT ELSE SPK := 104; LEAVE END END; IF VBL^.HLDING > MAXHLD THEN BEGIN SPK := 92; LEAVE END; IF (VBL^.OBJ = BIRD) AND (VARY^.PROP[BIRD] = 0) THEN BEGIN IF TOTING(ROD) THEN BEGIN SPK := 26; LEAVE END; IF NOT TOTING(CAGE) THEN BEGIN SPK := 27; LEAVE END; VARY^.PROP[BIRD] := 1 END; IF ((VBL^.OBJ = BIRD) OR (VBL^.OBJ = CAGE)) AND (VARY^.PROP[BIRD] <> 0) THEN CARRY(BIRD + CAGE - VBL^.OBJ, VBL^.LOC); CARRY(VBL^.OBJ, VBL^.LOC); K := LIQ; IF (VBL^.OBJ = BOTTLE) AND (K <> 0) THEN VARY^.PLACE[K] := -1; SPK := 54; LEAVE END; { CARRY_IT } PROCEDURE DISTURBDWARVES; BEGIN { DISTURBDWARVES } SPEAK(ARY^.RTEXT[136]); ALLDONE := TRUE; EXIT(DOWHATHESAYS) END; { DISTURBDWARVES } PROCEDURE DROP_IT; BEGIN IF TOTING(ROD2) AND (VBL^.OBJ = ROD) AND NOT TOTING(ROD) THEN VBL^.OBJ := ROD2; IF NOT TOTING(VBL^.OBJ) THEN LEAVE; IF (VBL^.OBJ = BIRD) AND HERE(SNAKE) THEN BEGIN SPK := 30; IF VBL^.CLOSED THEN DISTURBDWARVES; DESTROY(SNAKE); VARY^.PROP[SNAKE] := 1 END ELSE MISCXIT; K := LIQ; IF K = VBL^.OBJ THEN VBL^.OBJ := BOTTLE; IF (VBL^.OBJ = BOTTLE) AND (K <> 0) THEN VARY^.PLACE[K] := 0; IF (VBL^.OBJ = CAGE) AND (VARY^.PROP[BIRD] <> 0) THEN DROP(BIRD, VBL^.LOC); IF VBL^.OBJ = BIRD THEN VARY^.PROP[BIRD] := 0; DROP(VBL^.OBJ, VBL^.LOC); LEAVE END; { DROP IT } PROCEDURE SAY_IT; VAR I : INTEGER; BEGIN { SAY_IT } IF WD2 = '' THEN BEGIN WD2 := WD1; WD2X := WD1X END; I := VOCAB(WD2, -1); IF (I = 62) OR (I = 65) OR (I = 71) OR (I = 2025) THEN RESTART := 1 ELSE WRITELN('Okay, "', WD2, WD2X, '"') END; { SAY_IT } PROCEDURE L_U_IT; BEGIN IF (VBL^.OBJ = CLAM) OR (VBL^.OBJ = OYSTER) THEN BEGIN IF VBL^.OBJ = OYSTER THEN K := 1 ELSE K := 0; SPK := 124 + K; IF TOTING(VBL^.OBJ) THEN SPK := 120 + K; IF NOT TOTING(TRIDENT) THEN SPK := 122 + K; IF VBL^.VERB = LOCK THEN SPK := 61; IF SPK = 124 THEN BEGIN DESTROY(CLAM); DROP(OYSTER, VBL^.LOC); DROP(PEARL, 105) END; LEAVE END; if (vbl^.obj = door) and at(door2) then vbl^.obj := door2; IF VBL^.OBJ = DOOR THEN SPK := 111; IF (VBL^.OBJ = DOOR) AND (VARY^.PROP[DOOR] = 1) THEN SPK := 54; IF VBL^.OBJ = CAGE THEN SPK := 32; IF VBL^.OBJ = KEYS THEN SPK := 55; IF (VBL^.OBJ = GRATE) OR (VBL^.OBJ = CHAIN) or (vbl^.obj = door2) THEN SPK := 31; IF (SPK = 31) AND HERE(KEYS) THEN BEGIN { KEYS HERE } IF VBL^.OBJ = CHAIN THEN BEGIN IF VBL^.VERB = LOCK THEN BEGIN IF VARY^.PROP[CHAIN] <> 0 THEN SPK := 34 ELSE IF VBL^.LOC <> ARY^.PLAC[CHAIN] THEN SPK := 173 ELSE BEGIN SPK := 172; VARY^.PROP[CHAIN] := 2; IF TOTING(CHAIN) THEN DROP(CHAIN, VBL^.LOC); VARY^.FIXED[CHAIN] := -1 END END ELSE BEGIN IF VARY^.PROP[BEAR] = 0 THEN SPK := 41 ELSE IF VARY^.PROP[CHAIN] = 0 THEN SPK := 37 ELSE BEGIN SPK := 171; VARY^.PROP[CHAIN] := 0; VARY^.FIXED[CHAIN] := 0; IF VARY^.PROP[BEAR] <> 3 THEN VARY^.PROP[BEAR] := 2; VARY^.FIXED[BEAR] := 2 - VARY^.PROP[BEAR] END END END ELSE if vbl^.obj = door2 then begin spk := 202 + vary^.prop[door2]; if vbl^.verb = lock then vary^.prop[door2] := 0 else vary^.prop[door2] := 1; spk := spk + 2 * vary^.prop[door2] end else IF VBL^.CLOSING THEN BEGIN SPK := 130; IF NOT VBL^.PANIC THEN VBL^.CLOCK2 := 15; VBL^.PANIC := TRUE END ELSE BEGIN SPK := 34 + VARY^.PROP[GRATE]; IF VBL^.VERB = LOCK THEN VARY^.PROP[GRATE] := 0 ELSE BEGIN SPK := SPK + 2; VARY^.PROP[GRATE] := 1 END END END; LEAVE END; { L_U_IT } PROCEDURE SAY_OK; BEGIN SPK := 54; LEAVE END; { SAY_OK } PROCEDURE LAMP_ON; BEGIN IF HERE(LAMP) THEN IF VBL^.LIMIT < 0 THEN SPK := 184 ELSE BEGIN VARY^.PROP[LAMP] := 1; SPK := 0; SPEAK(ARY^.RTEXT[39]); SKIPDWARF := TRUE; IF VBL^.WZDARK THEN EXIT(DOWHATHESAYS) END; LEAVE END; { LAMP_ON } PROCEDURE LAMP_OFF; BEGIN IF HERE(LAMP) THEN BEGIN VARY^.PROP[LAMP] := 0; SPEAK(ARY^.RTEXT[40]); IF DARK THEN SPK := 16 ELSE SPK := 0 END; LEAVE END; { LAMP_OFF } PROCEDURE WAVE_IT; BEGIN { WAVE_IT } IF (NOT TOTING(VBL^.OBJ)) AND ((VBL^.OBJ <> ROD) OR NOT TOTING(ROD2)) THEN SPK := 29; IF (VBL^.OBJ = ROD) AND AT(FISSURE) AND TOTING(VBL^.OBJ) AND NOT VBL^.CLOSING THEN BEGIN SPK := 0; VARY^.PROP[FISSURE] := 1 - VARY^.PROP[FISSURE]; PSPEAK(FISSURE, 2 - VARY^.PROP[FISSURE]) END; LEAVE END; { WAVE_IT } PROCEDURE KILL_IT; VAR I, J : INTEGER; BEGIN { KILL_IT } I := 0; FOR J := 1 TO 5 DO IF (VARY^.DLOC[J] = VBL^.LOC) AND (VBL^.DFLAG >= 2) THEN BEGIN I := J; J := 5 END; IF VBL^.OBJ = 0 THEN BEGIN IF I <> 0 THEN VBL^.OBJ := DWARF; IF HERE(SNAKE) THEN VBL^.OBJ := VBL^.OBJ * 100 + SNAKE; if vbl^.loc = 149 then if vary^.prop[wizard] = 0 then vbl^.obj := 100 * vbl^.obj + wizard; IF AT(DRAGON) AND (VARY^.PROP[DRAGON] = 0) THEN VBL^.OBJ := VBL^.OBJ * 100 + DRAGON; IF AT(TROLL) THEN VBL^.OBJ := VBL^.OBJ * 100 + TROLL; IF HERE(BEAR) AND (VARY^.PROP[BEAR] = 0) THEN VBL^.OBJ := VBL^.OBJ * 100 + BEAR; IF VBL^.OBJ > 100 THEN ASKWHATTODOITTO; IF VBL^.OBJ = 0 THEN BEGIN IF HERE(BIRD) AND (VBL^.VERB <> THROW) THEN VBL^.OBJ := BIRD; IF HERE(CLAM) OR HERE(OYSTER) THEN VBL^.OBJ := VBL^.OBJ * 100 + CLAM; IF VBL^.OBJ > 100 THEN ASKWHATTODOITTO END END; IF VBL^.OBJ = BIRD THEN BEGIN SPK := 137; IF VBL^.CLOSED THEN LEAVE; DESTROY(BIRD); VARY^.PROP[BIRD] := 0; IF VARY^.PLACE[SNAKE] = ARY^.PLAC[SNAKE] THEN VBL^.TALLY2 := VBL^.TALLY2 + 1; SPK := 45 END; IF VBL^.OBJ = 0 THEN SPK := 44; IF (VBL^.OBJ = CLAM) OR (VBL^.OBJ = OYSTER) THEN SPK := 150; IF VBL^.OBJ = SNAKE THEN SPK := 46; IF VBL^.OBJ = DWARF THEN SPK := 49; IF (VBL^.OBJ = DWARF) AND VBL^.CLOSED THEN DISTURBDWARVES; IF VBL^.OBJ = DRAGON THEN SPK := 167; if (vbl^.obj = wizard) and (vary^.prop[wizard] = 0) then spk := 209; IF VBL^.OBJ = TROLL THEN SPK := 157; IF VBL^.OBJ = BEAR THEN SPK := 165 + (VARY^.PROP[BEAR] + 1) DIV 2; IF (VBL^.OBJ <> DRAGON) OR (VARY^.PROP[DRAGON] <> 0) THEN LEAVE; VBL^.VERB := 0; VBL^.OBJ := 0; IF NOT YES(49, 0, 0) THEN BEGIN RESTART := 2; SPK := 0; LEAVE END; PSPEAK(DRAGON, 1); VARY^.PROP[DRAGON] := 2; VARY^.PROP[RUG] := 0; K := (ARY^.PLAC[DRAGON] + VARY^.FIXED[DRAGON]) DIV 2; MOVE(DRAGON + 100, -1); MOVE(RUG + 100, 0); MOVE(DRAGON, K); MOVE(RUG, K); FOR I := 1 TO 100 DO IF (VARY^.PLACE[I] = ARY^.PLAC[DRAGON]) OR (VARY^.PLACE[I] = ARY^.FIXD[DRAGON]) THEN MOVE(I, K); VBL^.LOC := K; K := NULL; SET_NEW_LOC; EXIT(DOWHATHESAYS) END; { KILL_IT } PROCEDURE POUR_IT; BEGIN IF (VBL^.OBJ = BOTTLE) OR (VBL^.OBJ = 0) THEN VBL^.OBJ := LIQ; IF VBL^.OBJ = 0 THEN ASKWHATTODOITTO; IF NOT TOTING(VBL^.OBJ) THEN LEAVE; SPK := 78; IF (VBL^.OBJ <> WATER) AND (VBL^.OBJ <> OIL) THEN LEAVE; VARY^.PROP[BOTTLE] := 1; VARY^.PLACE[VBL^.OBJ] := 0; SPK := 77; IF NOT (AT(PLANT) OR AT(DOOR)) THEN LEAVE; IF AT(DOOR) THEN BEGIN IF VBL^.OBJ = OIL THEN BEGIN SPK := 114; VARY^.PROP[DOOR] := 1 END ELSE BEGIN SPK := 113; VARY^.PROP[DOOR] := 0 END; LEAVE END; SPK := 112; IF VBL^.OBJ <> WATER THEN LEAVE; PSPEAK(PLANT, VARY^.PROP[PLANT] + 1); VARY^.PROP[PLANT] := (VARY^.PROP[PLANT] + 2) MOD 6; VARY^.PROP[PLANT2] := VARY^.PROP[PLANT] DIV 2; K := NULL; SET_NEW_LOC; EXIT(DOWHATHESAYS) END; { POUR_IT } PROCEDURE EAT_IT; BEGIN IF VBL^.OBJ = FOOD THEN BEGIN DESTROY(FOOD); SPK := 72; LEAVE END; IF (VBL^.OBJ = BIRD) OR (VBL^.OBJ = SNAKE) OR (VBL^.OBJ = CLAM) OR (VBL^.OBJ = OYSTER) OR (VBL^.OBJ = DWARF) OR (VBL^.OBJ = DRAGON) OR ((vbl^.obj = wizard) and (vary^.prop[wizard] = 0)) or (VBL^.OBJ = TROLL) OR (VBL^.OBJ = BEAR) THEN SPK := 71; LEAVE END; { EAT_IT } PROCEDURE DRINK_IT; VAR I : INTEGER; BEGIN { DRINK_IT } IF (VBL^.OBJ = 0) AND (LIQLOC(VBL^.LOC) <> WATER) AND ((LIQ <> WATER) OR NOT HERE(BOTTLE)) THEN ASKWHATTODOITTO; IF (VBL^.OBJ <> 0) AND (VBL^.OBJ <> WATER) THEN SPK := 110; IF (SPK = 110) OR (LIQ <> WATER) OR NOT HERE(BOTTLE) THEN LEAVE; VARY^.PROP[BOTTLE] := 1; VARY^.PLACE[WATER] := 0; SPK := 74; LEAVE END; { DRINK_IT } PROCEDURE RUB_IT; BEGIN IF VBL^.OBJ <> LAMP THEN SPK := 76; if (vbl^.obj = wizard) and (vary^.prop[wizard] = 0) then spk := 212; LEAVE END; { RUB_IT } PROCEDURE FEED_IT; BEGIN IF VBL^.OBJ = BIRD THEN BEGIN SPK := 100; LEAVE END; IF (VBL^.OBJ = SNAKE) OR (VBL^.OBJ = DRAGON) OR (VBL^.OBJ = TROLL) THEN BEGIN spk := 102; IF (VBL^.OBJ = DRAGON) AND (VARY^.PROP[DRAGON] <> 0) THEN SPK := 110; IF VBL^.OBJ = TROLL THEN SPK := 182; IF (VBL^.OBJ <> SNAKE) OR VBL^.CLOSED OR NOT HERE(BIRD) THEN LEAVE; SPK := 101; DESTROY(BIRD); VARY^.PROP[BIRD] := 0; VBL^.TALLY2 := VBL^.TALLY2 + 1; LEAVE END; IF VBL^.OBJ = DWARF THEN BEGIN IF NOT HERE(FOOD) THEN LEAVE; SPK := 103; VBL^.DFLAG := VBL^.DFLAG + 1; LEAVE END; IF VBL^.OBJ = BEAR THEN BEGIN IF VARY^.PROP[BEAR] = 0 THEN SPK := 102; IF VARY^.PROP[BEAR] = 3 THEN SPK := 110; IF NOT HERE(FOOD) THEN LEAVE; DESTROY(FOOD); VARY^.PROP[BEAR] := 1; VARY^.FIXED[AXE] := 0; VARY^.PROP[AXE] := 0; SPK := 168; LEAVE END; if (vbl^.loc = 149) and (vary^.prop[wizard] <> 1) then begin spk := 208; leave end; SPK := 14; LEAVE END; { FEED_IT } PROCEDURE TOSS_IT; VAR I : INTEGER; PROCEDURE TOSS_IT_AWAY; BEGIN SPEAK(ARY^.RTEXT[SPK]); DROP(AXE, VBL^.LOC); K := NULL; SET_NEW_LOC; EXIT(DOWHATHESAYS) END; { TOSS_IT_AWAY } BEGIN { TOSS_IT } IF TOTING(ROD2) AND (VBL^.OBJ = ROD) AND NOT TOTING(ROD) THEN VBL^.OBJ := ROD2; IF NOT TOTING(VBL^.OBJ) THEN LEAVE; IF (VBL^.OBJ >= 50) AND (VBL^.OBJ <= MAXTRS) AND AT(TROLL) THEN BEGIN SPK := 159; DROP(VBL^.OBJ, 0); MOVE(TROLL, 0); MOVE(TROLL + 100, 0); DROP(TROLL2, ARY^.PLAC[TROLL]); DROP(TROLL2 + 100, ARY^.FIXD[TROLL]); JUGGLE(CHASM); LEAVE END; IF (VBL^.OBJ = FOOD) AND HERE(BEAR) THEN BEGIN VBL^.OBJ := BEAR; FEED_IT END; if (vbl^.obj = ball) and (vbl^.loc = 149) and (vary^.prop[wizard] = 0) and toting(ball) then begin speak(ary^.rtext[207]); vary^.prop[wizard] := 1; destroy(ball); drop(jade,vbl^.loc); k := null; set_new_loc; exit(dowhathesays) end; IF VBL^.OBJ <> AXE THEN DROP_IT; FOR I := 1 TO 5 DO BEGIN IF VARY^.DLOC[I] = VBL^.LOC THEN BEGIN SPK := 48; IF RAN(3) <> 0 THEN BEGIN VARY^.DSEEN[I] := FALSE; VARY^.DLOC[I] := 0; SPK := 47; VBL^.DKILL := VBL^.DKILL + 1; IF VBL^.DKILL = 1 THEN SPK := 149 END; TOSS_IT_AWAY END END; if (vbl^.loc = 149) and (vary^.prop[wizard] <> 1) then begin speak(ary^.rtext[213]); drop(axe,vbl^.loc); k := null; set_new_loc; exit(dowhathesays) end; SPK := 152; IF AT(DRAGON) AND (VARY^.PROP[DRAGON] = 0) THEN TOSS_IT_AWAY; SPK := 158; IF AT(TROLL) THEN TOSS_IT_AWAY; IF HERE(BEAR) AND (VARY^.PROP[BEAR] = 0) THEN BEGIN SPK := 164; DROP(AXE, VBL^.LOC); VARY^.FIXED[AXE] := -1; VARY^.PROP[AXE] := 1; JUGGLE(BEAR); LEAVE END; VBL^.OBJ := 0; KILL_IT END; { TOSS_IT } PROCEDURE FIND_IT; VAR I : INTEGER; BEGIN { FIND_IT } IF AT(VBL^.OBJ) OR ((LIQ = VBL^.OBJ) AND AT(BOTTLE)) OR (K = LIQLOC(VBL^.LOC)) THEN SPK := 94; IF VBL^.OBJ = DWARF THEN FOR I := 1 TO 6 DO IF (VARY^.DLOC[I] = VBL^.LOC) AND (VBL^.DFLAG >= 2) THEN SPK := 94; IF VBL^.CLOSED THEN SPK := 138; IF TOTING(VBL^.OBJ) THEN SPK := 24; LEAVE END; { FIND_IT } PROCEDURE BLAST_IT; BEGIN IF (VARY^.PROP[ROD2] < 0) OR NOT VBL^.CLOSED THEN LEAVE; BONUS := 133; IF VBL^.LOC = 115 THEN BONUS := 134; IF HERE(ROD2) THEN BONUS := 135; SPEAK(ARY^.RTEXT[BONUS]); ALLDONE := TRUE; EXIT(DOWHATHESAYS) END; { BLAST_IT } PROCEDURE READ_IT; BEGIN IF DARK THEN BEGIN WRITELN('I see no ', WD1, WD1X, ' here.'); SPK := 0; LEAVE END; IF VBL^.OBJ = MAGAZINE THEN SPK := 190; IF VBL^.OBJ = TABLET THEN SPK := 196; IF VBL^.OBJ = MESSAGE THEN SPK := 191; if vbl^.obj = scroll then spk := 214; IF (VBL^.OBJ = OYSTER) AND VARY^.HINTED[2] AND TOTING(OYSTER) THEN SPK := 194; IF (VBL^.OBJ <> OYSTER) OR VARY^.HINTED[2] OR NOT TOTING(OYSTER) OR NOT VBL^.CLOSED THEN LEAVE; VARY^.HINTED[2] := YES(192, 193, 54); SPK := 0; LEAVE END; { READ_IT } PROCEDURE BREAK_IT; BEGIN IF VBL^.OBJ = MIRROR THEN SPK := 148; IF (VBL^.OBJ = VASE) AND (VARY^.PROP[VASE] = 0) THEN BEGIN SPK := 198; IF TOTING(VASE) THEN DROP(VASE, VBL^.LOC); VARY^.PROP[VASE] := 2; VARY^.FIXED[VASE] := -1; LEAVE END ELSE BEGIN IF (VBL^.OBJ <> MIRROR) OR NOT VBL^.CLOSED THEN LEAVE; SPEAK(ARY^.RTEXT[197]); DISTURBDWARVES END END; { BREAK_IT } PROCEDURE WAKE_IT; BEGIN IF (VBL^.OBJ <> DWARF) OR NOT VBL^.CLOSED THEN LEAVE; SPEAK(ARY^.RTEXT[199]); DISTURBDWARVES END; { WAKE_IT } PROCEDURE CARRY_SOMETHING; VAR I : INTEGER; BEGIN { CARRY_SOMETHING } IF (VARY^.ATLOC[VBL^.LOC] = 0) THEN ASKWHATTODOITTO; IF VARY^.LINK[VARY^.ATLOC[VBL^.LOC]] <> 0 THEN ASKWHATTODOITTO; FOR I := 1 TO 5 DO IF (VARY^.DLOC[I] = VBL^.LOC) AND (VBL^.DFLAG >= 2) THEN ASKWHATTODOITTO; VBL^.OBJ := VARY^.ATLOC[VBL^.LOC]; CARRY_IT END; { CARRY_SOMETHING } PROCEDURE L_U_SOMETHING; BEGIN SPK := 28; IF HERE(CLAM) THEN VBL^.OBJ := CLAM; IF HERE(OYSTER) THEN VBL^.OBJ := OYSTER; IF AT(DOOR) THEN VBL^.OBJ := DOOR; if at(door2) then vbl^.obj := door2; IF AT(GRATE) THEN VBL^.OBJ := GRATE; IF (VBL^.OBJ <> 0) AND HERE(CHAIN) THEN ASKWHATTODOITTO; IF HERE(CHAIN) THEN VBL^.OBJ := CHAIN; IF VBL^.OBJ = 0 THEN LEAVE; L_U_IT END; { L_U_SOMETHING } PROCEDURE EAT_SOMETHING; BEGIN IF NOT HERE(FOOD) THEN ASKWHATTODOITTO; VBL^.OBJ := FOOD; EAT_IT END; { EAT_SOMETHING } PROCEDURE QUIT2; BEGIN ALLDONE := GAVEUP; IF GAVEUP THEN EXIT(DOWHATHESAYS); SPK := 0; LEAVE END; { QUIT2 } PROCEDURE QUIT; BEGIN GAVEUP := YES(22, 54, 54); QUIT2 END; { QUIT } PROCEDURE REPORT; VAR I : INTEGER; BEGIN { REPORT - INVENTORY } SPK := 98; FOR I := 1 TO 100 DO IF (I <> BEAR) AND TOTING(I) THEN BEGIN IF SPK = 98 THEN SPEAK(ARY^.RTEXT[99]); PSPEAK(I, -1); SPK := 0 END; IF TOTING(BEAR) THEN SPK := 141; LEAVE END; { REPORT } PROCEDURE REPORT_SCORE; BEGIN { REPORT_SCORE } SCORE := GETSCORE(TRUE); WRITE('If you were to quit now, you would score '); if termwidth < 64 then writeln; WRITELN(SCORE, ' out of a possible ', MAXSCORE, '.'); GAVEUP := YES(143, 54, 54); QUIT2 END; { REPORT_SCORE } PROCEDURE WORD_FOO; BEGIN K := VOCAB(WD1, 3); SPK := 42; IF VBL^.FOOBAR = 1 - K THEN BEGIN VBL^.FOOBAR := K; IF K <> 4 THEN BEGIN SPK := 54; LEAVE END; IF (VARY^.PLACE[EGGS] = ARY^.PLAC[EGGS]) OR (TOTING(EGGS) AND (VBL^.LOC = ARY^.PLAC[EGGS])) THEN LEAVE; IF (VARY^.PLACE[EGGS] = 0) AND (VARY^.PLACE[TROLL] = 0) AND (VARY^.PROP[TROLL] = 0) THEN VARY^.PROP[TROLL] := 1; K := 2; IF HERE(EGGS) THEN K := 1; IF VBL^.LOC = ARY^.PLAC[EGGS] THEN K := 0; MOVE(EGGS, ARY^.PLAC[EGGS]); PSPEAK(EGGS, K); SPK := 0; LEAVE END; IF VBL^.FOOBAR <> 0 THEN SPK := 151; LEAVE END; { WORD_FOO } PROCEDURE SET_BRIEF; BEGIN SPK := 156; VBL^.ABBNUM := 10000; VBL^.DETAIL := 3; LEAVE END; { SET_BRIEF } PROCEDURE READ_SOMETHING; BEGIN IF HERE(MAGAZINE) THEN VBL^.OBJ := MAGAZINE; IF HERE(TABLET) THEN VBL^.OBJ := VBL^.OBJ * 100 + TABLET; IF HERE(MESSAGE) THEN VBL^.OBJ := VBL^.OBJ * 100 + MESSAGE; IF VBL^.CLOSED AND TOTING(OYSTER) THEN VBL^.OBJ := OYSTER; IF (VBL^.OBJ > 100) OR (VBL^.OBJ = 0) OR DARK THEN ASKWHATTODOITTO; READ_IT END; { READ_SOMETHING } PROCEDURE SUSPEND; PROCEDURE SUSPEXIT; BEGIN WRITELN('Error suspending game.'); CLOSE(INFILE); EXIT(SUSPEND) END; { SUSPEXIT } BEGIN { SUSPEND } NAMEANDPW; VBL^.PASSWORD := TESTPW; VBL^.VERSION := VERSION; REWRITE(INFILE, NAMEOFUSER); I := (SIZEOF(VARYS) + 511) DIV 512; IF I <> BLOCKWRITE(INFILE, VARY^.DBLK, I) THEN SUSPEXIT; I := (SIZEOF(VBLS) + 511) DIV 512; IF I <> BLOCKWRITE(INFILE, VBL^.DBLK, I) THEN SUSPEXIT; CLOSE(INFILE, LOCK); WRITELN; WRITE('Adventure game saved as ', NAMEOFUSER); EXIT(ADVENTURE) END; { SUSPEND } PROCEDURE ANALANITVERB; BEGIN CASE VBL^.VERB OF 1 : CARRY_SOMETHING; { TAKE } 2 : ASKWHATTODOITTO; { DROP } 3 : ASKWHATTODOITTO; { SAY } 4 : L_U_SOMETHING; { OPEN } 5 : SAY_OK; { NOTHING } 6 : L_U_SOMETHING; { LOCK } 7 : LAMP_ON; { ON } 8 : LAMP_OFF; { OFF } 9 : ASKWHATTODOITTO; { WAVE } 10 : ASKWHATTODOITTO; { CALM } 11 : LEAVE; { WALK } 12 : KILL_IT; { KILL } 13 : POUR_IT; { POUR } 14 : EAT_SOMETHING; { EAT } 15 : DRINK_IT; { DRINK } 16 : ASKWHATTODOITTO; { RUB } 17 : ASKWHATTODOITTO; { TOSS } 18 : QUIT; { QUIT } 19 : ASKWHATTODOITTO; { FIND } 20 : REPORT; { INVENTORY } 21 : ASKWHATTODOITTO; { FEED } 22 : FILL_IT; { FILL } 23 : BLAST_IT; { BLAST } 24 : REPORT_SCORE; { SCORE } 25 : WORD_FOO; { FOO } 26 : SET_BRIEF; { BRIEF } 27 : READ_SOMETHING; { READ } 28 : ASKWHATTODOITTO; { BREAK } 29 : ASKWHATTODOITTO; { WAKE } 30 : SUSPEND; { SUSPEND } END; { CASE } IF VBL^.VERB > 29 THEN ERRORHALT(23) END; { ANALANITVERB } PROCEDURE ANALATVERB; BEGIN CASE VBL^.VERB OF 1 : CARRY_IT; { TAKE } 2 : DROP_IT; { DROP } 3 : SAY_IT; { SAY } 4 : L_U_IT; { OPEN } 5 : SAY_OK; { NOTHING } 6 : L_U_IT; { LOCK } 7 : LAMP_ON; { ON } 8 : LAMP_OFF; { OFF } 9 : WAVE_IT; { WAVE } 10 : LEAVE; { CALM } 11 : LEAVE; { WALK } 12 : KILL_IT; { KILL } 13 : POUR_IT; { POUR } 14 : EAT_IT; { EAT } 15 : DRINK_IT; { DRINK } 16 : RUB_IT; { RUB } 17 : TOSS_IT; { TOSS } 18 : LEAVE; { QUIT } 19 : FIND_IT; { FIND } 20 : FIND_IT; { INVENTORY } 21 : FEED_IT; { FEED } 22 : FILL_IT; { FILL } 23 : BLAST_IT; { BLAST } 24 : LEAVE; { SCORE } 25 : LEAVE; { FOO } 26 : LEAVE; { BRIEF } 27 : READ_IT; { READ } 28 : BREAK_IT; { BREAK } 29 : WAKE_IT; { WAKE } 30 : SUSPEND; { SUSPEND } END; { CASE } IF VBL^.VERB > 29 THEN ERRORHALT(24) END; { ANALATVERB } ======================================================================================== DOCUMENT :usus Folder:VOL24:vol24.doc.text ======================================================================================== USUS Library Volume 24 Adventure 500, the 500 point version VOL24: ADVX1.TEXT 48 A data file ADVX2.TEXT 8 ADVX3.TEXT 22 ADVX4.TEXT 10 ADVX5.TEXT 16 ADVX6.TEXT 42 ADVX7.TEXT 6 ADVX8.TEXT 4 ADVX9.TEXT 4 ADVX10.TEXT 4 ADVX11.TEXT 4 The last data file ADVXCONS.TEXT 4 An include file of Adventure ADVXINIT.TEXT 24 Creates the Adventure data file from the data source files ADVXVERB.TEXT 44 An include file of Adventure ADVXINIT4.CODE 8 A version 4 code file of ADVXINIT ADVXINIT2.CODE 9 A version 2 code file if ADVXINIT ADV.MISCINFO 4 Specifies screen size ADVX4.CODE 45 A version 4 code file of ADVX ADVX2.CODE 50 An un-linked version 2 code file of ADVX ADVXSUBS.TEXT 20 An include file of Adventure ADVXSEGS.TEXT 28 An include file of Adventure ADVX.TEXT 38 The main program of Adventure ADVX.DOC.TEXT 22 Documentation of Adventure VOL24.DOC.TEXT 6 You're reading it. Please transfer the text below to a disk label if you copy this volume. USUS Volume 24 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOL25:readme.1st.text ======================================================================================== Some notes from the reviewer: I have made UDE marginally work. I am not really very impressed with the entire package, but it shows some interesting programming constructs and is very possibly useful to somebody. The documentation, although extensive is unclear and hard to follow. The example given in the last part of the documentation has some errors, but after a couple of hours of playing around, you too will figure it out. The program requires that the code files reside on #4:. You can easily change this in UD.UDE.TEXT. The program has the built in and annoying tendency to chain back to itself, so you may find that it restarts when you don't want it to. Simply remove the last call to CHAIN in UD.UDE.TEXT and re- compile it. There is some rather clever code in SH.INIT.TEXT to to obtain the cursor control characters for the user's terminal. Unfortunatly, it don't work. If your terminal uses two character control sequences for the arrow keys you will have to go in and hard wire stuff. The function SC_MAP_CRT_COMMAND is kind of odd and can't really be used in the way shown with two character sequences. SC_MAP_CRT_COMMAND (in screenops) expects you to read characters from the terminal and pass all of them through it. If your terminal has two character control sequences, some of the characters that you read will be the prefix characters. When SC_MAP_CRT_COMMAND is passed a prefix character, IT GOES OUT AND READS THE TERMINAL, EXPECTING TO FIND ANOTHER CHARACTER!! If the next character is one of the ones for the special keys, it will return the enumerated type of the special key and the value of the character that it read. This means that the method used in UDE hangs whenever this procedure is called. UNLESS THE CORRECT CHARACTERS ARE TYPED IN THE CORRECT ORDER the program will not be able to determine the values of the arrow keys. With one character command sequences, the method should work fine. The author has also done something which will cause a lot of users, especially those with APC's and PC's a lot of grief. Most of the prompt lines are written to the screen with the 8th bit set. This is probably some special video attribute for his terminal, but many terminals use the characters between 128 and 255 as graphics characters. This means the much of the prompting information will be displayed as graphic garbage. This stuff is scattered throughout the program, and I didn't want to change it. If it causes you problems, you will have to go in and delete the < +128 > expressions. Good luck george w. schreyer p.s. The submittor has requested that any changes, bug fixes, or upgrades be submitted back to him. If you improve on this program, other than the items mentioned above, please contact me so that we can send the upgrades back to him. ======================================================================================== DOCUMENT :usus Folder:VOL25:sd.define.text ======================================================================================== Program DEFINE; {$L PRINTER:} USES {$U SH/SCREEN.UNIT } SCREEN40; var MASK,NEWMASK: SCREEN_ARR; PPROMPTS,NEWPROMPTS: PROMPT_ARR; VERSION,FNAME,GETP,EDITP,SAVEP,QUITP,PRNTP,CLEARP, EDITP1,EDITP2,FILEPROMPT: String; BLNKREC: FIELD_DEFS; BLNKPROMPT: PROMPT_DEFS; NFLDS,NPFLDS: Integer; SAVED: Boolean; CH: Char; Segment Procedure INITIALIZE; var I: Integer; Procedure LIGHT(var TEMP: String); var I: Integer; begin {LIGHT} for I:=1 to length(TEMP) do if not(TEMP[I] in['A'..'Z'])then TEMP[I]:=chr(ord(TEMP[I])+128); end; Procedure SET_FILEMASK; begin {set FILEMASK} with MASK[1] do begin S_ROW:=0; S_ID:='VOLUME'; S_LEN:=8; S_JUS:='L'; end; with MASK[2] do begin S_ROW:=1; S_ID:='NAME'; S_LEN:=10; S_JUS:='L'; end; with MASK[3] do begin S_ROW:=2; S_ID:='FTYPE'; S_LEN:=4; S_JUS:='L'; S_DEF:='SCRN'; end; with PPROMPTS[1] do P_FLD:='Volume :'; with PPROMPTS[2] do begin P_ROW:=1; P_FLD:='Name :'; end; with PPROMPTS[3] do begin P_ROW:=2; P_FLD:='Type :'; end; end; {set MASK} Procedure SET_SMASK; begin for I:=4 to 13 do with MASK[I] do begin S_JUS:='L'; S_LEN:=1; S_MIN:=1; end; with MASK[4] do begin S_ID:='IDNAME'; S_ROW:=7; S_LEN:=8; S_MIN:=0; S_SKIP:=False; end; with MASK[5] do begin S_ID:='SKIP'; S_ROW:=7; S_COL:=40; S_FLD:='T'; S_DEF:='T'; S_SKIP:=True; end; with MASK[6] do begin S_ID:='TYPE'; S_ROW:=8; S_NA:='L'; S_DEF:='V'; S_FLD:='V'; S_SKIP:=True; end; with MASK[7] do begin S_ID:='JUST'; S_ROW:=8; S_COL:=40; S_NA:='L'; S_FLD:='N'; S_DEF:='N'; S_SKIP:=True; end; with MASK[8] do begin S_ID:='FROW'; S_ROW:=9; S_NA:='N'; S_JUS:='R'; S_LEN:=2; S_DEF:='0'; end; with MASK[9] do begin S_ID:='FCOL'; S_ROW:=9; S_COL:=5; S_NA:='N'; S_JUS:='R'; S_LEN:=2; S_DEF:='0'; end; with MASK[10] do begin S_ID:='ALFA'; S_ROW:=9; S_COL:=40; S_NA:='L'; S_FLD:='A'; S_DEF:='A'; S_SKIP:=True; end; with MASK[11] do begin S_ID:='LEN'; S_ROW:=10; S_NA:='N'; S_JUS:='R'; S_LEN:=2; S_DEF:='0'; end; with MASK[12] do begin S_ID:='MIN'; S_ROW:=10; S_COL:=40; S_NA:='N'; S_JUS:='R'; S_LEN:=2; S_DEF:='0'; end; with MASK[13] do begin S_ID:='DEFVAL'; S_ROW:=11; S_MIN:=0; S_JUS:='N'; S_LEN:=40; end; with PPROMPTS[4] do begin P_ROW:=4; P_COL:=29; P_FLD:='DEFINE INPUT FIELD'; end; with PPROMPTS[5] do begin P_ROW:=5; P_COL:=29; P_FLD:='------------------'; end; with PPROMPTS[6] do begin P_ROW:=7; P_FLD:='Field ID Name :'; end; with PPROMPTS[7] do begin P_ROW:=7; P_COL:=40; P_FLD:='Auto Skip (T/F) :'; end; with PPROMPTS[8] do begin P_ROW:=8; P_FLD:='Field Type (C/D/I/V) :'; end; with PPROMPTS[9] do begin P_ROW:=8; P_COL:=40; P_FLD:='Justify (L/R/N) :'; end; with PPROMPTS[10] do begin P_ROW:=9; P_FLD:='Row / Column Number : /'; end; with PPROMPTS[11] do begin P_ROW:=9; P_COL:=40; P_FLD:='Alpha-Numeric (A/L/N/S) :'; end; with PPROMPTS[12] do begin P_ROW:=10; P_FLD:='Field Length :'; end; with PPROMPTS[13] do begin P_ROW:=10; P_COL:=40; P_FLD:='Minimum Input :'; end; with PPROMPTS[14] do begin P_ROW:=11; P_FLD:='Default/Calculation :'; end; end; {SET_SMASK} Procedure SET_PMASK; begin for I:=14 to 17 do begin with MASK[I] do begin S_ROW:=I+1; S_COL:=16; S_NA:='N'; S_LEN:=2; S_JUS:='R'; S_MIN:=1; S_DEF:='0'; end; {with} with PPROMPTS[I+3] do P_ROW:=I+1; end; {for} MASK[14].S_ID:='INDEX'; MASK[15].S_ID:='PROW'; MASK[16].S_ID:='PCOL'; with MASK[17] do begin S_ID:='PROMPT'; S_LEN:=40; S_COL:=9; S_DEF:=''; S_JUS:='N'; S_NA:='S'; end; with PPROMPTS[15] do begin P_FLD:='DEFINE PROMPT FIELD'; P_ROW:=12; P_COL:=29; end; with PPROMPTS[16] do begin P_FLD:='-------------------'; P_ROW:=13; P_COL:=29; end; PPROMPTS[17].P_FLD:='Prompt Number :'; PPROMPTS[18].P_FLD:='Row Number :'; PPROMPTS[19].P_FLD:='Column Number :'; PPROMPTS[20].P_FLD:='Prompt :'; end; {SET_PMASK} begin {INITIALIZE} with BLNKREC do begin S_ID :=''; S_ROW:=END_SCREEN; S_COL:=0; S_LEN:=0; S_MIN:=0; S_TYP:='V'; S_JUS:='N'; S_NA :='S'; S_SKIP:=False; S_DEF:=''; S_FLD:=''; end; with BLNKPROMPT do begin P_ROW:=END_SCREEN; P_COL:=0; P_FLD:=''; end; for I:=1 to SCREEN_FIELDS do begin NEWMASK[I]:=BLNKREC; MASK[I]:=BLNKREC; NEWPROMPTS[I]:=BLNKPROMPT; PPROMPTS[I]:=BLNKPROMPT; PPROMPTS[I].P_ROW:=0; end; NPFLDS:=0; NFLDS:=0; FNAME:=''; SET_FILEMASK; SET_SMASK; SET_PMASK; VERSION:='Version IV.0'; for I:=1 to length(VERSION) do VERSION[I]:=chr(ord(VERSION[I])+128); FILEPROMPT:=' to execute, to abort'; LIGHT(FILEPROMPT); EDITP1:='Upper Field Add Back Examine Test'; LIGHT(EDITP1); EDITP2:='Lower Prompt Delete Next Change Quit:'; LIGHT(EDITP2); CLEARP:='Clear current screen defintion'; LIGHT(CLEARP); GETP:='Get old screen definition file'; LIGHT(GETP); EDITP:='Edit screen definition file'; LIGHT(EDITP); SAVEP:='Save current screen definition file'; LIGHT(SAVEP); PRNTP:='Print screen definition file'; LIGHT(PRNTP); QUITP:='Quit'; LIGHT(QUITP); end; {initialize} Procedure SORTRECS(var A: SCREEN_ARR; var R: Integer); forward; Procedure SORTP(var A: PROMPT_ARR; var R: Integer); forward; Function IVAL(NUMBER: String): Integer; forward; Segment Procedure FILE_IO(OPT: Char); var VOLNAME,FILENAME,FILETYPE: String; RESULT: Integer; F_EXIT,CH: Char; Procedure PRINT_FILE; const UL3 = '=== === ==='; UL40 = '========================================'; var LP: Text; IOCOL,EDGE,I: Integer; WIDTH: String; EXXIT: Char; Procedure PRINTPROMPTS; begin {Print prompts} if (EDGE=80) and ((NFLDS*2)+NPFLDS>50) then writeln(LP,FORM_FEED) else for I:=1 to 3 do writeln(LP); writeln(LP,' ':(EDGE-25) div 2,'SCREEN PROMPT DEFINITIONS'); writeln(LP); writeln(LP,'NO. ROW COL PROMPT '); writeln(LP,UL3,' ',UL40); for I:=1 to NPFLDS do with NEWPROMPTS[I] do writeln(LP,I:2, P_ROW:4, P_COL:4,' ',P_FLD); writeln(LP,FORM_FEED); end; {print prompts} begin {PRINT_FILE} rewrite(LP,'PRINTER:'); gotoxy(0,MAXROW); write('Printer width (80/132):'); IOCOL:=25; WIDTH:='132'; EDGE:=0; while not(EDGE in[80,132]) do begin FIELD(MAX_ROW,IOCOL,MAX_ROW,MAX_COL-40,3,1,EXXIT,'L','N',WIDTH,False); EDGE:=IVAL(WIDTH); if (EDGE=0) or (EXXIT=ESC_KEY) then exit(PRINT_FILE); end; if FNAME='' then writeln(LP) else writeln(LP,'Current Screen Definition file is "',FNAME,'"'); writeln(LP); writeln(LP,' ':(EDGE-24) div 2,'SCREEN FIELD DEFINITIONS'); writeln(LP); write(LP,'NO. ROW COL IDNAME TYP SKIP LEN MIN JUS N/A'); if EDGE=80 then begin writeln(LP); writeln(LP,UL3,' ======== === ===== ===== ',UL3); end; writeln(LP,' ':14,'CURRENT VALUE',' ':27,'DEFAULT VALUE'); if EDGE=132 then write(LP,UL3,' ======== === ===== === ',UL3,' '); writeln(LP,UL40,' ',UL40); for I:=1 to NFLDS do with NEWMASK[I] do begin write(LP,I:2, S_ROW:4, S_COL:4,' ',S_ID,' ':9-length(S_ID),S_TYP:2,' '); if S_SKIP then write(LP,'TRUE ') else write(LP,'FALSE '); write(LP,S_LEN:2, S_MIN:4, S_JUS:4, S_NA:4); if EDGE=80 then writeln(LP) else write(LP,' '); writeln(LP,S_FLD,' ':41-length(S_FLD),S_DEF,' ':41-length(S_DEF)); end; {with/for} PRINTPROMPTS; end; {PRINT_FILE} Procedure OPEN_FILE; var RESULT: Integer; begin {OPEN_FILE} GET_FILE(FNAME,NEWMASK,NEWPROMPTS,RESULT); gotoxy(MAX_COL-40,MAX_ROW); if RESULT<>0 then write('STATUS: No File Loaded - ERROR ',RESULT,ALARM_BELL) else begin write('STATUS: File Loaded.'); NFLDS:=SCREEN_FIELDS; SORTRECS(NEWMASK,NFLDS); NPFLDS:=SCREEN_FIELDS; SORTP(NEWPROMPTS,NPFLDS); SAVED:=True; with NEWMASK[1] do begin str(S_ROW,MASK[FIND('FROW',MASK)].S_FLD); str(S_COL,MASK[FIND('FCOL',MASK)].S_FLD); MASK[FIND('IDNAME',MASK)].S_FLD :=S_ID ; str(S_LEN,MASK[FIND('LEN',MASK)].S_FLD); str(S_MIN,MASK[FIND('MIN',MASK)].S_FLD); if S_SKIP then MASK[FIND('SKIP',MASK)].S_FLD:='T' else MASK[FIND('SKIP',MASK)].S_FLD:='F'; MASK[FIND('DEFVAL',MASK)].S_FLD :=S_DEF; MASK[FIND('TYPE',MASK)].S_FLD[1]:=S_TYP; MASK[FIND('JUST',MASK)].S_FLD[1]:=S_JUS; MASK[FIND('ALFA',MASK)].S_FLD[1]:=S_NA ; end; with NEWPROMPTS[1] do begin MASK[FIND('INDEX',MASK)].S_FLD:='1'; str(P_ROW,MASK[FIND('PROW',MASK)].S_FLD); str(P_COL,MASK[FIND('PCOL',MASK)].S_FLD); MASK[FIND('PROMPT',MASK)].S_FLD :=P_FLD; end; exit(FILE_IO); end; end; {OPEN_FILE} Procedure SAVE; var FILE_TO_SAVE: File of SCREEN_REC; SIZE,RESULT,I: Integer; begin {SAVE} SAVE_FILE(FNAME,NEWMASK,NEWPROMPTS,RESULT); if RESULT<>0 then begin gotoxy(MAX_COL-40,MAX_ROW); write(ALARM_BELL,'STATUS: File not saved.','ERROR ',RESULT,ALARM_BELL); end else begin SIZE:=0; gotoxy(0,MAX_ROW); for I:=1 to NFLDS do SIZE:=SIZE+NEWMASK[I].S_LEN; write('STATUS: File saved. Total length : ',SIZE,'.'); SAVED:=True; write(' Press to continue.'); repeat read(Keyboard,CH); until eoln(Keyboard); exit(FILE_IO); end; {save} end; {SAVE} begin {FILE_IO} case OPT of 'G': begin {get prompt} CLEAR_HOME ; writeln(' ':28,'GET SCREEN DEFINITION'); writeln(' ':28,'====================='); end; 'P': begin {print} PRINT_FILE; exit(FILE_IO); end; {print} 'S': begin {save prompt} CLEAR_HOME ; writeln(' ':28,'SAVE SCREEN DEFINITION'); writeln(' ':28,'======================'); end; end; {case} DISPLAY_PROMPTS(PPROMPTS,8,10,0,2); DISPLAY_SCREEN(MASK,8,20,0,2); gotoxy(0,MAX_ROW-1); write(FILEPROMPT); repeat SCREEN(MASK,True,1,8,20,0,2,MAX_ROW,MAX_COL-40,F_EXIT); if F_EXIT=ESC_KEY then exit(FILE_IO) else begin {execute} VOLNAME:=MASK[1].S_FLD; FILENAME:=MASK[2].S_FLD; FILETYPE:=MASK[3].S_FLD; EATSPR(VOLNAME); EATSPR(FILENAME); EATSPR(FILETYPE); FNAME:=concat(VOLNAME,':',FILENAME,'.',FILETYPE); case OPT of 'G': OPEN_FILE; 'S': SAVE; end; {case} end; {execute} until False; end; {FILE_IO} Segment Procedure EDIT_FILE; var F_EXIT,CH: Char; X,R_OFF,I: Integer; OLDVAL: Packed array[1..14] of STRINGFL; TNAME: STR_ID; P_MODE: Boolean; Procedure E_MSG(MSG: String); begin {E_MSG} ERASE_EOL(MAX_COL-40,MAX_ROW); write(ALARM_BELL); write('ERROR: ',MSG,ALARM_BELL); end; {E_MSG} Procedure DISPLAY; begin {DISPLAY} if P_MODE then begin {prompt screen} DISPLAY_PROMPTS(NEWPROMPTS,0,0,((MAX_ROW+1)div 2)-R_OFF,MAX_ROW-R_OFF); DISPLAY_PROMPTS(PPROMPTS,R_OFF-12,0,12,18); DISPLAY_SCREEN(NEWMASK,0,0,((MAX_ROW+1) div 2)-R_OFF,MAX_ROW-R_OFF); DISPLAY_SCREEN(MASK,R_OFF-12,0,12,18); end {prompt screen} else begin {data field screen} DISPLAY_PROMPTS(NEWPROMPTS,0,0,((MAX_ROW+1) div 2)-R_OFF,MAX_ROW-R_OFF); DISPLAY_PROMPTS(PPROMPTS,R_OFF-4,0,4,11); DISPLAY_SCREEN(NEWMASK,0,0,((MAX_ROW+1) div 2)-R_OFF,MAX_ROW-R_OFF); DISPLAY_SCREEN(MASK,R_OFF-4,26,4,11); end; {data field screen} gotoxy(0,10+R_OFF); writeln(EDITP1); write(EDITP2); end; Procedure EXAMINE; begin {Examine} if PMODE then begin {examine prompt} X:=IVAL(MASK[FIND('INDEX',MASK)].S_FLD); if X<1 then X:=1 else if X>NPFLDS then X:=NPFLDS; with NEWPROMPTS[X] do begin str(P_ROW,MASK[FIND('PROW',MASK)].S_FLD); str(P_COL,MASK[FIND('PCOL',MASK)].S_FLD); MASK[FIND('PROMPT',MASK)].S_FLD:=P_FLD; end; {with} DISPLAY_SCREEN(MASK,R_OFF-12,0,12,18); end {examine prompt} else begin {examine field} TNAME:=MASK[FIND('IDNAME',MASK)].S_FLD; EATSPR(TNAME); X:=FIND(TNAME,NEWMASK); if X=0 then E_MSG('Invalid ID Name.') else begin with NEWMASK[X] do begin MASK[FIND('IDNAME',MASK)].S_FLD :=S_ID ; str(S_ROW,MASK[FIND('FROW',MASK)].S_FLD); str(S_COL,MASK[FIND('FCOL',MASK)].S_FLD); str(S_LEN,MASK[FIND('LEN',MASK)].S_FLD); str(S_MIN,MASK[FIND('MIN',MASK)].S_FLD); MASK[FIND('DEFVAL',MASK)].S_FLD:=S_DEF; if S_SKIP then MASK[FIND('SKIP',MASK)].S_FLD :='T' else MASK[FIND('SKIP',MASK)].S_FLD :='F'; MASK[FIND('TYPE',MASK)].S_FLD[1]:=S_TYP; MASK[FIND('JUST',MASK)].S_FLD[1]:=S_JUS; MASK[FIND('ALFA',MASK)].S_FLD[1]:=S_NA ; end; {with} DISPLAY_SCREEN(MASK,R_OFF-4,26,4,11); end; {else} end; {examine field} end; {examine} Procedure ADD; var TEMPID: STR_ID; TEMPINT: Integer; Procedure WARN(MSG: String); begin {WARN} gotoxy(MAX_COL-40,MAX_ROW); write(ALARM_BELL,'WARNING: ',MSG); end; {WARN} Procedure ADD_ERROR(MSG,FIELD: String); begin {ADD_ERROR} E_MSG(MSG); if P_MODE then SCREEN(MASK,True,FIND(FIELD,MASK),R_OFF-12,0,12,18,MAX_ROW,MAX_COL-40,F_EXIT) else begin NEWMASK[NFLDS+1]:=BLNKREC; SCREEN(MASK,True,FIND(FIELD,MASK),R_OFF-4,26,4,11,MAX_ROW,MAX_COL-40,F_EXIT); end; {else} exit(ADD); end; {ADD_ERROR} Procedure EXPR(TEXTLINE: String); var CURRENT_CHAR: Char; CHARCLASS,NPAREN,LASTOKEN,CH_COUNT,TOKENTYPE: Integer; Procedure ERROR(OPT: Integer); begin {error} case OPT of 0: ADD_ERROR('Illegal character in expression.','DEFVAL'); 1: ADD_ERROR('Missing right parenthesis.','DEFVAL'); 2: ADD_ERROR('Illegal operator, number expected.','DEFVAL'); 3: ADD_ERROR('Unexpected end of expression, number expected.','DEFVAL'); 4: ADD_ERROR('Missing operator in expression.','DEFVAL'); 5: ADD_ERROR('Too many right parenthesis.','DEFVAL'); end; {case} exit(EXPR); end; {error} Procedure SCAN; (* The following table lists the integer returned for the token listed: 1) + 6) ( 2) - 7) ) 3) * 8) 4) / 9) 5) ^ 10) *) var FINAL_STATE: Boolean; STATE: Integer; Procedure GETCHAR; { Function : GETCHAR pops the next character from TEXTLINE and returns it or an end-of-line marker. Input : None (TEXTLINE is global) Output: A the next character in TEXTLINE. Local Variables : None. } begin {GETCHAR} if CH_COUNT=length(TEXTLINE) then CURRENT_CHAR:='' else begin {return next character and bump character count} CH_COUNT:=CH_COUNT+1; CURRENT_CHAR:=TEXTLINE[CH_COUNT]; end; {else} if CURRENT_CHAR in['a'..'z','A'..'Z'] then CHARCLASS:=10 else if CURRENT_CHAR in['0'..'9'] then CHARCLASS:=9 else if CURRENT_CHAR='.' then CHARCLASS:=8 else if CURRENT_CHAR=')' then CHARCLASS:=7 else if CURRENT_CHAR='(' then CHARCLASS:=6 else if CURRENT_CHAR='^' then CHARCLASS:=5 else if CURRENT_CHAR='/' then CHARCLASS:=4 else if CURRENT_CHAR='*' then CHARCLASS:=3 else if CURRENT_CHAR='-' then CHARCLASS:=2 else if CURRENT_CHAR='+' then CHARCLASS:=1 else if CURRENT_CHAR='' then CHARCLASS:=11 else if CURRENT_CHAR=' ' then CHARCLASS:=0 else ERROR(0); end; {GETCHAR} begin {SCAN} STATE:=0; {Start state - Initialize everybody} FINAL_STATE:=False; while CURRENT_CHAR=' ' do GETCHAR; {eat spaces} if CHARCLASS<8 then STATE:=CHARCLASS else STATE:=CHARCLASS+3; repeat case STATE of 0,1,2,3,4,5,6,7: begin GETCHAR; FINALSTATE:=True; end; 8,9,10,14: FINALSTATE:=True; 11: begin {real no} GETCHAR; if CHARCLASS<>9 then ERROR(2) {real no must have digit} else STATE:=15; end; {real no} 12: begin {integer} GETCHAR; if CHARCLASS=8 then STATE:=15 else if CHARCLASS<>9 then STATE:=9; end; {integer} 13: begin {var} GETCHAR; if (CHARCLASS<>10) and (CHARCLASS<>9) then STATE:=10; end; {var} 15: begin {real no} GETCHAR; if CHARCLASS<>9 then STATE:=8; end; {real no} end {case} until FINAL_STATE; TOKENTYPE:=STATE; end; {SCAN} begin {EXPR} CURRENT_CHAR:=' '; {Initialize input buffer} CH_COUNT:=0; LASTOKEN:=0; NPAREN:=0; SCAN; repeat case TOKENTYPE of 1,2: {plus minus} if LASTOKEN=12 then ERROR(2) else if LASTOKEN in[1,2,3,4,5] then TOKENTYPE:=12; 3,4,5:if LASTOKEN<6 then ERROR(2); {multiply,divide,exponent} 6: if LASTOKEN in[7,8,9,10] then ERROR(4) else NPAREN:=NPAREN+1; {left paren} 7: if LASTOKEN=6 then ERROR(4) else if LASTOKEN<6 then ERROR(2) else if NPAREN=0 then ERROR(5) else NPAREN:=NPAREN-1; {right paren} 8,9,10: if LASTOKEN in[7,8,9,10] then ERROR(4); {number} 14: ERROR(3); end; {case} LASTOKEN:=TOKENTYPE; SCAN; until TOKENTYPE=14; {while} if NPAREN>0 then ERROR(1) else if LASTOKEN<7 then ERROR(3); end; {EXPR} Procedure TESTPROMPT; begin {TESTPROMPT} NPFLDS:=NPFLDS+1; with NEWPROMPTS[NPFLDS] do begin {test prompt info} P_ROW:=IVAL(MASK[FIND('PROW',MASK)].S_FLD); if (P_ROW<0) or (P_ROW>MAX_ROW) then ADD_ERROR('Illegal row number.','PROW'); if P_ROW=MAX_ROW then WARN('Prompt defined on last row.'); P_COL:=IVAL(MASK[FIND('PCOL',MASK)].S_FLD); if (P_COL<0) or (P_COL>MAX_COL) then ADD_ERROR('Illegal column number.','PCOL'); P_FLD:=MASK[FIND('PROMPT',MASK)].S_FLD; EATSPR(P_FLD); if P_COL+length(P_FLD)>MAX_COL then WARN('Prompt defined past EOL.'); DISPLAY; SORTP(NEWPROMPTS,NPFLDS); EXAMINE; end; {test info} end; {TESTPROMPT} begin {Add} if P_MODE then if NPFLDS=SCREEN_FIELDS then E_MSG('Maximum number of prompts reached.') else TESTPROMPT else if NFLDS=SCREEN_FIELDS then E_MSG('Maximum Number of Fields Reached.') else with NEWMASK[NFLDS+1] do begin TEMPID:=MASK[FIND('IDNAME',MASK)].S_FLD; EATSPR(TEMPID); if FIND(TEMPID,NEWMASK)<>0 then ADD_ERROR('Duplicate ID Name.','IDNAME'); if TEMPID='' then ADD_ERROR('Invalid ID Name.','IDNAME') else S_ID :=TEMPID; if MASK[FIND('SKIP',MASK)].S_FLD[1] in['T','F','f','t'] then S_SKIP:=(MASK[FIND('SKIP',MASK)].S_FLD[1]='T') or (MASK[FIND('SKIP',MASK)].S_FLD[1]='t') else ADD_ERROR('Auto Skip must be T or F.','SKIP'); S_TYP:=MASK[FIND('TYPE',MASK)].S_FLD[1]; if S_TYP in['c','d','i','v'] then S_TYP:=chr(ord(S_TYP)-32) else if not (S_TYP in['C','D','I','V']) then ADD_ERROR('Illegal field type.','TYPE'); S_ROW:=IVAL(MASK[FIND('FROW',MASK)].S_FLD); if not (S_ROW in[0..MAX_ROW]) then ADD_ERROR('Illegal row number.','FROW'); if S_ROW=MAX_ROW then WARN('Field defined on last row.'); S_JUS:=MASK[FIND('JUST',MASK)].S_FLD[1]; if S_JUS in['l','r','n'] then S_JUS:=chr(ord(S_TYP)-32) else if not (S_JUS in ['L','R','N']) then ADD_ERROR('Illegal justification type.','JUST'); S_COL:=IVAL(MASK[FIND('FCOL',MASK)].S_FLD); if not (S_COL in[0..MAX_COL]) then ADD_ERROR('Illegal column number.','FCOL'); S_NA :=MASK[FIND('ALFA',MASK)].S_FLD[1]; if S_NA in['a','l','n','s'] then S_NA:=chr(ord(S_NA)-32) else if not (S_NA in['A','L','N','S']) then ADD_ERROR('Illegal input type.','ALFA'); S_LEN:=IVAL(MASK[FIND('LEN',MASK)].S_FLD); if not (S_LEN in[0..MAX_FLEN]) then ADD_ERROR('Illegal field length.','LEN'); if S_COL+S_LEN>MAX_COL then WARN('Field defined past EOL.'); S_MIN:=IVAL(MASK[FIND('MIN',MASK)].S_FLD); if not (S_MIN in[0..S_LEN]) then ADD_ERROR('Illegal field minimum.','MIN'); S_DEF:=MASK[FIND('DEFVAL',MASK)].S_FLD; EATSPR(S_DEF); if S_TYP='C' then EXPR(S_DEF) else if length(S_DEF)>0 then if S_DEF[1]='[' then begin TEMPID:=copy(S_DEF,2,length(S_DEF)-2); if length(TEMPID)<=LEN_ID then TEMPINT:=FIND(TEMPID,NEWMASK) else TEMPINT:=-1; if (TEMPINT=-1) or (S_DEF[length(S_DEF)]<>']') then ADD_ERROR('Illegal default field.','DEFVAL') else if TEMPINT=0 then WARN('Default field undefined.') else S_FLD:=NEWMASK[TEMPINT].S_FLD; end else if length(S_DEF)>S_LEN then ADD_ERROR('Literal default > field length.','DEFVAL') else S_FLD:=S_DEF else S_FLD:=''; NFLDS:=NFLDS+1; SORTRECS(NEWMASK,NFLDS); DISPLAY; end; {else} end; {Add} Procedure NEXT(OP: Integer); begin {next} if P_MODE then begin {next prompt} X:=IVAL(MASK[FIND('INDEX',MASK)].S_FLD)+OP; if NPFLDS=0 then E_MSG('No prompts defined.') else if X>NPFLDS then E_MSG('End of prompt definitions.') else if X<1 then E_MSG('Begining of prompt definitions.') else begin str(X,MASK[FIND('INDEX',MASK)].S_FLD); EXAMINE; end; end {next prompt} else begin {Next Field} TNAME:=MASK[FIND('IDNAME',MASK)].S_FLD; EATSPR(TNAME); X:=FIND(TNAME,NEWMASK)+OP; if NFLDS=0 then E_MSG('No fields defined.') else if X>NFLDS then E_MSG('End of field definitions.') else if X<1 then E_MSG('Begining of field definitions.') else begin MASK[FIND('IDNAME',MASK)].S_FLD:=NEWMASK[X].S_ID; EXAMINE; end; end; {Next field} end; {NEXT} Procedure ERASEIT(R,C,LEN: Integer); begin {ERASEIT} if ((R_OFF=0) and (R>=MAX_ROW div 2)) or ((R_OFF>0) and (R'q') and (CH<>'Q') do begin case CH of 'l','L': begin {Lower} CLEAR_HOME ; R_OFF:=0; DISPLAY; end; {Lower} 'u','U': begin {Upper} CLEAR_HOME ; R_OFF:=(MAX_ROW+1) div 2; DISPLAY; end; {Upper} 'a','A': ADD; 'b','B': NEXT(-1); 'c','C': begin {change} for I:=4 to 17 do OLDVAL[I-3]:=MASK[I].S_FLD; if P_MODE then SCREEN(MASK,True,1,R_OFF-12,0,12,18,MAX_ROW,MAX_COL-40,F_EXIT) else SCREEN(MASK,True,1,R_OFF-4,26,4,11,MAX_ROW,MAX_COL-40,F_EXIT); if F_EXIT=ESC_KEY then begin for I:=4 to 17 do MASK[I].S_FLD:=OLDVAL[I-3]; EXAMINE; end; end; {change} 'd','D': if P_MODE then begin {delete prompt} X:=IVAL(MASK[FIND('INDEX',MASK)].S_FLD); if (X<1) or (X>NPFLDS) then E_MSG('Illegal prompt number.') else begin with NEWPROMPTS[X] do ERASEIT(P_ROW,P_COL,length(P_FLD)); NEWPROMPTS[X]:=BLNKPROMPT; SORTP(NEWPROMPTS,NPFLDS); DISPLAY; end; end {delete prompt} else begin {Delete field} if MASK[FIND('IDNAME',MASK)].S_FLD='' then E_MSG('Invalid ID Name.') else begin TNAME:=MASK[FIND('IDNAME',MASK)].S_FLD; EATSPR(TNAME); X:=FIND(TNAME,NEWMASK); if X=0 then E_MSG('ID Name does not exist.') else begin with NEWMASK[X] do ERASEIT(S_ROW,S_COL,S_LEN); NEWMASK[X]:=BLNKREC; SORTRECS(NEWMASK,NFLDS); DISPLAY; end; end; end; {delete field} 'e','E': EXAMINE; 'f','F': if P_MODE then begin ERASE_PROMPTS(PPROMPTS,R_OFF-12,0,12,18); ERASE_SCREEN(MASK,R_OFF-12,0,12,18); P_MODE:=False; DISPLAY; end; 'n','N': NEXT(1); 'p','P': if not P_MODE then begin ERASE_PROMPTS(PPROMPTS,R_OFF-4,0,4,11); ERASE_SCREEN(MASK,R_OFF-4,26,4,11); P_MODE:=True; DISPLAY; end; 't','T': begin {Test} if NFLDS=0 then E_MSG('Invalid screen file.') else begin SORTRECS(NEWMASK,NFLDS); CLEAR_HOME ; DISPLAY_PROMPTS(NEWPROMPTS,0,0,0,MAX_ROW); DISPLAY_SCREEN(NEWMASK,0,0,0,MAX_ROW); SCREEN(NEWMASK,True,1,0,0,0,MAX_ROW,MAX_ROW,MAX_COL-40,F_EXIT); CLEAR_HOME ; DISPLAY; end; end; {Test} end; {case} gotoxy(38,11+R_OFF); read(Keyboard,CH); if CH in['A'..'Z','a'..'z'] then begin ERASE_EOL(38,11+R_OFF) ; write(CH) ; end else write(ALARM_BELL); end; {While} for I:=1 to NFLDS do with NEWMASK[I] do begin EATSPR(S_FLD); for X:=1 to length(S_FLD) do if S_FLD[X]=ULINE then S_FLD[X]:=' '; end; SORTRECS(NEWMASK,NFLDS); SORTP(NEWPROMPTS,NPFLDS); end; {EDIT_FILE} Function IVAL (* NUMBER: String): Integer *) ; var SUM,I,J,X: Integer; CH: Char; Procedure ERR; begin {ERR} write(ALARM_BELL); IVAL:=0 ; exit(IVAL); end; {ERR} begin {IVAL} SUM:=0; X:=1; EATSPR(NUMBER); EATSPL(NUMBER); for I:=1 to length(NUMBER) do begin CH:=NUMBER[I]; if CH in['0'..'9'] then SUM:=10*SUM+ord(CH)-ord('0') else if (CH='-') and (I=1) then X:=-1 else if (CH='+') and (I=1) then X:=1 else ERR; end; {for I} IVAL:=SUM*X; end; {IVAL} Procedure SORTRECS; (* var A: SCREEN_ARR; var R: Integer*) var TREC: FIELD_DEFS; J,K,L: Integer; CONT: Boolean; begin {SORTRECS} L:=2; K:=R; repeat {shaker sort} for J:=R downto L do if (A[J-1].S_ROW+(A[J-1].S_COL/100))>(A[J].S_ROW+(A[J].S_COL/100)) then begin TREC:=A[J-1]; A[J-1]:=A[J]; A[J]:=TREC; K:=J; end; L:=K+1; for J:=L to R do if (A[J-1].S_ROW+(A[J-1].S_COL/100))>(A[J].S_ROW+(A[J].S_COL/100)) then begin TREC:=A[J-1]; A[J-1]:=A[J]; A[J]:=TREC; K:=J; end; R:=K-1; until L>R; {shaker sort} R:=0; CONT:=True; while CONT do if R=SCREEN_FIELDS then CONT:=False else if A[R+1].S_ROW=END_SCREEN then CONT:=False else R:=R+1; end; {SORTRECS} Procedure SORTP; (* var A: PROMPT_ARR; var R: Integer*) var TREC: PROMPT_DEFS; J,K,L: Integer; CONT: Boolean; begin {SORTP} L:=2; K:=R; repeat {shaker sort} for J:=R downto L do if (A[J-1].P_ROW+(A[J-1].P_COL/100))>(A[J].P_ROW+(A[J].P_COL/100)) then begin TREC:=A[J-1]; A[J-1]:=A[J]; A[J]:=TREC; K:=J; end; L:=K+1; for J:=L to R do if (A[J-1].P_ROW+(A[J-1].P_COL/100))>(A[J].P_ROW+(A[J].P_COL/100)) then begin TREC:=A[J-1]; A[J-1]:=A[J]; A[J]:=TREC; K:=J; end; R:=K-1; until L>R; {shaker sort} R:=0; CONT:=True; while CONT do if R=SCREEN_FIELDS then CONT:=False else if A[R+1].P_ROW=END_SCREEN then CONT:=False else R:=R+1; end; {SORTP} begin {DEFINE} INITIALIZE; SAVED:=True; CH:='C'; while (CH<>'Q') and (CH<>'q') do begin {while} if CH in['c','C','e','E','g','G','p','P','q','Q','s','S'] then begin CLEAR_HOME ; writeln(RETURN_KEY,' ':30,'SCREEN DEFINITION'); writeln(' ':30,'================='); writeln(' ':30,VERSION); gotoxy(26,8); writeln(CLEARP); writeln(' ':26,EDITP); writeln(' ':26,GETP); writeln(' ':26,PRNTP); writeln(' ':26,QUITP); writeln(' ':26,SAVEP); gotoxy(0,MAX_ROW); write('SELECTION : _'); end; gotoxy(12,MAX_ROW); read(Keyboard,CH); if CH in['a'..'z'] then CH:=chr(ord(CH)+ord('A')-ord('a')); if not(CH in['C','E','G','P','Q','S']) then write(CURSOR_LEFT,ALARM_BELL) else write(CH); case CH of 'C': INITIALIZE; 'E': EDIT_FILE; 'G': FILE_IO('G'); 'P': if NFLDS+NPFLDS=0 then begin write(ALARM_BELL,' No prompt or field definitions.'); read(Keyboard,CH); end else FILE_IO('P'); 'Q': if not SAVED then begin write(ALARM_BELL, ' Do you want to save the current definition file?'); while not(CH in['n','y','N','Y']) do read(Keyboard,CH); write(CH); if (CH='n') or (CH='N') then CH:='Q' else begin CH:='S'; FILE_IO('S'); end; {else} end; 'S': if NFLDS+NPFLDS=0 then begin write(ALARM_BELL,' No prompt or field definitions.'); read(Keyboard,CH); end else FILE_IO('S'); end; {case} end; {while} end. {DEFINE} ======================================================================================== DOCUMENT :usus Folder:VOL25:sh.calc.text ======================================================================================== Function EVAL (* NUMBER: String): Real *) ; var SUM: Real; RIGHT,I,J,X: Integer; CH: Char; begin {EVAL} SUM:=0; X:=1; EATSPR(NUMBER); EATSPL(NUMBER); for I:=1 to length(NUMBER) do begin CH:=NUMBER[I]; if CH in['0'..'9'] then SUM:=10*SUM+(ord(CH)-48) else begin if (CH='-') and (I=1) then X:=-1 else if (CH='+') and (I=1) then X:=1 else if (CH='.') then {Decimal part} begin RIGHT:=10; for J:=I+1 to length(NUMBER) do begin CH:=NUMBER[J]; if CH in['0'..'9'] then begin SUM:=SUM + ((ord(CH)-48) / RIGHT); RIGHT:=RIGHT*10; end {then} else write(ALARM_BELL); end; {for J} EVAL:=SUM*X; exit(EVAL); end {Decimal part} else write(ALARM_BELL); end; {else} end; {for I} EVAL:=SUM*X; exit(EVAL); end; {EVAL} Procedure CALC(var CALC_SCREEN: SCREEN_ARR; FLD,R_OFF,C_OFF: Integer; var EFLAG: Boolean); var DPART,INDEX,J: Integer; {Integer pointers and temporary storage} OP: Char; {Algebraic operator} DPSTR,TEMP: String; {Temporary string storage} OPERAND,ANS: Real; {Answer returned and temporary operand} Procedure ERR(OP: Integer); { Inform the user he has entered an illegal expression } begin {ERROR} with CALC_SCREEN[FLD] do begin if OP=1 then S_FLD:='Division by zero.' else if OP=2 then S_FLD:='Illegal numeric constant.' else if OP=3 then S_FLD:='Result overflow.' else S_FLD:='Illegal expression.'; end; {with} EFLAG:=True; exit(CALC); { Return directly to main program } end; {ERROR} begin {CALC} with CALC_SCREEN[FLD] do begin if S_FLD[length(S_FLD)]<>'=' then S_FLD:=concat(S_FLD,'='); INDEX:=1; OP:=' '; OPERAND:=0; EFLAG:=False; while INDEX<=length(S_FLD) do begin if S_FLD[INDEX] in['0'..'9','.','-'] then begin {Evaluate number string} J:=1; TEMP:=' '; while S_FLD[INDEX] in['0'..'9','.'] do begin TEMP[J]:=S_FLD[INDEX]; INDEX:=INDEX+1; J:=J+1; end; {while} OPERAND:=EVAL(TEMP); end else begin J:=1; TEMP:=' '; while not(S_FLD[INDEX] in['+','-','*','/','=']) and (J<=8) do begin TEMP[J]:=S_FLD[INDEX]; INDEX:=INDEX+1; J:=J+1; end; {while} EATSPR(TEMP); J:=FIND(TEMP,CALC_SCREEN); if J=0 then OPERAND:=0 else OPERAND:=EVAL(CALC_SCREEN[J].S_FLD); end; case OP of ' ': ANS:=OPERAND; '+': ANS:=ANS + OPERAND; '-': ANS:=ANS - OPERAND; '*': ANS:=ANS * OPERAND; '/': if OPERAND=0 then ERR(4) else ANS:=ANS / OPERAND; end; {case} if INDEX<=length(S_FLD) then if S_FLD[INDEX] in['+','-','*','/','='] then begin { Check for operator } OP:=S_FLD[INDEX]; if OP='=' then INDEX:=length(S_FLD)+1 else INDEX:=INDEX+1; end; end; {while} DPART:=trunc( ABS(ANS-trunc(ANS)) *10000); str(trunc(ANS),TEMP); str(DPART,DPSTR); DPSTR:=copy(concat(DPSTR,'00000'),1,S_MIN); if length(TEMP)+length(DPSTR)>=40 then ERR(3) else S_FLD:=concat(TEMP,'.',DPSTR); gotoxy(S_COL+C_OFF,S_ROW+R_OFF); if S_JUS='R' then while length(S_FLD)0) and (S_TYP<>'C') then if (S_DEF[1]='[') and (S_DEF[length(S_DEF)]=']') then if FIND(copy(S_DEF,2,length(S_DEF)-2),SHOW_SCREEN)>0 then S_FLD:=SHOW_SCREEN[FIND(copy(S_DEF,2,length(S_DEF)-2) ,SHOW_SCREEN)].S_FLD else S_FLD:=S_DEF else S_FLD:=S_DEF; S_FLD:=copy(concat(S_FLD,UNDERLINE),1,S_LEN); for I:=1 to length(S_FLD) do if S_FLD[I]=' ' then S_FLD[I]:=ULINE; write(S_FLD); end; end; {DISPLAY_SCREEN} Procedure DISPLAY_PROMPTS; (* var P_ARRAY: PROMPT_ARR; ROW_OFFSET,COL_OFFSET, START_ROW,END_ROW:Integer *) var INDEX: Integer; begin {DISPLAY_PROMPTS} for INDEX:=1 to PROMPT_FIELDS do with P_ARRAY[INDEX] do if (P_ROW+ROW_OFFSET in[0..MAX_ROW]) and (P_ROW in[START_ROW..END_ROW]) and (P_COL+COL_OFFSET in[0..MAX_COL]) then begin gotoxy(P_COL+COL_OFFSET,P_ROW+ROW_OFFSET); write(P_FLD); end else if P_ROW=END_SCREEN then exit(DISPLAY_PROMPTS); end; {DISPLAY_PROMPTS} Procedure ERASE_SCREEN; (* var E_SCREEN:SCREEN_ARR; ROW_OFFSET,COL_OFFSET, START_ROW,END_ROW:Integer *) var INDEX,LEN:Integer; begin {ERASE_SCREEN} for INDEX:=1 to SCREEN_FIELDS do with E_SCREEN[INDEX] do if (S_ROW+ROW_OFFSET in[0..MAX_ROW]) and (S_ROW in[START_ROW..END_ROW]) and (S_COL+COL_OFFSET in [0..MAX_COL]) then begin gotoxy(S_COL+COL_OFFSET,S_ROW+ROW_OFFSET); for LEN:=1 to S_LEN do write(' '); end else if S_ROW=END_SCREEN then exit(ERASE_SCREEN); end; {ERASE_SCREEN} Procedure ERASE_PROMPTS; (* var P_ARRAY:PROMPT_ARR; ERASE_OFFSET,START_ROW,END_ROW:Integer *) var INDEX,LEN: Integer; begin {ERASE_PROMPTS} for INDEX:=1 to PROMPT_FIELDS do with P_ARRAY[INDEX] do if (P_ROW+ROW_OFFSET in[0..MAX_ROW]) and (P_ROW in[START_ROW..END_ROW]) and (P_COL+COL_OFFSET in [0..MAX_COL]) then begin gotoxy(P_COL+COL_OFFSET,P_ROW+ROW_OFFSET); for LEN:=1 to length(P_FLD) do write(' '); end else if P_ROW=END_SCREEN then exit(ERASE_PROMPTS); end; {ERASE_PROMPTS} ======================================================================================== DOCUMENT :usus Folder:VOL25:sh.field.text ======================================================================================== Procedure EATSPL; (* var F_FLD: STRING *) { Local procedure that removes all spaces on the left end of string F_FLD. } begin {EATSPL} repeat if length(F_FLD)=0 then exit(EATSPL) else if (F_FLD[1]=' ') or (F_FLD[1]=ULINE) then delete(F_FLD,1,1) else exit(EATSPL); until False; end; {EATSPL} Procedure EATSPR; (* var F_FLD: STRING *) { Local procdeure that removes all spaces on the right side of string F_FLD.} begin {EATSPR} repeat if length(F_FLD)=0 then exit(EATSPR) else if (F_FLD[length(F_FLD)]=' ') or (F_FLD[length(F_FLD)]=ULINE) then delete(F_FLD,length(F_FLD),1) else exit(EATSPR); until False; end; {EATSPR} Procedure FIELD; var CHAR_POSITION,TEMP_CHAR,MAX_CHAR,CHAR_INDEX,CHAR_COUNT: Integer; F_ERROR,EXIT_FLAG: Boolean; ULCHAR: String[1]; F_INPUT: Char; Procedure INIT_FIELD(var F_FLD:STRINGFL; F_LEN,F_E_COL,F_E_ROW:Integer; F_JUS:Char); {Local procedure that initilizes the data field and some other variables} begin {INIT} if (F_E_ROW<0) or (F_E_ROW>MAX_ROW) then F_E_ROW:=MAX_ROW; if (F_E_COL<0) or (F_E_COL>MAX_COL) then F_E_COL:=MAX_COL-40; if (F_JUS='L') or (F_AN='N') then begin EATSPL(F_FLD); F_FLD:=copy(concat(F_FLD,UNDERLINE),1,F_LEN); end else if F_JUS='R' then begin EATSPR(F_FLD); while length(F_FLD)=F_LEN) then F_INPUT:=CURSOR_RIGHT; end else begin F_ERROR:=True; gotoxy(F_E_COL,F_E_ROW); write(ALARM_BELL,'ERROR: '); if not (F_AN in['A','L','N','S']) then F_AN:='S'; case F_AN of 'A' : write('Alphanumeric character required.'); 'L' : write('Alphabetic letter required.'); 'N' : write('Numeric character required.'); 'S' : write('Illegal character.'); end; {case} end; {else} end; {UPDATE} begin {FIELD} ULCHAR:=' '; ULCHAR[1]:=ULINE; INIT_FIELD(F_FLD,F_LEN,F_E_COL,F_E_ROW,F_JUS); CHAR_POSITION:=0; gotoxy(F_COL,F_ROW); write(F_FLD); gotoxy(F_COL,F_ROW); F_ERROR:=True; repeat EXIT_FLAG:=False; repeat if CHAR_POSITION0 then CHAR_POSITION:=CHAR_POSITION-1 else EXIT_FLAG:=True else if F_INPUT=CURSOR_RIGHT then if CHAR_POSITION+1MAX_CHAR then MAX_CHAR:=CHAR_POSITION; if MAX_CHAR>F_LEN then MAX_CHAR:=F_LEN; gotoxy(F_COL,F_ROW); write(copy(concat(F_FLD,UNDERLINE),1,MAX_CHAR)); until EXIT_FLAG=True; CHAR_COUNT:=0; for CHAR_INDEX:=1 to F_LEN do if F_FLD[CHAR_INDEX]<>ULINE then CHAR_COUNT:=CHAR_COUNT+1; if CHAR_COUNT 0 then begin {open error} close(FILE_TO_GET); exit(GET_PHILE); end;{open error} seek(FILE_TO_GET,0); get(FILE_TO_GET); GET_RESULT:=IO_RESULT; NFLDS:=0; NP:=0; while not eof(FILE_TO_GET) do begin if IO_RESULT<>0 then begin {wierd error} GET_RESULT:=IO_RESULT; close(FILE_TO_GET); exit(GET_PHILE); end; {wierd error} if FILE_TO_GET^.TAG then begin {read prompt data} if NP=PROMPT_FIELDS then begin GET_RESULT:=15; exit(GET_PHILE); end; NP:=NP+1; GET_PROMPTS[NP]:=FILE_TO_GET^.P[1]; EATSPR(GET_PROMPTS[NP].P_FLD); NP:=NP+1; GET_PROMPTS[NP]:=FILE_TO_GET^.P[2]; EATSPR(GET_PROMPTS[NP].P_FLD); end {read prompt data} else begin {read field data} if NFLDS=SCREEN_FIELDS then begin GET_RESULT:=15; exit(GET_PHILE); end; NFLDS:=NFLDS+1; GET_SCREEN[NFLDS]:=FILE_TO_GET^.S; end; {read field data} get(FILE_TO_GET); GET_RESULT:=IO_RESULT; end; {while} for I:=NFLDS+1 to SCREEN_FIELDS do GET_SCREEN[I].S_ROW:=END_SCREEN; for I:=NP+1 to PROMPT_FIELDS do GET_PROMPTS[I].P_ROW:=END_SCREEN; close(FILE_TO_GET); {$I+} end; {GET_PHILE} Procedure GET_FILE(* GET_NAME: String; { File name to get } var GET_SCREEN: SCREEN_ARR; { Screen to load } var GET_PROMPTS: PROMPT_ARR; { Prompts to load } var GET_RESULT: Integer*); { IO return code } BEGIN GET_PHILE( GET_NAME, { File name to get } GET_SCREEN, { Screen to load } GET_PROMPTS, { Prompts to load } GET_RESULT );{ IO return code } END ; { GET_FILE } Procedure SAVE_FILE(* SAVE_NAME: String; { File name to save } var SAVE_SCREEN: SCREEN_ARR; { Screen to save } var SAVE_PROMPTS: PROMPT_ARR; { Prompts to save } var SAVE_RESULT: Integer*); { IO return code } begin SAVE_PHILE( SAVE_NAME, { File name to save } SAVE_SCREEN, { Screen to save } SAVE_PROMPTS, { Prompts to save } SAVE_RESULT ) ; { IO return code } end ; Function FIND; (* FIELD_ID: STR_ID; var FIND_SCREEN:SCREEN_ARR): Integer *) var FIND_INDEX: Integer; begin {FIND} FIND_INDEX:=1; FIND:=0; while FIND_SCREEN[FIND_INDEX].S_ROW<>END_SCREEN do begin {while} if FIELD_ID=FIND_SCREEN[FIND_INDEX].S_ID then begin FIND:=FIND_INDEX; exit(FIND); end; if FIND_INDEX=SCREEN_FIELDS then exit(FIND) else FIND_INDEX:=FIND_INDEX+1; end; {while} end; {FIND} {$I SH.FIELD.TEXT} {$I SH.DISPLAY.TEXT} Procedure SCREEN; (* var RUNING_SCREEN: SCREEN_ARR; ROW_OFFSET,COL_OFFSET,START_ROW,END_ROW, ERROR_COL,ERROR_ROW: Integer; var F_EXIT: Integer *) var FLD1,FLD2,RTEMP_COL,RTEMP_ROW,R_T_COL,RUN_INDEX: Integer; FIELD_ERROR,EXIT_RUN: Boolean; Procedure COUNT_FIELDS(var COUNT_SCREEN:SCREEN_ARR; var TOP_ROW,END_ROW,START_FLD,END_FLD:Integer); begin {COUNT} START_FLD:=1; while COUNT_SCREEN[START_FLD].S_ROW1 then END_FLD:=END_FLD-1 else exit(SCREEN); end; {COUNT} Procedure CHECK_INPUT(var CHECK_SCREEN:SCREEN_ARR; {Screen being checked } var CHECK_START, CHECK_END, CHECK_E_COL, {Error message column } CHECK_E_ROW:Integer; {Error message row } var CHECK_ERROR:Boolean; {Set true if error found } var CHECK_INDEX:Integer); {Index of field with error } var NUM_CHAR,CHAR_INDEX: Integer; KEY_IN:Char; begin {CHECK INPUT} CHECK_INDEX:=CHECK_START; CHECK_ERROR:=False; while (not CHECK_ERROR) and (CHECK_INDEX<=CHECK_END) do begin with CHECK_SCREEN[CHECK_INDEX] do begin if S_TYP<>'C' then begin NUM_CHAR:=0; for CHAR_INDEX:=1 to length(S_FLD) do if S_FLD[CHAR_INDEX]=ULINE then S_FLD[CHAR_INDEX]:=' ' else NUM_CHAR:=NUM_CHAR+1; if (NUM_CHARFLD2 then begin FIELDNO:=FLD1; if not WRAP then EXIT_RUN:=True; end else if FIELDNO'C'; end; {NEXTFIELD} begin {SCREEN} if END_ROW+ROW_OFFSET>MAX_ROW then END_ROW:=MAX_ROW-ROW_OFFSET; if START_ROW+ROW_OFFSET<0 then START_ROW:=-ROW_OFFSET; COUNT_FIELDS(RUNING_SCREEN,START_ROW,END_ROW,FLD1,FLD2); if FLD1>START_FIELD then START_FIELD:=FLD1; RUN_INDEX:=START_FIELD; FIELD_ERROR:=False; repeat EXIT_RUN:=False; repeat with RUNING_SCREEN[RUN_INDEX] do begin R_T_COL:=S_COL+COL_OFFSET; if S_TYP='C' then F_EXIT:=TAB_SKIP else begin EATSPR(S_FLD); if (S_FLD='') and (S_DEF>'') and (S_TYP<>'C') then if (S_DEF[1]='[') and (length(S_DEF)<=LEN_ID+2) then S_FLD:=RUNING_SCREEN[FIND(copy(S_DEF,2,length(S_DEF)-2),RUNING_SCREEN)].S_FLD else S_FLD:=S_DEF; FIELD(S_ROW+ROW_OFFSET,R_T_COL,ERROR_ROW,ERROR_COL,S_LEN,S_MIN, F_EXIT,S_JUS,S_NA,S_FLD,S_SKIP); end; {else} end; {with} if FIELD_ERROR=True then ERASE_EOL(ERROR_COL,ERROR_ROW); {case F_EXIT of } if F_EXIT in[TAB_SKIP,CURSOR_RIGHT,TAB_RIGHT] then NEXTFIELD(RUN_INDEX,1) else if F_EXIT in[TAB_LEFT,CURSOR_LEFT] then NEXTFIELD(RUN_INDEX,-1) else if F_EXIT=CURSOR_DOWN then begin with RUNING_SCREEN[RUN_INDEX] do begin RTEMP_ROW:=S_ROW; RTEMP_COL:=S_COL; end; repeat NEXTFIELD(RUN_INDEX,1); if RUN_INDEX=FLD1 then RTEMP_ROW:=-1; until (RUNING_SCREEN[RUN_INDEX].S_ROW>RTEMP_ROW) and (RUNING_SCREEN[RUN_INDEX].S_COL>=RTEMP_COL); end else if F_EXIT=CURSOR_UP then begin with RUNING_SCREEN[RUN_INDEX] do begin RTEMP_ROW:=S_ROW; RTEMP_COL:=S_COL; end; repeat NEXTFIELD(RUN_INDEX,-1); if RUN_INDEX=FLD2 then RTEMP_ROW:=MAX_ROW+1; until (RUNING_SCREEN[RUN_INDEX].S_ROWRTEMP_ROW); end else if F_EXIT=ERASE_INPUT then begin for RUN_INDEX:=FLD1 to FLD2 do with RUNING_SCREEN[RUN_INDEX] do if S_TYP<>'C' then S_FLD:=''; DISPLAY_SCREEN(RUNING_SCREEN,ROW_OFFSET,COL_OFFSET,START_ROW,END_ROW); RUN_INDEX:=START_FIELD; end else if F_EXIT=C_HOME then RUN_INDEX:=FLD1 else if F_EXIT=ENTER_KEY then EXIT_RUN:=True else if F_EXIT=ESC_KEY then exit(SCREEN) else write(ALARM_BELL); until EXIT_RUN=True; CHECK_INPUT(RUNING_SCREEN,FLD1,FLD2,ERROR_COL,ERROR_ROW,FIELD_ERROR,RUN_INDEX); until FIELD_ERROR=False; end; {SCREEN} Procedure CLEAR_HOME ; begin sc_home ; sc_clr_screen ; end ; Procedure ERASE_EOL{ X:integer ; Y:integer } ; begin sc_erase_to_eol( x, y ) ; end ; Procedure ERASE_EOS{ X:integer ; Y:integer } ; begin sc_eras_eos( x, y ) ; end ; Procedure HOME ; begin sc_home ; end ; {$I SH.INIT.TEXT} end. {UNIT} ======================================================================================== DOCUMENT :usus Folder:VOL25:ud.copy.text ======================================================================================== {xL #5:CPYLST.TEXT } PROGRAM COPY_DATA_FILE; { Author : Mike Smith Date written : July 23, 1981 Revision : This program copies records from one data file to another Files required: UDE SCRN and TEXT files to copy from and SCRN and TEXT files to copy to. The program will create the TEXT file to copy to if it does not already exist. Method: After opening the required files, the program prompts the the user for information regarding which records of the "from" data file are to be copied. The program then does the following in a loop until the end of either data file is reached. A record is read from the "from" data file and the fields of that record are loaded into OLD_FIELDS. If it is decided that that record is to be copied, the proper fields are copied from OLD_FIELDS to NEW_FIELDS. The NEW_FIELDS are put in the proper format and written out to a buffer to be written to disk when full. } USES {$U SH.SCREEN.UNIT} SCREEN40; CONST SCREEN_TESTS = 13; MAX_TESTS = 52; MAX_INT = 32767; MAX_REC_LEN = 255; TYPE MAP_REC = RECORD OLD_FLD_NO : INTEGER; SET_TYPE : CHAR; END; OPS = (LT,GT,EQ,LE,GE,NE); TEST_REC = PACKED RECORD FIELD_LOC : 0..SCREEN_FIELDS; OPERATOR : OPS; VALUE : STRINGFL; END; GENFILE = FILE OF PACKED RECORD CASE INTEGER OF 0:(NFLDS,RSIZE,NRECS,LIM : INTEGER); 1:(DATA : STRING[MAX_REC_LEN]); END; MAP_DEF = ARRAY[1..SCREEN_FIELDS] OF MAP_REC; TEST_DEF = ARRAY[1..MAX_TESTS] OF TEST_REC; STRING2 = STRING[2]; STRING5 = STRING[5]; STRING23 = STRING[23]; STRING40 = STRING[40]; STRING255 = STRING[255]; THREEWORDINT = INTEGER[8]; BUF_DEF = PACKED ARRAY[0..511] OF 0..255; VAR OLD_FIELDS,NEW_FIELDS : SCREEN_ARR; MAP_ARRAY : MAP_DEF; TEST_ARRAY : TEST_DEF; DATA_RESULTS, { 0 If data file exists } DEFI_RESULTS, { 0 If data file definition exists } GET_RESULTS, { 0 If 'GET.SCRN' loaded } RESULTS,INDEX,NUM_OLD_FLDS,NUM_NEW_FLDS,NEW_REC_NO,NUM_FLDS, FIELD_ROW,FIELD_COL,FIELD_LEN,FIELD_MIN,OLD_BLOCK,NEW_BLOCK,MAX_RECORDS, NUM_OLD_RECS,I,II,OLD_REC_NO,OLD_REC_LEN,NEW_REC_LEN, NUM_REC,ERRCOL,ERROW : INTEGER; EXIT_KEY,FIELD_JUS,FIELD_NA,CH : CHAR; FIELD_FLD : STRINGFL; DIGITSET : SET OF CHAR; VOLUME : STRING[7]; { Data file volume } NAME : STRING[10]; { Data file name } DB_NAME : STRING[18]; { Volume + Data file name } O_DEFI_NAME : STRING[23];{ Data File Definition Name } N_DATA_NAME : STRING[23];{ Data File Name } STR_RECNO : STRING[5]; OLD_FILE,NEW_FILE : FILE; OLD_GEN_FILE : GENFILE; TRUNC_FLDS_OK,ALL_TESTS,FIELD_SKIP,COPY_BLNKS,COPY_ALL_FLDS,COPY_ALL_RECS, DB_IS_NEW,CLEAR_FILE,APPEND_FILE,UDE_FILE,REC_IS_BLANK : BOOLEAN; Procedure MESSAGE(M_ROW,M_COL :Integer; MSG :String; DING: Boolean); FORWARD; Procedure EAT_SPACES(var TEMP :String; LEFT_EAT,RIGHT_EAT :Boolean); FORWARD; PROCEDURE LEAVE(MSG : STRING); FORWARD; SEGMENT PROCEDURE INITIALIZE; BEGIN FOR I := 1 TO SCREEN_FIELDS DO WITH OLD_FIELDS[I] DO BEGIN S_ID := ''; S_ROW := END_SCREEN; S_COL := 0; S_LEN := 0; S_MIN := 0; S_TYP := 'V'; S_JUS := 'L'; S_NA := 'A'; S_SKIP := TRUE; S_DEF := ''; S_FLD := ''; END; FOR I := 1 TO SCREEN_FIELDS DO WITH NEW_FIELDS[I] DO BEGIN S_ID := ''; S_ROW := END_SCREEN; S_COL := 0; S_LEN := 0; S_MIN := 0; S_TYP := 'V'; S_JUS := 'L'; S_NA := 'A'; S_SKIP := TRUE; S_DEF := ''; S_FLD := ''; END; FOR I := 1 TO MAX_TESTS DO WITH TEST_ARRAY[I] DO BEGIN FIELD_LOC := 0; VALUE := ''; END; WITH OLD_FIELDS[1] DO BEGIN S_ID := 'OLDVOL'; S_NA := 'S'; S_ROW := 7; S_COL := 15; S_LEN := 7; END; WITH OLD_FIELDS[2] DO BEGIN S_ID := 'OLDNAME'; S_ROW := 9; S_COL := 15; S_LEN := 10; END; WITH OLD_FIELDS[3] DO BEGIN S_ID := 'NEWVOL'; S_NA := 'S'; S_ROW := 16; S_COL := 15; S_LEN := 7; END; WITH OLD_FIELDS[4] DO BEGIN S_ID := 'NEWNAME'; S_ROW := 18; S_COL := 15; S_LEN := 10; END; ERASE_EOS(0,0); GOTOXY(27,0); WRITE('COPY A DATA FILE'); GOTOXY(27,1); WRITE('================'); GOTOXY(27,2); WRITE('Version IV.0'); GOTOXY(0,5); WRITE('DATA FILE TO COPY FROM'); GOTOXY(0,7); WRITE('Volume :'); GOTOXY(0,9); WRITE('Name :'); GOTOXY(0,11); WRITE('Type : SCRN and either TEXT or GEN'); GOTOXY(0,14); WRITE('DATA FILE TO COPY TO'); GOTOXY(0,16); WRITE('Volume :'); GOTOXY(0,18); WRITE('Name :'); GOTOXY(0,20); WRITE('Type : SCRN and TEXT'); OLD_BLOCK := -1; NEW_BLOCK := -1; DIGITSET := ['0'..'9']; FIELD_LEN := 5; FIELD_MIN := 0; ERRCOL := 40; ERROW := 23; FIELD_JUS := 'L'; FIELD_NA := 'N'; FIELD_FLD := '0'; FIELD_SKIP := FALSE; END; SEGMENT PROCEDURE GET_FILES; { Gets the "from" and "to" data files } LABEL 1; VAR DATA_FILE : FILE; O_DATA_NAME,N_DEFI_NAME : STRING[23]; GET_PROMPTS : PROMPT_ARR; SEGMENT Procedure GET_DATA_FILE; { Procedure checks for data file data file. If no data file exist then the operator can create one. } var RIGHT: BOOLEAN; function INTVALUE(S: STRING; var NUM: INTEGER): boolean; var I: integer; NUML : THREEWORDINT; begin INTVALUE:=false; I:=1; NUML:=0; EATSPL(S); EATSPR(S); if length(S)=0 then exit(INTVALUE); for I:=1 to length(S) do if S[I] in DIGITSET then NUML:=10*NUML+ord(S[I])-ord('0') else exit(INTVALUE); if NUML>MAX_INT then exit(INTVALUE); NUM := TRUNC(NUML); INTVALUE:=true; end; { INTVALUE } Procedure CREATE(var CREATE_NAME:STRING23; var CREATE_LENGTH,NUMBER_RECORDS,CREATE_RESULTS:Integer); { Procedure creates and initilizes a file to hold data file records. } var NO_BLOCKS : Integer; buffer: packed array[0..1023] of 0..255; off_set: integer; IO_REC : PACKED RECORD CASE INTEGER OF 1: (A: PACKED ARRAY[0..255] OF 0..255); 2: (B: STRING[255]); END; check: integer; begin {CREATE} CREATE_RESULTS:=1; fillchar(IO_REC.A[0],sizeof(IO_REC),chr(00)); NO_BLOCKS:=NUMBER_RECORDS div (1024 div CREATE_LENGTH)+1; (*$i-*) rewrite(data_file,CREATE_NAME); if IO_RESULT<>0 then exit(create); fillchar(IO_REC.A[4],CREATE_LENGTH-5,' '); IO_REC.A[0]:=CREATE_LENGTH; IO_REC.A[1]:=16; IO_REC.A[2]:=32; IO_REC.A[3]:=126; IO_REC.A[CREATE_LENGTH-1]:=42; IO_REC.A[CREATE_LENGTH]:=13; fillchar(buffer[0],sizeof(buffer),chr(00)); check:=blockwrite(data_file,buffer,2); (* text file prefix *) if CHECK<>2 then begin close(data_file); exit(create); end; off_set:=0; while off_set+create_length <= 1023 do begin moveleft(io_rec.a[1],buffer[off_set],create_length); off_set:=off_set+create_length; end; index:=1; while index <= no_blocks do begin check:=blockwrite(data_file,buffer,2); if check<>2 then begin close(data_file); exit(create); end; index:=index+1; end; (* while *) (*$i+*) close(data_file,LOCK); CREATE_RESULTS:=0; end; {CREATE} begin {GET_DATA_FILE} {$I-} DB_IS_NEW := FALSE; reset(DATA_FILE,N_DATA_NAME); {$I+} if IO_RESULTS <> 0 then begin ERASE_EOL(0,MAX_ROW); write('Create new data file Y/N ? Y'); gotoxy(27,MAX_ROW); read(Keyboard,CH); if CH in [' ','Y','y'] then begin {make the file} DB_IS_NEW := TRUE; ERASE_EOL(0,MAX_ROW); write('Maximum number of records ?'); REPEAT FIELD_ROW:=MAX_ROW; FIELD_COL:=29; FIELD_FLD:='0'; FIELD_SKIP:=FALSE; FIELD(FIELD_ROW,FIELD_COL,ERROW,ERRCOL,FIELD_LEN,FIELD_MIN, EXIT_KEY,FIELD_JUS,FIELD_NA,FIELD_FLD,FIELD_SKIP); RIGHT:=INTVALUE(FIELD_FLD,MAX_RECORDS); { MAR 11 } IF NOT RIGHT THEN MESSAGE(MAX_ROW,40,'ERROR: Incorrect number of records',TRUE); UNTIL RIGHT; MESSAGE(MAX_ROW,40,'STATUS: Creating Data File',False); CREATE(N_DATA_NAME,NEW_REC_LEN,MAX_RECORDS,RESULTS); if RESULTS<>0 then begin MESSAGE(MAX_ROW,40,'ERROR: Unable to create text data file', True); DATA_RESULTS:=1; end else DATA_RESULTS:=0; end else DATA_RESULTS:=1; end else begin close(DATA_FILE); DATA_RESULTS:=0; end; end; {GET DATA FILE} SEGMENT Procedure RECORD_LENGTH(var S_ARRAY :SCREEN_ARR; var REC_LEN:integer; var NUM_FIELDS: integer); { Function to find the length of the record defined by the data file definition.} var DONE: boolean; { Jan 5 To correct end_screen problem } begin {RECORD LENGTH} REC_LEN:=0; DONE:=false; { Jan 5 } INDEX:=1; while not DONE do if S_ARRAY[INDEX].S_ROW=END_SCREEN then DONE:=true else begin REC_LEN:=REC_LEN+S_ARRAY[INDEX].S_LEN; DONE := INDEX = SCREEN_FIELDS; INDEX:=INDEX+1; end; REC_LEN:=REC_LEN+5; NUM_FIELDS:=INDEX-1; { Jan 5/Mar 12 } end; {RECORD LENGTH} BEGIN {GET_FILES} 1: DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23); MESSAGE(MAX_ROW,0,' to execute, to abort',false); SCREEN(OLD_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY); IF EXIT_KEY = ESC_KEY THEN EXIT(COPY_DATA_FILE); VOLUME := OLD_FIELDS[FIND('NEWVOL',OLD_FIELDS)].S_FLD; EATSPR(VOLUME); NAME := OLD_FIELDS[FIND('NEWNAME',OLD_FIELDS)].S_FLD; EAT_SPACES(NAME,TRUE,TRUE); DB_NAME := CONCAT(VOLUME,':',NAME); N_DEFI_NAME := CONCAT(DB_NAME,'.SCRN'); N_DATA_NAME := CONCAT(DB_NAME,'.TEXT'); GET_FILE(N_DEFI_NAME,NEW_FIELDS,GET_PROMPTS,RESULTS); IF RESULTS <> 0 THEN BEGIN MESSAGE(MAX_ROW,40,'ERROR: Unknown "to" data file',TRUE); GOTO 1; END; RECORD_LENGTH(NEW_FIELDS,NEW_REC_LEN,NUM_NEW_FLDS); IF NEW_REC_LEN > 255 THEN BEGIN MESSAGE(MAX_ROW,40,'ERROR: Defined screen is too long',TRUE); GOTO 1; END; VOLUME := OLD_FIELDS[FIND('OLDVOL',OLD_FIELDS)].S_FLD; EATSPR(VOLUME); NAME := OLD_FIELDS[FIND('OLDNAME',OLD_FIELDS)].S_FLD; EAT_SPACES(NAME,TRUE,TRUE); DB_NAME := CONCAT(VOLUME,':',NAME); O_DEFI_NAME := CONCAT(DB_NAME,'.SCRN'); O_DATA_NAME := CONCAT(DB_NAME,'.TEXT'); DATA_RESULTS := 0; GET_FILE(O_DEFI_NAME,OLD_FIELDS,GET_PROMPTS,RESULTS); IF RESULTS <> 0 THEN BEGIN MESSAGE(MAX_ROW,40,'ERROR: Unknown "from" data file',TRUE); GOTO 1; END; RECORD_LENGTH(OLD_FIELDS,OLD_REC_LEN,NUM_OLD_FLDS); IF OLD_REC_LEN > 255 THEN BEGIN MESSAGE(MAX_ROW,40,'ERROR: Defined screen is too long',TRUE); GOTO 1; END; UDE_FILE := TRUE; {$I-} RESET(OLD_FILE,O_DATA_NAME); IF IO_RESULT <> 0 THEN BEGIN UDE_FILE := FALSE; { Copying from a GENLIST file } O_DATA_NAME := CONCAT(VOLUME,':',NAME,'.GEN'); RESET(OLD_GEN_FILE,O_DATA_NAME); IF IO_RESULTS <> 0 THEN BEGIN MESSAGE(MAX_ROW,40, 'ERROR: Found no TEXT or GEN file to copy from',TRUE); GOTO 1; END; {$I+} SEEK(OLD_GEN_FILE,0); GET(OLD_GEN_FILE); NUM_OLD_FLDS := OLD_GEN_FILE^.NFLDS; OLD_REC_LEN := OLD_GEN_FILE^.RSIZE; NUM_OLD_RECS := OLD_GEN_FILE^.NRECS; END; GET_DATA_FILE; FOR I := 1 TO SCREEN_FIELDS DO BEGIN EAT_SPACES(NEW_FIELDS[I].S_ID,TRUE,TRUE); EAT_SPACES(OLD_FIELDS[I].S_ID,TRUE,TRUE); END; END; SEGMENT PROCEDURE CREATE_MAP_ARRAY; { Creates an array that determines the mapping of the fields of the from data file to the fields of the to data file. There is a one to one correspondance between elements of MAP_ARRAY and elements of NEW_FIELDS. For example, the subscript of the field in OLD_FIELDS to be copied to NEW_FIELDS[3].S_FLD may be found in MAP_ARRAY[3].OLD_FLD_NO. A 0 in OLD_FLD_NO indicates that there is no corresponding field in OLD_FIELDS. MAP_ARRAY may be modified by the GET_COPY_INFO procedure depending on the type of copy being executed. The SET_TYPE field of MAP_ARRAY indicates what type of data is to be accepted into the new field. } VAR NO_GOOD : BOOLEAN; NUM_FLDS : INTEGER; BEGIN NO_GOOD := FALSE; FOR I := 1 TO SCREEN_FIELDS DO WITH MAP_ARRAY[I] DO BEGIN OLD_FLD_NO := FIND(NEW_FIELDS[I].S_ID,OLD_FIELDS); SET_TYPE := '-'; { Indicates any data is acceptable } IF OLD_FLD_NO > 0 THEN CASE OLD_FIELDS[OLD_FLD_NO].S_NA OF 'A': CASE NEW_FIELDS[I].S_NA OF 'N': SET_TYPE := 'N'; { Only numeric data } 'L': SET_TYPE := 'L'; { Only alphabetic data } END; 'N': IF NEW_FIELDS[I].S_NA = 'L' { Conflict of data } THEN NO_GOOD := TRUE; 'L': IF NEW_FIELDS[I].S_NA = 'N' { Conflict of data } THEN NO_GOOD := TRUE; 'S': CASE NEW_FIELDS[I].S_NA OF 'A': SET_TYPE := 'A'; 'N': SET_TYPE := 'N'; 'L': SET_TYPE := 'L'; END; END; END; IF NO_GOOD THEN LEAVE('ERROR: Data files have incompatible field types'); I := 1; NUM_FLDS := 0; WHILE ((I <= SCREEN_FIELDS) AND (NUM_FLDS = 0)) DO IF MAP_ARRAY[I].OLD_FLD_NO <> 0 THEN NUM_FLDS := 1 ELSE I := I + 1; IF NUM_FLDS = 0 THEN LEAVE('ERROR: Data files have no fields in common'); END; SEGMENT PROCEDURE GET_COPY_INFO; { Determines which records and fields of the from data file are to be copied to the to data file. } VAR X,Y,Q_ROW : INTEGER; GOOD : BOOLEAN; S,MSG : STRING; SEGMENT PROCEDURE FIELDS_YN; { Prompts the user to indicate which fields are to be copied. } { This is the only procedure other than CREATE_MAP_ARRAY that } { modifies MAP_ARRAY. } VAR NUM_FLDS : INTEGER; BEGIN ERASE_EOS(0,0); WRITELN('The following fields are common to both data files.', ' Indicate'); WRITELN('those fields whose information is to be copied (Y/N)'); MESSAGE(MAX_ROW,0,' to execute, to abort',false); FOR I := 1 TO SCREEN_FIELDS DO WITH OLD_FIELDS[I] DO BEGIN S_ROW := END_SCREEN; S_COL := 0; S_MIN := 0; S_TYP := 'V'; S_JUS := 'L'; S_NA := 'L'; S_DEF := ''; S_FLD := ''; S_SKIP := TRUE; S_ID := ''; S_LEN := 0; END; NUM_FLDS := 0; FOR I := 1 TO SCREEN_FIELDS DO IF MAP_ARRAY[I].OLD_FLD_NO <> 0 THEN NUM_FLDS := NUM_FLDS + 1; X := 0; Y := 3; FOR I := 1 TO SCREEN_FIELDS DO BEGIN IF MAP_ARRAY[I].OLD_FLD_NO <> 0 THEN BEGIN GOTOXY(X,Y); WRITE(NEW_FIELDS[I].S_ID); WITH OLD_FIELDS[I] DO BEGIN S_COL := X + 9; S_ROW := Y; S_NA := 'L'; S_SKIP := TRUE; S_DEF := 'Y'; S_LEN := 1; END; END; IF NUM_FLDS <= 20 { If there are 20 or less common } THEN Y := Y + 1 { fields they are written out in } ELSE { a single column. Otherwise they} IF X = 20 { are written out alternating } THEN { between two columns. } BEGIN Y := Y + 1; X := 0; END ELSE X := 20; END; REPEAT DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23); SCREEN(OLD_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY); IF EXIT_KEY = ESC_KEY THEN EXIT(COPY_DATA_FILE); NUM_FLDS := 0; I := 1; { Check to see that at least one field is to be copied. For any field that is not to be copied, set its OLD_FLD_NO to 0. } WHILE ((I <= SCREEN_FIELDS) AND (NUM_FLDS = 0)) DO BEGIN IF ((OLD_FIELDS[I].S_FLD = 'Y') OR (OLD_FIELDS[I].S_FLD = 'y')) THEN IF MAP_ARRAY[I].OLD_FLD_NO > 0 THEN NUM_FLDS := NUM_FLDS + 1; I := I + 1; END; IF NUM_FLDS = 0 THEN MESSAGE(MAX_ROW,40,'ERROR: Must respond Y to at least one', TRUE) ELSE FOR I := 1 TO SCREEN_FIELDS DO IF (NOT((OLD_FIELDS[I].S_FLD = 'Y') OR (OLD_FIELDS[I].S_FLD = 'y'))) THEN MAP_ARRAY[I].OLD_FLD_NO := 0; UNTIL NUM_FLDS > 0; END; SEGMENT PROCEDURE GET_TEST_ARRAY; { Gets the tests to be made on each record of the "from" data file before it is copied to the "to" data file. Only a limited no. of these tests are displayed on the screen at any one time (limited by the no. of possible fields in OLD_FIELDS). } VAR FIRST_TEST,NUM_TESTS : INTEGER; ERROR : BOOLEAN; PROMPT : STRING[50]; SEGMENT PROCEDURE USER_TESTS; VAR NUM_FIELDS,ROW,ID_COL,ID_ROW : INTEGER; BEGIN ERASE_EOS(0,0); WRITE('Comparison tests to be made on fields of each record:'); GOTOXY(62,0); WRITE('Choose from the'); GOTOXY(62,1); WRITE('following fields:'); GOTOXY(0,18); WRITE('Valid operators are: < , > , = , <= , >= , or <>'); GOTOXY(0,20); WRITE('Currently viewing tests 1 - 13'); GOTOXY(0,22); PROMPT := 'Get, Save tests, Change, Next, Back, Quit:'; FOR I := 1 TO LENGTH(PROMPT) DO IF NOT(PROMPT[I] IN ['A'..'Z']) THEN PROMPT[I] := CHR(ORD(PROMPT[I])+128); WRITE(PROMPT); I := 1; ROW := 4; WHILE I < SCREEN_FIELDS-1 DO BEGIN WITH OLD_FIELDS[I] DO { Field } BEGIN S_ROW := ROW; S_COL := 0; S_LEN := 8; S_MIN := 0; S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE; S_DEF := ''; S_FLD := ''; S_TYP := 'V'; END; WITH OLD_FIELDS[I+1] DO { Operator } BEGIN S_ROW := ROW; S_COL := 12; S_LEN := 2; S_MIN := 0; S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE; S_DEF := ''; S_FLD := ''; S_TYP := 'V'; END; WITH OLD_FIELDS[I+2] DO { Value } BEGIN S_ROW := ROW; S_COL := 18; S_LEN := 40; S_MIN := 0; S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE; S_DEF := ''; S_FLD := ''; S_TYP := 'V'; END; ROW := ROW + 1; I := I + 3; END; WITH OLD_FIELDS[SCREEN_FIELDS] DO BEGIN S_ROW := END_SCREEN; S_LEN := 0; S_FLD := ''; END; DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23); GOTOXY(0,2); WRITE('FIELD ID OPERATOR VALUE'); NUM_FIELDS := 0; FOR I := 1 TO SCREEN_FIELDS DO IF MAP_ARRAY[I].OLD_FLD_NO <> 0 THEN NUM_FIELDS := NUM_FIELDS + 1; { The following code writes out the ids the user may choose from in testing the fields to be copied. If there are less than 20, they are written out in a single column, otherwise they are written out alternating between two columns. } IF NUM_FIELDS <= 20 THEN ID_COL := 66 { Center a single column } ELSE ID_COL := 62; { Center double columns } ID_ROW := 3; I := 1; WHILE I <= SCREEN_FIELDS DO BEGIN IF MAP_ARRAY[I].OLD_FLD_NO <> 0 THEN BEGIN GOTOXY(ID_COL,ID_ROW); WRITE(NEW_FIELDS[I].S_ID); IF ID_COL = 62 THEN { Alternate ids between 1st and 2nd cols } ID_COL := 72 ELSE IF ID_COL = 66 THEN ID_ROW := ID_ROW + 1 ELSE IF ID_COL = 72 THEN BEGIN ID_COL := 62; ID_ROW := ID_ROW + 1; END; END; I := I + 1; END; END; {USER_TESTS} SEGMENT PROCEDURE DISPLAY_TESTS(TEST_NO : INTEGER); { Transfers the appropriate section of TEST_ARRAY tests to OLD_FIELDS for display. } VAR FOUND : BOOLEAN; BEGIN FOR I := 1 TO SCREEN_FIELDS DO OLD_FIELDS[I].S_FLD := ''; I := 1; WHILE I < SCREEN_TESTS*3 DO WITH TEST_ARRAY[TEST_NO +(I DIV 3)] DO BEGIN II := 1; FOUND := FALSE; WHILE NOT FOUND DO BEGIN IF MAP_ARRAY[II].OLD_FLD_NO <> FIELD_LOC THEN II := II + 1 ELSE FOUND := TRUE; IF II > SCREEN_FIELDS THEN BEGIN II := 0; FOUND := TRUE; END; END; IF ((FIELD_LOC = 0) OR (II = 0)) THEN BEGIN OLD_FIELDS[I].S_FLD := ''; OLD_FIELDS[I+1].S_FLD := ''; OLD_FIELDS[I+2].S_FLD := ''; END ELSE BEGIN OLD_FIELDS[I].S_FLD := NEW_FIELDS[II].S_ID; WITH OLD_FIELDS[I+1] DO CASE OPERATOR OF LT: S_FLD := '<'; GT: S_FLD := '>'; EQ: S_FLD := '='; LE: S_FLD := '<='; GE: S_FLD := '>='; NE: S_FLD := '<>'; END; OLD_FIELDS[I+2].S_FLD := VALUE; END; I := I + 3; END; DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23); END; SEGMENT PROCEDURE UPDATE_TEST_ARRAY(TEST_NO : INTEGER); { Checks the tests in OLD_FIELDS for validity and transfers them to the appropriate section of TEST_ARRAY. } VAR OP : OPS; FLD_LEN,I,K,LOCATION : INTEGER; BLANK_FIELD,BLANK_OP,BLANK_VALUE : BOOLEAN; PROCEDURE CHK_FIELD(VAR FIELD : STRING; VAR LOC : INTEGER; VAR IS_BLANK : BOOLEAN; VAR FLD_LENGTH : INTEGER); { Determines if the field name of the test is valid. Passes back the length of the fields value field so that CHK_VALUE may determine if the length of value of the test is within the maximum allowable. } VAR FOUND : BOOLEAN; BEGIN EAT_SPACES(FIELD,TRUE,TRUE); IF LENGTH(FIELD) = 0 THEN IS_BLANK := TRUE ELSE IS_BLANK := FALSE; FLD_LENGTH := 0; IF NOT IS_BLANK THEN BEGIN FOUND := FALSE; II := FIND(FIELD,NEW_FIELDS); IF II <> 0 THEN IF MAP_ARRAY[II].OLD_FLD_NO <> 0 THEN BEGIN LOC := MAP_ARRAY[II].OLD_FLD_NO; FOUND := TRUE; FLD_LENGTH := NEW_FIELDS[II].S_LEN; END; IF NOT FOUND THEN BEGIN MESSAGE(MAX_ROW,40,CONCAT('ERROR: ',FIELD, ' is an invalid field name'), TRUE); ERROR := TRUE; EXIT(UPDATE_TEST_ARRAY); END; END; END; PROCEDURE CHK_OP(VAR OP_STRING : STRING; VAR OPRATR : OPS; VAR IS_BLANK : BOOLEAN); { Determine if the operator of the test is valid. Valid operators are: "<", ">", "<=", ">=", "<>", and "=". } VAR GOOD : BOOLEAN; BEGIN EAT_SPACES(OP_STRING,TRUE,TRUE); GOOD := TRUE; IS_BLANK := FALSE; IF LENGTH(OP_STRING) = 0 THEN IS_BLANK := TRUE ELSE IF OP_STRING = '<' THEN OPRATR := LT ELSE IF OP_STRING = '>' THEN OPRATR := GT ELSE IF OP_STRING = '=' THEN OPRATR := EQ ELSE IF OP_STRING = '<=' THEN OPRATR := LE ELSE IF OP_STRING = '>=' THEN OPRATR := GE ELSE IF OP_STRING = '<>' THEN OPRATR := NE ELSE GOOD := FALSE; IF NOT GOOD THEN BEGIN MESSAGE(MAX_ROW,40,CONCAT('ERROR: ',OP_STRING,' is an invalid ', 'operator'),TRUE); ERROR := TRUE; EXIT(UPDATE_TEST_ARRAY); END; END; PROCEDURE CHK_VALUE(VAR VALUE: STRING; IS_BLANK: BOOLEAN; FLD_LENGTH: INTEGER); { Determines if the length of the value of the test is within the maximum. } VAR COL : INTEGER; BEGIN IF FLD_LENGTH > 0 THEN BEGIN EAT_SPACES(VALUE,TRUE,TRUE); IF LENGTH(VALUE) > FLD_LENGTH THEN BEGIN STR(FLD_LENGTH,MSG); MSG := CONCAT('ERROR: Value "',VALUE,'" exceeds max length', ' of ',MSG); COL := 80-LENGTH(MSG); IF COL > 40 THEN COL := 40; MESSAGE(MAX_ROW,COL,MSG,TRUE); ERROR := TRUE; EXIT(UPDATE_TEST_ARRAY); END ELSE IF LENGTH(VALUE) = 0 THEN IS_BLANK := TRUE ELSE IS_BLANK := FALSE; END; END; BEGIN {UPDATE_TEST_ARRAY} ERASE_EOL(0,MAX_ROW); ERROR := FALSE; I := 1; WHILE I < 3*SCREEN_TESTS DO BEGIN CHK_FIELD(OLD_FIELDS[I].S_FLD,LOCATION,BLANK_FIELD,FLD_LEN); CHK_OP(OLD_FIELDS[I+1].S_FLD,OP,BLANK_OP); CHK_VALUE(OLD_FIELDS[I+2].S_FLD,BLANK_VALUE,FLD_LEN); IF ((BLANK_OP) AND (NOT BLANK_FIELD)) THEN BEGIN MESSAGE(MAX_ROW,40,'ERROR: Missing operator',true); ERROR := TRUE; EXIT(UPDATE_TEST_ARRAY); END; IF ((BLANK_FIELD) OR (BLANK_OP)) THEN TEST_ARRAY[TEST_NO + (I DIV 3)].FIELD_LOC := 0 ELSE WITH TEST_ARRAY[TEST_NO+(I DIV 3)] DO BEGIN FIELD_LOC := LOCATION; OPERATOR := OP; VALUE := OLD_FIELDS[I+2].S_FLD; END; I := I + 3; END; END; {UPDATE_TEST_ARRAY} PROCEDURE GET_SAVE(COMMAND : CHAR); VAR GOOD : BOOLEAN; FILE_NAME : STRING[23]; TEST_FILE : FILE OF TEST_REC; BEGIN FOR II := 1 TO SCREEN_FIELDS DO WITH OLD_FIELDS[II] DO BEGIN S_ROW := END_SCREEN; S_COL := 14; S_MIN := 0; S_TYP := 'V'; S_JUS := 'L'; S_NA := 'S'; S_DEF := ''; S_FLD := ''; END; WITH OLD_FIELDS[1] DO BEGIN S_ID := 'VOL'; S_ROW := 6; S_LEN := 7; END; WITH OLD_FIELDS[2] DO BEGIN S_ID := 'NAME'; S_ROW := 8; S_LEN := 10; END; ERASE_EOS(0,0); GOTOXY(25,0); IF COMMAND = 'G' THEN WRITE('GET COMPARISON TESTS') ELSE WRITE('SAVE COMPARISON TESTS'); GOTOXY(25,1); IF COMMAND = 'G' THEN WRITE('====================') ELSE WRITE('====================='); GOTOXY(0,6); WRITELN('Volume :'); WRITELN; WRITELN('Name :'); WRITELN; WRITELN('Type : Cmpr'); MESSAGE(MAX_ROW,0,' to execute, to abort',false); DISPLAY_SCREEN(OLD_FIELDS,0,0,0,23); REPEAT GOOD := TRUE; SCREEN(OLD_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY); IF EXIT_KEY = ESC_KEY THEN EXIT(GET_SAVE); VOLUME := OLD_FIELDS[1].S_FLD; NAME := OLD_FIELDS[2].S_FLD; EAT_SPACES(VOLUME,TRUE,TRUE); EAT_SPACES(NAME,TRUE,TRUE); FILE_NAME := CONCAT(VOLUME,':',NAME,'.CMPR'); {$I-} IF COMMAND = 'G' THEN BEGIN RESET(TEST_FILE,FILE_NAME); IF IO_RESULT = 0 THEN BEGIN FOR I := 1 TO MAX_TESTS DO BEGIN TEST_ARRAY[I].FIELD_LOC := TEST_FILE^.FIELD_LOC; TEST_ARRAY[I].OPERATOR := TEST_FILE^.OPERATOR; TEST_ARRAY[I].VALUE := TEST_FILE^.VALUE; IF I <> MAX_TESTS THEN GET(TEST_FILE); IF IO_RESULT <> 0 THEN GOOD := FALSE; END; CLOSE(TEST_FILE,LOCK); END ELSE GOOD := FALSE; END ELSE BEGIN REWRITE(TEST_FILE,FILE_NAME); IF IO_RESULT = 0 THEN BEGIN FOR I := 1 TO MAX_TESTS DO BEGIN TEST_FILE^.FIELD_LOC := TEST_ARRAY[I].FIELD_LOC; TEST_FILE^.OPERATOR := TEST_ARRAY[I].OPERATOR; TEST_FILE^.VALUE := TEST_ARRAY[I].VALUE; PUT(TEST_FILE); IF IO_RESULT <> 0 THEN GOOD := FALSE; END; CLOSE(TEST_FILE,LOCK); END ELSE GOOD := FALSE; END; IF NOT GOOD THEN MESSAGE(MAX_ROW,40,'ERROR: Invalid file specification',true); UNTIL GOOD; {$I+} END; {GET_SAVE} BEGIN {GET_TEST_ARRAY} USER_TESTS; FIRST_TEST := 1; ERROR := FALSE; REPEAT IF ERROR THEN CH := 'C' ELSE BEGIN GOTOXY(43,MAX_ROW-1); READ(KEYBOARD,CH); IF CH = ESC_KEY THEN EXIT(PROGRAM); ERASE_EOL(0,MAX_ROW); END; CASE CH OF 'C','c': BEGIN SCREEN(OLD_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY); IF EXIT_KEY = ESC_KEY THEN EXIT(COPY_DATA_FILE); UPDATE_TEST_ARRAY(FIRST_TEST); END; 'B','b': BEGIN IF ERROR THEN WRITE(ALARM_BELL) ELSE BEGIN IF FIRST_TEST <> 1 THEN FIRST_TEST := FIRST_TEST - SCREEN_TESTS ELSE FIRST_TEST := MAX_TESTS-SCREEN_TESTS+1; STR(FIRST_TEST,S); STR(FIRST_TEST+12,MSG); MSG := CONCAT('Currently viewing tests ',S,' - ', MSG,' '); MESSAGE(20,0,MSG,FALSE); DISPLAY_TESTS(FIRST_TEST); END; END; 'G','g': BEGIN GET_SAVE('G'); USER_TESTS; FIRST_TEST := 1; DISPLAY_TESTS(FIRST_TEST); END; 'S','s': BEGIN IF ERROR THEN WRITE(ALARM_BELL) ELSE BEGIN GET_SAVE('S'); USER_TESTS; FIRST_TEST := 1; DISPLAY_TESTS(FIRST_TEST); END; END; 'N','n': BEGIN IF ERROR THEN WRITE(ALARM_BELL) ELSE BEGIN IF FIRST_TEST < MAX_TESTS-SCREEN_TESTS+1 THEN FIRST_TEST := FIRST_TEST + SCREEN_TESTS ELSE FIRST_TEST := 1; STR(FIRST_TEST,S); STR(FIRST_TEST+12,MSG); MSG := CONCAT('Currently viewing tests ',S,' - ', MSG,' '); MESSAGE(20,0,MSG,FALSE); DISPLAY_TESTS(FIRST_TEST); END; END; 'Q','q': IF ERROR THEN BEGIN WRITE(ALARM_BELL); CH := ' '; END; END; UNTIL ((CH = 'Q') OR (CH = 'q')); II := 1; NUM_TESTS := 0; WHILE ((II <= MAX_TESTS) AND (NUM_TESTS < 2)) DO BEGIN IF TEST_ARRAY[II].FIELD_LOC > 0 THEN NUM_TESTS := NUM_TESTS + 1; II := II + 1; END; ALL_TESTS := TRUE; IF NUM_TESTS > 1 THEN BEGIN ERASE_EOS(0,0); WRITE('Copy each record if :'); GOTOXY(0,2); WRITE('1) All of the above tests have been met'); GOTOXY(0,4); WRITE('2) Any of the above tests has been met'); GOTOXY(0,6); WRITE('Enter 1 or 2 :'); REPEAT ERASE_EOL(15,6); READ(KEYBOARD,CH); IF CH = ESC_KEY THEN EXIT(PROGRAM); UNTIL ((CH = '1') OR (CH = '2')); WRITE(CH); IF CH = '2' THEN ALL_TESTS := FALSE; END; END; {GET_TEST_ARRAY} BEGIN {GET_COPY_INFO} ERASE_EOS(0,0); GOTOXY(0,0); WRITE('Please answer the following questions:'); Q_ROW := 3; CLEAR_FILE := FALSE; APPEND_FILE := FALSE; IF NOT DB_IS_NEW {DB_IS_NEW flag is set in procedure GET_COPY_INFO} THEN BEGIN Q_ROW := 6; GOTOXY(0,3); WRITELN('Data file being copied to has existing records. ', 'Do you wish'); WRITELN('to delete them? (Y/N): Y'); GOTOXY(23,4); REPEAT READ(KEYBOARD,CH); IF CH = ESC_KEY THEN EXIT(PROGRAM); UNTIL CH IN [' ','Y','y','N','n']; IF CH <> ' ' THEN WRITE(CH); CLEAR_FILE := (CH IN [' ','Y','y']); IF NOT CLEAR_FILE THEN BEGIN Q_ROW := 8; GOTOXY(0,6); WRITELN('Do you wish to add the new records at ', 'the end of the data file? (Y/N): Y'); GOTOXY(71,6); REPEAT READ(KEYBOARD,CH); IF CH = ESC_KEY THEN EXIT(PROGRAM); UNTIL CH IN [' ','Y','y','N','n']; IF CH <> ' ' THEN WRITE(CH); APPEND_FILE := (CH IN [' ','Y','y']); IF NOT APPEND_FILE THEN BEGIN Q_ROW := 11; GOTOXY(0,8); WRITELN('NOTE: Any fields of the existing ', 'data file that are not copied to will'); WRITELN('be left intact. Do you wish to proceed?', ' (Y/N): Y'); GOTOXY(47,9); REPEAT READ(KEYBOARD,CH); IF CH = ESC_KEY THEN EXIT(PROGRAM); UNTIL CH IN [' ','Y','y','N','n']; IF (NOT(CH IN [' ','Y','y'])) THEN EXIT(PROGRAM); END; END; END; GOTOXY(0,Q_ROW); WRITE('Do you wish to copy all fields common to both data files? (Y/N): Y'); REPEAT GOTOXY(65,Q_ROW); READ(KEYBOARD,CH); IF CH = ESC_KEY THEN EXIT(PROGRAM); UNTIL CH IN [' ','Y','y','N','n']; IF CH <> ' ' THEN WRITE(CH); COPY_ALL_FLDS := (CH IN [' ','Y','y']); IF NOT COPY_ALL_FLDS THEN BEGIN FIELDS_YN; Q_ROW := 3; ERASE_EOS(0,0); END ELSE Q_ROW := Q_ROW + 2; IF Q_ROW = 3 THEN BEGIN GOTOXY(0,0); WRITE('Please answer the following questions:'); END; GOTOXY(0,Q_ROW); WRITELN('Are fields to be tested for certain values before record'); WRITELN('is copied? (Y/N): N'); Q_ROW := Q_ROW + 1; REPEAT GOTOXY(18,Q_ROW); READ(KEYBOARD,CH); IF CH = ESC_KEY THEN EXIT(PROGRAM); UNTIL CH IN [' ','Y','y','N','n']; IF CH <> ' ' THEN WRITE(CH); COPY_ALL_RECS := (CH IN [' ','N','n']); IF NOT COPY_ALL_RECS THEN BEGIN GET_TEST_ARRAY; ERASE_EOS(0,0); Q_ROW := 3; END ELSE Q_ROW := Q_ROW + 2; IF Q_ROW = 3 THEN BEGIN GOTOXY(0,0); WRITE('Please answer the following questions:'); END; GOTOXY(0,Q_ROW); WRITE('Copy blank records? (Y/N): N'); REPEAT GOTOXY(27,Q_ROW); READ(KEYBOARD,CH); IF CH = ESC_KEY THEN EXIT(PROGRAM); UNTIL CH IN [' ','Y','y','N','n']; IF CH <> ' ' THEN WRITE(CH); COPY_BLNKS := (CH IN ['Y','y']); END; SEGMENT PROCEDURE READ_TEST_COPY; VAR S,MSG : STRING; OFFSET_RECS : INTEGER; END_NEW_FILE : BOOLEAN; IO_REC : PACKED RECORD CASE INTEGER OF 1: (A: PACKED ARRAY[0..255] OF 0..255); 2: (B: STRING[255]); END; GET_PROMPTS : PROMPT_ARR; OLD_BUF,NEW_BUF : BUF_DEF; SEGMENT Procedure READ_WRITE( RW_COMMAND, WHICH_FILE :Char; var REC_NO, REC_LEN :Integer; var BUFFER :BUF_DEF; var CURRENT_BLOCK, IO_RET_CODE :Integer); var IO_BLOCKS,START_POSITION,TWO_BLOCK,START_REC,BYTE_TWO_BLOCK, BLOCK_NO,REC_NUM,FIRST_MOV_LEN,CHAR_OFFSET: Integer; begin {READ_WRITE} {$I-} IO_RET_CODE:=-1; REC_NUM:=REC_NO-1; if REC_NUM<0 then REC_NUM:=0; TWO_BLOCK:=REC_NUM div (1023 div REC_LEN); (* 1024 correction Dec 5 1980 *) START_REC:=TWO_BLOCK*(1023 div REC_LEN); (* 1024 correction Dec 5 1980 *) BYTE_TWO_BLOCK:=(REC_NUM-START_REC)*REC_LEN; BLOCK_NO:=(TWO_BLOCK*2)+2; if BYTE_TWO_BLOCK>=512 (* = correction Dec 5 1980 *) then begin BLOCK_NO:=BLOCK_NO+1; CHAR_OFFSET:=BYTE_TWO_BLOCK-512; end else CHAR_OFFSET:=BYTE_TWO_BLOCK; if CHAR_OFFSET+REC_LEN>512 then begin if CURRENT_BLOCK<>BLOCK_NO then begin IF WHICH_FILE = 'O' THEN IO_BLOCKS:=blockread(OLD_FILE,BUFFER,1,BLOCK_NO) ELSE IO_BLOCKS:=blockread(NEW_FILE,BUFFER,1,BLOCK_NO); IF IO_BLOCKS=0 then exit(READ_WRITE); end; FIRST_MOV_LEN:=512-CHAR_OFFSET; if RW_COMMAND='W' then begin moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],FIRST_MOV_LEN); IF WHICH_FILE = 'O' THEN IO_BLOCKS:=blockwrite(OLD_FILE,BUFFER,1,BLOCK_NO) ELSE IO_BLOCKS:=blockwrite(NEW_FILE,BUFFER,1,BLOCK_NO); IF IO_BLOCKS=0 then exit(READ_WRITE); end else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],FIRST_MOV_LEN); BLOCK_NO:=BLOCK_NO+1; IF WHICH_FILE = 'O' THEN IO_BLOCKS:=blockread(OLD_FILE,BUFFER,1,BLOCK_NO) ELSE IO_BLOCKS:=blockread(NEW_FILE,BUFFER,1,BLOCK_NO); IF IO_BLOCKS=0 then exit(READ_WRITE); if RW_COMMAND='W' then begin moveleft(IO_REC.A[FIRST_MOV_LEN+1],BUFFER[0],REC_LEN-FIRST_MOV_LEN); IF WHICH_FILE = 'O' THEN IO_BLOCKS:=blockwrite(OLD_FILE,BUFFER,1,BLOCK_NO) ELSE IO_BLOCKS:=blockwrite(NEW_FILE,BUFFER,1,BLOCK_NO); IF IO_BLOCKS=0 then exit(READ_WRITE); end else moveleft(BUFFER[0],IO_REC.A[FIRST_MOV_LEN+1], REC_LEN-FIRST_MOV_LEN); end else begin if ((RW_COMMAND='R') AND (CURRENT_BLOCK<>BLOCK_NO)) then begin IF WHICH_FILE = 'O' THEN IO_BLOCKS:=blockread(OLD_FILE,BUFFER,1,BLOCK_NO) ELSE IO_BLOCKS:=blockread(NEW_FILE,BUFFER,1,BLOCK_NO); IF IO_BLOCKS=0 then exit(READ_WRITE); end; if RW_COMMAND='W' then begin moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],REC_LEN); IF ((CURRENT_BLOCK<>BLOCK_NO) OR (CHAR_OFFSET+(2*REC_LEN)>=512)) THEN { WRITE BUFFER; NEXT READ WOULD } BEGIN { CUASE NEW BUFFER TO BE READ IN } IF WHICH_FILE = 'O' THEN IO_BLOCKS:=blockwrite(OLD_FILE,BUFFER,1,BLOCK_NO) ELSE IO_BLOCKS:=blockwrite(NEW_FILE,BUFFER,1,BLOCK_NO); IF IO_BLOCKS=0 then exit(READ_WRITE); END; end else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],REC_LEN); end; CURRENT_BLOCK:=BLOCK_NO; if IO_REC.A[3]=0 then exit(READ_WRITE); IO_RET_CODE:=0; IO_REC.A[0]:=REC_LEN; {$I+} end; {READ_WRITE} SEGMENT Procedure LOAD_SCREEN(LOAD_COMMAND :Char; var S_ARRAY: SCREEN_ARR; NUMBER_FLDS:INTEGER; var RECORD_STRING: STRING255); { Procedure load the screen array from a record obtained from the disk } { file. } var LOAD_INDEX,T_INDEX,COPY_INDEX,COPY_LENGTH : Integer; begin {LOAD_SCREEN} COPY_INDEX := 4; LOAD_INDEX:=1; while LOAD_INDEX <= NUMBER_FLDS do with S_ARRAY[LOAD_INDEX] do begin COPY_LENGTH:=S_LEN; if (LOAD_COMMAND = 'A') or ((LOAD_COMMAND = 'D') and (S_ID = COPY(S_DEF,2,LENGTH(S_DEF)-2))) then S_FLD:=copy(RECORD_STRING,COPY_INDEX,COPY_LENGTH) else begin IF (S_DEF = '') OR (S_DEF = COPY(UNDERLINE,1,1)) THEN BEGIN S_FLD := ' '; FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX); END ELSE { s_def<>'' Mar 12 } if s_def[1]<>'[' then begin s_fld:=' '; FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX) end else begin { s_def[1]='[' } t_index:=find(copy(s_def,2,length(s_def)-2),S_ARRAY); if t_index=0 then s_fld:=s_def else s_fld:=S_ARRAY[t_index].s_fld; end; end; COPY_INDEX:=COPY_INDEX + COPY_LENGTH; LOAD_INDEX:=LOAD_INDEX + 1; end; {with/while} end; {LOAD SCREEN} SEGMENT Procedure BUILD_RECORD; { Procedure builds records to be placed on the disk. } begin {BUILD RECORD} IO_REC.A[0]:=3; for INDEX:=1 to NUM_NEW_FLDS do { Jan 5 To correct value range error } IO_REC.B:=concat(IO_REC.B,NEW_FIELDS[INDEX].S_FLD); (*get rid of leftover low-intensity underscores *) for index:=1 to length(io_rec.b) do if io_rec.a[index]=223 then io_rec.a[index]:=32; (* blank *) IO_REC.A[0]:=NEW_REC_LEN; IO_REC.A[1]:=16; (* dle *) IO_REC.A[2]:=32; (* space *) IO_REC.A[3]:=42; (* * *) IO_REC.A[NEW_REC_LEN-1]:=42; IO_REC.A[NEW_REC_LEN]:=13; (* carriage return *) end; {BUILD RECORD} SEGMENT FUNCTION COPY_RECORD : BOOLEAN; { Determines whether a record is to be copied or not. } VAR BLANK,PASSED : BOOLEAN; F : STRINGFL; FUNCTION COMPARE(TEST : TEST_REC): BOOLEAN; { Function is true if test passes, false if not. } VAR OLD_VAL : STRINGFL; NUM1,NUM2 : REAL; function STR_TO_REAL(var S: STRING; var NUM: REAL): boolean; { Returns a value of true and the real value in NUM if string can be converted to real, is set to false otherwise } var I : integer; FACTOR : REAL; D_PT : BOOLEAN; begin STR_TO_REAL:=false; I:=1; D_PT := FALSE; NUM:=0; EATSPL(S); EATSPR(S); if length(S)=0 then exit(STR_TO_REAL); WHILE ((I <= LENGTH(S)) AND (NOT D_PT)) DO BEGIN if S[I] in DIGITSET then NUM:=10*NUM+ord(S[I])-ord('0') ELSE IF S[I] = '.' THEN D_PT := TRUE else exit(STR_TO_REAL); I := I + 1; END; IF D_PT THEN BEGIN FACTOR := 10; WHILE I <= LENGTH(S) DO IF S[I] IN DIGITSET THEN BEGIN NUM := NUM + ((ord(S[I])-ord('0'))/FACTOR); FACTOR := FACTOR * 10; I := I + 1; END ELSE EXIT(STR_TO_REAL); END; STR_TO_REAL:=true; end; { STR_TO_REAL } BEGIN { COMPARE } COMPARE := FALSE; OLD_VAL := OLD_FIELDS[TEST.FIELD_LOC].S_FLD; EAT_SPACES(OLD_VAL,TRUE,TRUE); WITH TEST DO IF ((STR_TO_REAL(OLD_VAL,NUM1)) AND (STR_TO_REAL(VALUE,NUM2))) THEN { Compare as reals if possible } CASE TEST.OPERATOR OF LT: COMPARE := NUM1 < NUM2; GT: COMPARE := NUM1 > NUM2; EQ: COMPARE := NUM1 = NUM2; LE: COMPARE := NUM1 <= NUM2; GE: COMPARE := NUM1 >= NUM2; NE: COMPARE := NUM1 <> NUM2; END ELSE { Otherwise compare as strings } CASE TEST.OPERATOR OF LT: COMPARE := OLD_VAL < VALUE; GT: COMPARE := OLD_VAL > VALUE; EQ: COMPARE := OLD_VAL = VALUE; LE: COMPARE := OLD_VAL <= VALUE; GE: COMPARE := OLD_VAL >= VALUE; NE: COMPARE := OLD_VAL <> VALUE; END; END; {COMPARE} BEGIN {COPY_RECORD} COPY_RECORD := TRUE; IF NOT COPY_ALL_RECS { Then see if record meets the user's tests } THEN BEGIN IF ALL_TESTS { COPY_RECORD set to true if all tests pass } THEN BEGIN I := 1; PASSED := TRUE; WHILE ((I <= MAX_TESTS) AND (PASSED)) DO BEGIN IF TEST_ARRAY[I].FIELD_LOC > 0 THEN PASSED := COMPARE(TEST_ARRAY[I]); I := I + 1; END; COPY_RECORD := PASSED; END ELSE BEGIN {COPY_RECORD set to true if any test passes} I := 1; PASSED := FALSE; WHILE ((I <= MAX_TESTS) AND (NOT PASSED)) DO BEGIN IF TEST_ARRAY[I].FIELD_LOC > 0 THEN PASSED := COMPARE(TEST_ARRAY[I]); I := I + 1; END; COPY_RECORD := PASSED; END; END; END; {COPY_RECORD} SEGMENT PROCEDURE READ_OLD_RECORD(VAR IS_BLANK : BOOLEAN; VAR READ_RESULTS : INTEGER); { This procedure determines whether the "from" data file is a UDE file or a GENLIST file and reads a record from it. NOTE: In a UDE file a blank record is defined to be one where IO_REC.A[3] = 126. In a GENLIST file a blank record is defined be one where OLD_GEN_FILE^.DATA[1] = chr(127). Any other records are assumed to be non-blank, even if all of their fields are blank. } BEGIN READ_RESULTS := 0; IS_BLANK := FALSE; IF UDE_FILE THEN BEGIN READ_WRITE('R','O',OLD_REC_NO,OLD_REC_LEN,OLD_BUF, OLD_BLOCK,READ_RESULTS); IF READ_RESULTS = 0 THEN BEGIN IF IO_REC.A[3] = 126 THEN IS_BLANK := TRUE ELSE LOAD_SCREEN('A',OLD_FIELDS,NUM_OLD_FLDS,IO_REC.B); END; END ELSE BEGIN IF OLD_REC_NO <= NUM_OLD_RECS THEN BEGIN SEEK(OLD_GEN_FILE,OLD_REC_NO); GET(OLD_GEN_FILE); IF OLD_GEN_FILE^.DATA[1] = CHR(127) THEN IS_BLANK := TRUE ELSE BEGIN INDEX := 1; FOR II := 1 TO NUM_OLD_FLDS DO IF OLD_FIELDS[II].S_LEN > 0 THEN BEGIN OLD_FIELDS[II].S_FLD := COPY(OLD_GEN_FILE^.DATA, INDEX,OLD_FIELDS[II].S_LEN); INDEX := INDEX + OLD_FIELDS[II].S_LEN; END; END; END ELSE READ_RESULTS := -1; END; END; {READ_OLD_RECORD} SEGMENT PROCEDURE COPY_FIELDS; { Copies the fields of the current "from" record to the current "to" record. } VAR I,CHAR_INDEX : INTEGER; ONE_CHAR : CHAR; TOO_LONG : BOOLEAN; FUNCTION CHR_IN_SET(CHR,SET_TYPE : CHAR) : BOOLEAN; { CHR_IN_SET is set to true if chr is in the indicated set. } BEGIN CHR_IN_SET := FALSE; CASE SET_TYPE OF 'A': IF CHR IN ['A'..'Z','a'..'z','''','.','0'..'9','+','-',' '] THEN CHR_IN_SET := TRUE; 'N': IF CHR IN ['0'..'9','.','+','-',' '] THEN CHR_IN_SET := TRUE; 'L': IF CHR IN ['A'..'Z','a'..'z','''','.',' '] THEN CHR_IN_SET := TRUE; '-': CHR_IN_SET := TRUE; END; END; BEGIN {COPY_FIELDS} GOTOXY(0,19); FOR I := 1 TO SCREEN_FIELDS DO BEGIN IF MAP_ARRAY[I].OLD_FLD_NO <> 0 THEN WITH OLD_FIELDS[MAP_ARRAY[I].OLD_FLD_NO] DO BEGIN CHAR_INDEX := 1; WHILE ((CHAR_INDEX <= LENGTH(S_FLD)) AND (CHAR_INDEX <= NEW_FIELDS[I].S_LEN)) DO BEGIN ONE_CHAR := S_FLD[CHAR_INDEX]; IF CHR_IN_SET(ONE_CHAR,MAP_ARRAY[I].SET_TYPE) THEN NEW_FIELDS[I].S_FLD[CHAR_INDEX] := S_FLD[CHAR_INDEX] ELSE BEGIN MESSAGE(MAX_ROW,30,CONCAT('ERROR: Data is of ', 'wrong type for field ',S_ID),TRUE); EXIT(COPY_DATA_FILE); END; CHAR_INDEX := CHAR_INDEX + 1; END; S := S_FLD; EAT_SPACES(S,TRUE,TRUE); IF ((LENGTH(S) > NEW_FIELDS[I].S_LEN) AND (NOT TRUNC_FLDS_OK)) THEN BEGIN MSG := S_ID; EAT_SPACES(MSG,TRUE,TRUE); ERASE_EOS(0,MAX_ROW-1); WRITELN('One or more of the fields', ' is not large enough to hold all of the'); WRITE('data being copied ', 'to it. Proceed anyway? Y/N :'); WRITE(ALARM_BELL); GOTOXY(47,MAX_ROW); CH := ' '; REPEAT READ(KEYBOARD,CH); UNTIL CH IN ['Y','y','N','n']; IF (NOT (CH IN ['Y','y'])) THEN EXIT(COPY_DATA_FILE); GOTOXY(0,22); WRITE(' ', ' '); ERASE_EOS(0,MAX_ROW); TRUNC_FLDS_OK := TRUE; END; END; END; END; {COPY_FIELDS} BEGIN {READ_TEST_COPY} GET_FILE(O_DEFI_NAME,OLD_FIELDS,GET_PROMPTS,RESULTS); ERASE_EOS(0,22); RESET(NEW_FILE,N_DATA_NAME); RESULTS := 0; OFFSET_RECS := 0; TRUNC_FLDS_OK := FALSE; END_NEW_FILE := FALSE; OLD_REC_NO := 1; NEW_REC_NO := 1; IF APPEND_FILE { Find last non-blank record } THEN WHILE RESULTS = 0 DO BEGIN READ_WRITE('R','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF,NEW_BLOCK, RESULTS); IF ((IO_REC.A[3] <> 126) AND (RESULTS = 0)) THEN OFFSET_RECS := NEW_REC_NO; NEW_REC_NO := NEW_REC_NO + 1; END; RESULTS := 0; NEW_REC_NO := OFFSET_RECS + 1; WHILE RESULTS = 0 DO BEGIN READ_OLD_RECORD(REC_IS_BLANK,RESULTS); IF RESULTS = 0 THEN BEGIN IF REC_IS_BLANK THEN BEGIN IF COPY_BLNKS THEN BEGIN READ_WRITE('R','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF, NEW_BLOCK,RESULTS); IF RESULTS = 0 THEN BEGIN FILLCHAR(IO_REC.A[0],NEW_REC_LEN,' '); IO_REC.A[0] := NEW_REC_LEN; IO_REC.A[1] := 16; IO_REC.A[2] := 32; IO_REC.A[3] := 126; IO_REC.A[NEW_REC_LEN-1] := 42; IO_REC.A[NEW_REC_LEN] := 13; READ_WRITE('W','N',NEW_REC_NO,NEW_REC_LEN, NEW_BUF,NEW_BLOCK,RESULTS); STR(OLD_REC_NO,S); MESSAGE(MAX_ROW,40,CONCAT('STATUS: Copying record# ', S),FALSE); NEW_REC_NO := NEW_REC_NO + 1; END ELSE END_NEW_FILE := TRUE; END; END ELSE IF COPY_RECORD THEN BEGIN READ_WRITE('R','N',NEW_REC_NO,NEW_REC_LEN, NEW_BUF,NEW_BLOCK,RESULTS); IF RESULTS = 0 THEN BEGIN IF CLEAR_FILE THEN FOR II := 1 TO SCREEN_FIELDS DO BEGIN NEW_FIELDS[II].S_FLD := ''; FOR I := 1 TO NEW_FIELDS[II].S_LEN DO INSERT(' ',NEW_FIELDS[II].S_FLD,1); END ELSE LOAD_SCREEN('A',NEW_FIELDS,NUM_NEW_FLDS, IO_REC.B); COPY_FIELDS; BUILD_RECORD; STR(OLD_REC_NO,S); MESSAGE(MAX_ROW,40,CONCAT('STATUS: Copying record# ', S),FALSE); READ_WRITE('W','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF, NEW_BLOCK,RESULTS); NEW_REC_NO := NEW_REC_NO + 1; END ELSE END_NEW_FILE := TRUE; END; END; OLD_REC_NO := OLD_REC_NO + 1; END; IF CLEAR_FILE THEN BEGIN II := NEW_REC_NO; RESULTS := 0; WHILE RESULTS = 0 DO BEGIN READ_WRITE('R','N',II,NEW_REC_LEN,NEW_BUF,NEW_BLOCK,RESULTS); IF RESULTS = 0 THEN BEGIN FILLCHAR(IO_REC.A[0],NEW_REC_LEN,' '); IO_REC.A[0] := NEW_REC_LEN; IO_REC.A[1] := 16; IO_REC.A[2] := 32; IO_REC.A[3] := 126; IO_REC.A[NEW_REC_LEN-1] := 42; IO_REC.A[NEW_REC_LEN] := 13; READ_WRITE('W','N',II,NEW_REC_LEN,NEW_BUF,NEW_BLOCK,RESULTS); II := II + 1; END END; END; NEW_REC_NO := NEW_REC_NO - 1; IF ((NEW_REC_NO >= 1) OR (CLEAR_FILE)) THEN { Forces NEW_BUF to be written after } BEGIN { last record has been written to it } READ_WRITE('R','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF,NEW_BLOCK,RESULTS); NEW_BLOCK := -1; READ_WRITE('W','N',NEW_REC_NO,NEW_REC_LEN,NEW_BUF,NEW_BLOCK,RESULTS); END; STR(NEW_REC_NO-OFFSET_RECS,S); IF ((S = '0') AND (NOT(END_NEW_FILE))) THEN MSG := 'Found no records meeting specifications' ELSE IF END_NEW_FILE THEN MSG := CONCAT('File full, ',S,' records copied.') ELSE MSG := CONCAT('Copy complete, ',S,' records copied.'); ERASE_EOS(0,22); MESSAGE(MAX_ROW,40,MSG,TRUE); CLOSE(NEW_FILE,LOCK); END; {READ_TEST_COPY} Procedure MESSAGE{M_ROW,M_COL :Integer; MSG :String; DING: Boolean}; { Procedure displays messages at the message row and column. } begin {MESSAGE} gotoxy(M_COL,M_ROW); write(MSG); if DING then write(ALARM_BELL); end; {MESSAGE} Procedure EAT_SPACES{var TEMP :String; LEFT_EAT,RIGHT_EAT :Boolean}; { Procedure to remove the spaces from either or both sides of a string. } begin {EAT SPACES} if LEFT_EAT then EATSPL(TEMP); if RIGHT_EAT then EATSPR(TEMP); end; {EAT SPACES} PROCEDURE LEAVE{MSG : STRING}; BEGIN MESSAGE(MAX_ROW,38,MSG,TRUE); EXIT(COPY_DATA_FILE); END; BEGIN {COPY_DATA_FILE} INITIALIZE; GET_FILES; CREATE_MAP_ARRAY; GET_COPY_INFO; READ_TEST_COPY; END. ======================================================================================== DOCUMENT :usus Folder:VOL25:ud.list.text ======================================================================================== {xL #5:LSTLST.TEXT} PROGRAM LIST; { Once a data base has been defined, this set of procedures allows the operator to list out the data in the data base records. } uses {$U sh.screen.unit} SCREEN40; CONST MAX_TESTS = 52; SCREEN_TESTS = 13; TYPE OPS = (LT,GT,EQ,LE,GE,NE); TEST_REC = PACKED RECORD FIELD_LOC : 0..SCREEN_FIELDS; OPERATOR : OPS; VALUE : STRINGFL; END; TEST_DEF = ARRAY[1..MAX_TESTS] OF TEST_REC; STRING255 = STRING[255]; VAR GET_FIELDS,MAINT_FIELDS : SCREEN_ARR; { Array to hold data fields } GET_PROMPTS : PROMPT_ARR; { Array to hold screen prompts } GET_RESULTS, { 0 If 'GET.SCRN' loaded } RESULTS,I,II,INDEX,DB_RECNO,REC_LEN,NUM_FLDS,CURRENT_BLOCK: Integer; EXXIT,CH,EXIT_KEY : CHAR; VERSION : String[28]; PROMPT1 : STRING[29]; PROMPT2 : STRING[31]; VOLUME, { Data base volume } LIST_TYPE, { Output file type } LIST_VOL :String[7]; { Print format volume } NAME, { Data base Name } LIST_NAME :String[10];{ Print format name } DB_NAME :String[18];{ Volume + Data Base Name } WRITE_FILE_NAME : string[28]; { Output file name } STR_RECNO : String[5]; IO_REC : Packed record { String to hold data base record } case Integer of 1: (A: Packed Array[0..255] of 0..255); 2: (B: String[255]); end; DATA_FILE : File; Procedure RECORD_LENGTH(var S_ARRAY: SCREEN_ARR); forward; Function VAL(S: string; var NUM: integer): boolean; forward; Procedure MESSAGE(M_ROW,M_COL: Integer; MSG: String; DING: Boolean); forward; Segment Procedure INITIALIZE; { Procedure initilizes everything to begin maintaining the data base. } var I: Integer; begin {INITIALIZE} for I:=1 to SCREEN_FIELDS do with GET_FIELDS[I] do begin S_ROW := END_SCREEN; S_COL := 15; S_MIN := 0; S_TYP := 'V'; S_JUS := 'L'; S_NA := 'S'; S_SKIP := False; S_DEF := ''; S_FLD := ''; S_ID := ''; end; for I:=1 to SCREEN_FIELDS do with MAINT_FIELDS[I] do begin S_ROW := END_SCREEN; S_COL := 15; S_MIN := 0; S_TYP := 'V'; S_LEN := 0; S_JUS := 'L'; S_NA := 'S'; S_SKIP := False; S_DEF := ''; S_FLD := ''; S_ID := ''; end; for I:=1 to PROMPT_FIELDS do with GET_PROMPTS[I] do begin P_ROW:=END_SCREEN; P_COL:=0; P_FLD:=''; end; with GET_FIELDS[1] do begin S_ID := 'VOL'; S_ROW := 8; S_LEN := 7; end; with GET_FIELDS[2] do begin S_ID := 'NAME'; S_ROW := 10; S_LEN := 10; end; with GET_PROMPTS[1] do begin P_ROW := 8; P_FLD := 'Volume :'; end; with GET_PROMPTS[2] do begin P_ROW := 10; P_FLD := 'Name :'; end; with GET_PROMPTS[3] do begin P_ROW := 12; P_FLD := 'Type : SCRN and TEXT'; end; VERSION:='Version IV.0'; PROMPT1:='Get,Save format,Output file'; PROMPT2:='Change,Export,List,Tests,Quit ?'; for I:=1 to 27 do if not(PROMPT1[I] in['A'..'Z']) then PROMPT1[I]:=chr(ord(PROMPT1[I])+128); for I:=1 to 29 do if not(PROMPT2[I] in['A'..'Z']) then PROMPT2[I]:=chr(ord(PROMPT2[I])+128); DB_RECNO := 1; CURRENT_BLOCK := -1; write_file_name:=''; { Dec 29 } end; {INITIALIZE} Segment Procedure GET_DATA_BASE; { Procedure gets the Data Base Definition from the disk. } var DATA_NAME, { Data file name } DEFI_NAME:String[23]; { Data Base Definition file name } begin {GET_DATA_BASE} ERASE_EOS(0,0); writeln(' ':25,'PRINT A DATA BASE'); writeln(' ':25,'================='); writeln(' ':25,VERSION); writeln; writeln( 'Copyright (C) 1981 by Texas Instruments Corporate Engineering Center'); writeln('All rights reserved as per the Computer Software ', 'Copyright Act of 1980'); DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23); DISPLAY_SCREEN(GET_FIELDS,0,0,0,23); MESSAGE(MAX_ROW,0,' to execute, to abort',False); repeat SCREEN(GET_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXXIT); if EXXIT = ESC_KEY then exit(LIST); VOLUME := GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD; EATSPR(VOLUME); NAME := GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD; EATSPR(NAME); DB_NAME := concat(VOLUME,':',NAME); DEFI_NAME := concat(DB_NAME,'.SCRN'); DATA_NAME := concat(DB_NAME,'.TEXT'); GET_FILE(DEFI_NAME,MAINT_FIELDS,GET_PROMPTS,RESULTS); if RESULTS = 0 then begin {$I-} reset(DATA_FILE,DATA_NAME); {$I+} if IORESULT<>0 then MESSAGE(MAX_ROW,40,'ERROR: No data file found',True) else exit(GET_DATA_BASE); end else MESSAGE(MAX_ROW,40,'ERROR: Unknown Data Base',True); until False; end; {GET_DATA_BASE} Segment Procedure ACCESS_DATA_BASE; { Procedure performs all the adds, examines and deletes for the data base } var DISPLAY_FLAG:Boolean; START_LIST:Integer; ESC:boolean; { Mar 16 } BUFFER: Packed Array[0..511] of 0..255; LIST_VOL_NAME :String[23]; { Print format file name } EXPRT_FILE_NAME :String[28]; { Export file name } IO_REC : Packed record { String to hold data base record } case Integer of 1: (A: Packed Array[0..255] of 0..255); 2: (B: String[255]); end; TEST_ARRAY : TEST_DEF; TESTS,ALL_TESTS : BOOLEAN; Segment Procedure GET_SAVE_FORMAT(GS_COMMAND:char; var ESC: boolean); { Procedure loads or saves printing format specification on disk. } var S: string; P_FIELDS,TEMP_FIELDS: SCREEN_ARR; P_PROMPTS,TEMP_PROMPTS: PROMPT_ARR; I: integer; begin FOR I := 1 TO SCREEN_FIELDS DO WITH P_FIELDS[I] DO BEGIN S_ROW := END_SCREEN; S_COL := 15; S_MIN := 0; S_TYP := 'V'; S_JUS := 'L'; S_NA := 'S'; S_SKIP := FALSE; S_DEF := ''; S_FLD := ''; END; FOR I := 1 TO PROMPT_FIELDS DO WITH P_PROMPTS[I] DO BEGIN P_ROW := END_SCREEN; P_COL := 0; P_FLD := ''; END; with P_FIELDS[1] do begin S_ID := 'VOL'; S_ROW := 8; S_LEN := 7; end; with P_FIELDS[2] do begin S_ID := 'NAME'; S_ROW := 10; S_LEN := 10; end; with P_PROMPTS[1] do begin P_ROW := 8; P_FLD := 'Volume :'; end; with P_PROMPTS[2] do begin P_ROW := 10; P_FLD := 'Name :'; end; if CH='O' then begin with P_PROMPTS[3] do begin P_ROW:=12; P_FLD:='Type :'; end; with P_FIELDS[3] do begin S_ID:='TYPE'; S_ROW:=12; S_LEN:=5; end; end else begin with P_PROMPTS[3] do begin P_ROW:=12; P_FLD:='Type : SCRN and TEXT'; end; P_FIELDS[3].S_ROW:=END_SCREEN; end; ERASE_EOS(0,0); if GS_COMMAND='G' then S:='GET PRINTING FORMAT' else if GS_COMMAND='S' then S:='SAVE PRINTING FORMAT' else if GS_COMMAND='E' then S:='EXPORT FILE NAME' else S:='OUTPUT FILE NAME'; writeln(' ':25,S); writeln(' ':25,'====================':LENGTH(S)); DISPLAY_PROMPTS(P_PROMPTS,0,0,0,23); gotoxy(0,12); if GS_COMMAND <>'O' then if GS_COMMAND = 'E' then write('Type : TEXT ') else write('Type : LIST '); MESSAGE(MAX_ROW,0,' to execute, to abort',False); DISPLAY_SCREEN(P_FIELDS,0,0,0,23); repeat SCREEN(P_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXXIT); ERASE_EOL(MAX_ROW,40); if EXXIT = ENTER_KEY then begin ESC:=false; LIST_VOL := P_FIELDS[FIND('VOL',P_FIELDS)].S_FLD; EATSPR(LIST_VOL); LIST_NAME := P_FIELDS[FIND('NAME',P_FIELDS)].S_FLD; EATSPR(LIST_NAME); if GS_COMMAND = 'O' then begin { Jan 8 } LIST_TYPE:=P_FIELDS[FIND('TYPE',P_FIELDS)].S_FLD; IF (LIST_VOL='') AND (LIST_NAME='') THEN WRITE_FILE_NAME:='' else WRITE_FILE_NAME:=concat(LIST_VOL,':',LIST_NAME,'.', LIST_TYPE); exit(GET_SAVE_FORMAT); end else if GS_COMMAND = 'E' then begin { Dec 29 } EXPRT_FILE_NAME := concat(LIST_VOL,':',LIST_NAME,'.TEXT'); exit(GET_SAVE_FORMAT); end else LIST_VOL_NAME := concat(LIST_VOL,':',LIST_NAME,'.LIST'); if GS_COMMAND = 'G' then begin GET_FILE(LIST_VOL_NAME,TEMP_FIELDS,TEMP_PROMPTS,GET_RESULTS); if GET_RESULTS <> 0 then MESSAGE(MAX_ROW,40,'ERROR: Unknown printing format', True) else begin I := FIND('WIDTH',TEMP_FIELDS); if I = 0 then MESSAGE(MAX_ROW,40,'ERROR: Format file is obsolete', True) else begin GET_FIELDS:=TEMP_FIELDS; GET_PROMPTS:=TEMP_PROMPTS; exit(GET_SAVE_FORMAT); end end end else { GS_COMMAND = 'S' } begin SAVE_FILE(LIST_VOL_NAME,GET_FIELDS,GET_PROMPTS, GET_RESULTS); if GET_RESULTS <> 0 then MESSAGE(MAX_ROW,40, 'ERROR: Unable to save printing format',True) else exit(GET_SAVE_FORMAT); end; end else begin ESC:=true; exit(GET_SAVE_FORMAT); end; until False; end; SEGMENT Procedure READ_WRITE(RW_COMMAND: Char; var REC_NO,REC_LEN,IO_RET_CODE:Integer); var IO_BLOCKS,START_POSITION,TWO_BLOCK,START_REC,BYTE_TWO_BLOCK, BLOCK_NO,REC_NUM,FIRST_MOV_LEN,CHAR_OFFSET: Integer; begin {READ_WRITE} {$I-} IO_RET_CODE:=-1; REC_NUM:=REC_NO-1; if REC_NUM<0 then REC_NUM:=0; TWO_BLOCK:=REC_NUM div (1023 div REC_LEN); (* 1024 correction Dec 5 1980 *) START_REC:=TWO_BLOCK*(1023 div REC_LEN); (* 1024 correction Dec 5 1980 *) BYTE_TWO_BLOCK:=(REC_NUM-START_REC)*REC_LEN; BLOCK_NO:=(TWO_BLOCK*2)+2; if BYTE_TWO_BLOCK>=512 (* = correction Dec 5 1980 *) then begin BLOCK_NO:=BLOCK_NO+1; CHAR_OFFSET:=BYTE_TWO_BLOCK-512; end else CHAR_OFFSET:=BYTE_TWO_BLOCK; if CHAR_OFFSET+REC_LEN>512 then begin if CURRENT_BLOCK<>BLOCK_NO then begin IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end; FIRST_MOV_LEN:=512-CHAR_OFFSET; if RW_COMMAND='W' then begin moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],FIRST_MOV_LEN); IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],FIRST_MOV_LEN); BLOCK_NO:=BLOCK_NO+1; IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); if RW_COMMAND='W' then begin moveleft(IO_REC.A[FIRST_MOV_LEN+1],BUFFER[0],REC_LEN-FIRST_MOV_LEN); IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end else moveleft(BUFFER[0],IO_REC.A[FIRST_MOV_LEN+1],REC_LEN-FIRST_MOV_LEN); end else begin if CURRENT_BLOCK<>BLOCK_NO then begin IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end; if RW_COMMAND='W' then begin moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],REC_LEN); IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],REC_LEN); end; CURRENT_BLOCK:=BLOCK_NO; if IO_REC.A[3]=0 then exit(READ_WRITE); IO_RET_CODE:=0; IO_REC.A[0]:=REC_LEN; {$I+} end; {READ_WRITE} SEGMENT Procedure LOAD_SCREEN(LOAD_COMMAND :Char; var S_ARRAY: SCREEN_ARR; NUMBER_FLDS:INTEGER; var RECORD_STRING: STRING255); { Procedure load the screen array from a record obtained from the disk } { file. } var LOAD_INDEX,T_INDEX,COPY_INDEX,COPY_LENGTH : Integer; begin {LOAD_SCREEN} COPY_INDEX := 4; LOAD_INDEX:=1; while LOAD_INDEX <= NUMBER_FLDS do with S_ARRAY[LOAD_INDEX] do begin COPY_LENGTH:=S_LEN; if (LOAD_COMMAND = 'A') or ((LOAD_COMMAND = 'D') and (S_ID = COPY(S_DEF,2,LENGTH(S_DEF)-2))) then S_FLD:=copy(RECORD_STRING,COPY_INDEX,COPY_LENGTH) else begin IF (S_DEF = '') OR (S_DEF = COPY(UNDERLINE,1,1)) THEN BEGIN S_FLD := ' '; FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX); END ELSE { s_def<>'' Mar 12 } if s_def[1]<>'[' then begin s_fld:=' '; FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX) end else begin { s_def[1]='[' } t_index:=find(copy(s_def,2,length(s_def)-2),S_ARRAY); if t_index=0 then s_fld:=s_def else s_fld:=S_ARRAY[t_index].s_fld; end; end; COPY_INDEX:=COPY_INDEX + COPY_LENGTH; LOAD_INDEX:=LOAD_INDEX + 1; end; {with/while} end; {LOAD SCREEN} SEGMENT FUNCTION LIST_RECORD : BOOLEAN; { Determines whether a record is to be copied or not. } VAR BLANK,PASSED : BOOLEAN; F : STRINGFL; FUNCTION COMPARE(TEST : TEST_REC): BOOLEAN; { Function is true if test passes, false if not. } VAR OLD_VAL : STRINGFL; NUM1,NUM2 : REAL; function STR_TO_REAL(var S: STRING; var NUM: REAL): boolean; { Returns a value of true and the real value in NUM if string can be converted to real, is set to false otherwise } var I : integer; FACTOR : REAL; D_PT : BOOLEAN; begin STR_TO_REAL:=false; I:=1; D_PT := FALSE; NUM:=0; EATSPL(S); EATSPR(S); if length(S)=0 then exit(STR_TO_REAL); WHILE ((I <= LENGTH(S)) AND (NOT D_PT)) DO BEGIN if S[I] in ['0'..'9'] then NUM:=10*NUM+ord(S[I])-ord('0') ELSE IF S[I] = '.' THEN D_PT := TRUE else exit(STR_TO_REAL); I := I + 1; END; IF D_PT THEN BEGIN FACTOR := 10; WHILE I <= LENGTH(S) DO IF S[I] IN ['0'..'9'] THEN BEGIN NUM := NUM + ((ord(S[I])-ord('0'))/FACTOR); FACTOR := FACTOR * 10; I := I + 1; END ELSE EXIT(STR_TO_REAL); END; STR_TO_REAL:=true; end; { STR_TO_REAL } BEGIN { COMPARE } COMPARE := FALSE; OLD_VAL := MAINT_FIELDS[TEST.FIELD_LOC].S_FLD; EATSPL(OLD_VAL); EATSPR(OLD_VAL); WITH TEST DO IF ((STR_TO_REAL(OLD_VAL,NUM1)) AND (STR_TO_REAL(VALUE,NUM2))) THEN { Compare as reals if possible } CASE TEST.OPERATOR OF LT: COMPARE := NUM1 < NUM2; GT: COMPARE := NUM1 > NUM2; EQ: COMPARE := NUM1 = NUM2; LE: COMPARE := NUM1 <= NUM2; GE: COMPARE := NUM1 >= NUM2; NE: COMPARE := NUM1 <> NUM2; END ELSE { Otherwise compare as strings } CASE TEST.OPERATOR OF LT: COMPARE := OLD_VAL < VALUE; GT: COMPARE := OLD_VAL > VALUE; EQ: COMPARE := OLD_VAL = VALUE; LE: COMPARE := OLD_VAL <= VALUE; GE: COMPARE := OLD_VAL >= VALUE; NE: COMPARE := OLD_VAL <> VALUE; END; END; {COMPARE} BEGIN {LIST_RECORD} LIST_RECORD := TRUE; IF TESTS { Then see if record meets the user's tests } THEN BEGIN IF ALL_TESTS { LIST_RECORD set to true if all tests pass } THEN BEGIN I := 1; PASSED := TRUE; WHILE ((I <= MAX_TESTS) AND (PASSED)) DO BEGIN IF TEST_ARRAY[I].FIELD_LOC > 0 THEN PASSED := COMPARE(TEST_ARRAY[I]); I := I + 1; END; LIST_RECORD := PASSED; END ELSE BEGIN {LIST_RECORD set to true if any test passes} I := 1; PASSED := FALSE; WHILE ((I <= MAX_TESTS) AND (NOT PASSED)) DO BEGIN IF TEST_ARRAY[I].FIELD_LOC > 0 THEN PASSED := COMPARE(TEST_ARRAY[I]); I := I + 1; END; LIST_RECORD := PASSED; END; END; END; SEGMENT Procedure EXPORT(EXP_FILENAME: String; var DATARRAY: SCREEN_ARR; var OUT_FILE: String); { Data export unit Version II.2.B.2b modified for UDE Jan 1981} const MAXSIZE = 500; AMT_MEM = 1300; MAXLINES = 10; type BUFR = Array[0..0] of String[255]; STR255 = String[255]; EXP_RECORD = record START,LENGTH: integer; end; var EXPFILELNS : Integer; HEAPPTR: ^BUFR; OUT,EXPFILE: Text; NUMERIC,EATLEFT,EATRIGHT :Boolean; IDNO,LNS,N,I,J: Integer; CH :String[1]; IDVAL,IDNAME,LINE_IMAGE: String; LINE: STR255; RESULT: Integer; EXP_ARRAY : array[1..SCREEN_FIELDS] of EXP_RECORD; Segment Procedure EXPORT_ARRAY; var i,n: integer; begin i:=1; n:=4; while i<=screen_fields do if maint_fields[i].s_row=end_screen then i:=screen_fields+1 else with exp_array[i] do begin start:=n; length:=maint_fields[i].s_len; n:=length+n; i:=i+1; end; end; {export_array} Segment Procedure GET_EXPFILE(EXP_FILENAME: String; var RESULT: Integer); var QUIT: Boolean; begin {GET_EXPFILE} {$R-} EXPFILELNS:=0; repeat readln(EXPFILE,HEAPPTR^[EXPFILELNS]); EXPFILELNS:=EXPFILELNS+1; { if MEMAVAIL0 then ERROR(2); {$i+} EXPORT_ARRAY; { Jan 9 } IF VARNEW(HEAPPTR,AMT_MEM) <> AMT_MEM THEN ERROR(7); DB_RECNO:=1; READ_WRITE('R',DB_RECNO,REC_LEN,RESULT); IF TESTS THEN LOAD_SCREEN('A',MAINT_FIELDS,NUM_FLDS,IO_REC.B); WHILE RESULT=0 do begin { Jan 9 } if ((IO_REC.A[3]=ord('*')) and (LIST_RECORD)) then { Jan 9 } BEGIN RESET(EXPFILE,EXP_FILENAME); IF IO_RESULT <> 0 THEN ERROR(5); REPEAT Get_Expfile(EXP_FILENAME,RESULT); if RESULT=99 then ERROR(6) else if RESULT<>0 then ERROR(5); for I:=0 to EXPFILELNS do begin {$R-} LINE_IMAGE:=''; N:=0; LINE:=HEAPPTR^[I]; repeat CH:=' '; N:=N+1; if length(LINE)>0 then CH[1]:=LINE[N]; if CH[1]='{' then begin { ID } EATRIGHT:=False; EATLEFT:=False; N:=N+1; CH[1]:=LINE[N]; if CH[1]='*' then begin EATLEFT:=True; IDNAME:=''; end else IDNAME:=CH; while CH[1]<>'}' do begin N:=N+1; CH[1]:=LINE[N]; if CH[1]=RETURN_KEY then ERROR(4) else IDNAME:=concat(IDNAME,CH); if CH[1]='*' then begin if (IDNAME='') then ERROR(3); EATRIGHT:=True; N:=N+1; CH[1]:=LINE[N]; if CH[1]<>'}' then ERROR(4); end; {then} end; {while} delete(IDNAME,length(IDNAME),1); IDVAL:=' '; NUMERIC:=True; for J:=1 to length(IDNAME) do if not(IDNAME[J] in['0'..'9']) then NUMERIC:=False; if NUMERIC then begin if VAL(IDNAME,IDNO) then IDVAL[1]:=chr(IDNO); end else begin IDNO:=FIND(IDNAME,DATARRAY); if IDNO>0 then IDVAL:=copy(IO_REC.B,EXP_ARRAY[IDNO].START, EXP_ARRAY[IDNO].LENGTH) else IDVAL:=concat('{',IDNAME,'}'); if EATLEFT then EATSPL(IDVAL); if EATRIGHT then EATSPR(IDVAL); end; LINE_IMAGE:=concat(LINE_IMAGE,IDVAL); end { ID } else LINE_IMAGE:=concat(LINE_IMAGE,CH); until N>=length(LINE); {if SHOW then writeln(LINE_IMAGE);} {Jan 8} writeln(OUT,LINE_IMAGE); end; { for } UNTIL EOF(EXPFILE); CLOSE(EXPFILE); END; DB_RECNO:=DB_RECNO+1; READ_WRITE('R',DB_RECNO,REC_LEN,RESULT); IF TESTS THEN LOAD_SCREEN('A',MAINT_FIELDS,NUM_FLDS,IO_REC.B); end; {while result=0} {$R+} close(OUT,lock); close_expfile; end; {EXPORT} SEGMENT PROCEDURE GET_TEST_ARRAY; { Gets the tests to be made on each record of the "from" data file before it is copied to the "to" data file. Only a limited no. of these tests are displayed on the screen at any one time (limited by the no. of possible fields in GET_FIELDS). } VAR FIRST_TEST,NUM_TESTS : INTEGER; GET_FIELDS : SCREEN_ARR; ERROR : BOOLEAN; S,MSG : STRING; SEGMENT PROCEDURE USER_TESTS; VAR NUM_FIELDS,ROW,ID_COL,ID_ROW : INTEGER; PROMPT : STRING; BEGIN ERASE_EOS(0,0); WRITE('Comparison tests to be made on fields of each record:'); GOTOXY(62,0); WRITE('Choose from the'); GOTOXY(62,1); WRITE('following fields:'); GOTOXY(0,18); WRITE('Valid operators are: < , > , = , <= , >= , or <>'); GOTOXY(0,20); WRITE('Currently viewing tests 1 - 13'); GOTOXY(0,22); PROMPT := 'Get, Save tests, Change, Next, Back, Quit:'; FOR I := 1 TO LENGTH(PROMPT) DO IF NOT(PROMPT[I] IN ['A'..'Z']) THEN PROMPT[I] := CHR(ORD(PROMPT[I])+128); WRITE(PROMPT); I := 1; ROW := 4; WHILE I < SCREEN_FIELDS-1 DO BEGIN WITH GET_FIELDS[I] DO { Field } BEGIN S_ROW := ROW; S_COL := 0; S_LEN := 8; S_MIN := 0; S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE; S_DEF := ''; S_FLD := ''; S_TYP := 'V'; END; WITH GET_FIELDS[I+1] DO { Operator } BEGIN S_ROW := ROW; S_COL := 12; S_LEN := 2; S_MIN := 0; S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE; S_DEF := ''; S_FLD := ''; S_TYP := 'V'; END; WITH GET_FIELDS[I+2] DO { Value } BEGIN S_ROW := ROW; S_COL := 18; S_LEN := 40; S_MIN := 0; S_JUS := 'L'; S_NA := 'S'; S_SKIP := TRUE; S_DEF := ''; S_FLD := ''; S_TYP := 'V'; END; ROW := ROW + 1; I := I + 3; END; WITH GET_FIELDS[SCREEN_FIELDS] DO BEGIN S_ROW := END_SCREEN; S_LEN := 0; S_FLD := ''; END; DISPLAY_SCREEN(GET_FIELDS,0,0,0,23); GOTOXY(0,2); WRITE('FIELD ID OPERATOR VALUE'); NUM_FIELDS := 0; I := 1; WHILE I <= SCREEN_FIELDS DO BEGIN IF MAINT_FIELDS[I].S_ROW = END_SCREEN THEN I := SCREEN_FIELDS ELSE NUMFIELDS := NUMFIELDS + 1; I := I + 1; END; { The following code writes out the ids the user may choose from in testing the fields to be copied. If there are less than 20, they are written out in a single column, otherwise they are written out alternating between two columns. } IF NUM_FIELDS <= 20 THEN ID_COL := 66 { Center a single column } ELSE ID_COL := 62; { Center double columns } ID_ROW := 3; I := 1; WHILE I <= NUM_FIELDS DO BEGIN GOTOXY(ID_COL,ID_ROW); WRITE(MAINT_FIELDS[I].S_ID); IF ID_COL = 62 THEN { Alternate ids between 1st and 2nd cols } ID_COL := 72 ELSE IF ID_COL = 66 THEN ID_ROW := ID_ROW + 1 ELSE IF ID_COL = 72 THEN BEGIN ID_COL := 62; ID_ROW := ID_ROW + 1; END; I := I + 1; END; END; {USER_TESTS} SEGMENT PROCEDURE DISPLAY_TESTS(TEST_NO : INTEGER); { Transfers the appropriate section of TEST_ARRAY tests to GET_FIELDS for display. } VAR FOUND : BOOLEAN; BEGIN FOR I := 1 TO SCREEN_FIELDS DO GET_FIELDS[I].S_FLD := ''; I := 1; WHILE I < SCREEN_TESTS*3 DO WITH TEST_ARRAY[TEST_NO +(I DIV 3)] DO BEGIN IF FIELD_LOC = 0 THEN BEGIN GET_FIELDS[I].S_FLD := ''; GET_FIELDS[I+1].S_FLD := ''; GET_FIELDS[I+3].S_FLD := ''; END ELSE BEGIN GET_FIELDS[I].S_FLD := MAINT_FIELDS[FIELD_LOC].S_ID; WITH GET_FIELDS[I+1] DO CASE OPERATOR OF LT: S_FLD := '<'; GT: S_FLD := '>'; EQ: S_FLD := '='; LE: S_FLD := '<='; GE: S_FLD := '>='; NE: S_FLD := '<>'; END; GET_FIELDS[I+2].S_FLD := VALUE; END; I := I + 3; END; DISPLAY_SCREEN(GET_FIELDS,0,0,0,23); END; SEGMENT PROCEDURE UPDATE_TEST_ARRAY(TEST_NO : INTEGER); { Checks the tests in GET_FIELDS for validity and transfers them to the appropriate section of TEST_ARRAY. } VAR OP : OPS; FLD_LEN,I,K,LOCATION : INTEGER; BLANK_FIELD,BLANK_OP,BLANK_VALUE : BOOLEAN; PROCEDURE CHK_FIELD(VAR FIELD : STRING; VAR LOC : INTEGER; VAR IS_BLANK : BOOLEAN; VAR FLD_LENGTH : INTEGER); { Determines if the field name of the test is valid. Passes back the length of the fields value field so that CHK_VALUE may determine if the length of value of the test is within the maximum allowable. } VAR FOUND : BOOLEAN; BEGIN EATSPL(FIELD); EATSPR(FIELD); IF LENGTH(FIELD) = 0 THEN IS_BLANK := TRUE ELSE IS_BLANK := FALSE; FLD_LENGTH := 0; IF NOT IS_BLANK THEN BEGIN FOUND := FALSE; LOC := FIND(FIELD,MAINT_FIELDS); IF LOC <> 0 THEN BEGIN FOUND := TRUE; FLD_LENGTH := MAINT_FIELDS[LOC].S_LEN; END; IF NOT FOUND THEN BEGIN MESSAGE(MAX_ROW,40,CONCAT('ERROR: ',FIELD, ' is an invalid field name'), TRUE); ERROR := TRUE; EXIT(UPDATE_TEST_ARRAY); END; END; END; PROCEDURE CHK_OP(VAR OP_STRING : STRING; VAR OPRATR : OPS; VAR IS_BLANK : BOOLEAN); { Determine if the operator of the test is valid. Valid operators are: "<", ">", "<=", ">=", "<>", and "=". } VAR GOOD : BOOLEAN; BEGIN EATSPL(OP_STRING); EATSPR(OP_STRING); GOOD := TRUE; IS_BLANK := FALSE; IF LENGTH(OP_STRING) = 0 THEN IS_BLANK := TRUE ELSE IF OP_STRING = '<' THEN OPRATR := LT ELSE IF OP_STRING = '>' THEN OPRATR := GT ELSE IF OP_STRING = '=' THEN OPRATR := EQ ELSE IF OP_STRING = '<=' THEN OPRATR := LE ELSE IF OP_STRING = '>=' THEN OPRATR := GE ELSE IF OP_STRING = '<>' THEN OPRATR := NE ELSE GOOD := FALSE; IF NOT GOOD THEN BEGIN MESSAGE(MAX_ROW,40,CONCAT('ERROR: ',OP_STRING,' is an invalid ', 'operator'),TRUE); ERROR := TRUE; EXIT(UPDATE_TEST_ARRAY); END; END; PROCEDURE CHK_VALUE(VAR VALUE: STRING; IS_BLANK: BOOLEAN; FLD_LENGTH: INTEGER); { Determines if the length of the value of the test is within the maximum. } VAR COL : INTEGER; BEGIN IF FLD_LENGTH > 0 THEN BEGIN EATSPL(VALUE); EATSPR(VALUE); IF LENGTH(VALUE) > FLD_LENGTH THEN BEGIN STR(FLD_LENGTH,MSG); MSG := CONCAT('ERROR: Value "',VALUE,'" exceeds max length', ' of ',MSG); COL := 80-LENGTH(MSG); IF COL > 40 THEN COL := 40; MESSAGE(MAX_ROW,COL,MSG,TRUE); ERROR := TRUE; EXIT(UPDATE_TEST_ARRAY); END ELSE IF LENGTH(VALUE) = 0 THEN IS_BLANK := TRUE ELSE IS_BLANK := FALSE; END; END; BEGIN {UPDATE_TEST_ARRAY} ERASE_EOL(0,MAX_ROW); ERROR := FALSE; I := 1; WHILE I < 3*SCREEN_TESTS DO BEGIN CHK_FIELD(GET_FIELDS[I].S_FLD,LOCATION,BLANK_FIELD,FLD_LEN); CHK_OP(GET_FIELDS[I+1].S_FLD,OP,BLANK_OP); CHK_VALUE(GET_FIELDS[I+2].S_FLD,BLANK_VALUE,FLD_LEN); IF ((BLANK_OP) AND (NOT BLANK_FIELD)) THEN BEGIN MESSAGE(MAX_ROW,40,'ERROR: Missing operator',true); ERROR := TRUE; EXIT(UPDATE_TEST_ARRAY); END; IF ((BLANK_FIELD) OR (BLANK_OP)) THEN TEST_ARRAY[TEST_NO + (I DIV 3)].FIELD_LOC := 0 ELSE WITH TEST_ARRAY[TEST_NO+(I DIV 3)] DO BEGIN FIELD_LOC := LOCATION; OPERATOR := OP; VALUE := GET_FIELDS[I+2].S_FLD; END; I := I + 3; END; END; {UPDATE_TEST_ARRAY} Segment PROCEDURE GET_SAVE(COMMAND : CHAR); VAR GOOD : BOOLEAN; FILE_NAME : STRING[23]; TEST_FILE : FILE OF TEST_REC; BEGIN FOR II := 1 TO SCREEN_FIELDS DO WITH GET_FIELDS[II] DO BEGIN S_ROW := END_SCREEN; S_COL := 14; S_MIN := 0; S_TYP := 'V'; S_JUS := 'L'; S_NA := 'S'; S_DEF := ''; S_FLD := ''; END; WITH GET_FIELDS[1] DO BEGIN S_ID := 'VOL'; S_ROW := 6; S_LEN := 7; END; WITH GET_FIELDS[2] DO BEGIN S_ID := 'NAME'; S_ROW := 8; S_LEN := 10; END; ERASE_EOS(0,0); GOTOXY(25,0); IF COMMAND = 'G' THEN WRITE('GET COMPARISON TESTS') ELSE WRITE('SAVE COMPARISON TESTS'); GOTOXY(25,1); IF COMMAND = 'G' THEN WRITE('====================') ELSE WRITE('====================='); GOTOXY(0,6); WRITELN('Volume :'); WRITELN; WRITELN('Name :'); WRITELN; WRITELN('Type : Cmpr'); MESSAGE(MAX_ROW,0,' to execute, to abort',false); DISPLAY_SCREEN(GET_FIELDS,0,0,0,23); REPEAT GOOD := TRUE; SCREEN(GET_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY); IF EXIT_KEY = ESC_KEY THEN EXIT(GET_SAVE); VOLUME := GET_FIELDS[1].S_FLD; NAME := GET_FIELDS[2].S_FLD; EATSPL(VOLUME); EATSPR(VOLUME); EATSPL(NAME); EATSPR(NAME); FILE_NAME := CONCAT(VOLUME,':',NAME,'.CMPR'); {$I-} IF COMMAND = 'G' THEN BEGIN RESET(TEST_FILE,FILE_NAME); IF IO_RESULT = 0 THEN BEGIN FOR I := 1 TO MAX_TESTS DO BEGIN TEST_ARRAY[I].FIELD_LOC := TEST_FILE^.FIELD_LOC; TEST_ARRAY[I].OPERATOR := TEST_FILE^.OPERATOR; TEST_ARRAY[I].VALUE := TEST_FILE^.VALUE; IF I <> MAX_TESTS THEN GET(TEST_FILE); IF IO_RESULT <> 0 THEN GOOD := FALSE; END; CLOSE(TEST_FILE,LOCK); END ELSE GOOD := FALSE; END ELSE BEGIN REWRITE(TEST_FILE,FILE_NAME); IF IO_RESULT = 0 THEN BEGIN FOR I := 1 TO MAX_TESTS DO BEGIN TEST_FILE^.FIELD_LOC := TEST_ARRAY[I].FIELD_LOC; TEST_FILE^.OPERATOR := TEST_ARRAY[I].OPERATOR; TEST_FILE^.VALUE := TEST_ARRAY[I].VALUE; PUT(TEST_FILE); IF IO_RESULT <> 0 THEN GOOD := FALSE; END; CLOSE(TEST_FILE,LOCK); END ELSE GOOD := FALSE; END; IF NOT GOOD THEN MESSAGE(MAX_ROW,40,'ERROR: Invalid file specification',true); UNTIL GOOD; {$I+} END; {GET_SAVE} BEGIN {GET_TEST_ARRAY} USER_TESTS; ERROR := FALSE; FIRST_TEST := 1; DISPLAY_TESTS(FIRST_TEST); REPEAT IF ERROR THEN CH := 'C' ELSE BEGIN GOTOXY(43,MAX_ROW-1); READ(KEYBOARD,CH); ERASE_EOL(0,MAX_ROW); END; CASE CH OF 'C','c': BEGIN SCREEN(GET_FIELDS,TRUE,0,0,0,0,23,MAX_ROW,40,EXIT_KEY); IF EXIT_KEY = ESC_KEY THEN EXIT(GET_TEST_ARRAY); UPDATE_TEST_ARRAY(FIRST_TEST); END; 'B','b': BEGIN IF ERROR THEN WRITE(ALARM_BELL) ELSE BEGIN IF FIRST_TEST <> 1 THEN FIRST_TEST := FIRST_TEST - SCREEN_TESTS ELSE FIRST_TEST := MAX_TESTS-SCREEN_TESTS+1; STR(FIRST_TEST,S); STR(FIRST_TEST+12,MSG); MSG := CONCAT('Currently viewing tests ',S,' - ', MSG,' '); MESSAGE(20,0,MSG,FALSE); DISPLAY_TESTS(FIRST_TEST); END; END; 'G','g': BEGIN GET_SAVE('G'); USER_TESTS; FIRST_TEST := 1; DISPLAY_TESTS(FIRST_TEST); END; 'S','s': BEGIN IF ERROR THEN WRITE(ALARM_BELL) ELSE BEGIN GET_SAVE('S'); USER_TESTS; FIRST_TEST := 1; DISPLAY_TESTS(FIRST_TEST); END; END; 'N','n': BEGIN IF ERROR THEN WRITE(ALARM_BELL) ELSE BEGIN IF FIRST_TEST < MAX_TESTS-SCREEN_TESTS+1 THEN FIRST_TEST := FIRST_TEST + SCREEN_TESTS ELSE FIRST_TEST := 1; STR(FIRST_TEST,S); STR(FIRST_TEST+12,MSG); MSG := CONCAT('Currently viewing tests ',S,' - ', MSG,' '); MESSAGE(20,0,MSG,FALSE); DISPLAY_TESTS(FIRST_TEST); END; END; END; UNTIL ((CH = 'Q') OR (CH = 'q')); II := 1; NUM_TESTS := 0; WHILE ((II <= MAX_TESTS) AND (NUM_TESTS < 2)) DO BEGIN IF TEST_ARRAY[II].FIELD_LOC > 0 THEN NUM_TESTS := NUM_TESTS + 1; II := II + 1; END; IF NUM_TESTS <> 0 THEN TESTS := TRUE; ALL_TESTS := TRUE; IF NUM_TESTS > 1 THEN BEGIN ERASE_EOS(0,0); WRITE('List or export each record if :'); GOTOXY(0,2); WRITE('1) All of the above tests have been met'); GOTOXY(0,4); WRITE('2) Any of the above tests has been met'); GOTOXY(0,6); WRITE('Enter 1 or 2 :'); REPEAT ERASE_EOL(15,6); READ(KEYBOARD,CH); UNTIL ((CH = '1') OR (CH = '2')); WRITE(CH); IF CH = '2' THEN ALL_TESTS := FALSE; END; END; {GET_TEST_ARRAY} Segment Procedure PRINT_IT(var ERROR_FIELD: Integer); { Procedure formats the data records according the the format specifaction and then prints the records. } const NUMBER_COLUMNS = 8; MAX_LINES = 61; type PRINT_FIELDS = record FIELD_WIDTH, COLUMN_WIDTH, START_POS:Integer; PRINT_TITLE:String[40]; end; var PAGE_NUMBER,P_LENGTH,COLUMN_NUMBER,INDEX,LENGTH_INDEX,LIST_INDEX, ARRAY_INDEX,HEADING_INDEX,TITLE_WIDTH,LINE_NUMBER,FOOTING_INDEX, FOOTING_LINES,LAST_LINE,MAINT_INDEX,PRINT_INDEX: Integer; FOOTING,HEADING,ASCII_TITLE,ASCII_ID: String[40]; STRING_HEAD,STRING_INDEX,STRING_RECNO:String[5]; STRING_FOOT,STRING_ID,STRING_TITLE: String[8]; PRINT_ARRAY: Array[1..NUMBER_COLUMNS] of PRINT_FIELDS; LP: Text; STRING_WIDTH: string; WIDTH: integer; Procedure PSTRING(FLEN: Integer; STRNG: String); var I: integer; begin {PSTRING} for I:=1 to length(STRNG) do if STRNG[I] = ULINE then STRNG[I] := ' '; write(LP,' ':(FLEN-length(STRNG)) div 2,STRNG, ' ':(FLEN-length(STRNG)+1) div 2); end; {PSTRNG} Procedure PRINT_LENGTH; begin {PRINT LENGTH} P_LENGTH := 0; for LENGTH_INDEX := 1 to ARRAY_INDEX-1 do P_LENGTH := P_LENGTH + PRINT_ARRAY[LENGTH_INDEX].COLUMN_WIDTH; end; {PRINT LENGTH} Procedure COUNT_FOOTINGS; begin {COUNT FOOTINGS} FOOTING_LINES := 0; for FOOTING_INDEX := 1 to 3 do begin str(FOOTING_INDEX,STRING_FOOT); STRING_FOOT := concat('FOOT',STRING_FOOT); FOOTING := GET_FIELDS[FIND(STRING_FOOT,GET_FIELDS)].S_FLD; EATSPL(FOOTING); EATSPR(FOOTING); if length(FOOTING)>0 then FOOTING_LINES:=FOOTING_LINES + 1; end; end; {COUNT FOOTINGS} Procedure PRINT_FOOTINGS; begin {PRINT FOOTINGS} writeln(LP); for FOOTING_INDEX := 1 to 3 do begin str(FOOTING_INDEX,STRING_FOOT); STRING_FOOT := concat('FOOT',STRING_FOOT); FOOTING := GET_FIELDS[FIND(STRING_FOOT,GET_FIELDS)].S_FLD; EATSPL(FOOTING); EATSPR(FOOTING); if FOOTING = '#' then begin str(PAGE_NUMBER,STRING_FOOT); PSTRING_(P_LENGTH,concat('PAGE ',STRING_FOOT)); writeln(LP); LINE_NUMBER := LINE_NUMBER + 1 end else if length(FOOTING) > 0 then begin PSTRING(P_LENGTH,FOOTING); writeln(LP); LINE_NUMBER:=LINE_NUMBER + 1; end; end; end; {PRINT FOOTINGS} Procedure PRINT_HEADINGS; var UNDER_LINE:String[40]; TEMP_WIDTH:Integer; begin {PRINT_HEADINGS} UNDER_LINE := '========================================'; for HEADING_INDEX:=1 to 3 do begin str(HEADING_INDEX,STRING_HEAD); STRING_HEAD := concat('HEAD',STRING_HEAD); HEADING := GET_FIELDS[FIND(STRING_HEAD,GET_FIELDS)].S_FLD; EATSPL(HEADING); EATSPR(HEADING); if length(HEADING) > 0 then begin PSTRING(P_LENGTH,HEADING); writeln(LP); LINE_NUMBER := LINE_NUMBER + 1; end; end; if LINE_NUMBER>1 then writeln(LP); for HEADING_INDEX:=1 to ARRAY_INDEX - 1 do begin with PRINT_ARRAY[HEADING_INDEX] do PSTRING(COLUMN_WIDTH,PRINT_TITLE); end; writeln(LP); for HEADING_INDEX := 1 to ARRAY_INDEX -1 do begin with PRINT_ARRAY[HEADING_INDEX] do begin if FIELD_WIDTH>0 then TEMP_WIDTH := FIELD_WIDTH else TEMP_WIDTH := -FIELD_WIDTH; PSTRING(COLUMN_WIDTH,COPY(UNDER_LINE,1,TEMP_WIDTH)); end; end; writeln(LP); writeln(LP); LINE_NUMBER := LINE_NUMBER + 3; end; {PRINT HEADINGS} begin {PRINT IT} MESSAGE(MAX_ROW,40,'List in progress',false); {$I-} if WRITE_FILE_NAME ='' then begin rewrite(LP,'PRINTER:'); if IORESULT<>0 then begin MESSAGE(MAX_ROW,40,'ERROR: Printer not on line.',True); exit(PRINT_IT); end; end else begin rewrite(lp,write_file_name); if ioresult<>0 then begin message(max_row,40,'ERROR: Output file not available.',true); exit(print_it); end; end; {Dec 29} ERROR_FIELD := 0; ARRAY_INDEX := 1; string_width:=GET_FIELDS[find('WIDTH',GET_FIELDS)].s_fld; {Dec 29} if not val(string_width,width) then begin {Dec 29} message(max_row,40,'ERROR: Invalid print width',true); error_field:=find('WIDTH',GET_FIELDS); end; {if not val} for PRINT_INDEX := 1 to NUMBER_COLUMNS do begin str(PRINT_INDEX,STRING_INDEX); STRING_ID := concat('ID',STRING_INDEX); STRING_TITLE := concat('TIT',STRING_INDEX); ASCII_TITLE := GET_FIELDS[FIND(STRING_TITLE,GET_FIELDS)].S_FLD; EATSPL(ASCII_TITLE); EATSPR(ASCII_TITLE); TITLE_WIDTH := length(ASCII_TITLE); LIST_INDEX := FIND(STRING_ID,GET_FIELDS); ASCII_ID := GET_FIELDS[LIST_INDEX].S_FLD; EATSPL(ASCII_ID); EATSPR(ASCII_ID); if ASCII_ID = '#' then with PRINT_ARRAY[ARRAY_INDEX] do begin FIELD_WIDTH := 5; if TITLE_WIDTH <= FIELD_WIDTH then COLUMN_WIDTH := FIELD_WIDTH + 2 else COLUMN_WIDTH := TITLE_WIDTH + 2; FIELD_WIDTH := -FIELD_WIDTH; PRINT_TITLE := ASCII_TITLE; ARRAY_INDEX := ARRAY_INDEX + 1; end else begin MAINT_INDEX := FIND(ASCII_ID,MAINT_FIELDS); if (MAINT_INDEX = 0) and (length(ASCII_ID) > 0) then begin MESSAGE(MAX_ROW,40,'ERROR: Invalid field ID',True); ERROR_FIELD := LIST_INDEX; exit(PRINT_IT); end else if MAINT_INDEX > 0 then begin with PRINT_ARRAY[ARRAY_INDEX] do begin PRINT_TITLE := ASCII_TITLE; FIELD_WIDTH := MAINT_FIELDS[MAINT_INDEX].S_LEN; if TITLE_WIDTH <= FIELD_WIDTH then COLUMN_WIDTH := FIELD_WIDTH + 2 else COLUMN_WIDTH := TITLE_WIDTH + 2; START_POS:=0; for INDEX:=1 to MAINT_INDEX-1 do START_POS:=START_POS+MAINT_FIELDS[INDEX].S_LEN; START_POS:=START_POS+1; end; ARRAY_INDEX := ARRAY_INDEX + 1; end; end; end; if ARRAY_INDEX = 1 then begin MESSAGE(MAX_ROW,40,'ERROR: No Field IDs found',True); exit(PRINT_IT); end; PRINT_LENGTH; if P_LENGTH > width {Dec 29} then begin MESSAGE(MAX_ROW,40,concat('ERROR: Print record > ', string_width,' characters'),True); {Dec 29} exit(PRINT_IT); end; COUNT_FOOTINGS; LAST_LINE := MAX_LINES-FOOTING_LINES; writeln(LP,FORM_FEED); LINE_NUMBER := 1; PAGE_NUMBER := 1; DB_RECNO := 1; READ_WRITE('R',DB_RECNO,REC_LEN,RESULTS); IF TESTS THEN LOAD_SCREEN('A',MAINT_FIELDS,NUM_FLDS,IO_REC.B); while RESULTS = 0 do begin if LINE_NUMBER = LAST_LINE then begin if FOOTING_LINES>0 then PRINT_FOOTINGS; writeln(LP,FORM_FEED); LINE_NUMBER := 1; PAGE_NUMBER := PAGE_NUMBER + 1; end; if LINE_NUMBER = 1 then PRINT_HEADINGS; str(DB_RECNO,STRING_RECNO); while length(STRING_RECNO)<4 do STRING_RECNO:=concat(' ',STRING_RECNO); { gotoxy(13,23); write(STRING_RECNO); } {Dec 29} if IO_REC.A[3] = 42 THEN IF LIST_RECORD THEN begin for COLUMN_NUMBER := 1 to ARRAY_INDEX-1 do begin with PRINT_ARRAY[COLUMN_NUMBER] do begin if FIELD_WIDTH < 1 then begin PSTRING_(COLUMN_WIDTH,STRING_RECNO); end else PSTRING(COLUMN_WIDTH, copy(IO_REC.B,START_POS+3,FIELD_WIDTH)); end; end; writeln(LP); LINE_NUMBER := LINE_NUMBER + 1; end; DB_RECNO := DB_RECNO +1; READ_WRITE('R',DB_RECNO,REC_LEN,RESULTS); IF TESTS THEN LOAD_SCREEN('A',MAINT_FIELDS,NUM_FLDS,IO_REC.B); end; {while RESULTS} if LINE_NUMBER < LAST_LINE then begin for PRINT_INDEX := LINE_NUMBER to LAST_LINE-1 do writeln(LP); if FOOTING_LINES > 0 then PRINT_FOOTINGS; end; close(lp,lock); {Dec 29} ERASE_EOL(40,MAX_ROW); end; {PRINT IT} begin {ACCESS_DATA_BASE} FOR I := 1 TO MAX_TESTS DO WITH TEST_ARRAY[I] DO BEGIN FIELD_LOC := 0; VALUE := ''; END; TESTS := FALSE; RECORD_LENGTH(MAINT_FIELDS); {Jan 9} ERASE_EOS(0,0); GET_FILE('*UD/LIST.SCRN',GET_FIELDS,GET_PROMPTS,RESULTS); if RESULTS <> 0 then begin MESSAGE(MAX_ROW,40,'ERROR: Unable to load "UD/LIST.SCRN"',True); exit(LIST); end; DISPLAY_FLAG := True; repeat if DISPLAY_FLAG then begin ERASE_EOS(0,0); DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23); DISPLAY_SCREEN(GET_FIELDS,0,0,0,23); gotoxy(0,MAX_ROW-1); writeln(PROMPT1); write(PROMPT2); DISPLAY_FLAG := False; end; gotoxy(32,23); read(Keyboard,CH); if CH = ESC_KEY then begin close(DATA_FILE,lock); exit(LIST); end else if CH in['a'..'z'] then CH:=chr(ord(CH)+ord('A')-ord('a')); ERASE_EOL(32,23); write(CH); case CH of 'G','S','O': begin GET_SAVE_FORMAT(CH,ESC); DISPLAY_FLAG := True; end; 'L': begin PRINT_IT(START_LIST); if START_LIST <> 0 then SCREEN(GET_FIELDS,true,START_LIST,0,0,0,MAX_ROW, MAX_ROW,40,EXXIT); end; 'C': SCREEN(GET_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXXIT); 'E': begin GET_SAVE_FORMAT(CH,ESC); {Export file} if not ESC then EXPORT(EXPRT_FILE_NAME,MAINT_FIELDS,WRITE_FILE_NAME); DISPLAY_FLAG:=TRUE; end; 'T': BEGIN GET_TEST_ARRAY; { GET_FILE('*UD/LIST.SCRN',GET_FIELDS,GET_PROMPTS,RESULTS); if RESULTS <> 0 then begin MESSAGE(MAX_ROW,40, 'ERROR: Unable to load "UD/LIST.SCRN"',True); exit(LIST); end; } DISPLAY_FLAG:=TRUE; END; 'Q': exit(ACCESS_DATA_BASE); end; until False; end; {ACCESS_DATA_BASE} Procedure RECORD_LENGTH{var S_ARRAY: SCREEN_ARR}; { Function to find the length of the record defined by the data base definition. } var DONE: boolean; begin REC_LEN := 0; INDEX := 1; DONE:=false; {Mar 20 to handle 40 fields } while (not DONE) and (INDEX<=SCREEN_FIELDS) do if S_ARRAY[INDEX].S_ROW <> END_SCREEN then begin REC_LEN := REC_LEN + S_ARRAY[INDEX].S_LEN; INDEX := INDEX + 1; end else DONE:=true; REC_LEN := REC_LEN + 5; NUM_FLDS := INDEX-1; end; Procedure MESSAGE; (* M_ROW,M_COL: Integer; MSG: String; DING: Boolean *) { Procedure displays messages at the message row and column. } begin gotoxy(M_COL,M_ROW); write(MSG); if DING then write(ALARM_BELL); end; Function VAL; {(S: string; var NUM: integer): boolean;}{ Jan 7} { Procedure converts a string to an integer and returns an error indicator } var neg: boolean; i: integer; correct: boolean; begin num:=0; eatspl(s); eatspr(s); if length(s)=0 then begin val:=false; exit(val); end; neg:=s[1]='-'; if s[1] in ['+','-'] then delete(s,1,1); correct:=true; for i:=1 to length(s) do if s[i] in ['0'..'9'] then num:=10*num+ord(s[i])-ord('0') else correct:=false; if correct and neg then num:=-num; if not correct then num:=0; val:=correct; end; { val } begin {LIST} INITIALIZE; GET_DATA_BASE; ACCESS_DATA_BASE; close(DATA_FILE,lock); end. {LIST} ======================================================================================== DOCUMENT :usus Folder:VOL25:ud.maint.text ======================================================================================== {$L #5:MNTLST.TEXT} PROGRAM MAINTAIN; { Once a data base has been defined, this set of procedures maintains the data base by adding, examining, changing and deleting the various data base records. } Uses {$U sh.screen.unit} SCREEN40; const MAX_INT = 32767; (* maximum integer & number of records *) BLANKS = ' ' ; ERROR_COL = 0 ; ERROR_LINE = 23 ; MAXFRAC = 4 ; MAXWHOLE = 9 ; MAX_CALC_TEXT = 40 ; MAX_VALUE_DIGITS = 14 ; STARS = '**************' ; ZEROS = '00000000000000' ; ROUNDING_FACTOR = 0 ; type STRING5 = String[5]; STRING23 = String[23]; STRING40 = String[40]; STRING255 = String[255]; INTEGER14 = Integer[14]; ASTRING = STRING ; SIXWORDINT = INTEGER[ 20 ] ; THREEWORDINT = INTEGER[ 8 ] ; T_SCREEN_COLUMN = 0 .. 79 ; T_SCREEN_LINE = 0 .. 23 ; T_CALC = RECORD CALC_TEXT : STRING[ MAX_CALC_TEXT ] ; END ; { T_CALC } T_VALUE = RECORD VALUE : STRING[ MAX_VALUE_DIGITS ] ; DECIMAL_POSITION : INTEGER ; END ; { T_VALUE } var GET_FIELDS,MAINT_FIELDS : SCREEN_ARR; { Array to hold data fields } GET_PROMPTS,MAINT_PROMPTS : PROMPT_ARR; { Array to hold screen prompts } DATA_RESULTS, { 0 If data file exist } DEFI_RESULTS, { 0 If data base definition exist } GET_RESULTS, { 0 If 'GET.SCRN' loaded } RESULTS, FIELD_ROW,FIELD_COL,FIELD_LEN,FIELD_MIN, COPY_INDEX,COPY_LENGTH,INDEX,MAX_RECORDS,ERRCOL,ERROW, DB_RECNO,REC_LEN,CURRENT_BLOCK : Integer; EXXIT,EXIT_KEY,CH,FIELD_JUS,FIELD_NA : Char; FIELD_FLD : STRINGFL; EXAMINE_FLAG,FIELD_SKIP,CALCULATIONS : Boolean; PROMPTLINE,OPTLINE: String; VOLUME : String[7]; { Data base volume } NAME : String[10]; { Data base Name } DB_NAME : String[18]; { Volumn + Data Base Name } DATA_NAME : STRING23; { Data file name } DEFI_NAME : STRING23; { Data Base Definition file name } STR_RECNO : String[5]; IO_REC : Packed record { String to hold data base record } case Integer of 1: (A: Packed Array[0..255] of 0..255); 2: (B: STRING255); end; NUM_FIELDS : integer; { number of screen fields } DATA_FILE : File; Digitset : Set of Char; Operators : Set of Char; Longintzero : threewordint; Max : Threewordint; Multipler : Threewordint; Procedure MESSAGE(M_ROW,M_COL :Integer; MSG :String; DING: Boolean); Forward; Procedure RECORD_LENGTH(var S_ARRAY :SCREEN_ARR); Forward; Segment Procedure INIT_FLOAT ; CONST ONE_HUNDRED = 100 ; TEN = 10 ; VAR I : INTEGER ; INT : INTEGER ; ONE : INTEGER ; BEGIN DIGITSET := [ '0' .. '9' ] ; OPERATORS := ['+','-','*','/','^','(',')','#','=',' ']; { NOTE: The following strange code is placed here to get around a compiler requirement that reals be present in order for the compiler to compile a LongInteger constant. } ONE := 1 ; INT := 10 ; MAX := INT ; FOR I := 1 TO 14-1 DO MAX := MAX * INT ; { Compute 1E14 } MAX := MAX - ONE ; { Compute (1E14)-1, the largest VALUE allowed. } MULTIPLER := INT ; FOR I := 1 TO 5-1 DO MULTIPLER := MULTIPLER * INT ; { Compute 1E5, used to shift and align digits around the implied decimal point. } { See above note about compiler needing reals to compile a longinteger const } LONGINTZERO := MAX - MAX ; END ; { INIT_FLOAT } Segment Procedure NUMTOSTR ( VAR ANS : ASTRING ; NUM : THREEWORDINT ; BEFORE, AFTER: INTEGER ) ; { Dale Ander May 28, 1980 NUMTOSTR takes the Longinteger in NUM and creates a string representation of it and puts this string into ANS. The form of the string is dependant upon the values of BEFORE and AFTER. BEFORE is the number of digits to put before the decimal point and AFTER is the number after. } VAR I, L : INTEGER ; MINUSZERO : BOOLEAN ; BEGIN IF NUM>=MAX THEN NUM:=0; { SEP 28 TO HANDLE OVERFLOW NUMBERS } IF NOT (BEFORE IN [1..MAXWHOLE]) THEN BEFORE := MAXWHOLE ; BEFORE := BEFORE + 1 ; { Allow room for sign. } IF NOT (AFTER IN [0..MAXFRAC]) THEN AFTER := MAXFRAC ; STR( NUM, ANS ) ; { Convert NUM to a string } IF NUM >= 0 { Put space instead of minus sign } THEN ANS := CONCAT( ' ', ANS ) ; L := LENGTH( ANS ) - MAXFRAC ; IF L < 3 THEN BEGIN INSERT( COPY( ZEROS, 1, 3-L ), ANS, 2 ) ; L := LENGTH( ANS ) - MAXFRAC ; END ; { Remove part of fraction not needed } DELETE( ANS, L+AFTER, MAXFRAC - AFTER + 1 ) ; IF BEFORE - L + 1 > 0 { Insert leading blanks } THEN INSERT( COPY( BLANKS, 1, BEFORE - L + 1 ), ANS, 1 ) ELSE { If field is not wide enough for number then return *'s } IF BEFORE < L - 1 THEN ANS := COPY( STARS, 1, BEFORE + AFTER ) ; IF NUM < 0 { Look for -0 case } THEN BEGIN I := 1 ; L := LENGTH( ANS ) ; REPEAT I := I + 1 ; MINUSZERO := ANS[I] IN DIGITSET ; UNTIL ( I = L ) OR NOT MINUSZERO ; END ; { IF NUM < 0 } IF AFTER > 0 { Put in decimal point } THEN INSERT( '.', ANS, LENGTH( ANS ) - AFTER + 1 ) ; END ; { OF NUMTOSTR } Segment Function FIGURE ( VAR Z : THREEWORDINT ; X, Y : THREEWORDINT ; OP : CHAR ) : BOOLEAN ; { Dale Ander May 28, 1980 This function calculates Z given X and Y and the operation in OP. It is assumed that both X and Y have an 'implied' decimal point in them and that they have (Maxfrac+1) digits to the right of this 'implied' decimal point. The answer, Z, is to also have this implied decimal point in the same position. If an overflow occurs it returns false and sets Z to 9's. Otherwise it return true. } VAR I, POWER : INTEGER ; ANS : SIXWORDINT ; BEGIN CASE OP OF '+' : ANS := X + Y ; '-' : ANS := X - Y ; '*' : ANS := (X * Y + ROUNDING_FACTOR) DIV MULTIPLER ; '/' : IF Y <> 0 THEN ANS := (X * MULTIPLER) DIV Y ELSE IF X = 0 THEN ANS := 0 ELSE ANS := MAX + 1 ; '^' : BEGIN Y := Y DIV MULTIPLER ; IF (Y < 0) OR (Y > MAXINT) THEN ANS := MAX + 1 ELSE IF Y = 0 THEN ANS := MULTIPLER ELSE BEGIN POWER := TRUNC( Y ) ; I := 1 ; ANS := X ; WHILE (I < POWER) AND (ANS < MAX) DO BEGIN ANS := (ANS * X) DIV MULTIPLER ; I := I + 1 ; END END END ; END ; { CASE } IF ANS > MAX THEN BEGIN Z := MAX ; FIGURE := FALSE ; END ELSE BEGIN Z := ANS ; FIGURE := TRUE ; END ; END ; { OF FIGURE } Segment Procedure INT_TO_STR (INT : INTEGER ; VAR OUT : STRING) ; BEGIN STR( INT, OUT); END; { INT_TO_STR } Segment Procedure VALUE ( RETURN_INTEGER : BOOLEAN ; INSTRING : ASTRING ; VAR REALANS : THREEWORDINT ; VAR INTANS : INTEGER ) ; VAR WSUM, FSUM : THREEWORDINT ; NEGATIVE : BOOLEAN ; PTR : INTEGER ; CH : CHAR ; PROCEDURE GETCHAR ; BEGIN CH := INSTRING[ PTR ] ; PTR := PTR + 1 ; END ; { GETCHAR } PROCEDURE SUM( VAR ANS : THREEWORDINT ; DIGITS : INTEGER ) ; VAR COUNT, ORDZERO : INTEGER ; BEGIN COUNT := 0 ; ANS := 0 ; ORDZERO := ORD('0') ; WHILE (CH IN DIGITSET) AND (COUNT < DIGITS) DO BEGIN COUNT := COUNT + 1 ; ANS := 10 * ANS + ORD( CH ) - ORDZERO ; GETCHAR ; END ; END ; { SUM } BEGIN NEGATIVE := FALSE ; FSUM := 0 ; WSUM := 0 ; EATSPL( INSTRING ) ; EATSPR( INSTRING ) ; INSTRING := CONCAT( INSTRING, ' ' ) ; PTR := 1 ; GETCHAR ; IF CH IN ['+', '-'] THEN BEGIN NEGATIVE := CH = '-' ; GETCHAR END ; SUM( WSUM, MAXWHOLE ) ; { GET WHOLE PART OF NUMBER } IF CH = '.' THEN BEGIN { Put trailing zeroes on } INSERT( COPY( ZEROS, 1, MAXFRAC+1 ), INSTRING, LENGTH( INSTRING ) ) ; GETCHAR ; { Skip period } SUM( FSUM, MAXFRAC + 1 ) ; END ; IF RETURNINTEGER THEN BEGIN INTANS := TRUNC( WSUM ) ; REALANS := - 77 ; IF NEGATIVE THEN INTANS := -INTANS ; END ELSE BEGIN REALANS := WSUM * MULTIPLER + FSUM ; INTANS := -77 ; IF NEGATIVE THEN REALANS := -REALANS ; END ; END ; { OF VALUE } Segment Function INTVALUE (S: STRING; var NUM: integer): boolean ; var I: integer; NUML: threewordint; begin INTVALUE:=false; I:=1; NUML:=0; EATSPL(S); EATSPR(S); if length(S)=0 then exit(INTVALUE); for I:=1 to length(S) do if S[I] in DIGITSET then NUML:=10*NUML+ord(S[I])-ord('0') else exit(INTVALUE); if NUML>MAX_INT then exit(INTVALUE); NUM:=trunc(NUML); INTVALUE:=true; end; { INTVALUE } Segment Procedure INITIALIZE; {Procedure initilizes everything to begin maintaining the data base.} var I: Integer; begin {INITIALIZE} for I:=1 to SCREEN_FIELDS do with GET_FIELDS[I] do begin {Init fields} S_ROW:=END_SCREEN; S_COL:=15; S_MIN:=0; S_TYP:='V'; S_JUS:='L'; S_NA:='S'; S_DEF:=''; S_FLD:=''; S_SKIP:=false; end; {Init fields} with GET_FIELDS[1] do begin S_ID:='VOL'; S_ROW:=8; S_LEN:=7; end; with GET_FIELDS[2] do begin S_ID:='NAME'; S_ROW:=10; S_LEN:=10; end; for I:=1 to PROMPT_FIELDS do with GET_PROMPTS[I] do begin P_ROW:=END_SCREEN; P_COL:=0; P_FLD:=''; end; {with/for} with GET_PROMPTS[1] do begin P_ROW:=0; P_COL:=25; P_FLD:='MAINTAIN A DATA BASE'; end; with GET_PROMPTS[2] do begin P_ROW:=1; P_COL:=25; P_FLD:='===================='; end; with GET_PROMPTS[3] do begin P_ROW:=2; P_COL:=25; P_FLD:='Version IV.0'; end; with GET_PROMPTS[4] do begin P_ROW:=8; P_FLD:='Volume :'; end; with GET_PROMPTS[5] do begin P_ROW:=10; P_FLD:='Name :'; end; with GET_PROMPTS[6] do begin P_ROW:=12; P_FLD:='Type : SCRN and TEXT'; end; ERASE_EOS(0,0); PROMPTLINE:='Rec # <_____>,Add,Mash'; OPTLINE:='Store,Examine,Change,Delete,Quit ?'; for I:=1 to 22 do if not(PROMPTLINE[I] in['A'..'Z']) then PROMPTLINE[I]:=chr(ord(PROMPTLINE[I])+128); for I:=1 to 33 do if not(OPTLINE[I] in['A'..'Z']) then OPTLINE[I]:=chr(ord(OPTLINE[I])+128); FIELD_LEN:=5; FIELD_MIN:=0; ERRCOL:=40; ERROW:=23; FIELD_JUS:='L'; FIELD_NA :='N'; FIELD_FLD:='0'; FIELD_SKIP:=FALSE; DB_RECNO:=1; CURRENT_BLOCK:=-1; EXAMINE_FLAG:=True; Init_Float; end; {INITIALIZE} Segment Procedure GET_DATA_BASE; {Procedure gets the Data Base Definition form the disk or initilizes a new data base file.} Procedure CREATE(var CREATE_NAME:STRING23; var CREATE_LENGTH,NUMBER_RECORDS,CREATE_RESULTS:Integer); { Procedure creates and initilizes a file to hold data base records. } var NO_BLOCKS : Integer; buffer: packed array[0..1023] of 0..255; off_set: integer; check: integer; begin {CREATE} CREATE_RESULTS:=1; fillchar(IO_REC.A[0],sizeof(IO_REC),chr(00)); NO_BLOCKS:=NUMBER_RECORDS div (1024 div REC_LEN)+1; (*$i-*) rewrite(data_file,CREATE_NAME); if IO_RESULT<>0 then exit(create); fillchar(IO_REC.A[4],CREATE_LENGTH-5,' '); IO_REC.A[0]:=CREATE_LENGTH; IO_REC.A[1]:=16; IO_REC.A[2]:=32; IO_REC.A[3]:=126; IO_REC.A[CREATE_LENGTH-1]:=42; IO_REC.A[CREATE_LENGTH]:=13; fillchar(BUFFER[0],sizeof(BUFFER),chr(00)); check:=blockwrite(data_file,buffer,2); (* text file prefix *) if CHECK<>2 then begin close(data_file); exit(create); end; off_set:=0; while off_set+create_length <= 1023 do begin moveleft(io_rec.a[1],buffer[off_set],create_length); off_set:=off_set+create_length; end; index:=1; while index <= no_blocks do begin check:=blockwrite(data_file,buffer,2); if check<>2 then begin close(data_file); exit(create); end; index:=index+1; end; (* while *) (*$i+*) close(data_file,LOCK); CREATE_RESULTS:=0; end; {CREATE} Procedure GET_DATA_FILE; { Procedure checks for data base data file. If no data file exist then the operator can create one. } var RIGHT: BOOLEAN; begin {GET DATA FILE} {$I-} reset(DATA_FILE,DATA_NAME); {$I+} if IO_RESULTS <> 0 then begin ERASE_EOL(0,MAX_ROW); write('Create new data base Y/N ? Y'); gotoxy(27,MAX_ROW); read(Keyboard,CH); if CH in [' ','Y','y'] then begin {make the file} ERASE_EOL(0,MAX_ROW); write('Maximum number of records ?'); REPEAT FIELD_ROW:=MAX_ROW; FIELD_COL:=29; FIELD_FLD:='0'; FIELD_SKIP:=FALSE; FIELD(FIELD_ROW,FIELD_COL,ERROW,ERRCOL,FIELD_LEN,FIELD_MIN,EXXIT, FIELD_JUS,FIELD_NA,FIELD_FLD,FIELD_SKIP); RIGHT:=INTVALUE(FIELD_FLD,MAX_RECORDS); { MAR 11 } IF NOT RIGHT THEN MESSAGE(MAX_ROW,40,'ERROR: Incorrect number of records',TRUE); UNTIL RIGHT; MESSAGE(MAX_ROW,40,'STATUS: Creating Data File',False); CREATE(DATA_NAME,REC_LEN,MAX_RECORDS,RESULTS); if RESULTS<>0 then begin MESSAGE(MAX_ROW,40,'ERROR: Unable to create text data file', True); DATA_RESULTS:=1; end else DATA_RESULTS:=0; end else DATA_RESULTS:=1; end else begin close(DATA_FILE); DATA_RESULTS:=0; end; end; {GET DATA FILE} begin {GET_DATA_BASE} DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23); DISPLAY_SCREEN(GET_FIELDS,0,0,0,23); repeat MESSAGE(4,0, 'Copyright (C) 1981 by Texas Instruments Corporate Engineering Center', false); MESSAGE(5,0, 'All rights reserved as per the Computer Software Copyright Act of 1980', false); MESSAGE(MAX_ROW,0,' to execute, to abort',False); SCREEN(GET_FIELDS,true,0,0,0,0,23,MAX_ROW,40,EXIT_KEY); if EXIT_KEY=ESC_KEY then exit(MAINTAIN); VOLUME:=GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD; EATSPR(VOLUME); NAME:=GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD; EATSPL(NAME); DB_NAME:=concat(VOLUME,':',NAME); DEFI_NAME:=concat(DB_NAME,'.SCRN'); DATA_NAME:=concat(DB_NAME,'.TEXT'); DATA_RESULTS:=0; GET_FILE(DEFI_NAME,MAINT_FIELDS,MAINT_PROMPTS,RESULTS); if RESULTS=0 then begin RECORD_LENGTH(MAINT_FIELDS); if REC_LEN>255 then begin message(MAX_ROW,40,'ERROR: Defined screen is too long',true); DATA_RESULTS:=1; end; { if CALCULATIONS then begin message(MAX_ROW,40,'ERROR: Calculated fields in screen',true); DATA_RESULTS:=1; end; } if DATA_RESULTS=0 THEN GET_DATA_FILE; end else begin MESSAGE(MAX_ROW,40,'ERROR: Unknown Data Base',True); DATA_RESULTS:=1; end; if DATA_RESULTS=0 then exit(GET_DATA_BASE); until False; end; {GET_DATA_BASE} {$P} { } { Perform the calculations. } { } SEGMENT PROCEDURE DO_CALC ; VAR RESULT : INTEGER ; CALC : T_CALC ; TEMP_STRING : STRING ; OUTANS : STRING ; DONE : BOOLEAN ; OVERFLOW : BOOLEAN ; UNDEFINED : BOOLEAN ; INDX : INTEGER ; PROCEDURE ERR(NUM: INTEGER); VAR ERR_TEXT : STRING ; C : CHAR ; BEGIN CASE NUM OF 1: ERR_TEXT := 'ERROR: OVERFLOW occurred' ; 2: ERR_TEXT := 'WARNING: Undefined Field in Calculation'; 3: ERR_TEXT := 'ERROR: Calculation Value too large'; END; message(max_row-1,40,err_text,true); erase_eol(40,max_row); write('Press SPACE to continue'); read(keyboard,c); if eof(keyboard) then reset(keyboard); erase_eol(40,max_row-1); erase_eol(40,max_row); END; (* of err *) PROCEDURE DOIT ; VAR ANSWER : THREEWORDINT ; CURRENT_CALC_LINE : INTEGER ; C_STRING : STRING ; RESULT : INTEGER ; PROCEDURE DOMATH; TYPE TOKENKINDS = (CONSTV, EOFV, LPARENV, MINUSV, PLUSV, UPARROWV, RPARENV, VALUEV, SLASHV, STARV, EQV); VAR SCANRSLT: THREEWORDINT; TOKENTYPE: TOKENKINDS; PT: INTEGER; PROCEDURE SCANNER; VAR NUM: INTEGER; CH: CHAR; PROCEDURE GETVALUE; VAR REQ_INT : INTEGER ; VALSTR : STRING; ENDOFNUM : INTEGER ; N : INTEGER; CH : CHAR; NUMERIC : BOOLEAN; BEGIN (* get name or number value *) NUMERIC:=TRUE; ENDOFNUM := PT + 1; WHILE NOT (C_STRING[ENDOFNUM] IN OPERATORS) DO ENDOFNUM:=ENDOFNUM+1; VALSTR:=COPY(C_STRING,PT,ENDOFNUM-PT); PT := ENDOFNUM; (* determine if a constant *) for n:=1 to length(valstr) do if not((valstr[n] in digitset) or (valstr[n]='.')) then numeric:=false; (* get value of number *) IF NUMERIC THEN BEGIN VALUE( FALSE, VALSTR, SCANRSLT, REQ_INT ) ; TOKENTYPE := CONSTV; END ELSE BEGIN (* NOT NUMERIC *) N:=FIND(VALSTR,MAINT_FIELDS); IF N<>0 THEN VALUE(FALSE,MAINT_FIELDS[N].S_FLD,SCANRSLT,REQ_INT) ELSE BEGIN VALUE(FALSE,'0',SCANRSLT,REQ_INT); UNDEFINED:=TRUE; END; TOKENTYPE:=VALUEV; END; (* NOT NUMERIC *) END; (* getvalue *) BEGIN (* SCANNER *) IF C_STRING[ PT ] = ' ' THEN REPEAT PT := PT + 1 UNTIL C_STRING[ PT ] <> ' '; (* get non blank *) CH := C_STRING[ PT ]; IF NOT (CH IN OPERATORS) THEN GETVALUE ELSE BEGIN CASE CH OF '+': TOKENTYPE:=PLUSV; '-': TOKENTYPE:=MINUSV; '*': TOKENTYPE:=STARV; '/': TOKENTYPE:=SLASHV; '^': TOKENTYPE:=UPARROWV; '(': TOKENTYPE:=LPARENV; ')': TOKENTYPE:=RPARENV; '#': TOKENTYPE:=EOFV; '=': TOKENTYPE:=EQV END; PT := PT + 1 END; IF TOKENTYPE = EOFV THEN PT := PT - 1; END; (* of scanner *) PROCEDURE EXPRESSION( VAR ANS: THREEWORDINT ); VAR SAVEOP: CHAR; CHANGESIGN: BOOLEAN; RESULT: THREEWORDINT; PROCEDURE PARENEXPRESSION( VAR ANS: THREEWORDINT ); BEGIN SCANNER; (* throw away left paren *) EXPRESSION( ANS ); SCANNER (* throw away right paren *) END; (* of parenexpression *) PROCEDURE PRIMARY( VAR ANS: THREEWORDINT ); BEGIN (* PRIMARY *) IF TOKENTYPE IN [ CONSTV, VALUEV ] THEN BEGIN { The following statement is used to remove the requirement that DECOPS be included in this segment. The original line of code follows and is commented out. } IF NOT FIGURE( ANS,LONGINTZERO,SCANRSLT,'+') THEN ERR(1); {ANS := SCANRSLT;} SCANNER END ELSE IF TOKENTYPE = LPARENV THEN PARENEXPRESSION( ANS ) END; (* of primary *) PROCEDURE FACTOR( VAR ANS: THREEWORDINT ); VAR RESULT: THREEWORDINT; BEGIN (* FACTOR *) PRIMARY( ANS ); WHILE TOKENTYPE = UPARROWV DO BEGIN SCANNER; PRIMARY( RESULT ); IF NOT FIGURE(ANS,ANS,RESULT,'^') THEN ERR(1); END END; (* of factor *) PROCEDURE TERM( VAR ANS: THREEWORDINT ); VAR SAVEOP: CHAR; RESULT: THREEWORDINT; BEGIN (* TERM *) FACTOR( ANS ); WHILE TOKENTYPE IN [ STARV, SLASHV ] DO BEGIN IF TOKENTYPE = STARV THEN SAVEOP := '*' ELSE SAVEOP := '/'; SCANNER; FACTOR( RESULT ); IF NOT FIGURE(ANS,ANS,RESULT,SAVEOP) THEN ERR(1); END END; (* of term *) BEGIN (* EXPRESSION *) IF TOKENTYPE IN [ PLUSV, MINUSV ] THEN BEGIN CHANGESIGN := TOKENTYPE = MINUSV; SCANNER END ELSE CHANGESIGN := FALSE; TERM( ANS ); IF CHANGESIGN THEN IF FIGURE(ANS,LONGINTZERO,ANS,'-') THEN; (* do the unary minus *) WHILE TOKENTYPE IN [ PLUSV, MINUSV ] DO BEGIN IF TOKENTYPE = PLUSV THEN SAVEOP := '+' ELSE SAVEOP := '-'; SCANNER; TERM( RESULT ); IF NOT FIGURE(ANS,ANS,RESULT,SAVEOP) THEN ERR(1); END END; (* of expression *) BEGIN (* DOMATH *) PT := 1; SCANNER; EXPRESSION( ANSWER ); NUMTOSTR(OUTANS,ANSWER,MAXWHOLE,MAXFRAC); { MAR 9 } END; (* of domath *) BEGIN EATSPR( CALC.calc_text ) ; c_string:=concat(calc.calc_text,'#'); DOMATH; END; (* of doit *) {------------------------------------------------------------------------------} BEGIN { get the calculation string } done:=false; overflow:=false; undefined:=false; indx:=1; while (not done) and (indx <= screen_fields) do with maint_fields[indx] do begin if s_row=end_screen then done:=true else if s_typ in ['C','c'] then begin calc.calc_text:=s_def; (*$r-*) s_fld[0]:=chr(s_len); (*$r+*) doit; eatspl(outans); eatspr(outans); (*$r-*) (* remove trailing blanks *) while outans[length(outans)]='0' do delete(outans,length(outans),1); if outans[length(outans)]='.' then delete(outans,length(outans),1); result:=pos('.',outans); {Sep 22} if length(outans)>s_len then {truncate if necessary Sep 22} if (result>0) and (result-1<=s_len) then begin while length(outans)>s_len do delete(outans,length(outans),1); if outans[length(outans)]='.' then delete(outans,length(outans),1); end else begin outans:='0'; overflow:=true; end; fillchar(s_fld[1],s_len,' '); if s_jus in ['R','r'] then moveleft(outans[1],s_fld[s_len-length(outans)+1],length(outans)) else moveleft(outans[1],s_fld[1],length(outans)); (*$r+*) end; (* if s_type *) indx:=indx+1; end; if overflow then err(3); if undefined then err(2); END; {docalc} Segment Procedure ACCESS_DATA_BASE; { Procedure performs all the adds, examines and deletes for the data base } var BUFFER : Packed array[0..511] of 0..255; DEFAULT_REC : STRING255; Segment Procedure READ_WRITE(RW_COMMAND: Char; var REC_NO,REC_LEN, IO_RET_CODE:Integer); var IO_BLOCKS,START_POSITION,TWO_BLOCK,START_REC,BYTE_TWO_BLOCK, BLOCK_NO,REC_NUM,FIRST_MOV_LEN,CHAR_OFFSET: Integer; begin {READ_WRITE} {$I-} IO_RET_CODE:=-1; REC_NUM:=REC_NO-1; if REC_NUM<0 then REC_NUM:=0; TWO_BLOCK:=REC_NUM div (1023 div REC_LEN); (* 1024 correction Dec 5 1980 *) START_REC:=TWO_BLOCK*(1023 div REC_LEN); (* 1024 correction Dec 5 1980 *) BYTE_TWO_BLOCK:=(REC_NUM-START_REC)*REC_LEN; BLOCK_NO:=(TWO_BLOCK*2)+2; if BYTE_TWO_BLOCK>=512 (* = correction Dec 5 1980 *) then begin BLOCK_NO:=BLOCK_NO+1; CHAR_OFFSET:=BYTE_TWO_BLOCK-512; end else CHAR_OFFSET:=BYTE_TWO_BLOCK; if CHAR_OFFSET+REC_LEN>512 then begin if CURRENT_BLOCK<>BLOCK_NO then begin IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end; FIRST_MOV_LEN:=512-CHAR_OFFSET; if RW_COMMAND='W' then begin moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],FIRST_MOV_LEN); IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],FIRST_MOV_LEN); BLOCK_NO:=BLOCK_NO+1; IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); if RW_COMMAND='W' then begin moveleft(IO_REC.A[FIRST_MOV_LEN+1],BUFFER[0],REC_LEN-FIRST_MOV_LEN); IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end else moveleft(BUFFER[0],IO_REC.A[FIRST_MOV_LEN+1],REC_LEN-FIRST_MOV_LEN); end else begin if CURRENT_BLOCK<>BLOCK_NO then begin IO_BLOCKS:=blockread(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end; if RW_COMMAND='W' then begin moveleft(IO_REC.A[1],BUFFER[CHAR_OFFSET],REC_LEN); IO_BLOCKS:=blockwrite(DATA_FILE,BUFFER,1,BLOCK_NO); if IO_BLOCKS=0 then exit(READ_WRITE); end else moveleft(BUFFER[CHAR_OFFSET],IO_REC.A[1],REC_LEN); end; CURRENT_BLOCK:=BLOCK_NO; if IO_REC.A[3]=0 then exit(READ_WRITE); IO_RET_CODE:=0; IO_REC.A[0]:=REC_LEN; {$I+} end; {READ_WRITE} Procedure DISPLAY_RECNO; { Procedure displays the current record number on the screen. } begin {DISPLAY RECNO} int_to_str(DB_RECNO,STR_RECNO); if length(STR_RECNO)<5 then STR_RECNO:=concat(STR_RECNO,copy(UNDERLINE,1,5-length(STR_RECNO))); gotoxy(7,MAX_ROW-1); write(STR_RECNO); end; {DISPLAY RECNO} Procedure LOAD_SCREEN(LOAD_COMMAND :Char; var RECORD_STRING: STRING255); { Procedure load the screen array from a record obtained from the disk file. } var LOAD_INDEX,T_INDEX : Integer; begin {LOAD_SCREEN} COPY_INDEX := 4; LOAD_INDEX:=1; while LOAD_INDEX <= NUM_FIELDS do with MAINT_FIELDS[LOAD_INDEX] do begin COPY_LENGTH:=S_LEN; if (LOAD_COMMAND = 'A') or ((LOAD_COMMAND = 'D') and (S_ID = COPY(S_DEF,2,LENGTH(S_DEF)-2))) then S_FLD:=copy(RECORD_STRING,COPY_INDEX,COPY_LENGTH) else begin IF (S_DEF = '') OR (S_DEF = COPY(UNDERLINE,1,1)) THEN BEGIN S_FLD := ' '; FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX); END ELSE { s_def<>'' Mar 12 } if s_def[1]<>'[' then begin s_fld:=' '; FOR T_INDEX := 1 TO S_LEN-1 DO INSERT(' ',S_FLD,T_INDEX) end else begin { s_def[1]='[' } t_index:=find(copy(s_def,2,length(s_def)-2),maint_fields); if t_index=0 then s_fld:=s_def else s_fld:=maint_fields[t_index].s_fld; end; end; COPY_INDEX:=COPY_INDEX + COPY_LENGTH; LOAD_INDEX:=LOAD_INDEX + 1; end; {with/while} end; {LOAD SCREEN} Procedure BUILD_RECORD; { Procedure builds records to be placed on the disk. } begin {BUILD RECORD} IO_REC.A[0]:=3; for INDEX:=1 to NUM_FIELDS do { Jan 5 To correct value range error } IO_REC.B:=concat(IO_REC.B,MAINT_FIELDS[INDEX].S_FLD); (*get rid of leftover low-intensity underscores *) for index:=1 to length(io_rec.b) do if io_rec.a[index]=223 then io_rec.a[index]:=32; (* blank *) IO_REC.A[0]:=REC_LEN; IO_REC.A[1]:=16; (* dle *) IO_REC.A[2]:=32; (* space *) IO_REC.A[3]:=42; (* * *) IO_REC.A[REC_LEN-1]:=42; IO_REC.A[REC_LEN]:=13; (* carriage return *) end; {BUILD RECORD} Procedure ADD; { Procdure finds the first next blank record and allows the operator to add a new record. } var BLANK_INDEX:Integer; begin ERASE_EOL(0,MAX_ROW); write('Add Mode, to Add, to quit'); for BLANK_INDEX := 1 to 255 do insert(' ',DEFAULT_REC,BLANK_INDEX); repeat repeat (* file max=32767 records Oct 30 *) if db_recno<0 then begin ERASE_EOL(34,MAX_ROW); MESSAGE(MAX_ROW,40,'ERROR: Unable to find blank record',True); db_recno:=max_int; exit(ADD); end; READ_WRITE('R',DB_RECNO,REC_LEN,RESULTS); if RESULTS <> 0 then begin ERASE_EOL(34,MAX_ROW); MESSAGE(MAX_ROW,40,'ERROR: Unable to find blank record',True); exit(ADD); end; DISPLAY_RECNO; DB_RECNO := DB_RECNO + 1; until (IO_REC.A[3] = 0) or (IO_REC.A[3] = 126); DB_RECNO := DB_RECNO -1; LOAD_SCREEN('D',DEFAULT_REC); DISPLAY_SCREEN(MAINT_FIELDS,0,0,0,23); SCREEN(MAINT_FIELDS,true,0,0,0,0,23,MAX_ROW,40,EXIT_KEY); if EXIT_KEY=ESC_KEY then begin ERASE_EOL(0,MAX_ROW); exit(ADD); end; if calculations then begin docalc; { Mar 9 } display_screen(maint_fields,0,0,0,23); end; BUILD_RECORD; READ_WRITE('W',DB_RECNO,REC_LEN,RESULTS); DEFAULT_REC:=IO_REC.B; until False; end; (*xL-*) (* Removed Jan 5 Procedure INDEX_SET; { Procedure sets the index on a specific key in the data base. } begin MESSAGE(MAX_ROW,40,'ERROR: Inoperative selection',True); end; *) Procedure RECNO; { Procedure allows the operative to set the physical record number in the data base. } begin EXAMINE_FLAG:=False; FIELD_ROW := 22; FIELD_COL := 7; int_to_str(DB_RECNO,FIELD_FLD); FIELD(FIELD_ROW,FIELD_COL,ERROW,ERRCOL,FIELD_LEN,FIELD_MIN,EXXIT, FIELD_JUS,FIELD_NA,FIELD_FLD,FIELD_SKIP); if not intvalue(field_fld,db_recno) then begin { Mar 11 } message(max_row,40,'ERROR: Incorrect record number',true); exit(recno); end; if DB_RECNO<1 then DB_RECNO:=1; DISPLAY_RECNO; end; Procedure STORE; { Procedure allows operator to store records in the data base. } begin BUILD_RECORD; READ_WRITE('W',DB_RECNO,REC_LEN,RESULTS); if RESULTS = 0 then EXAMINE_FLAG := True else MESSAGE(MAX_ROW,40,'ERROR: Unable to add record',True); end; Procedure EXAMINE; { Procedure allows the operator to examine records in the data base. } begin if EXAMINE_FLAG then if DB_RECNO 0 then begin MESSAGE(MAX_ROW,40,'ERROR: Unable to read record',True); EXAMINE_FLAG:=FALSE; end else begin EXAMINE_FLAG:=True; LOAD_SCREEN('A',IO_REC.B); DISPLAY_SCREEN(MAINT_FIELDS,0,0,0,23); end; end; Procedure DELETE(DISPLAY: boolean); { Procedure allows the operator to delete records from the data base. } begin fillchar(IO_REC.A[0],REC_LEN,' '); IO_REC.A[0] := REC_LEN; IO_REC.A[1] := 16; IO_REC.A[2] := 32; IO_REC.A[3] := 126; IO_REC.A[REC_LEN-1] := 42; IO_REC.A[REC_LEN] := 13; READ_WRITE('W',DB_RECNO,REC_LEN,RESULTS); if RESULTS <> 0 then MESSAGE(MAX_ROW,40,'ERROR: Unable to delete record',True) else if DISPLAY then begin LOAD_SCREEN('A',IO_REC.B); DISPLAY_SCREEN(MAINT_FIELDS,0,0,0,23); end; end; Procedure COMPRESS; { Compresses all records to the front of the file } (*$g+*) label 1; var NEXT,BLANK: integer; DONE: boolean; RESULT: integer; begin { compress } message(max_row,40,'Mash in Progress',false); blank:=1; done:=false; repeat { find blank record } read_write('R',blank,rec_len,result); if result<>0 then goto 1; if io_rec.a[3]=ord('~') then done:=true else if blank=max_int then goto 1 else blank:=blank+1; until done; next:=blank+1; done:=false; while not done do begin repeat { find record } read_write('R',next,rec_len,result); if result<>0 then goto 1; if io_rec.a[3]=ord('*') then done:=true else if next=max_int then goto 1 else next:=next+1; until done; read_write('W',blank,rec_len,result); if result<>0 then begin message(max_row,40,'Data file has uncorrectible error!',true); exit(compress); end; done:=false; blank:=blank+1; db_recno:=next; delete(false); if next=max_int then done:=true else next:=next+1; end; (* while *) 1: db_recno:=1; { display record 1 } examine_flag:=false; examine; message(max_row,40,'Mash Complete ',false); (*$g-*) end; { compress } begin {ACCESS_DATA_BASE} ERASE_EOS(0,0); (*i-*) reset(DATA_FILE,DATA_NAME); if IO_RESULT <> 0 then begin MESSAGE(MAX_ROW,40,'ERROR: Unable to re-open data file',True); exit(MAINTAIN); end; (*i+*) READ_WRITE('R',DB_RECNO,REC_LEN,RESULTS); if RESULTS <> 0 then MESSAGE(MAX_ROW,40,'ERROR: Unable to read first record',True) else LOAD_SCREEN('A',IO_REC.B); DISPLAY_PROMPTS(MAINT_PROMPTS,0,0,0,23); DISPLAY_SCREEN(MAINT_FIELDS,0,0,0,23); gotoxy(0,MAX_ROW-1); writeln(PROMPTLINE); DISPLAY_RECNO; repeat gotoxy(0,MAX_ROW); write(OPTLINE); read(Keyboard,CH); if CH=ESC_KEY then exit(MAINTAIN) else ERASE_EOL(LENGTH(OPTLINE),MAX_ROW); if CH in['a'..'z'] then CH:=chr(ord(CH)+ord('A')-ord('a')); if not (CH IN['S','M','R','A','E','C','D','Q']) then MESSAGE(MAX_ROW,40,'ERROR: Invalid Selection',True) else case CH of 'M' : COMPRESS; 'R' : RECNO; 'S' : STORE; 'A' : ADD; 'E' : EXAMINE; 'C' : BEGIN { Mar 9 } SCREEN(MAINT_FIELDS,true,0,0,0,0,23,MAX_ROW,40,EXIT_KEY); if calculations then begin { Mar 11 } docalc; display_screen(maint_fields,0,0,0,23); end; END; 'D' : DELETE(true); 'Q' : exit(ACCESS_DATA_BASE); end; until False; end; {ACCESS_DATA_BASE} Procedure FORMAT_RECNO(var RECNO_FIELD :STRING5); var RECNO_INDEX: Integer; begin {FORMAT RECNO} for RECNO_INDEX:=1 to length(RECNO_FIELD) do if RECNO_FIELD[RECNO_INDEX] in ['+','-','.'] then RECNO_FIELD[RECNO_INDEX]:=' '; RECNO_INDEX:=pos(' ',RECNO_FIELD); if RECNO_INDEX=0 then RECNO_INDEX:=length(RECNO_FIELD) else RECNO_INDEX:=RECNO_INDEX-1; if RECNO_INDEX=0 then RECNO_FIELD:='1' else RECNO_FIELD:=copy(RECNO_FIELD,1,RECNO_INDEX); end; {FORMAT RECNO} Procedure BELL; begin {BELL} write(ALARM_BELL); end; {BELL} Procedure RECORD_LENGTH{var S_ARRAY :SCREEN_ARR}; { Function to find the length of the record defined by the data base definition.} { For the first release this will also check to see if there are any fields defined as calculated. These will be marked as in error. } var DONE: boolean; { Jan 5 To correct end_screen problem } begin {RECORD LENGTH} REC_LEN:=0; DONE:=false; { Jan 5 } INDEX:=1; CALCULATIONS:=false; while not DONE do if MAINT_FIELDS[INDEX].S_ROW=END_SCREEN then DONE:=true else begin REC_LEN:=REC_LEN+MAINT_FIELDS[INDEX].S_LEN; if MAINT_FIELDS[INDEX].S_TYP IN ['C','c'] then CALCULATIONS:=true; DONE := INDEX = SCREEN_FIELDS; INDEX:=INDEX+1; end; REC_LEN:=REC_LEN+5; NUM_FIELDS:=INDEX-1; { Jan 5/Mar 12 } end; {RECORD LENGTH} Procedure MESSAGE{M_ROW,M_COL :Integer; MSG :String; DING: Boolean}; { Procedure displays messages at the message row and column. } begin {MESSAGE} gotoxy(M_COL,M_ROW); write(MSG); if DING then write(ALARM_BELL); end; {MESSAGE} Procedure EAT_SPACES(var TEMP :String; LEFT_EAT,RIGHT_EAT :Boolean); { Procedure to remove the spaces from either or both sides of a string. } begin {EAT SPACES} if LEFT_EAT then EATSPL(TEMP); if RIGHT_EAT then EATSPR(TEMP); end; {EAT SPACES} begin {MAINTAIN} INITIALIZE; GET_DATA_BASE; ACCESS_DATA_BASE; close(DATA_FILE,lock); end. {MAINTAIN} ======================================================================================== DOCUMENT :usus Folder:VOL25:ud.sort.text ======================================================================================== {$L PRINTER:} PROGRAM UDE_SORT; { Once a data base has been defined, this set of procedures allows the operator to sort data base records. } uses {$U SH.SCREEN.UNIT} SCREEN40; type STRING25 = String[25]; var ACCESS_FLAG: Boolean; ERROR,RECSREAD,RECSWRIT: Integer; CH: Char; Segment Procedure ACCESS_DATA_BASE(var SORT_FLAG: Boolean); { Procedure initilizes everything to begin maintaining the data base. } var GET_FIELDS,SORT_FIELDS, MAINT_FIELDS : SCREEN_ARR; { Array to hold data fields } GET_PROMPTS,SORT_PROMPTS, MAINT_PROMPTS : PROMPT_ARR; { Array to hold screen prompts } GET_RESULTS,RESULTS,ERROR_ID: Integer; EXIT_KEY,CH: Char; DISPLAY_FLAG: Boolean; VOLUME, { Data base volume } SORT_VOL : STRING[7]; NAME, { Data base Name } SORT_NAME : STRING[10]; { Sort format name } DB_NAME : STRING[18]; { Volume + Data Base Name } PROMPT1,PROMPT2,VERSION, DATA_NAME, { Data file name } DEFI_NAME, { Data Base Definition file name } SORT_VOL_NAME : STRING[23]; { Sort format file name } DATA_FILE : File; Procedure MESSAGE(M_ROW,M_COL: Integer; MSG: String; DING: Boolean); forward; Procedure INITIALIZE; var I: Integer; begin {INITIALIZE} for I:=1 to SCREEN_FIELDS do with GET_FIELDS[I] do begin S_ID :=''; S_ROW:=END_SCREEN; S_COL:=15; S_LEN:=7; S_MIN:=0; S_TYP:='V'; S_JUS:='L'; S_NA :='S'; S_SKIP:=False;S_DEF:=''; S_FLD:=''; end; {with/for} for I:=1 to PROMPT_FIELDS do with GET_PROMPTS[I] do begin P_ROW:=END_SCREEN; P_COL:=0; P_FLD:=''; end; {with/for} with GET_FIELDS[1] do begin S_ID :='VOL'; S_ROW:=5; end; with GET_FIELDS[2] do begin S_ID :='NAME'; S_ROW:=7; S_LEN:=10; end; with GET_PROMPTS[1] do begin P_ROW:=5; P_FLD:='Volume :' end; with GET_PROMPTS[2] do begin P_ROW:=7; P_FLD:='Name :' end; CLEAR_HOME; PROMPT1:='Get format,Save format'; PROMPT2:='Change,eXecute,Quit ?'; VERSION:='Version IV.0'; for I:=1 to 22 do if not(PROMPT1[I] in['A'..'Z']) then PROMPT1[I]:=chr(ord(PROMPT1[I])+128); for I:=1 to 21 do if not(PROMPT2[I] in['A'..'Z']) then PROMPT2[I]:=chr(ord(PROMPT2[I])+128); end; {INITIALIZE} Procedure GET_DATA_BASE; { Procedure gets the Data Base Definition from the disk. } begin {GET_DATA_BASE} HOME; writeln(' ':25,'SORT A DATA BASE'); writeln(' ':25,'================='); writeln(' ':25,VERSION); DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23); gotoxy(0,9); write('Type : SCRN and TEXT'); DISPLAY_SCREEN(GET_FIELDS,0,0,0,23); MESSAGE(MAX_ROW,0,' to execute, to abort',False); repeat SCREEN(GET_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXIT_KEY); if EXIT_KEY = ESC_KEY then exit(UDE_SORT); VOLUME := GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD; EATSPR(VOLUME); NAME := GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD; EATSPR(NAME); DB_NAME := concat(VOLUME,':',NAME); DEFI_NAME := concat(DB_NAME,'.SCRN'); DATA_NAME := concat(DB_NAME,'.TEXT'); GET_FILE(DEFI_NAME,MAINT_FIELDS,MAINT_PROMPTS,RESULTS); if RESULTS = 0 then begin {$I-} reset(DATA_FILE,DATA_NAME); {$I+} if IORESULT <> 0 then MESSAGE(MAX_ROW,40,'ERROR: No data file found',True) else begin close(DATA_FILE,lock); exit(GET_DATA_BASE); end; end else MESSAGE(MAX_ROW,40,'ERROR: Unknown Data Base',True) until False; end; {GET_DATA_BASE} Procedure GET_SAVE_FORMAT(GS_COMMAND: Char); { Procedure loads or saves printing format specification on disk. } begin {GET SAVE FORMAT} CLEAR_HOME; if GS_COMMAND = 'G' then begin HOME; writeln(' ':25,'GET SORTING FORMAT'); writeln(' ':25,'=================='); end else begin HOME; writeln(' ':25,'SAVE SORTING FORMAT'); writeln(' ':25,'==================='); end; DISPLAY_PROMPTS(GET_PROMPTS,0,0,0,23); gotoxy(0,9); write('Type : SORT'); MESSAGE(MAX_ROW,0,' to execute, to abort',False); DISPLAY_SCREEN(GET_FIELDS,0,0,0,23); repeat SCREEN(GET_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXIT_KEY); ERASE_EOL(40,MAX_ROW); if EXIT_KEY = ENTER_KEY then begin SORT_VOL := GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD; EATSPR(SORT_VOL); SORT_NAME := GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD; EATSPR(SORT_NAME); SORT_VOL_NAME := concat(SORT_VOL,':',SORT_NAME,'.SORT'); if GS_COMMAND = 'G' then begin GET_FILE(SORT_VOL_NAME,SORT_FIELDS,SORT_PROMPTS,GET_RESULTS); if GET_RESULTS <> 0 then MESSAGE(MAX_ROW,40,'ERROR: Unknown sorting format',True) else exit(GET_SAVE_FORMAT); end else begin SAVE_FILE(SORT_VOL_NAME,SORT_FIELDS,SORT_PROMPTS,GET_RESULTS); if GET_RESULTS <> 0 then MESSAGE(MAX_ROW,40, 'ERROR: Unable to save sorting format',True) else exit(GET_SAVE_FORMAT); end; end else exit(GET_SAVE_FORMAT); until False; end; {GET SAVE FORMAT} Procedure MESSAGE;(* M_ROW,M_COL: Integer; MSG: String; DING: Boolean *) { Procedure displays messages at the message row and column. } begin gotoxy(M_COL,M_ROW); write(MSG); if DING then write(ALARM_BELL); end; Procedure SORTPARM(var PARM_RETURN: Integer); const NUMBER_KEYS = 10; { Maximnu number of keys allowed on screen } type PARM_RECORD = record FIELD_NUMBER : Integer; AD_VALUE : Char; end; var PARM_INDEX,IDFIELD_NUMBER,MAINT_INDEX,ARRAY_INDEX : Integer; IDVALUE,IDNAME : String[8]; PARM_ARRAY : Array[1..NUMBER_KEYS] of PARM_RECORD; PARM_FILE : Text; WORK_VOL, OUTPUT_VOLUME : STRING[7]; OUTPUT_NAME : STRING[10]; begin {SORTPARM} PARM_RETURN := 0; PARM_INDEX := 0; gotoxy(0,10); for ARRAY_INDEX := 1 to NUMBER_KEYS do begin str(ARRAY_INDEX,IDNAME); IDNAME := concat('ID',IDNAME); IDFIELD_NUMBER := FIND(IDNAME,SORT_FIELDS); IDVALUE := SORT_FIELDS[IDFIELD_NUMBER].S_FLD; EATSPL(IDVALUE); EATSPR(IDVALUE); if length(IDVALUE) > 0 then begin MAINT_INDEX := FIND(IDVALUE,MAINT_FIELDS); if (MAINT_INDEX = 0) then begin MESSAGE(MAX_ROW,40,'ERROR: Invalid field ID',True); PARM_RETURN := IDFIELD_NUMBER; exit(SORT_PARM); end else begin str(ARRAY_INDEX,IDNAME); IDNAME := concat('AD',IDNAME); IDFIELD_NUMBER := FIND(IDNAME,SORT_FIELDS); IDVALUE := SORT_FIELDS[IDFIELD_NUMBER].S_FLD; EATSPL(IDVALUE); EATSPR(IDVALUE); PARM_INDEX := PARM_INDEX + 1; with PARM_ARRAY[PARM_INDEX] do begin FIELD_NUMBER := MAINT_INDEX + 1; if (IDVALUE = 'D') or (IDVALUE = 'd') then AD_VALUE := 'D' else AD_VALUE := 'A'; end; end; end; end; if PARM_INDEX = 0 then begin MESSAGE(MAX_ROW,40,'ERROR: No valid field ids found',True); PARM_RETURN := 1; exit(SORTPARM); end; (*$i-*) rewrite(PARMFILE,'TEMPSORT.TEXT'); if IORESULT <> 0 then begin MESSAGE(MAX_ROW,40,'ERROR: No room for param file on disk',True); PARM_RETURN := 1; exit(SORTPARM); end; (*$i+*) writeln(PARMFILE,'S'); writeln(PARMFILE,DATA_NAME); writeln(PARMFILE,'T'); OUTPUT_VOLUME := SORT_FIELDS[FIND('VOL',SORT_FIELDS)].S_FLD; EATSPL(OUTPUT_VOLUME); EATSPR(OUTPUT_VOLUME); if (OUTPUT_VOLUME = 'PRINTER') or (OUTPUT_VOLUME = 'printer') then writeln(PARMFILE,'PRINTER:') else begin OUTPUT_NAME := SORT_FIELDS[FIND('NAME',SORT_FIELDS)].S_FLD; EATSPL(OUTPUT_NAME); EATSPR(OUTPUT_NAME); if length(OUTPUT_NAME) < 1 then writeln(PARMFILE,DATA_NAME) else writeln(PARMFILE,concat(OUTPUT_VOLUME,':',OUTPUT_NAME,'.TEXT')); end; writeln(PARMFILE,'T'); WORK_VOL := SORT_FIELDS[FIND('WORKVOL',SORT_FIELDS)].S_FLD; EATSPL(WORK_VOL); EATSPR(WORK_VOL); writeln(PARMFILE,concat(WORK_VOL,':')); writeln(PARMFILE,'T'); writeln(PARMFILE,'Y'); writeln(PARMFILE,'F'); writeln(PARMFILE,'1'); ARRAY_INDEX := 1; while ARRAY_INDEX <= SCREEN_FIELDS do begin if MAINT_FIELDS[ARRAY_INDEX].S_ROW <> END_SCREEN then writeln(PARMFILE,MAINT_FIELDS[ARRAY_INDEX].S_LEN) else ARRAY_INDEX := SCREEN_FIELDS; ARRAY_INDEX := ARRAY_INDEX + 1; end; writeln(PARMFILE,'1'); writeln(PARMFILE,'0'); writeln(PARMFILE,'1'); writeln(PARMFILE,'A'); for ARRAY_INDEX := 1 to PARM_INDEX do begin writeln(PARMFILE,PARM_ARRAY[ARRAY_INDEX].FIELD_NUMBER); writeln(PARMFILE,PARM_ARRAY[ARRAY_INDEX].AD_VALUE); end; writeln(PARMFILE,'0'); writeln(PARMFILE,'N'); close(PARMFILE,lock); end; begin {ACCESS_DATA_BASE} INITIALIZE; GET_DATA_BASE; GET_FILE('UD/SORT.SCRN',SORT_FIELDS,SORT_PROMPTS,RESULTS); if RESULTS <> 0 then begin MESSAGE(MAX_ROW,40,'ERROR: Unable to load "UD/SORT.SCRN"',True); exit(UDE_SORT); end; GET_FIELDS[FIND('VOL',GET_FIELDS)].S_FLD := ' '; GET_FIELDS[FIND('NAME',GET_FIELDS)].S_FLD := ' '; DISPLAY_FLAG := True; repeat if DISPLAY_FLAG then begin CLEAR_HOME; DISPLAY_PROMPTS(SORT_PROMPTS,0,0,0,23); DISPLAY_SCREEN(SORT_FIELDS,0,0,0,23); gotoxy(0,MAX_ROW-1); writeln(PROMPT1); write(PROMPT2); DISPLAY_FLAG := False; end; gotoxy(24,MAX_ROW); read(Keyboard,CH); if CH = ESC_KEY then exit(UDE_SORT); SORT_FLAG := False; if CH in['a'..'z'] then CH:=chr(ord(CH)+ord('A')-ord('a')); ERASE_EOL(25,MAX_ROW); if not(CH in['C','G','X','S','Q']) then MESSAGE(MAX_ROW,40,'ERROR: Invalid Selection',True) else case CH of 'G': begin GET_SAVE_FORMAT('G'); DISPLAY_FLAG := True; end; 'S': begin GET_SAVE_FORMAT('S'); DISPLAY_FLAG := True; end; 'X': begin SORTPARM(ERROR_ID); if ERROR_ID <> 0 then SCREEN(SORT_FIELDS,true,ERROR_ID,0,0,0,MAX_ROW, MAX_ROW,40,EXIT_KEY) else begin SORT_FLAG :=True; exit(ACCESS_DATA_BASE); end; end; 'C': SCREEN(SORT_FIELDS,true,0,0,0,0,MAX_ROW,MAX_ROW,40,EXIT_KEY); 'Q': exit(UDE_SORT); end; until False; end; {ACCESS_DATA_BASE} segment procedure psort(paramname:strING25; var error,recsread, recswritten:integer); const maxkeys = 11; {number of keys} maxkeylen = 40; {number of chars. in a key} maxfiles = 10; {number of intermediate workfiles} mrl = 255; {record (line) length} maxfields = 42; {number of fields in fixed length record} { plus 2 to account for the *'s at front and back} minmem = 9000; { leave room for stack } type stringrec = string[mrl]; key = string [maxkeylen]; nodeptr = ^node; node = record item : stringrec; majkey : key; lptr, rptr : nodeptr end; comparison = (lessthan, equal, greaterthan); keydirn = (ascending, descending); field = record keystart, keylen : 1..mrl end; keyvals = record fieldnum : 1..maxfields; keydirection : keydirn end; str = string[25]; var filename, ifilename, ofilename : str; infile, outfile : text; inffile, outffile : file of stringrec; filesused : integer; toomanyfiles : boolean; fielddata : array[1..maxfields] of field; keydata : array [1..maxkeys] of keyvals; intread : integer; numfields, numkeys : integer; memorycontained : boolean; intfilevol : string [10]; keytype : (fixed, variable); keydelim : char; i : integer; temp_outfile : integer; mergefile : integer; inform : boolean; mergeonly : boolean; one_mo_time : boolean; end_of_infile : boolean; textin, textint, textout : boolean; mergeinput : array[1..maxfiles] of str; bell : char; ioerr: boolean; {-----------DEFINED FOR BLOCK IO BY CLAY LAIRD 3 JUL 80------} BLOCKS_WROTE,BLOCK_NUMBER,ARRAY_INDEX,BLOCK_RESULTS: INTEGER; OUTPUT_FILE : FILE; BLOCK_ARRAY : PACKED ARRAY [0..1023] OF CHAR; PROCEDURE BL_OPEN(VAR BLOCK_FILE:STR; (* File name *) VAR BLOCK_RETURN:INTEGER); (* Return code *) FORWARD; PROCEDURE BL_WRITE(VAR BLOCK_RECORD:STRINGREC; (* String to write *) VAR BLOCK_RETURN:INTEGER); (* Return code *) FORWARD; PROCEDURE BL_CLOSE(VAR BLOCK_RETURN:INTEGER); (* Return code *) FORWARD; {-----------------------------------------------------} function relation(item1, item2 : stringrec; stkey : integer) : comparison;forward; procedure getfield(fieldnum : integer; source : stringrec; var thefield : key); forward; procedure checkio(str1, str2 : str; var ioerr : boolean); forward; procedure openoutputfile; forward; {----------------------------------------------------} segment procedure getparm(from : str); { Gets the parameters from the parameter file. } var parmfile : text; inint : integer; inchar : char; instring : str; start : integer; inkey : key; procedure setupmergenames; begin mergeinput[ 1] := concat(intfilevol, 'SRT1'); mergeinput[ 2] := concat(intfilevol, 'SRT2'); mergeinput[ 3] := concat(intfilevol, 'SRT3'); mergeinput[ 4] := concat(intfilevol, 'SRT4'); mergeinput[ 5] := concat(intfilevol, 'SRT5'); mergeinput[ 6] := concat(intfilevol, 'SRT6'); mergeinput[ 7] := concat(intfilevol, 'SRT7'); mergeinput[ 8] := concat(intfilevol, 'SRT8'); mergeinput[ 9] := concat(intfilevol, 'SRT9'); mergeinput[10] := concat(intfilevol, 'SRT10'); { mergeinput[11] := concat(intfilevol, 'SRT11'); mergeinput[12] := concat(intfilevol, 'SRT12'); mergeinput[13] := concat(intfilevol, 'SRT13'); mergeinput[14] := concat(intfilevol, 'SRT14'); mergeinput[15] := concat(intfilevol, 'SRT15'); mergeinput[16] := concat(intfilevol, 'SRT16'); mergeinput[17] := concat(intfilevol, 'SRT17'); mergeinput[18] := concat(intfilevol, 'SRT18'); mergeinput[19] := concat(intfilevol, 'SRT19'); mergeinput[20] := concat(intfilevol, 'SRT20'); } end; begin (*$I-*) reset(parmfile,from); checkio('abort',from,ioerr); (*$I+*) ERASE_EOL(40,22); writeln('STATUS: Reading parameter file'); readln(parmfile,instring); inchar := instring[1]; mergeonly := FALSE; readln(parmfile, ifilename); readln(parmfile,instring); inchar := instring[1]; textin := (inchar='T') or (inchar='t'); readln(parmfile, ofilename); readln(parmfile,instring); inchar := instring[1]; textout := (inchar='T') or (inchar='t'); readln(parmfile, intfilevol); readln(parmfile, instring); inchar := instring[1]; textint := (inchar='T') or (inchar='t'); readln(parmfile, instring);inchar := instring[1]; inform := (inchar = 'Y') or (inchar = 'y'); readln(parmfile, instring);inchar:=instring[1]; keytype := fixed; numfields := 1; start := 1; repeat readln(parmfile, inint); if inint > 0 then begin with fielddata[numfields] do begin keylen := inint; keystart := start end; {with} start := start + inint; numfields := numfields + 1 end; until inint <= 0; numfields := numfields - 1; numkeys := 1; repeat readln(parmfile, inint); if inint > 0 then begin with keydata[numkeys] do begin fieldnum := inint; readln(parmfile, instring); inchar := instring[1]; if inchar in ['A','a'] then keydirection := ascending else keydirection := descending; end; {with} numkeys := numkeys + 1 end until inint <= 0; numkeys := numkeys - 1; readln(parmfile, instring); inchar := instring[1]; close(parmfile,purge); (* to dispose of temp file, Oct 29 *) SETUPMERGENAMES; end; { getparmp } {------------------------------------------------------} segment procedure distribute; var f1 : text; inrec : stringrec; inrecmajkey : key; someontree : boolean; root : nodeptr; heap : ^integer; procedure writelnx(item : stringrec); begin writeln(f1, item) end; { writelnx } procedure rewritex(n : integer); begin (*$i-*) rewrite(f1, mergeinput[n]) (*$i+*) end; { rewritex } procedure closex; begin close(f1, lock) end; { closex } procedure putontree(var ptr : nodeptr); var p1 : nodeptr; function compare : comparison; begin if inrecmajkey < p1^.majkey then begin if keydata[1].keydirection = ascending then compare := lessthan else compare := greaterthan end else begin if keydata[1].keydirection = ascending then compare := greaterthan else compare := lessthan end end; { compare } begin p1 := ptr; if p1 = nil then begin new(p1); with p1^ do begin lptr := nil; rptr := nil; item := inrec; majkey := inrecmajkey end; ptr := p1; someontree := true end else begin if inrecmajkey = p1^.majkey then begin if relation(inrec, p1^.item,2) = lessthan then putontree(p1^.lptr) else putontree(p1^.rptr) end else begin { use major key } if compare = lessthan then putontree(p1^.lptr) else putontree(p1^.rptr) end end end; { putontree } procedure outputree(ptr : nodeptr); begin if ptr <> nil then with ptr^ do begin outputree(lptr); if memorycontained then begin ITEM := CONCAT(' ',ITEM,' '); ITEM[1] := CHR(16); ITEM[2] := CHR(32); ITEM[LENGTH(ITEM)] := CHR(13); BL_WRITE(ITEM,BLOCK_RESULTS); recswritten := recswritten + 1; end else writelnx(item); outputree(rptr) end end; { outputree } function eofinfile : boolean; begin eofinfile := eof(infile) end; { eofinfile } begin { distribute } ERASE_EOL(40,22); write('STATUS: Distributing ...'); ERASE_EOL(40,23); toomanyfiles := false; someontree := false; filesused := 0; while (not eofinfile) and (filesused < maxfiles-2) do begin root := nil; mark(heap); while (varavail('ude_sort,psort,distribute') > minmem) and (not eofinfile) do begin readln(infile, inrec); if inrec <> '' then { use only non-null strs} begin recsread := recsread + 1; getfield(keydata[1].fieldnum,inrec,inrecmajkey); putontree(root) end end; if someontree then begin if (not eofinfile) or (filesused > 0) or (one_mo_time) then begin filesused := filesused + 1; ERASE_EOL(40,23); write(' Writing workfile # ',filesused, '...'); rewritex(filesused); if IORESULT <> 0 then CHECKIO('abort','',IOERR); outputree(root); { write to int file} closex; { close and lock that workfile } release(heap) end else begin { memory contained } memorycontained := true; openoutputfile; ERASE_EOL(40,22); GOTOXY(40,23); write('STATUS: Writing output file... '); outputree(root); release(heap) end end else begin release(heap); memorycontained := true; {prevent the merge} openoutputfile {for the later close (of empty file)} end end; end_of_infile := eofinfile; end; { distribute } {---------------------------------------------------- } segment procedure merge; type tabrec = record hasdata : boolean; inrec : stringrec end; var {--------- SHIFT COMMENT DELIMITER TO CHANGE --------} {--------- NUMBER OF WORK/MERGE-INPUT FILES. --------} {............... Text Files .........................} f1,f2,f3,f4,f5,f6,f7,f8,f9,f10 { ,f11,f12,f13,f14,f15,f16,f17,f18,f19,f20 } :text; {----------------------------------------------------} table : array [1..maxfiles] of tabrec; current : 0..maxfiles; { points to current smallest record } i : 1..maxfiles; badio : boolean; {----------------------------------------------------} { The following functions/procedures are because the declaration f : array[1..maxfiles] of text; is not permitted in UCSD Pascal (and some others). } procedure readlnx(n : integer; var item : stringrec); begin case n of 1: readln( f1, item); 2: readln( f2, item); 3: readln( f3, item); 4: readln( f4, item); 5: readln( f5, item); 6: readln( f6, item); 7: readln( f7, item); 8: readln( f8, item); 9: readln( f9, item); 10: readln(f10, item); { 11: readln(f11, item); 12: readln(f12, item); 13: readln(f13, item); 14: readln(f14, item); 15: readln(f15, item); 16: readln(f16, item); 17: readln(f17, item); 18: readln(f18, item); 19: readln(f19, item); 20: readln(f20, item); } end; end; { readlnx } function eofx(n : integer) : boolean; begin {$I-} case n of 1 : eofx := eof( f1); 2 : eofx := eof( f2); 3 : eofx := eof( f3); 4 : eofx := eof( f4); 5 : eofx := eof( f5); 6 : eofx := eof( f6); 7 : eofx := eof( f7); 8 : eofx := eof( f8); 9 : eofx := eof( f9); 10: eofx := eof(f10); { 11: eofx := eof(f11); 12: eofx := eof(f12); 13: eofx := eof(f13); 14: eofx := eof(f14); 15: eofx := eof(f15); 16: eofx := eof(f16); 17: eofx := eof(f17); 18: eofx := eof(f18); 19: eofx := eof(f19); 20: eofx := eof(f20); } end; {$I+} end; { eofx } procedure resetx(n : integer); begin (*$I-*) case n of 1: reset( f1, mergeinput[1]); 2: reset( f2, mergeinput[2]); 3: reset( f3, mergeinput[3]); 4: reset( f4, mergeinput[4]); 5: reset( f5, mergeinput[5]); 6: reset( f6, mergeinput[6]); 7: reset( f7, mergeinput[7]); 8: reset( f8, mergeinput[8]); 9: reset( f9, mergeinput[9]); 10: reset(f10, mergeinput[10]); { 11: reset(f11, mergeinput[11]); 12: reset(f12, mergeinput[12]); 13: reset(f13, mergeinput[13]); 14: reset(f14, mergeinput[14]); 15: reset(f15, mergeinput[15]); 16: reset(f16, mergeinput[16]); 17: reset(f17, mergeinput[17]); 18: reset(f18, mergeinput[18]); 19: reset(f19, mergeinput[19]); 20: reset(f20, mergeinput[20]); } end; (*$I+*) end; { resetx } procedure closex(n : integer; l_or_p : char); begin if l_or_p = 'l' then case n of 1 : close( f1,lock); 2 : close( f2,lock); 3 : close( f3,lock); 4 : close( f4,lock); 5 : close( f5,lock); 6 : close( f6,lock); 7 : close( f7,lock); 8 : close( f8,lock); 9 : close( f9,lock); 10 : close(f10,lock); { 11 : close(f11,lock); 12 : close(f12,lock); 13 : close(f13,lock); 14 : close(f14,lock); 15 : close(f15,lock); 16 : close(f16,lock); 17 : close(f17,lock); 18 : close(f18,lock); 19 : close(f19,lock); 20 : close(f20,lock) } end else case n of 1 : close( f1,purge); 2 : close( f2,purge); 3 : close( f3,purge); 4 : close( f4,purge); 5 : close( f5,purge); 6 : close( f6,purge); 7 : close( f7,purge); 8 : close( f8,purge); 9 : close( f9,purge); 10 : close(f10,purge); { 11 : close(f11,purge); 12 : close(f12,purge); 13 : close(f13,purge); 14 : close(f14,purge); 15 : close(f15,purge); 16 : close(f16,purge); 17 : close(f17,purge); 18 : close(f18,purge); 19 : close(f19,purge); 20 : close(f20,purge) } end; { closepx } end; procedure writelnx(n : integer; var item : stringrec); begin case n of 1: writeln( f1, item); 2: writeln( f2, item); 3: writeln( f3, item); 4: writeln( f4, item); 5: writeln( f5, item); 6: writeln( f6, item); 7: writeln( f7, item); 8: writeln( f8, item); 9: writeln( f9, item); 10: writeln(f10, item); { 11: writeln(f11, item); 12: writeln(f12, item); 13: writeln(f13, item); 14: writeln(f14, item); 15: writeln(f15, item); 16: writeln(f16, item); 17: writeln(f17, item); 18: writeln(f18, item); 19: writeln(f19, item); 20: writeln(f20, item); } end; end; { writelnx } procedure rewritex(n : integer); begin (*$i-*) case n of 1: rewrite( f1, mergeinput[1]); 2: rewrite( f2, mergeinput[2]); 3: rewrite( f3, mergeinput[3]); 4: rewrite( f4, mergeinput[4]); 5: rewrite( f5, mergeinput[5]); 6: rewrite( f6, mergeinput[6]); 7: rewrite( f7, mergeinput[7]); 8: rewrite( f8, mergeinput[8]); 9: rewrite( f9, mergeinput[9]); 10: rewrite(f10, mergeinput[10]); { 11: rewrite(f11, mergeinput[11]); 12: rewrite(f12, mergeinput[12]); 13: rewrite(f13, mergeinput[13]); 14: rewrite(f14, mergeinput[14]); 15: rewrite(f15, mergeinput[15]); 16: rewrite(f16, mergeinput[16]); 17: rewrite(f17, mergeinput[17]); 18: rewrite(f18, mergeinput[18]); 19: rewrite(f19, mergeinput[19]); 20: rewrite(f20, mergeinput[20]); } end; (*$i+*) end; { rewritex } {-----------------------------------------------------} function filesexhausted : boolean; var i : 1..maxfiles; result : boolean; accept : boolean; begin result := true; for i := 1 to filesused do result := result and eofx(i); if one_mo_time then result := result and eofx(mergefile); filesexhausted := result end; { filesexhausted } {------------------------------------------------------} function least : integer; { returns value which points to least entry in table } var i, j : 1..maxfiles; min : stringrec; begin j := 1; while (not table[j].hasdata) and (j < filesused) do { skip nonexistent values } j := j + 1; if table[j].hasdata then begin least := j; min := table[j].inrec; { get started } for i := j + 1 to filesused do with table[i] do if hasdata then begin if relation(inrec,min,1) = lessthan then begin least := i; min := inrec end end; if table[mergefile].hasdata then with table[mergefile] do if relation(inrec,min,1) = lessthan then least := mergefile; end else if table[mergefile].hasdata then least := mergefile else least := 0; { empty } end; { least } begin { merge } recswritten := 0; badio := false; if end_of_infile then openoutputfile else begin rewritex(temp_outfile); if IORESULT <> 0 then CHECKIO('abort','',IOERR); end; ERASE_EOL(40,22); if end_of_infile then write('STATUS: Merging to output file...') else write('STATUS: Merging to workfile ',temp_outfile,'...'); ERASE_EOL(40,23); for i := 1 to maxfiles do begin table[i].hasdata := false; if (i <= filesused) or ((i = mergefile) and (one_mo_time)) then begin resetx(i); checkio('noabort', mergeinput[i], ioerr); badio := badio or ioerr; with table[i] do if not ioerr then begin repeat { ignore null records } readlnx(i, inrec) until (inrec <> '') or eofx(i); if inrec <> '' then begin intread := intread + 1; hasdata := true end; end; end; end; if badio then begin error := 2; exit(psort) { ****************** } end; while not filesexhausted do begin current := least; { point to appropriate table entry } WITH TABLE[CURRENT] DO BEGIN if end_of_infile then begin INREC := CONCAT(' ',INREC,' '); INREC[1] := CHR(16); INREC[2] := CHR(32); INREC[LENGTH(INREC)] := CHR(13); BL_WRITE(INREC,BLOCK_RESULTS); END else writelnx(temp_outfile,inrec); end; recswritten := recswritten + 1; with table[current] do if not eofx(current) then { replenish record } begin repeat readlnx(current, inrec) until (inrec <> '') or eofx(current); if inrec = '' then hasdata := false else intread := intread + 1; end else hasdata := false; { remove from further consideration } end; { while } { Empty the table after filesexhausted } repeat current := least; if current > 0 then { some left } with table[current] do begin if end_of_infile then begin INREC := CONCAT(' ',INREC,' '); INREC[1] := CHR(16); INREC[2] := CHR(32); INREC[LENGTH(INREC)] := CHR(13); BL_WRITE(INREC,BLOCK_RESULTS); end else writelnx(temp_outfile,inrec); recswritten := recswritten + 1; hasdata := false end { with } until current = 0; { none left } if filesused > 0 then begin ERASE_EOL(40,23); write('STATUS: Purging intermediate files...'); for i := 1 to filesused do closex(i,'p'); if one_mo_time then closex(mergefile,'p'); end; if not end_of_infile then closex(temp_outfile,'l'); end; { merge } PROCEDURE BL_OPEN; (*VAR BLOCK_FILE :STR; File name VAR BLOCK_RETURN:INTEGER); Return Code *) BEGIN {$I-} BLOCK_RETURN := -1; REWRITE(OUTPUT_FILE,BLOCK_FILE); IF IORESULT = 0 THEN BEGIN ARRAY_INDEX := 0; BLOCK_NUMBER := 0; FILLCHAR(BLOCK_ARRAY[0],SIZEOF(BLOCK_ARRAY),CHR(0)); BLOCKS_WROTE := BLOCK_WRITE(OUTPUT_FILE,BLOCK_ARRAY,2, BLOCK_NUMBER); IF BLOCKS_WROTE = 2 THEN BEGIN BLOCK_RETURN := 0; BLOCK_NUMBER := BLOCK_NUMBER + 2; END; END; {$I+} END; PROCEDURE BL_WRITE; (* VAR BLOCK_RECORD:STRINGREC; String to write VAR BLOCK_RETURN:INTEGER); Return Code *) BEGIN BLOCK_RETURN := 1; IF (ARRAY_INDEX + LENGTH(BLOCK_RECORD)) > 1023 THEN BEGIN BLOCKS_WROTE := BLOCK_WRITE(OUTPUT_FILE,BLOCK_ARRAY,2, BLOCK_NUMBER); IF BLOCKS_WROTE = 2 THEN BEGIN BLOCK_RETURN := 0; BLOCK_NUMBER := BLOCK_NUMBER + 2; END; ARRAY_INDEX := 0; FILLCHAR(BLOCK_ARRAY[0],SIZEOF(BLOCK_ARRAY),CHR(0)); MOVELEFT(BLOCK_RECORD[1],BLOCK_ARRAY[ARRAY_INDEX], LENGTH(BLOCK_RECORD)); ARRAY_INDEX := LENGTH(BLOCK_RECORD); END ELSE BEGIN MOVELEFT(BLOCK_RECORD[1],BLOCK_ARRAY[ARRAY_INDEX], LENGTH(BLOCK_RECORD)); ARRAY_INDEX := ARRAY_INDEX + LENGTH(BLOCK_RECORD); BLOCK_RETURN := 0; END; END; PROCEDURE BL_CLOSE; (* VAR BLOCK_RETURN:INTEGER); Return Code *) BEGIN BLOCK_RETURN := -1; BLOCKS_WROTE := BLOCK_WRITE(OUTPUT_FILE,BLOCK_ARRAY,2, BLOCK_NUMBER); IF BLOCKS_WROTE = 2 THEN BEGIN BLOCK_RETURN := 0; CLOSE(OUTPUT_FILE,LOCK); END; (*$I+*) END; {----------------------------------------------------} procedure checkio{(str1, str2 : str; var ioerr : boolean)}; var iores : integer; begin iores := ioresult; if iores > 0 then begin if (iores = 9) or (iores = 10) then BEGIN ERASE_EOL(40,23); write(bell,'ERROR: Can''t find file: ',str2); END else if iores = 8 then BEGIN ERASE_EOL(40,23); write(bell,'ERROR: No room on disk'); END else BEGIN ERASE_EOL(30,23); write(bell,'ERROR: I/O error (',iores, ') for file: ',str2); END; if str1 = 'abort' then begin error := 2; exit(psort) { ********** } end else ioerr := true end else ioerr := false end; { checkio } {------------------------------------------------------} procedure openoutputfile; var i, iores : integer; ch : char; volname : string[15]; begin repeat BL_OPEN(OFILENAME,BLOCK_RESULTS); iores := ioresult; if iores = 9 then { vol. not on line } begin i := pos(':', ofilename); if i > 0 then volname := copy(ofilename, 1,i) else volname := 'default prefix'; ERASE_EOL(30,23); write(bell,'ACTION: Put in disk ', volname, ', type '); read(ch); ERASE_EOL(30,23); if ch = chr(27) {ESC} then begin error := 2; exit(psort) { *************************** } end; end; until IORES <> 9; if IORES <> 0 then begin ERASE_EOL(30,23); write(bell,'ERROR: Open error (',iores,') for: ', ofilename); error := 2; exit(psort) {***************************} end end; { openoutputfile } {----------------------------------------------------} procedure getfield{(fieldnum:integer; source:stringrec; var thefield:key)}; var numch, numdelim, slength, finposn, startposn, varkeylen : integer; ch : char; begin if keytype = fixed then thefield := copy(source, fielddata[fieldnumber].keystart, fielddata[fieldnumber].keylen) else begin slength :=length(source); numdelim := 0; finposn := 0; numch := 0; repeat numch := numch + 1; ch := source [numch]; if ch = keydelim then begin startposn :=finposn; finposn := numch; numdelim := numdelim + 1; end; until (numdelim = fieldnum) or (numch = slength); if (numch = slength) and (numdelim <> fieldnum) then if numdelim < fieldnum - 1 then begin ERASE_EOL(30,23); write(bell, 'ERROR: Insufficient key delimiters in: '); write(source); error := 3; exit(psort); { ************************ } end else begin startposn := finposn; finposn := numch + 1; end; varkeylen := finposn - startposn - 1; if varkeylen > maxkeylen then varkeylen := maxkeylen; thefield := copy(source, startposn + 1, varkeylen) end end; { getfield } {-----------------------------------------------------} function relation{(item1, item2 : stringrec; stkey : integer) : comparison}; var i : integer; key1, key2 : key; getresult : boolean; begin i := stkey; { start at appropriate key } getresult := false; while (i <= numkeys) and (not getresult) do begin getfield(keydata[i].fieldnum, item1, key1); getfield(keydata[i].fieldnum, item2, key2); if key1 > key2 then begin if keydata[i].keydirection = ascending then relation := greaterthan else relation := lessthan; getresult := true end else begin if key1 < key2 then begin if keydata[i].keydirection = ascending then relation := lessthan else relation := greaterthan; getresult := true end else { equal } i := i + 1 { next key } end end; if not getresult then relation := equal end; { relation } {-----------------------------------------------------} begin { psort } error := 0; bell := chr(7); memorycontained := false; toomanyfiles := false; filesused := 0; one_mo_time := false; temp_outfile := maxfiles; end_of_infile := false; recsread := 0; recswritten := 0; intread := 0; paramname := concat(paramname, '.TEXT'); getparm(paramname); (*$I-*) { turn I/O checking off } reset(infile, ifilename); checkio('abort', ifilename, ioerr); (*$I+*) while not end_of_infile do begin mergefile := temp_outfile; if temp_outfile = maxfiles-1 then temp_outfile := maxfiles else temp_outfile := maxfiles-1; distribute; if end_of_infile then begin ERASE_EOL(40,22); write('STATUS: Records read: ', recsread); end; if (filesused <> 0) or (one_mo_time) then merge; if not end_of_infile then one_mo_time := true else BL_CLOSE(BLOCK_RESULTS); end; end; { psort } begin { main program } ERROR := 0; ACCESS_FLAG := false; ACCESS_DATA_BASE(ACCESS_FLAG); if ACCESS_FLAG then PSORT('TEMPSORT',ERROR,RECSREAD,RECSWRIT); if ERROR <> 0 then begin ERASE_EOL(0,MAX_ROW-1); gotoxy(0,MAX_ROW); write(ALARM_BELL,'Press SPACE to continue: '); read(KEYBOARD,CH); exit(UDE_SORT); end; end. { main program } ======================================================================================== DOCUMENT :usus Folder:VOL25:ud.ude.text ======================================================================================== PROGRAM UDE; {$l#5:ud.udelst.text} USES {$U COMMANDIO.CODE} COMMANDIO; CONST CLEAR_SCREEN = 12; ESC_KEY = 27; VAR CH : CHAR; LINE : STRING; I : INTEGER; BEGIN WRITE(CHR(CLEAR_SCREEN)); GOTOXY(26,0); WRITE('UNIVERSAL DATA ENTRY'); GOTOXY(26,1); WRITE('===================='); GOTOXY(26,2); WRITE('Version IV.0'); LINE := 'Define a UDE data file'; FOR I := 2 TO LENGTH(LINE) DO LINE[I] := CHR(ORD(LINE[I])+128); GOTOXY(20,8); WRITE(LINE); LINE := 'Maintain a UDE data file'; FOR I := 2 TO LENGTH(LINE) DO LINE[I] := CHR(ORD(LINE[I])+128); GOTOXY(20,10); WRITE(LINE); LINE := 'Sort a UDE data file'; FOR I := 2 TO LENGTH(LINE) DO LINE[I] := CHR(ORD(LINE[I])+128); GOTOXY(20,12); WRITE(LINE); LINE := 'List a UDE data file'; FOR I := 2 TO LENGTH(LINE) DO LINE[I] := CHR(ORD(LINE[I])+128); GOTOXY(20,14); WRITE(LINE); LINE := 'Copy a UDE or GENLIST data file'; FOR I := 2 TO LENGTH(LINE) DO LINE[I] := CHR(ORD(LINE[I])+128); GOTOXY(20,16); WRITE(LINE); GOTOXY(0,23); WRITE('Enter selection or :'); REPEAT GOTOXY(27,23); READ(CH); IF CH = CHR(ESC_KEY) THEN EXIT(PROGRAM); CASE CH OF 'D','d' : CHAIN('#4:SD/DEFINE'); 'M','m' : CHAIN('#4:UD/MAINT'); 'S','s' : CHAIN('#4:UD/SORT'); 'C','c' : CHAIN('#4:UD/COPY'); 'L','l' : CHAIN('#4:UD/LIST'); END; UNTIL CH IN ['D','d','M','m','S','s','C','c','L','l']; GOTOXY(40,23); WRITE('One Moment Please'); CHAIN('#4:UD/UDE'); END. ======================================================================================== DOCUMENT :usus Folder:VOL25:ud.udelst.text ======================================================================================== Pascal Compiler IV.0 C1a-4 Page 1 16 November 1981 2 2 1:d 1 {$l#5:ud.udelst.text} 3 2 1:d 1 4 2 1:d 1 type bigstring=string[255]; 5 2 1:d 1 var havechain,inredirect,outredirect,monitoropen,inmonitor:boolean; 6 2 1:d 6 function redirect(command:bigstring):boolean; 7 2 1:d 1 procedure exception(stopchaining:boolean); 8 2 1:d 1 procedure chain(command:bigstring); 9 2 1:d 1 10 2 1:d 1 procedure initcommand; 11 2 1:d 1 procedure startmonitor; 12 2 1:d 1 procedure stopmonitor(saveit:boolean); 13 2 1:d 1 procedure getchainline(var command:bigstring); 14 2 1:d 1 15 2 1:d 1 USES {$U COMMANDIO.CODE} COMMANDIO; 16 2 1:d 1 17 2 1:d 1 CONST 18 2 1:d 1 CLEAR_SCREEN = 12; 19 2 1:d 1 ESC_KEY = 27; 20 2 1:d 1 21 2 1:d 1 VAR 22 2 1:d 1 CH : CHAR; 23 2 1:d 2 LINE : STRING; 24 2 1:d 43 I : INTEGER; 25 2 1:d 44 26 2 1:0 0 BEGIN 27 2 1:1 0 WRITE(CHR(CLEAR_SCREEN)); 28 2 1:1 9 GOTOXY(26,0); 29 2 1:1 13 WRITE('UNIVERSAL DATA ENTRY'); 30 2 1:1 26 GOTOXY(26,1); 31 2 1:1 30 WRITE('===================='); 32 2 1:1 43 GOTOXY(26,2); 33 2 1:1 47 WRITE('Version IV.0'); 34 2 1:1 60 LINE := 'Define a UDE data file'; 35 2 1:1 68 FOR I := 2 TO LENGTH(LINE) DO 36 2 1:2 84 LINE[I] := CHR(ORD(LINE[I])+128); 37 2 1:1 106 GOTOXY(20,8); 38 2 1:1 110 WRITE(LINE); 39 2 1:1 121 LINE := 'Maintain a UDE data file'; 40 2 1:1 129 FOR I := 2 TO LENGTH(LINE) DO 41 2 1:2 145 LINE[I] := CHR(ORD(LINE[I])+128); 42 2 1:1 167 GOTOXY(20,10); 43 2 1:1 171 WRITE(LINE); 44 2 1:1 182 LINE := 'Sort a UDE data file'; 45 2 1:1 190 FOR I := 2 TO LENGTH(LINE) DO 46 2 1:2 206 LINE[I] := CHR(ORD(LINE[I])+128); 47 2 1:1 228 GOTOXY(20,12); 48 2 1:1 232 WRITE(LINE); 49 2 1:1 243 LINE := 'List a UDE data file'; 50 2 1:1 251 FOR I := 2 TO LENGTH(LINE) DO 51 2 1:2 267 LINE[I] := CHR(ORD(LINE[I])+128); 52 2 1:1 289 GOTOXY(20,14); 53 2 1:1 293 WRITE(LINE); 54 2 1:1 304 LINE := 'Copy a UDE or GENLIST data file'; 55 2 1:1 312 FOR I := 2 TO LENGTH(LINE) DO 56 2 1:2 328 LINE[I] := CHR(ORD(LINE[I])+128); 57 2 1:1 350 GOTOXY(20,16); 58 2 1:1 354 WRITE(LINE); Pascal Compiler IV.0 C1a-4 Page 2 16 November 1981 59 2 1:1 365 GOTOXY(0,23); 60 2 1:1 369 WRITE('Enter selection or :'); 61 2 1:1 382 REPEAT 62 2 1:2 382 GOTOXY(27,23); 63 2 1:2 386 READ(CH); 64 2 1:2 395 IF CH = CHR(ESC_KEY) THEN EXIT(PROGRAM); 65 2 1:2 404 CASE CH OF 66 2 1:2 407 'D','d' : CHAIN('#4:SD/DEFINE'); 67 2 1:2 416 'M','m' : CHAIN('#4:UD/MAINT'); 68 2 1:2 425 'S','s' : CHAIN('#4:UD/SORT'); 69 2 1:2 434 'C','c' : CHAIN('#4:UD/COPY'); 70 2 1:2 443 'L','l' : CHAIN('#4:UD/LIST'); 71 2 1:2 452 END; 72 2 1:1 455 UNTIL CH IN ['D','d','M','m','S','s','C','c','L','l']; 73 2 1:1 465 GOTOXY(40,23); 74 2 1:1 470 WRITE('One Moment Please'); 75 2 1:1 483 CHAIN('#4:UD/UDE'); 76 2 :0 0 END. End of Compilation. ======================================================================================== DOCUMENT :usus Folder:VOL25:vol25.doc.text ======================================================================================== USUS Volume 25 Universal Data Entry Sources (Documentation and Code files on Volume 26) VOL25: UD.UDE.TEXT 6 A program package to allow the generation, and UD.COPY.TEXT 92 maintainance of data input screens and data files UD.LIST.TEXT 84 UD.MAINT.TEXT 70 UD.SORT.TEXT 70 UD.UDELST.TEXT 10 SD.DEFINE.TEXT 56 SH.CALC.TEXT 10 SH.DISPLAY.TEXT 8 SH.FIELD.TEXT 14 SH.INIT.TEXT 8 SH.SAVE.TEXT 6 SH.SCREEN.TEXT 30 README.1ST.TEXT 8 Read this file first!!! VOL25.DOC.TEXT 4 You're reading it --------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 25 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOL26:readme.1st.text ======================================================================================== Some notes from the reviewer: I have made UDE marginally work. I am not really very impressed with the entire package, but it shows some interesting programming constructs and is very possibly useful to somebody. The documentation, although extensive is unclear and hard to follow. The example given in the last part of the documentation has some errors, but after a couple of hours of playing around, you too will figure it out. The program requires that the code files reside on #4:. You can easily change this in UD.UDE.TEXT. The program has the built in and annoying tendency to chain back to itself, so you may find that it restarts when you don't want it to. Simply remove the last call to CHAIN in UD.UDE.TEXT and re- compile it. There is some rather clever code in SH.INIT.TEXT to to obtain the cursor control characters for the user's terminal. Unfortunatly, it don't work. If your terminal uses two character control sequences for the arrow keys you will have to go in and hard wire stuff. The function SC_MAP_CRT_COMMAND is kind of odd and can't really be used in the way shown with two character sequences. SC_MAP_CRT_COMMAND (in screenops) expects you to read characters from the terminal and pass all of them through it. If your terminal has two character control sequences, some of the characters that you read will be the prefix characters. When SC_MAP_CRT_COMMAND is passed a prefix character, IT GOES OUT AND READS THE TERMINAL, EXPECTING TO FIND ANOTHER CHARACTER!! If the next character is one of the ones for the special keys, it will return the enumerated type of the special key and the value of the character that it read. This means that the method used in UDE hangs whenever this procedure is called. UNLESS THE CORRECT CHARACTERS ARE TYPED IN THE CORRECT ORDER the program will not be able to determine the values of the arrow keys. With one character command sequences, the method should work fine. The author has also done something which will cause a lot of users, especially those with APC's and PC's a lot of grief. Most of the prompt lines are written to the screen with the 8th bit set. This is probably some special video attribute for his terminal, but many terminals use the characters between 128 and 255 as graphics characters. This means the much of the prompting information will be displayed as graphic garbage. This stuff is scattered throughout the program, and I didn't want to change it. If it causes you problems, you will have to go in and delete the < +128 > expressions. Good luck george w. schreyer p.s. The submittor has requested that any changes, bug fixes, or upgrades be submitted back to him. If you improve on this program, other than the items mentioned above, please contact me so that we can send the upgrades back to him. ======================================================================================== DOCUMENT :usus Folder:VOL26:sd_define.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL26:sh.screen.code ======================================================================================== { Screen handler compilation unit version II.2.B.40 }    { THIS VERSION FOR UCSD PASCAL VERSION IV.0 }    const END_SCREEN = 9999; { Signals end of a screen file } &MAX_FLEN = 40; { Maximum length of prompt or data field } &LEN_ID = 8; { Maximum length of an ID Name } &SCREEN_FIELDS = 40; { Maximum number of screen fields } &PROMPT_FIELDS = 40; { Maximum number of prompt fields } !  type STRINGFL = STRING[MAX_FLEN]; %STR_ID = STRING[LEN_ID]; %FIELD_DEFS = Packed Record )S_ID : STR_ID; )S_ROW,S_COL,S_LEN,S_MIN: Integer; )S_TYP,S_JUS,S_NA : Char; )S_SKIP: Boolean; )S_DEF,S_FLD: STRINGFL; 'end; %PROMPT_DEFS = Packed Record )P_ROW,P_COL : Integer; )P_FLD : STRINGFL; 'end; %SCREEN_ARR = Packed Array[1..SCREEN_FIELDS] of FIELD_DEFS; %PROMPT_ARR = Packed Array[1..PROMPT_FIELDS] of PROMPT_DEFS; %SCREEN_REC = Packed record case TAG: Boolean of 5False : (S:FIELD_DEFS); 5True : (P:Packed array[1..2] of PROMPT_DEFS) 3end; %T_THE_DATE = Packed Record 'month : 0..12 ; 'day : 0..31 ; 'year : 0..99 ; 'end ;   var "ALARM_BELL : Char; "CURSOR_DOWN : Char; "CURSOR_LEFT : Char; "CURSOR_RIGHT : Char; "CURSOR_UP : Char; "DEL_KEY : Char; "ENTER_KEY : Char; "ERASE_FIELD : Char; "ERASE_INPUT : Char; "ESC_KEY : Char; "FORM_FEED : Char; "INS_KEY : Char; "LINE_KEY : Char; "RETURN_KEY : Char; "TAB_LEFT : Char; "TAB_RIGHT : Char; "TAB_SKIP : Char; "ULINE : Char; " "FILE_TO_GET : File of SCREEN_REC; "MAX_ROW : Integer; "MAX_COL : Integer; "THE_DATE : T_THE_DATE ; "UNDERLINE : STRINGFL; $ & &  Function FIND(FIELD_ID: STR_ID; { Field ID to find } .var FIND_SCREEN: SCREEN_ARR { Screen array to search } .): Integer; { Zero returned if field Wnot found }   Procedure EATSPL(var F_FLD: String); { String to shorten }   Procedure EATSPR(var F_FLD: String); { String to shorten }   Procedure FIELD( F_ROW :Integer; { Field row } 0var F_COL :Integer; { Field column } 4F_E_ROW, { Field error row } 4F_E_COL, { Field error column } 4F_LEN, { Field length } 4F_MIN :Integer; { Minimum field length } 0var F_EXIT:Char; { Exit character } 4F_JUS, { Justify, L)eft, R)ight or N)one } 4F_AN: Char; { L)etter, N)umeric, A)lpha, S)pecial } 0var F_FLD:STRINGFL; { Input and output string } 4F_SKIP:Boolean); { Exit at end of field flag } 0  Procedure GET_FILE( GET_NAME: String; { File name to get } 3var GET_SCREEN: SCREEN_ARR; { Screen to load } 3var GET_PROMPTS: PROMPT_ARR; { Prompts to load } 3var GET_RESULT: Integer); { IO return code }   Procedure SAVE_FILE( SAVE_NAME: String; { File name to save } 4var SAVE_SCREEN: SCREEN_ARR; { Screen to save } 4var SAVE_PROMPTS: PROMPT_ARR; { Prompts to save } 4var SAVE_RESULT: Integer); { IO return code }   Procedure SCREEN(var RUNING_SCREEN: SCREEN_ARR;{ Screen to run } 5WRAP: Boolean; { Wrapping option On or Off } 5START_FIELD, { Field to position cursor } 5ROW_OFFSET, { Row offset } 5COL_OFFSET, { Column offset } 5START_ROW, { Starting data field row } 5END_ROW, { Ending data field row } 5ERROR_ROW, { Error row } 5ERROR_COL: Integer; { Error column } 1var F_EXIT: Char); { Key pressed to exit }   Procedure DISPLAY_SCREEN(var SHOW_SCREEN: SCREEN_ARR; { Screen to display } 9ROW_OFFSET, { Row offset } 9COL_OFFSET, { Column offset } 9START_ROW, { Starting data field row } 9END_ROW: Integer); { Ending data field row }   Procedure DISPLAY_PROMPTS(var P_ARRAY: PROMPT_ARR; { Prompts to display } :ROW_OFFSET, { Row offset } :COL_OFFSET, { Column offset } :START_ROW, { Starting prompt row } :END_ROW: Integer); { Ending prompt row }   Procedure ERASE_SCREEN(var E_SCREEN: SCREEN_ARR; { Screen to erase } ;ROW_OFFSET, { Row offset } ;COL_OFFSET, { Column offset } ;START_ROW, { First data field row to erase} ;END_ROW: Integer); { Last data field row to erase }   Procedure ERASE_PROMPTS(var P_ARRAY: PROMPT_ARR; { Prompts to erase } â¼Û…â¼Û?â¼Û4â¼Û8â¼Û1â¼Û=â¼ÛÚÔmŠ((9Ò‡€·(怴‚€}ë(pŠ(7Ò ‡€´†xë(l$"²ñ$j"‡€¹²ñ‡€¹j‡€¼x‡€½” š¤€Š„€Š‡€´˜€(w„€Š†x˜€Pw„€Š˜„ "w„ ˜u p%°Õpþh‡€¹¤ i!)²Ô‡€´!짅Ó íh!íiŠé ‡€¸³ñ/n‡€º‡€»” š0” pš‚€~u pš‡€¸upŠn&°Õþ‡€¶€LÒ5‡€´‘‡€´¤€Š„€Š‡€´˜€(w„€Š†x˜€Pw„€Š˜„ ‡€¹w„ ë(ŠS‡€¶€RÒ‡€´‘‡€´§‡€¹³ñ g˜‡€´€(wŠéŠ.‡€´¤€Š„€Š‡€´˜€(w„€Š†x˜€Pw„€Š˜„ ‡€¹w„ ë(‡€¼x‡€½” š‡€´˜„ ‡€¹w„ ˜u p‡€¹¤ l$)²Ô‡€´$짅Ò‡€´$ì€ È$ílŠä‡€´‡€´˜„ ‡€¹w„ ë(‡€·(Ä–€½Š®€(ki!#²ÕO‡€³!€(Ëî×5l$æ'Ò p‹-$懀²¢…u¼Ú$懀°‡€¯¼Ú¡$‡€±¢…v¼Ú¡Õ$‡€±¢$懀²¢” $ç ‘$ç ‘$ç §°$ç §²Ÿ¡$ç É€C±¡Ôs$ç 지[°$ç $ç §ì§€]°¡ÔQ$ç ˜e$ç §£we˜‡€³‘²ñ+$ç ‡€³$ç ˜e$ç §£we˜‡€³‘€(Ëî×5ç ë(Š $ç $ç ë(Š $ç $ç ë($ç ¤€†„€†$ç ˜€(w„€††x˜€Pw„€†˜e$~weë($ç §mh %²Ô$ç 지 Ò$ç ì…È íhŠäš$ç ˜u p!íi‹«þ–€³î€(ih !²ÔR' €(Ëî×j"y&¢…u¼Ú"y$#¼Ú¡"x%¢…v¼Ú¡Ô"x%¢"y&¢” š"ç˜u pŠ "y'Ò p íhŠ©–b€(ji!"²Ôd)!€(Ëî×5k#æ(¢…u¼Ú#æ&%¼Ú¡#'¢…v¼Ú¡Ô(#'¢#æ(¢” #~lh $²Ôš€ ” p íhŠëŠ #æ'Ò p!íiŠ—– Õ€(ji!"²Ôc)!€(Ëî×k#y(¢…u¼Ú#y&%¼Ú¡#x'¢…v¼Ú¡Ô*#x'¢#y(¢” #ç§lh $²Ôš€ ” p íhŠëŠ #y'Ò p!íiŠ˜– c!Ä$!x€(Ëî×5æ#x³ñ&!x€(°$!x€(Ëî×5æ'° ÔpŠ!!xíÄŠÉ !xÄ$ x€(Ëî×5æ"x²Ô& x€(°$ x€(Ëî×5æ'° ÔpŠ xíÄŠÉ x²ñ xîÄŠp– %*xÄ&Ä&xå%x)x²¡Õ‹+%x€(Ëî×5k#ç É€CÓni#ç §lh $²Ô#ç 짅Ò #ç ì€ ÈŠ!íi íhŠß!#}³ñ:&Ä(x'x” š0” pš‚€‹u pš#}upš‚€˜u pŠ&Ä%%xíÄ‹iÿ%%xîÄ– V!!x ¢Ä!x­²ñ!­Ä­'ñ¦Š!x­³ñ !­Ä­'ñ¦­(!x€(Ëî×5ç É€CÓ¾– ч"‡%¢…u²ñ…u‡%£¤"‡#‡%¢³ñ‡%á¤#‡(„#„"ed%‡&²ñ%¤&‡&hon‡( €(Ëî×5¤ (‡$¢i(ç É€CÒ‡…Ä‹–(ç ‘(ç ‚€Ÿè(ç ‚€ éŸ¡(ç É€C±¡ÔI(ç 지[°(ç §¢²¡Ô+(ç ‡((ç ˜„ (ç §£w„ ˜‡(‘€(Ëî×5ç ë(Š (ç (ç ë((æ‡%¢a‡!‡ (~(}‡(ç É(ç É(ç (ç É‘'Ò‡ ‡!‘‡x…â¼3â¼Û?â¼ÛÚÔ`‹E‡x>â¼2â¼ÛÚÔ`á‹0‡x1Ò@‡( €(Ëî×5¤ (æj(k` %Òáj‡( €(Ëî×5æ"²Ÿ‡( €(Ëî×5#³¡ÔÖ‹ê‡x4ÒC‡( €(Ëî×5¤ (æj(k`á $Ò…uíj‡( €(Ëî×5æ"³Ÿ‡( €(Ëî×5#²¡ÔÓ‹¡‡x=Ò)‡( €(Ëî×5æj` %Òj‡( €(Ëî×5æ"²ñæŠr‡x8Ò?%$¤ h (²Ô$‡( €(Ëî×5¤ )ç É€CÓ )ç ‚€¡ë( íhŠ×‡(‡%‡$‡#‡"‘ ‡&hŠ-‡x…Ò%hŠ!‡x6ÒnŠ‡x9ÒpŠ š0” p&°ÕØý‡(ed„ „!g`'°ÕÄý–( Ür r – æ! r– ð! r – ør –††?€6t¥¥¥¥¥ ¥ ¥€ÿ¥Í¥……ͲÔM…¥†rŠ3…¥Š/…¥Š(…¥Š!…¥Š…¥ Š…¥ Š …¥ŠŠÖ€¢…í¥Šª†‘r†‘¥Í†w…Íç)Å…Íç:¥Î…ÎÉ¥v…ÎÉ¥u¥ ¥ ¥ ¥ ¥ ¥Ž€‚¥€„¥€€¥€†¥ €‡¥€Œ¥…v€O°…u°¡Ô€ß¥Š€_¥†x€(Ȇx€(…p” †t–hÿ`ÿþÿÿþÿhÿÿþÿÿþÿÿÿÿÿÿÿÿÿÿÿÿERROR: P Alphanumeric character required..Alphabetic letter required.Numeric character required.Illegal character..ASÿÁÿÐÿßÿî ÿÿÿÿÿÿÿÿÿÿÿERROR: Minimun input is ERROR: Minimum input is Character(s) ÿÑÿôÿæÿíÿßÿØÿÑÿÊÿû ´mü}zupk3ùÈ- „`F"~*** GOTOXY EXTRAIO STRINGOPPASCALIOFILEOPS SCREENOP Ë{«N:]"'%Ð'ÖSCREEN40SAVEPHILGETPHILEUDESORT ACCESSDAPSORT GETPARM DISTRIBUMERGE €€€€€€ € € €Î( SCREEN40SCREEN402UDESORT UDESORT UDESORT UDESORT UDESORT .(c)Copyright 1982 Texas Instruments Inc. - ctw  ======================================================================================== DOCUMENT :usus Folder:VOL26:sh_screen.unit ======================================================================================== Ë { «SCREEN40SAVEPHILGETPHILE €€€€€€€€€€€€€€€€Î( SCREEN40SCREEN40çòçòhöÊIV0B\BRMÐMÐ=öè öörMÐMÌ5îBÄ  { Screen handler compilation unit version II.2.B.40 }    { THIS VERSION FOR UCSD PASCAL VERSION IV.0 }    const END_SCREEN = 9999; { Signals end of a screen file } &MAX_FLEN = 40; { Maximum length of prompt or data field } &LEN_ID = 8; { Maximum length of an ID Name } &SCREEN_FIELDS = 40; { Maximum number of screen fields } &PROMPT_FIELDS = 40; { Maximum number of prompt fields } !  type STRINGFL = STRING[MAX_FLEN]; %STR_ID = STRING[LEN_ID]; %FIELD_DEFS = Packed Record )S_ID : STR_ID; )S_ROW,S_COL,S_LEN,S_MIN: Integer; )S_TYP,S_JUS,S_NA : Char; )S_SKIP: Boolean; )S_DEF,S_FLD: STRINGFL; 'end; %PROMPT_DEFS = Packed Record )P_ROW,P_COL : Integer; )P_FLD : STRINGFL; 'end; %SCREEN_ARR = Packed Array[1..SCREEN_FIELDS] of FIELD_DEFS; %PROMPT_ARR = Packed Array[1..PROMPT_FIELDS] of PROMPT_DEFS; %SCREEN_REC = Packed record case TAG: Boolean of 5False : (S:FIELD_DEFS); 5True : (P:Packed array[1..2] of PROMPT_DEFS) 3end; %T_THE_DATE = Packed Record 'month : 0..12 ; 'day : 0..31 ; 'year : 0..99 ; 'end ;   var "ALARM_BELL : Char; "CURSOR_DOWN : Char; "CURSOR_LEFT : Char; "CURSOR_RIGHT : Char; "CURSOR_UP : Char; "DEL_KEY : Char; "ENTER_KEY : Char; "ERASE_FIELD : Char; "ERASE_INPUT : Char; "ESC_KEY : Char; "FORM_FEED : Char; "INS_KEY : Char; "LINE_KEY : Char; "RETURN_KEY : Char; "TAB_LEFT : Char; "TAB_RIGHT : Char; "TAB_SKIP : Char; "ULINE : Char; " "FILE_TO_GET : File of SCREEN_REC; "MAX_ROW : Integer; "MAX_COL : Integer; "THE_DATE : T_THE_DATE ; "UNDERLINE : STRINGFL; $ & &  Function FIND(FIELD_ID: STR_ID; { Field ID to find } .var FIND_SCREEN: SCREEN_ARR { Screen array to search } .): Integer; { Zero returned if field Wnot found }   Procedure EATSPL(var F_FLD: String); { String to shorten }   Procedure EATSPR(var F_FLD: String); { String to shorten }   Procedure FIELD( F_ROW :Integer; { Field row } 0var F_COL :Integer; { Field column } 4F_E_ROW, { Field error row } 4F_E_COL, { Field error column } 4F_LEN, { Field length } 4F_MIN :Integer; { Minimum field length } 0var F_EXIT:Char; { Exit character } 4F_JUS, { Justify, L)eft, R)ight or N)one } 4F_AN: Char; { L)etter, N)umeric, A)lpha, S)pecial } 0var F_FLD:STRINGFL; { Input and output string } 4F_SKIP:Boolean); { Exit at end of field flag } 0  Procedure GET_FILE( GET_NAME: String; { File name to get } 3var GET_SCREEN: SCREEN_ARR; { Screen to load } 3var GET_PROMPTS: PROMPT_ARR; { Prompts to load } 3var GET_RESULT: Integer); { IO return code }   Procedure SAVE_FILE( SAVE_NAME: String; { File name to save } 4var SAVE_SCREEN: SCREEN_ARR; { Screen to save } 4var SAVE_PROMPTS: PROMPT_ARR; { Prompts to save } 4var SAVE_RESULT: Integer); { IO return code }   Procedure SCREEN(var RUNING_SCREEN: SCREEN_ARR;{ Screen to run } 5WRAP: Boolean; { Wrapping option On or Off } 5START_FIELD, { Field to position cursor } 5ROW_OFFSET, { Row offset } 5COL_OFFSET, { Column offset } 5START_ROW, { Starting data field row } 5END_ROW, { Ending data field row } 5ERROR_ROW, { Error row } 5ERROR_COL: Integer; { Error column } 1var F_EXIT: Char); { Key pressed to exit }   Procedure DISPLAY_SCREEN(var SHOW_SCREEN: SCREEN_ARR; { Screen to display } 9ROW_OFFSET, { Row offset } 9COL_OFFSET, { Column offset } 9START_ROW, { Starting data field row } 9END_ROW: Integer); { Ending data field row }   Procedure DISPLAY_PROMPTS(var P_ARRAY: PROMPT_ARR; { Prompts to display } :ROW_OFFSET, { Row offset } :COL_OFFSET, { Column offset } :START_ROW, { Starting prompt row } :END_ROW: Integer); { Ending prompt row }   Procedure ERASE_SCREEN(var E_SCREEN: SCREEN_ARR; { Screen to erase } ;ROW_OFFSET, { Row offset } ;COL_OFFSET, { Column offset } ;START_ROW, { First data field row to erase} ;END_ROW: Integer); { Last data field row to erase }   Procedure ERASE_PROMPTS(var P_ARRAY: PROMPT_ARR; { Prompts to erase } â¼Û…â¼Û?â¼Û4â¼Û8â¼Û1â¼Û=â¼ÛÚÔmŠ((9Ò‡€·(怴‚€}ë(pŠ(7Ò ‡€´†xë(l$"²ñ$j"‡€¹²ñ‡€¹j‡€¼x‡€½” š¤€Š„€Š‡€´˜€(w„€Š†x˜€Pw„€Š˜„ "w„ ˜u p%°Õpþh‡€¹¤ i!)²Ô‡€´!짅Ó íh!íiŠé ‡€¸³ñ/n‡€º‡€»” š0” pš‚€~u pš‡€¸upŠn&°Õþ‡€¶€LÒ5‡€´‘‡€´¤€Š„€Š‡€´˜€(w„€Š†x˜€Pw„€Š˜„ ‡€¹w„ ë(ŠS‡€¶€RÒ‡€´‘‡€´§‡€¹³ñ g˜‡€´€(wŠéŠ.‡€´¤€Š„€Š‡€´˜€(w„€Š†x˜€Pw„€Š˜„ ‡€¹w„ ë(‡€¼x‡€½” š‡€´˜„ ‡€¹w„ ˜u p‡€¹¤ l$)²Ô‡€´$짅Ò‡€´$ì€ È$ílŠä‡€´‡€´˜„ ‡€¹w„ ë(‡€·(Ä–€½Š®€(ki!#²ÕO‡€³!€(Ëî×5l$æ'Ò p‹-$懀²¢…u¼Ú$懀°‡€¯¼Ú¡$‡€±¢…v¼Ú¡Õ$‡€±¢$懀²¢” $ç ‘$ç ‘$ç §°$ç §²Ÿ¡$ç É€C±¡Ôs$ç 지[°$ç $ç §ì§€]°¡ÔQ$ç ˜e$ç §£we˜‡€³‘²ñ+$ç ‡€³$ç ˜e$ç §£we˜‡€³‘€(Ëî×5ç ë(Š $ç $ç ë(Š $ç $ç ë($ç ¤€†„€†$ç ˜€(w„€††x˜€Pw„€†˜e$~weë($ç §mh %²Ô$ç 지 Ò$ç ì…È íhŠäš$ç ˜u p!íi‹«þ–€³î€(ih !²ÔR' €(Ëî×j"y&¢…u¼Ú"y$#¼Ú¡"x%¢…v¼Ú¡Ô"x%¢"y&¢” š"ç˜u pŠ "y'Ò p íhŠ©–b€(ji!"²Ôd)!€(Ëî×5k#æ(¢…u¼Ú#æ&%¼Ú¡#'¢…v¼Ú¡Ô(#'¢#æ(¢” #~lh $²Ôš€ ” p íhŠëŠ #æ'Ò p!íiŠ—– Õ€(ji!"²Ôc)!€(Ëî×k#y(¢…u¼Ú#y&%¼Ú¡#x'¢…v¼Ú¡Ô*#x'¢#y(¢” #ç§lh $²Ôš€ ” p íhŠëŠ #y'Ò p!íiŠ˜– c!Ä$!x€(Ëî×5æ#x³ñ&!x€(°$!x€(Ëî×5æ'° ÔpŠ!!xíÄŠÉ !xÄ$ x€(Ëî×5æ"x²Ô& x€(°$ x€(Ëî×5æ'° ÔpŠ xíÄŠÉ x²ñ xîÄŠp– %*xÄ&Ä&xå%x)x²¡Õ‹+%x€(Ëî×5k#ç É€CÓni#ç §lh $²Ô#ç 짅Ò #ç ì€ ÈŠ!íi íhŠß!#}³ñ:&Ä(x'x” š0” pš‚€‹u pš#}upš‚€˜u pŠ&Ä%%xíÄ‹iÿ%%xîÄ– V!!x ¢Ä!x­²ñ!­Ä­'ñ¦Š!x­³ñ !­Ä­'ñ¦­(!x€(Ëî×5ç É€CÓ¾– ч"‡%¢…u²ñ…u‡%£¤"‡#‡%¢³ñ‡%á¤#‡(„#„"ed%‡&²ñ%¤&‡&hon‡( €(Ëî×5¤ (‡$¢i(ç É€CÒ‡…Ä‹–(ç ‘(ç ‚€Ÿè(ç ‚€ éŸ¡(ç É€C±¡ÔI(ç 지[°(ç §¢²¡Ô+(ç ‡((ç ˜„ (ç §£w„ ˜‡(‘€(Ëî×5ç ë(Š (ç (ç ë((æ‡%¢a‡!‡ (~(}‡(ç É(ç É(ç (ç É‘'Ò‡ ‡!‘‡x…â¼3â¼Û?â¼ÛÚÔ`‹E‡x>â¼2â¼ÛÚÔ`á‹0‡x1Ò@‡( €(Ëî×5¤ (æj(k` %Òáj‡( €(Ëî×5æ"²Ÿ‡( €(Ëî×5#³¡ÔÖ‹ê‡x4ÒC‡( €(Ëî×5¤ (æj(k`á $Ò…uíj‡( €(Ëî×5æ"³Ÿ‡( €(Ëî×5#²¡ÔÓ‹¡‡x=Ò)‡( €(Ëî×5æj` %Òj‡( €(Ëî×5æ"²ñæŠr‡x8Ò?%$¤ h (²Ô$‡( €(Ëî×5¤ )ç É€CÓ )ç ‚€¡ë( íhŠ×‡(‡%‡$‡#‡"‘ ‡&hŠ-‡x…Ò%hŠ!‡x6ÒnŠ‡x9ÒpŠ š0” p&°ÕØý‡(ed„ „!g`'°ÕÄý–( Ür r – æ! r– ð! r – ør –††?€6t¥¥¥¥¥ ¥ ¥€ÿ¥Í¥……ͲÔM…¥†rŠ3…¥Š/…¥Š(…¥Š!…¥Š…¥ Š…¥ Š …¥ŠŠÖ€¢…í¥Šª†‘r†‘¥Í†w…Íç)Å…Íç:¥Î…ÎÉ¥v…ÎÉ¥u¥ ¥ ¥ ¥ ¥ ¥Ž€‚¥€„¥€€¥€†¥ €‡¥€Œ¥…v€O°…u°¡Ô€ß¥Š€_¥†x€(Ȇx€(…p” †t–hÿ`ÿþÿÿþÿhÿÿþÿÿþÿÿÿÿÿÿÿÿÿÿÿÿERROR: P Alphanumeric character required..Alphabetic letter required.Numeric character required.Illegal character..ASÿÁÿÐÿßÿî ÿÿÿÿÿÿÿÿÿÿÿERROR: Minimun input is ERROR: Minimum input is Character(s) ÿÑÿôÿæÿíÿßÿØÿÑÿÊÿû ´mü}zupk3ùÈ- „`F"~*** GOTOXY EXTRAIO STRINGOPPASCALIOFILEOPS SCREENOP $CURSOR $EQUAL O.X§X§ ======================================================================================== DOCUMENT :usus Folder:VOL26:ud.intrdoc.text ======================================================================================== [hf=5/he=1]|UNIVERSAL DATA ENTRY| [he=2]|Introduction| [he=3]|10/81| [st=1/tabs=6,9,12,r65/ff=3/hg=3/hm=1,1.0/vm=0.25,0.5] [hs=8/ce]|7. UNIVERSAL DATA ENTRY| [ff=3/fo=1]7-@ [hs=10] 7.1 |INTRODUCTION|  7.1.1 |Overview|  Universal Data Entry (|UDE|) enables users with little training to enter data into computer files which can later be sorted, printed, or accessed by other programs for data processing. It provides prompts at fields in which data is to be entered, and, if an error is detected, it advises the user. The screen prompts are created by the user with the help of the UDE Define function.  The UDE system is comprised of five programs: Define, Maintain, Sort, List and Copy. Define allows the user to set up the screen and record layout of a data file. Maintain collects data and enters it into a file which may be scanned to change or delete a record. Sort is used to sort the records by field. Up to ten fields may be used as keys, and each field may be sorted in ascending or descending order. The user may put the sorted results into a new file if the data needs to be saved in its original form. The keys used for sorting may also be stored for subsequent use.  List allows the user to list the records in the data file on a line or letter-quality printer. The list format is user-defined and allows choosing the headings and footings which are to appear at the tops and bottoms of pages, which fields and records are to be printed, and which headings are to appear above each field. Format information may be saved for use in printing other data. List also allows a user to "export" data file records into a text file to do custom letter writing or address lists.  Copy allows the user to copy data from selected fields and records of either a UDE or GENLIST data file to a UDE data file.  UDE may also be used in conjunction with other programs which read data and process it by means of specially-prepared software. Finally, UDE can collect data for transmission to other computers for storage or processing.  UDE can be used for name and address lists, inventory records, appointment calendars, purchase order records, payroll records, and many other business problems.  To use UDE for a particular application, start the program by entering /UDE from the main system menu or execute UD/UDE.CODE. Define a data file using the UDE Define function and specify the information (numbers, dates, names, addresses, amounts, descriptions, etc.) needed in the data file. This process is very similar to designing a manual filing system and takes only a few minutes to accomplish.  Having defined a data file format, create the data file and enter information using the Maintain function. Once entered, any record can be examined, changed or deleted.  Information in the data file can be sorted, printed or copied as required with the Sort, List and Copy functions.  [cp=18] UDE for the PCIF system is made up of the following programs: [in=5] |UD/UDE.CODE| - Allows the user to choose the UDE function that is to be performed.  |SD/DEFINE.CODE| - Defines the screen and record layout of a data file.  |UD/MAINT.CODE| - Creates a data file if necessary and maintains records in the data file with add, examine, delete and modify commands.  |UD/SORT.CODE| - Sorts data file records. This program requires the file UD/SORT.SCRN be available on the prefixed disk.  |UD/LIST.CODE| - Lists the active records in the data file. This program requires the file UD/LIST.SCRN to be on the prefixed disk.  |UD/COPY.CODE| - Copies all or part of either a UDE or GENLIST data file to a UDE data file. [in] [cp=4]7.1.2 |Screen Data Input|  A defined UDE data file will appear on the screen as an number of prompts followed by values.  [cp=10]***********************************************************************  [ce]|UDE Data File [ce]Example 1  1st prompt:_value1_ 2nd prompt:_value2_ 3rd prompt:_value3_ 4th prompt:_value4_|  ***********************************************************************  [cp=4]The underlined information is what the user enters into the data file. The rest of the information is prompts that the user does not change. For instance, a UDE data file could be set up to store customer names, addresses and telephone numbers. The prompts on the screen might look like:  [cp=9]************************************************************************  [ce]|Customer Data File  Name:_ _ Telephone number:_ _ Street:_ _ City:_ _ State:_ _ Zip:_ _|  ***********************************************************************  [cp=4] Each piece of information the user enters on the screen is known as a _field_. So there is a name field, a telephone number field, and so on. All the fields on the screen, when taken together, are known as a _record_. All the records are called the _data file_.  [cp=4] UDE collects all its records by presenting the screen to the user to be filled in. There is more information on entering records into UDE in the Maintain section. There are also some special keys that are used when entering data. These special keys are explained in Appendix D.  [cp=12]7.1.3 |Screen Messages|  During the operation of UDE the following types of messages may be displayed in the right half of the last line on the screen. [in=5] |STATUS:| Indicates the status of an operation.  |ERROR:| Indicates an error has occurred.  |WARNING:| Indicates the operator is about to perform a dangerous operation.  |ACTION:| Indicates some action is required by the operator to continue. [in] [cp=5]7.1.4 |Standard Screen Commands|  Some of the screens displayed by UDE programs have the following standard commands at the bottom of the screen. All other commands, unique to a certain UDE function, will be explained later in the manual.  [cp=4]7.1.4.1 |Execute Screen Functions|  When the e|X|ecute command is in the lower left of the UDE screen, press || to execute the function indicated by the screen display. [cp=5] 7.1.4.2 |Changing Screen Data Fields|  When the |C|hange command is in the lower left of the UDE screen, press || to change the values in the data fields on the screen. The cursor will be put at the beginning of the first field.  [cp=4]7.1.4.3 |Quitting the Current Screen|  When the |Q|uit command is in the lower left of the UDE screen, press || to exit the current operation. [tf=#5:UD.SAVEDOC] ======================================================================================== DOCUMENT :usus Folder:VOL26:ud.sort.code ======================================================================================== Ë{«N:]"'%Ð'ÖSCREEN40SAVEPHILGETPHILEUDESORT ACCESSDAPSORT GETPARM DISTRIBUMERGE €€€€€€ € € €Î( SCREEN40SCREEN402UDESORT UDESORT UDESORT UDESORT UDESORT .(c)Copyright 1982 Texas Instruments Inc. - ctw   { Screen handler compilation unit version II.2.B.40 }    { THIS VERSION FOR UCSD PASCAL VERSION IV.0 }    const END_SCREEN = 9999; { Signals end of a screen file } &MAX_FLEN = 40; { Maximum length of prompt or data field } &LEN_ID = 8; { Maximum length of an ID Name } &SCREEN_FIELDS = 40; { Maximum number of screen fields } &PROMPT_FIELDS = 40; { Maximum number of prompt fields } !  type STRINGFL = STRING[MAX_FLEN]; %STR_ID = STRING[LEN_ID]; %FIELD_DEFS = Packed Record )S_ID : STR_ID; )S_ROW,S_COL,S_LEN,S_MIN: Integer; )S_TYP,S_JUS,S_NA : Char; )S_SKIP: Boolean; )S_DEF,S_FLD: STRINGFL; 'end; %PROMPT_DEFS = Packed Record )P_ROW,P_COL : Integer; )P_FLD : STRINGFL; 'end; %SCREEN_ARR = Packed Array[1..SCREEN_FIELDS] of FIELD_DEFS; %PROMPT_ARR = Packed Array[1..PROMPT_FIELDS] of PROMPT_DEFS; %SCREEN_REC = Packed record case TAG: Boolean of 5False : (S:FIELD_DEFS); 5True : (P:Packed array[1..2] of PROMPT_DEFS) 3end; %T_THE_DATE = Packed Record 'month : 0..12 ; 'day : 0..31 ; 'year : 0..99 ; 'end ;   var "ALARM_BELL : Char; "CURSOR_DOWN : Char; "CURSOR_LEFT : Char; "CURSOR_RIGHT : Char; "CURSOR_UP : Char; "DEL_KEY : Char; "ENTER_KEY : Char; "ERASE_FIELD : Char; "ERASE_INPUT : Char; "ESC_KEY : Char; "FORM_FEED : Char; "INS_KEY : Char; "LINE_KEY : Char; "RETURN_KEY : Char; "TAB_LEFT : Char; "TAB_RIGHT : Char; "TAB_SKIP : Char; "ULINE : Char; " "FILE_TO_GET : File of SCREEN_REC; "MAX_ROW : Integer; "MAX_COL : Integer; "THE_DATE : T_THE_DATE ; "UNDERLINE : STRINGFL; $ & &  Function FIND(FIELD_ID: STR_ID; { Field ID to find } .var FIND_SCREEN: SCREEN_ARR { Screen array to search } .): Integer; { Zero returned if field Wnot found }   Procedure EATSPL(var F_FLD: String); { String to shorten }   Procedure EATSPR(var F_FLD: String); { String to shorten }   Procedure FIELD( F_ROW :Integer; { Field row } 0var F_COL :Integer; { Field column } 4F_E_ROW, { Field error row } 4F_E_COL, { Field error column } 4F_LEN, { Field length } 4F_MIN :Integer; { Minimum field length } 0var F_EXIT:Char; { Exit character } 4F_JUS, { Justify, L)eft, R)ight or N)one } 4F_AN: Char; { L)etter, N)umeric, A)lpha, S)pecial } 0var F_FLD:STRINGFL; { Input and output string } 4F_SKIP:Boolean); { Exit at end of field flag } 0  Procedure GET_FILE( GET_NAME: String; { File name to get } 3var GET_SCREEN: SCREEN_ARR; { Screen to load } 3var GET_PROMPTS: PROMPT_ARR; { Prompts to load } 3var GET_RESULT: Integer); { IO return code }   Procedure SAVE_FILE( SAVE_NAME: String; { File name to save } 4var SAVE_SCREEN: SCREEN_ARR; { Screen to save } 4var SAVE_PROMPTS: PROMPT_ARR; { Prompts to save } 4var SAVE_RESULT: Integer); { IO return code }   Procedure SCREEN(var RUNING_SCREEN: SCREEN_ARR;{ Screen to run } 5WRAP: Boolean; { Wrapping option On or Off } 5START_FIELD, { Field to position cursor } 5ROW_OFFSET, { Row offset } 5COL_OFFSET, { Column offset } 5START_ROW, { Starting data field row } 5END_ROW, { Ending data field row } 5ERROR_ROW, { Error row } 5ERROR_COL: Integer; { Error column } 1var F_EXIT: Char); { Key pressed to exit }   Procedure DISPLAY_SCREEN(var SHOW_SCREEN: SCREEN_ARR; { Screen to display } 9ROW_OFFSET, { Row offset } 9COL_OFFSET, { Column offset } 9START_ROW, { Starting data field row } 9END_ROW: Integer); { Ending data field row }   Procedure DISPLAY_PROMPTS(var P_ARRAY: PROMPT_ARR; { Prompts to display } :ROW_OFFSET, { Row offset } :COL_OFFSET, { Column offset } :START_ROW, { Starting prompt row } :END_ROW: Integer); { Ending prompt row }   Procedure ERASE_SCREEN(var E_SCREEN: SCREEN_ARR; { Screen to erase } ;ROW_OFFSET, { Row offset } ;COL_OFFSET, { Column offset } ;START_ROW, { First data field row to erase} ;END_ROW: Integer); { Last data field row to erase }   Procedure ERASE_PROMPTS(var P_ARRAY: PROMPT_ARR; { Prompts to erase } â¼Û…â¼Û?â¼Û4â¼Û8â¼Û1â¼Û=â¼ÛÚÔmŠ((9Ò‡€·(怴‚€}ë(pŠ(7Ò ‡€´†xë(l$"²ñ$j"‡€¹²ñ‡€¹j‡€¼x‡€½” š¤€Š„€Š‡€´˜€(w„€Š†x˜€Pw„€Š˜„ "w„ ˜u p%°Õpþh‡€¹¤ i!)²Ô‡€´!짅Ó íh!íiŠé ‡€¸³ñ/n‡€º‡€»” š0” pš‚€~u pš‡€¸upŠn&°Õþ‡€¶€LÒ5‡€´‘‡€´¤€Š„€Š‡€´˜€(w„€Š†x˜€Pw„€Š˜„ ‡€¹w„ ë(ŠS‡€¶€RÒ‡€´‘‡€´§‡€¹³ñ g˜‡€´€(wŠéŠ.‡€´¤€Š„€Š‡€´˜€(w„€Š†x˜€Pw„€Š˜„ ‡€¹w„ ë(‡€¼x‡€½” š‡€´˜„ ‡€¹w„ ˜u p‡€¹¤ l$)²Ô‡€´$짅Ò‡€´$ì€ È$ílŠä‡€´‡€´˜„ ‡€¹w„ ë(‡€·(Ä–€½Š®€(ki!#²ÕO‡€³!€(Ëî×5l$æ'Ò p‹-$懀²¢…u¼Ú$懀°‡€¯¼Ú¡$‡€±¢…v¼Ú¡Õ$‡€±¢$懀²¢” $ç ‘$ç ‘$ç §°$ç §²Ÿ¡$ç É€C±¡Ôs$ç 지[°$ç $ç §ì§€]°¡ÔQ$ç ˜e$ç §£we˜‡€³‘²ñ+$ç ‡€³$ç ˜e$ç §£we˜‡€³‘€(Ëî×5ç ë(Š $ç $ç ë(Š $ç $ç ë($ç ¤€†„€†$ç ˜€(w„€††x˜€Pw„€†˜e$~weë($ç §mh %²Ô$ç 지 Ò$ç ì…È íhŠäš$ç ˜u p!íi‹«þ–€³î€(ih !²ÔR' €(Ëî×j"y&¢…u¼Ú"y$#¼Ú¡"x%¢…v¼Ú¡Ô"x%¢"y&¢” š"ç˜u pŠ "y'Ò p íhŠ©–b€(ji!"²Ôd)!€(Ëî×5k#æ(¢…u¼Ú#æ&%¼Ú¡#'¢…v¼Ú¡Ô(#'¢#æ(¢” #~lh $²Ôš€ ” p íhŠëŠ #æ'Ò p!íiŠ—– Õ€(ji!"²Ôc)!€(Ëî×k#y(¢…u¼Ú#y&%¼Ú¡#x'¢…v¼Ú¡Ô*#x'¢#y(¢” #ç§lh $²Ôš€ ” p íhŠëŠ #y'Ò p!íiŠ˜– c!Ä$!x€(Ëî×5æ#x³ñ&!x€(°$!x€(Ëî×5æ'° ÔpŠ!!xíÄŠÉ !xÄ$ x€(Ëî×5æ"x²Ô& x€(°$ x€(Ëî×5æ'° ÔpŠ xíÄŠÉ x²ñ xîÄŠp– %*xÄ&Ä&xå%x)x²¡Õ‹+%x€(Ëî×5k#ç É€CÓni#ç §lh $²Ô#ç 짅Ò #ç ì€ ÈŠ!íi íhŠß!#}³ñ:&Ä(x'x” š0” pš‚€‹u pš#}upš‚€˜u pŠ&Ä%%xíÄ‹iÿ%%xîÄ– V!!x ¢Ä!x­²ñ!­Ä­'ñ¦Š!x­³ñ !­Ä­'ñ¦­(!x€(Ëî×5ç É€CÓ¾– ч"‡%¢…u²ñ…u‡%£¤"‡#‡%¢³ñ‡%á¤#‡(„#„"ed%‡&²ñ%¤&‡&hon‡( €(Ëî×5¤ (‡$¢i(ç É€CÒ‡…Ä‹–(ç ‘(ç ‚€Ÿè(ç ‚€ éŸ¡(ç É€C±¡ÔI(ç 지[°(ç §¢²¡Ô+(ç ‡((ç ˜„ (ç §£w„ ˜‡(‘€(Ëî×5ç ë(Š (ç (ç ë((æ‡%¢a‡!‡ (~(}‡(ç É(ç É(ç (ç É‘'Ò‡ ‡!‘‡x…â¼3â¼Û?â¼ÛÚÔ`‹E‡x>â¼2â¼ÛÚÔ`á‹0‡x1Ò@‡( €(Ëî×5¤ (æj(k` %Òáj‡( €(Ëî×5æ"²Ÿ‡( €(Ëî×5#³¡ÔÖ‹ê‡x4ÒC‡( €(Ëî×5¤ (æj(k`á $Ò…uíj‡( €(Ëî×5æ"³Ÿ‡( €(Ëî×5#²¡ÔÓ‹¡‡x=Ò)‡( €(Ëî×5æj` %Òj‡( €(Ëî×5æ"²ñæŠr‡x8Ò?%$¤ h (²Ô$‡( €(Ëî×5¤ )ç É€CÓ )ç ‚€¡ë( íhŠ×‡(‡%‡$‡#‡"‘ ‡&hŠ-‡x…Ò%hŠ!‡x6ÒnŠ‡x9ÒpŠ š0” p&°ÕØý‡(ed„ „!g`'°ÕÄý–( Ür r – æ! r– ð! r – ør –††?€6t¥¥¥¥¥ ¥ ¥€ÿ¥Í¥……ͲÔM…¥†rŠ3…¥Š/…¥Š(…¥Š!…¥Š…¥ Š…¥ Š …¥ŠŠÖ€¢…í¥Šª†‘r†‘¥Í†w…Íç)Å…Íç:¥Î…ÎÉ¥v…ÎÉ¥u¥ ¥ ¥ ¥ ¥ ¥Ž€‚¥€„¥€€¥€†¥ €‡¥€Œ¥…v€O°…u°¡Ô€ß¥Š€_¥†x€(Ȇx€(…p” †t–hÿ`ÿþÿÿþÿhÿÿþÿÿþÿÿÿÿÿÿÿÿÿÿÿÿERROR: P Alphanumeric character required..Alphabetic letter required.Numeric character required.Illegal character..ASÿÁÿÐÿßÿî ÿÿÿÿÿÿÿÿÿÿÿERROR: Minimun input is ERROR: Minimum input is Character(s) ÿÑÿôÿæÿíÿßÿØÿÑÿÊÿû ´mü}zupk3ùÈ- „`F"~*** GOTOXY EXTRAIO STRINGOPPASCALIOFILEOPS SCREENOP zSAVEPHILwì*a„.¬P†a˜t‡+pć+x°Õ·†tp†uph €(²ÔZ‡, €(Ëî×y'Ò€(íhŠB…Ê…çËîׇ, €(Ëî×Å íh…çËîׇ, €(Ëî×Å íh†upŠ h €(²Ô9‡- €(Ëî×5æ'Ò€(íhŠ …Ê…ç‡- €(Ëî×5Å5 íh†upŠÁ†tp–/ ªGETPHILE§L-d„1¬P†d˜t‡.pć.xÓ †tp†t†u‡.pÄih†uåÕ®pÓ‡.pĆtp…ÉÔb €(Ò ‡.Äp íh‡/ €(Ëî×…çËî×Ň/ €(Ëî×çq íh‡/ €(Ëî×…çËî×Ň/ €(Ëî×çqŠ"!€(Ò ‡.Äp!íi‡0!€(Ëî×5…çÅ5†u‡.pÄ‹Iÿ!í€(kj"#²Ô‡0"€(Ëî×5ç'Ä"íjŠæ í€(kj"#²Ô‡/"€(Ëî×ç'Ä"íjŠæ†t–2 MUDESORT 8n¥¥†s0Ô‚€†††” 3Ó5šuîršuvšštpš‚€u pš†u pp–TEMPSORTTPress SPACE to continue: EXTRAHEAHEAPOPS LONGOPS FILEOPS STRINGOPGOTOXY PASCALIOEXTRAIO SCREEN40 9ACCESSDAž€(ih !²Ô`ˆ‘ €(Ëî×5j"‚€ë"ç'Ä"çÄ"çÄ"çÄ"ç €VÊ"ç €LÊ"ç €SÊ"ç Ê"ç ‚€ë("ç ‚€ë( íhŠ›€(ih !²Ô%ˆ  €(Ëî×j"ç'Ä"Ä"ç‚€ë( íhŠÖˆ‘€(Ëî×5i!‚€ë!çĈ‘€(Ëî×5i!‚€ë!çÄ!ç Ĉ  €(Ëî×i!çÄ!ç‚€ ë(ˆ  €(Ëî×i!çÄ!ç‚€ë(r ˆ¤‚€ëˆ£õ‚€#눣邀.ëih !²Ô&ˆ¤ 짃€5Úñˆ¤ 숤 지€¢È íhŠÕih !²Ô&ˆ£õ 짃€;Úñˆ£õ 숣õ 지€¢È íhŠÕ–` rš€ tpš‚€Au pšupš€ tpš‚€Ju pšupš€ tpšˆ£é˜u pšupˆ  r vš‚€Su pˆ‘r šu‚€bšušu€(ˆ£¥r­£¥š Òpˆ£«ˆ‘‚€tˆ‘r€(Ëî×5ç 눣«rˆ£µˆ‘‚€vˆ‘r€(Ëî×5ç ë ˆ£µrˆ£»h`ˆ£«˜w`‚€yw`ˆ£µ˜w`눣Ñh`ˆ£»˜w`‚€zw`눣Ýh`ˆ£»˜w`‚€}w`눣јˆˆ˜Ùˆ£¢r­£¢Ò5ˆ¤ ˆ£Ý˜” pÓšu€(‚€€ïŠˆ¤ ” ppŠšu€(‚€ïÕÒþ– 0 r ,€GÒ@rš€ tpš‚€šu pšupš€ tpš‚€¤u pšupŠ>rš€ tpš‚€®u pšupš€ tpš‚€¸u pšupˆ  r vš‚€Âu pšu‚€Ìr ˆ‘šušu€(ˆ£¥r€(šur­£¥š°Õ߈£§ˆ‘‚€Þˆ‘r€(Ëî×5ç 눣§rˆ£¯ˆ‘‚€àˆ‘r€(Ëî×5ç ë ˆ£¯rˆ£Åh`ˆ£§˜w`‚€ãw`ˆ£¯˜w`‚€äw`ë,€GÒ0ˆ£Å˜ˆˆIˆœqˆ££r­££Óšu€(‚€çïŠpŠ.ˆ£Å˜ˆˆIˆœqˆ££r­££Óšu€(‚€öïŠpŠpÕíþ– Z)`„+¬P‡-‡.vš`˜u p‡*Ô šštp–. ]i„#„Oá” ‡jÄk v ¤^h ‡^²Õ ” d ” d¤_„_‚ w„_d˜ w„_ëd˜ˆˆIrj„ ˆˆI"€(Ëî×5ç ë„ r„ r„ §²ŸÕ±„ ˜ˆri!Òšu€(‚ ï‡j"Äp‹ˆ ” d ” d¤_„_‚w„_d˜ w„_ëd˜ˆˆIrj„ ˆˆI"€(Ëî×5ç ë„ r„ r#ík„# Ëîפ_‡_!íÄ„ ‚è„ ‚è Ô ‡_ç€DÄŠ‡_ç€AÄ íh‹éþ#Òšu€(‚ï‡jÄp„#‚+” pÓšu€(‚2ï‡jÄp„#€Stp„#up„#ˆ£Ý˜u p„#up„#€Ttp„#up„PˆˆI‚EˆˆIr€(Ëî×5ç ë„Pr„Pr„P‚Gè„P‚Kè Ô„#‚Ou p„#up‹…„XˆˆI‚TˆˆIr€(Ëî×5ç ë „Xr„Xr„X§³ñ„#ˆ£Ý˜u p„#upŠ?„#¤^„^„P˜w„^‚Ww„^„X˜w„^‚Xw„^˜u p„#up„#€Ttp„#up„TˆˆI‚[ˆˆIr€(Ëî×5ç ë„Tr„Tr„#¤^„^„T˜w„^‚_w„^˜u p„#up„#€Ttp„#up„#€Ytp„#up„#€Ftp„#up„#€1tp„#uph €(²Ô5ˆ €(Ëî×5æ'Ó„#ˆ €(Ëî×5~up„#upŠ€(h íhŠÅ„#€1tp„#up„#€0tp„#up„#€1tp„#up„#€Atp„#up#¤^h ‡^²Ô3„#„  Ëî×xup„#up„#„  Ëî×ytp„#up íhŠÆ„#€0tp„#up„#€Ntp„#up„#” p„#” –j ô$4„¤ „¥9á” ‚`„ˆI„œq„£¢r‡£¢Óšu€(‚gp„‘‚z„‘r€(Ëî×5ç ‚|ë(„‘‚}„‘r€(Ëî×5ç ‚€ë(¤£¦‡£¦Ô?r „œqr „ˆIr šuîvš„¤˜u pšupš„£õ˜u p¤£¦šuvš„£¤u p‡£¤š Òp‡¤5ć£¤ƒÚÔ ‡£¤€A¢€a£¤£¤šur‡£¤ƒ‰Úñšu€(‚Šn‡£¤Šf€G¤£¦Š_€S¤£¦ŠU„£¡‡£¡Ó„ˆI‡£¡šušu€(„£¥rŠ ‡¤5ÄpŠ#„ˆIšušu€(„£¥rŠ pŠÖœÕìþ„¤ ” –¤5VOLNAMEE Volume : Name :Get format,Save formattChange,eXecute,Quit ? Version IV.0ÿþÿÿþÿSORT A DATA BASEE=================Type : SCRN and TEXTT" to execute, to aborttVOLNAMEE:.SCRN.TEXTERROR: No data file foundERROR: Unknown Data BaseeGET SORTING FORMATT===================SAVE SORTING FORMAT===================Type : SORT" to execute, to aborttVOLNAMEE:.SORTERROR: Unknown sorting format$ERROR: Unable to save sorting formattIDDERROR: Invalid field IDADDDdERROR: No valid field ids found TEMPSORT.TEXT%ERROR: No room for param file on diskVOLPRINTERprinterPRINTER::NAMEE:.TEXTWORKVOL: UD/SORT.SCRNN$ERROR: Unable to load "UD/SORT.SCRN""VOL NAMEE ÿþÿˆ ERROR: Invalid SelectionnCXÿÝÿ—ÿöÿ¡ÿ«¯²Ñ š´\PSORT Õp áĈ†ä!˜” pÒA¦†á¦†âˆ‡ ÿËpˆ†äˆ‡ ­†ât¦†ã­†ãÒ Ä­†â¢¦†â– Ä­†á!§¢ÿ²ñ[ˆ†äˆ‡ ­†âtp¦†ã­†ãÒ Ä­†â¢¦†â¦†áˆ‡ ÿËp!숇 ­†áÿË!§p!§¦†áŠ"!숇 ­†áÿË!§p­†á!§¢¦†á Ä–8 áĈ†äˆ‡ ­†âtp¦†ã­†ãÒ Äˆ†ä” p–„„¬a„¬ph ²ŸÕ­ ° ° Ô)€(rš­†Þtpš‚€u pša˜u pŠ_ Ò€(rš­†Þtpš‚€u pŠ<rš­†Þtpš‚€u pš upš‚€%u pša˜u p„‚€,èÔ ­‰+Ä pŠ‡ÄŠ‡Ä– 爈†àïph Òx‚€/ˆ˜wi!²ñcˆ˜„ !w„ ëŠc‚€0ërš­†Þtpš‚€8u pšc˜u pš‚€Cu pšbu pr"Ò ­‰+Ä p ±Õqÿ ÓHrš­†Þtpš‚€Ku pš upš‚€Uu pšˆ˜u p­‰+Ä p–Ä„€ˆ„ ¬ÿ­†PÒ/‡„€ˆ˜gˆ…܇ €*Ëî×yˆ…܇ €*Ëî×xwgë(‹™„€ˆ§kljm%ím„€ˆ%ì§n&­†QÒ"i%j$íl$‡ °%#° ÔÞ%#°$‡ ±¡ÔA$‡ î³ñ4rš­†Þtpš‚€Yu pš„€ˆ˜u p­‰+Ä pŠ"i%íj"!£îh €(²ñ€(h‡„€ˆ˜g!í wgë(– m,„€­„0¬ÿ„-„.¬ÿ‡-h¤, ­†G²‡,å¡Ôxˆ†0  Ëî×x„€­˜„0  Ëî×x„-˜aï„aéñˆ†0  Ëî×yÒ¤2Š¤2¤,Š)„aêñˆ†0  Ëî×yÒ¤2Š¤2¤,Š íh‹}ÿ‡,ñ¤2–1… („‰„‰,¬„†ä„ˆá” „‚‚„ƒ®€€” „„.„…Z€€” „(„Tá” „U„‚á” ‡‰+Ĥ†Þ¤†I¤…Û¤…Ú¤†W ¤†S¤†X‡‰*ć‰)Ĥ†F„‰¤‰ „‰ „‰˜w„‰ ‚€mw„‰ 넉˜“ „U„˜” ‚€p„˜„†ß‡†Xñ^‡†S¤†T‡†S îÒ ¤†SŠ S“ ‡†XÔ€(rš‚€su pš‡‰*xup‡…Ú±‡†W Ô“‡†Xñ¤†WŠ„†àŠ„†ä” „‚‚” „„.” „(” „U” –‰-ERROR: Can't find file: ERROR: No room on diskkERROR: I/O error (( ) for file: abort:default prefixxACTION: Put in disk , type >ERROR: Open error () for: 'ERROR: Insufficient key delimiters in: .TEXTabortSTATUS: Records read: žvå„: 9&GETPARM êxˆ†\ Ëî× h`ˆ†J˜ w`‚€w`눆\ Ëî× h`ˆ†J˜ w`‚€w`눆\ Ëî× h`ˆ†J˜ w`‚€w`눆\ Ëî× h`ˆ†J˜ w`‚€ w`눆\ Ëî× h`ˆ†J˜ w`‚€w`눆\ Ëî× h`ˆ†J˜ w`‚€w`눆\ Ëî× h`ˆ†J˜ w`‚€w`눆\ Ëî× h`ˆ†J˜ w`‚€w`눆\  Ëî× h`ˆ†J˜ w`‚€w`눆\  Ëî× h`ˆ†J˜ w`‚€w`ë–Ë`„T„a¬`„-á” `„T˜” ‚€ „T˜ˆ†ß• €(rš‚€#u pšup`„0u p`u p„0짤/¦†V`ˆu p`u p`„0u p`u p„0짤/‡/€T°‡/€t° ¦†[`ˆu p`u p`„0u p`u p„0짤/‡/€T°‡/€t° ¦†Y`ˆ†J u p`u p`„0u p`u p„0짤/‡/€T°‡/€t° ¦†Z`„0u p`u p„0짤/‡/€Y°‡/€y° ¦†U`„0u p`u p„0짤/¦†P¦†H¤=`„.up`u p‡.²ñ;ˆ…Ü­†H€*ËîפS‡S‡.€ÿËćSç‡=€ÿËć=‡.¢¤=­†Hí¦†H‡.²Ôª­†HH¦†G`„.up`u p‡.²ñVˆ†0­†G ËîפS‡S‡.€*ËÄ`„0u p`u p„0짤/‡/ƒ€3ÚÔ ‡SçÄŠ‡SçÄ­†Gí¦†G‡.²Ô­†GG`„0u p`u p„0짤/`” p`” –bSRT11SRT22SRT33SRT44SRT55SRT66SRT77SRT88SRT99SRT10abortSTATUS: Reading parameter filee ¾ÏDISTRIBU„1€`„€¬ÿˆ`˜u pˆup–€‚Lˆˆ†\  Ëî× ˜” –[ˆ” p–œˆ®­瀀êñˆ†0 Ëî×yÒhŠhŠˆ†0 Ëî×yÒhŠh–"xh ˜Ò1`€—” i!瀖˜Ä!瀕˜Ä!ˆ.ëÿ!瀀ˆ®ë(" ĦÊAˆ® 瀀èÔ ˆ.˜ ˜• Ò 瀖ïŠ 瀕ïŠÒ 瀖ïŠ 瀕ï–ˆ‡€‚˜Ó`‡€‚h 怖ﮆIÔG ia‚€wa ˜€ÿwa‚€€ÿwaëÿ ìÈ ì€ È §ì È ˆ†à• ®‰)®‰)xíÄŠ ˜ï 怕ï–€‚šˆUuph–ÿÅ`„-á” €(rš‚€u p€(r¦…ۤæ…Úå­…Ú £³Ÿ¡Õ˜¤Ä„Å”‚€”(#²Ÿå¡ÔGˆU„.€ÿu pˆUu p„.‚€èñ%­‰*­‰*xíĈ†0 Ëî×x„.˜„®• „ÄŠ¤‡Ã՜孅ڲŸ ­†W Ô^­…Úí¦…Ú€(rš‚€ u pš­…Úupš‚€+u p­…ÚpÓ‚€-‚€0ˆ†ß• ‡Ä„Å”Š+¦†I• €(r€(vš‚€1u p‡Ä„Å”Š„Å”¦†I• ‹Öþ¦†X`” –Å  STATUS: Distributing ....ude_sort,psort,distribute Writing workfile # ...abort"STATUS: Writing output file... Ç0P( ÏÕMERGE /ô!‹ÓˆŠ– €ÿu pˆŠ–u p‹Àˆ‰i €ÿu pˆ‰iu p‹ªˆˆ< €ÿu pˆˆˆ…âuiŠ4ˆ„µuiŠ*ˆƒˆuiŠ ˆ‚[uiŠˆ.uiŠ ˆuiŠÖ€–Z ‹éˆŠ–ˆ†\ Ëî× ˜” ‹Ôˆ‰iˆ†\ Ëî× ˜” ‹¼ˆˆ<ˆ†\ Ëî× ˜” ‹¤ˆ‡ˆ†\ Ëî× ˜” ‹Œˆ…∆\ Ëî× ˜” Šuˆ„µˆ†\ Ëî× ˜” Š^ˆƒˆˆ†\ Ëî× ˜” ŠGˆ‚[ˆ†\ Ëî× ˜” Š0ˆ.ˆ†\  Ëî× ˜” Šˆˆ†\  Ëî× ˜” ŠÖ€–a €lÒ!ŠwˆŠ–” pŠnˆ‰i” pŠbˆˆ<” pŠVˆ‡” pŠJˆ…â” pŠ>ˆ„µ” pŠ2ˆƒˆ” pŠ&ˆ‚[” pŠˆ.” pŠˆ” pŠÖ€&Š}!ŠwˆŠ–” pŠnˆ‰i” pŠbˆˆ<” pŠVˆ‡” pŠJˆ…â” pŠ>ˆ„µ” pŠ2ˆƒˆ” pŠ&ˆ‚[” pŠˆ.” pŠˆ” pŠÖ€2–B!‹ÓˆŠ– ˜u pˆŠ–up‹Àˆ‰i ˜u pˆ‰iup‹ªˆˆ< ˜u pˆˆ–8 ‹éˆŠ–ˆ†\ Ëî× ˜” ‹Ôˆ‰iˆ†\ Ëî× ˜” ‹¼ˆˆ<ˆ†\ Ëî× ˜” ‹¤ˆ‡ˆ†\ Ëî× ˜” ‹Œˆ…∆\ Ëî× ˜” Šuˆ„µˆ†\ Ëî× ˜” Š^ˆƒˆˆ†\ Ëî× ˜” ŠGˆ‚[ˆ†\ Ëî× ˜” Š0ˆ.ˆ†\  Ëî× ˜” Šˆˆ†\  Ëî× ˜” ŠÖ€J–mi Ë®…Ú Ëkh #²Ô ! ï¡i íhŠï®†WÔ !®†Tï¡i!l–d„ Ëhˆ‹Ã  Ëî×€xå ®…Ú³Ÿ¡Ô í ËhŠáˆ‹Ã  Ëî×€xÕŸ ¤€…bˆ‹Ã  Ëî×€çëÿ í Ë®…Ú ˤ€ƒi!‡€ƒ²Ô8ˆ‹Ã! Ëî×€¤€„‡€„xÔ‡€„ç˜b˜• Ò !¤€…b‡€„çëÿ!íiŠÁˆ‹Ã®†T Ëî×€xÔ(ˆ‹Ã®†T Ëî×€¤€ƒ‡€ƒç˜b˜• Ò®†T¤€…Šˆ‹Ã®†T Ëî×€xÔ®†T¤€…Š¤€…–€„ P`„-á” „.„‚Zá” „‚[„ƒ‡á” „ƒˆ„„´á” „„µ„…áá” „…ℇá” „‡„ˆ;á” „ˆ<„‰há” „‰i„Š•á” „Š–„‹Âá” ­‰)Ĥϭ†XÔ• Š­†SpÓ‚€V‚€Yˆ†ß• €(r­†XÔš‚€Zu pŠ%š‚€ku pš­†Supš‚€zu p€(r Ë  ˤФ··вզ„‹Ã‡Î Ëî׀ćέ…Ú²‡Î­†T°­†W¡ Ôx‡Î‚€|ˆ†\‡Î Ëî× ˜ˆ†ß• ‡Ï­†ß ¤Ï„‹Ã‡Î Ëî×€¤Ñ­†ßñ9‡Î‡Ñç‡Ñç‚€€èŸ‡Î Ôá‡Ñç‚€èñ ­†Fí¦†F‡ÑćÎí¤Î‹Pÿ‡ÏÔ ­‰+Ä påÕò ˤ̈́‹Ã‡Í Ëî×€¤Ð­†XÔd‡Ðç¤Ñ„Ñ‚€‚w„чÐ瘀ÿw„Ñ‚€„€ÿw„Ñëÿ‡ÐçìȇÐçì€ È‡Ðç‡Ðç§ì ȇÐçˆ†à• Š ­†S‡Ðç­‰)­‰)xíÄ„‹Ã‡Í Ëî×€¤Ð‡Íñ=‡Í‡Ðç‡Ðç‚€…蟇͠Ôá‡Ðç‚€†èÔ‡ÐÄŠ­†Fí¦†FŠ‡ÐÄ‹ÿ ˤ͇ͲŸÕ‘„‹Ã‡Í Ëî×€¤Ð­†XÔd‡Ðç¤Ñ„Ñ‚€‡w„чÐ瘀ÿw„Ñ‚€‰€ÿw„Ñëÿ‡ÐçìȇÐçì€ È‡Ðç‡Ðç§ì ȇÐçˆ†à• Š ­†S‡Ðç­‰)­‰)xíćÐćͰÕUÿ­…Ú²ñG€(rš‚€Šu p Ë­…Ú ˤФ··вԇ΀p‡Îí¤ÎŠç­†WÔ­†T€p­†Xñ­†S€l`” „.” „‚[” „ƒˆ” „„µ” „…â” „‡” „ˆ<” „‰i” „Š–” –‘P ÿ*ÿ@ÿVÿlÿÿ–ÿ«ÿÀÿÕÿê ÿšÿ¤ÿ®ÿ¸ÿÂÿÌÿÖÿàÿêÿô ÿÿ,ÿDÿ\ÿtÿ‹ÿ¢ÿ¹ÿÐÿç ÿ†ÿ’ÿžÿªÿ¶ÿÂÿÎÿÚÿæÿò ÿ†ÿ’ÿžÿªÿ¶ÿÂÿÎÿÚÿæÿò ÿ*ÿ@ÿVÿlÿÿ–ÿ«ÿÀÿÕÿê ÿÿ,ÿDÿ\ÿtÿ‹ÿ¢ÿ¹ÿÐÿçabort!STATUS: Merging to output file...STATUS: Merging to workfile ...noabort    %STATUS: Purging intermediate files...¹ž#³/´| 5 'dô5ó: $ » ïåÈ$,¡†COPYDATAINITIALIGETFILESGETDATAFRECORDLECREATEMAGETCOPYIFIELDSYNGETTESTAUSERTESTDISPLAYTUPDATETEREADTESTREADWRITLOADSCREBUILDREC€€€€€ €€€€€€€€€€€Ð(COPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATACOPYDATA(çòçòhöÊIV0DL*5DBOÀOÀ?èè öörOÀO¼7àD´ ======================================================================================== DOCUMENT :usus Folder:VOL26:ude.1.text ======================================================================================== TABLE OF CONTENTS UNIVERSAL DATA ENTRY INTRODUCTION............................................................ 1.1 Overview ......................................................... 1.1.1 Screen Data Input................................................. 1.1.2 Screen Messages................................................... 1.1.3 Standard Screen Commands.......................................... 1.1.4 Execute Screen Functions.................................... 1.1.4.1 Changing Screen Data Fields................................. 1.1.4.2 Quitting the Current Screen................................. 1.1.4.3 Saving Screen Information on Disk........................... 1.1.4.4 Getting Screen Information from Disk........................ 1.1.4.5 USING THE UDE MAIN MENU................................................. 1.2 Getting Started................................................... 1.2.1 Selecting a Program from the UDE Menu............................. 1.2.2 Returning to the Main System Command Line......................... 1.2.3 DEFINING A UDE DATA BASE................................................ 1.3 MAINTAINING A UDE DATA FILE............................................. 1.4 Accessing the Data File........................................... 1.4.1 Performing Maintain Operations.................................... 1.4.2 Setting the Record Number......................................... 1.4.3 Adding New Records................................................ 1.4.4 Examining Records................................................. 1.4.5 Changing Records.................................................. 1.4.6 Storing Records................................................... 1.4.7 Deleting Records.................................................. 1.4.8 Mashing the File.................................................. 1.4.9 Performing Calculations........................................... 1.4.10 DEFINING A PRINTED LISTING FORMAT....................................... 1.5 Accessing the Data File........................................... 1.5.1 Creating a Printed Listing Format................................. 1.5.2 Specifying an Output File................................... 1.5.2.1 Listing Records with Certain Values......................... 1.5.2.2 Listing the Records......................................... 1.5.2.3 Exporting the Records....................................... 1.5.2.4 Creating an Export File..................................... 1.5.2.5 Export File Example......................................... 1.5.2.6 SORTING A DATA FILE..................................................... 1.6 Accessing the Data File........................................... 1.6.1 Creating a Sorting Specification.................................. 1.6.2 COPYING A UDE DATA FILE................................................. 1.7 Definition of Terms............................................... 1.7.1 Screen Definition Requirements.................................... 1.7.2 Accessing the Data Files.......................................... 1.7.3 Status Messages................................................... 1.7.4 Copying All Fields of All Records into a New Data File............ 1.7.5 Copying Only Certain Fields into a New Data File.................. 1.7.6 Copying Only Certain Records into a New Data File................. 1.7.7 Copying Additional Records to an Existing Data File............... 1.7.8 Merging Selected Fields into an Existing Data File................ 1.7.9 Deleting Unwanted Records From a Data File........................ 1.7.10 DEFINING A SCREEN FORMAT................................................ 1.8 Introduction...................................................... 1.8.1 Main Option Menu............................................ 1.8.1.1 Clear Current Screen Definition................................... 1.8.2 Edit Screen Definition File....................................... 1.8.3 Field Definition Input Mask................................. 1.8.3.1 Prompt Definition Input Mask................................ 1.8.3.2 Edit Options................................................ 1.8.3.3 Get Old Screen Definition......................................... 1.8.4 Screen Definition Example................................... 1.8.4.1 Print Screen Definition File...................................... 1.8.5 Printing the Current Screen Definition...................... 1.8.5.1 Quit.............................................................. 1.8.6 Save the Current Screen Definition File........................... 1.8.7 UNIVERSAL DATA ENTRY 8/82 1. UNIVERSAL DATA ENTRY 1.1 INTRODUCTION 1.1.1 Overview Universal Data Entry (UDE) enables users with little training to enter data into computer files which can later be sorted, printed, or accessed by other programs for data processing. This applications program is designed to run only under the UCSD p-SYSTEM (TM). Prompts are provided at fields in which data is to be entered; and, if an error is detected, the user is advised. The screen prompts are created by the user with the help of the UDE Define function (see section 1.8). The UDE system is comprised of five programs: Define, Maintain, Sort, List and Copy. Define allows the user to set up the screen and record layout of a data file. Maintain collects data and enters it into a file which may be scanned to change or delete a record. Sort is used to sort the records by field. Up to ten fields may be used as keys, and each field may be sorted in ascending or descending order. The user may put the sorted results into a new file if the data needs to be saved in its original form. The keys used for sorting may also be stored for subsequent use. List allows the user to list the records in a UDE data file on a line or letter-quality printer. The list format is user-defined and allows choosing the headings and footings which are to appear at the tops and bottoms of pages, which fields and records are to be printed, and which headings are to appear above each field. Format information may be saved for use in printing other data. List also allows a user to "export" data into a text file to do custom letter writing or address lists. Copy allows the user to copy data from selected fields and records of a UDE data file to another UDE data file. UDE may also be used in conjunction with other programs which read data and process it by means of specially-prepared software. Finally, UDE can collect data for transmission to other computers for storage or processing. UDE can be used for name and address lists, inventory records, appointment calendars, purchase order records, payroll records, and many other business problems. To use UDE for a particular application, start the program by executing the program UD/UDE.CODE. Define a data file using the UDE Define function and specify the information (numbers, dates, names, addresses, amounts, descriptions, etc.) needed in the data file. This process is very similar to designing a manual filing system and takes only a few minutes to accomplish. Having defined a data file format, create the data file and enter information using the Maintain function. Once entered, any record can be examined, changed or deleted. Information in the data file can be sorted, printed or copied as required with the Sort, List and Copy functions. UDE for the p-SYSTEM is made up of the following programs: UD/UDE.CODE - Allows the user to choose the UDE function that is to be performed. SD/DEFINE.CODE - Defines the screen and record layout of a data file. UD/MAINT.CODE - Creates a data file if necessary and maintains records in the data file with add, examine, delete and modify commands. UD/SORT.CODE - Sorts data file records. This program requires the file UD/SORT.SCRN be available on the prefixed disk. UD/LIST.CODE - Lists the active records in the data file. This program requires the file UD/LIST.SCRN to be on the prefixed disk. UD/COPY.CODE - Copies all or part of a UDE data file to another UDE data file. 1.1.2 Screen Data Input A defined UDE data file will appear on the screen as a number of prompts followed by values. *********************************************************************** UDE Data File Example 1 1st prompt:value1 2nd prompt:value2 3rd prompt:value3 4th prompt:value4 *********************************************************************** The rest of the information is prompts that the user does not change. For instance, a UDE data file could be set up to store customer names, addresses and telephone numbers. The prompts on the screen might look like: ************************************************************************ Customer Data File Name: _________________ Telephone number: ___________________ Street: _________________________________ City: _______________ State:___ Zip: __________ *********************************************************************** Each piece of information the user enters on the screen is known as a field. So there is a name field, a telephone number field, and so on. All the fields on the screen, when taken together, are known as a record. All the records are called the data file. UDE collects all its records by presenting the screen to the user to be filled in. There is more information on entering records into UDE in the Maintain section. There are also some special keys that are used when entering data. These special keys are explained in section 1.8. 1.1.3 Screen Messages During the operation of UDE the following types of messages may be displayed in the right half of the last line on the screen. STATUS: Indicates the status of an operation. ERROR: Indicates an error has occurred. WARNING: Indicates the operator is about to perform a dangerous operation. ACTION: Indicates some action is required by the operator to continue. 1.1.4 Standard Screen Commands Some of the screens displayed by UDE programs have the following standard commands at the bottom of the screen. All other commands, unique to a certain UDE function, will be explained later. 1.1.4.1 Execute Screen Functions When the eXecute command is in the lower left of the UDE screen, pressing will execute the function indicated by the screen display. 1.1.4.2 Changing Screen Data Fields When the Change command is in the lower left of the UDE screen, pressing will allow changing the values in the data fields on the screen. The cursor will be put at the beginning of the first field. 1.1.4.3 Quitting the Current Screen When the Quit command is in the lower left of the UDE screen, pressing allows the user to exit the current operation. 1.1.4.4 Saving Screen Information on Disk When the Save command is available in the lower left of a UDE screen, pressing will save the screen data. By keeping this information and using it when the same operation needs to be done again, time is saved and the possibility of error is reduced. The Save screen looks like: *************************************************************** SAVE SORTING (or PRINTING) FORMAT ================================= Volume : ___________ Name : _________________ Type : SORT (or LIST) to execute, to abort *************************************************************** If Volume is left blank it will default to the prefixed volume. Name can be any valid file name. Type is either LIST or SORT depending on what is to be saved. These fields may already be filled from a previous Get or Save operation. Press to perform the save operation. If the data in the screen was not saved due to a full disk, damaged disk or other error, a message will be displayed. Press to abort the Save operation and return to the previous menu. 1.1.4.5 Getting Screen Information from Disk The Get command assumes that a format has already been saved using a Save command. When the Get command is available at the lower left of a UDE screen, pressing loads the screen with data. It can then be used, changed or corrected. The Get screen looks like this: *************************************************************** GET PRINTING (or SORTING) FORMAT ================================ Volume : ___________ Name : _______________ Type : LIST (or SORT) to execute, to abort *************************************************************** If Volume is left blank it will default to the prefixed volume. Name can be any valid file name. Type is either LIST or SORT depending on what is being loaded. These fields may be already filled from a previous Get or Save operation. Press to perform the Get operation. If the data in the screen was not loaded due to an incorrect file name, damaged disk or other error, a message will be displayed. Press to abort the Get operation and return to the previous menu. 1.2 USING THE UDE MAIN MENU 1.2.1 Getting Started UDE may be started by executing the file UD/UDE.CODE. 1.2.2 Selecting a Program from the UDE Menu The UDE menu displays a list of programs on the screen and allows the operator to choose the program desired. All programs are described in detail in the appropriate sections of this manual. *************************************************************** UNIVERSAL DATA ENTRY ==================== Define a UDE data file Maintain a UDE data file Sort a UDE data file List a UDE data file Copy a UDE data file Enter selection or : *************************************************************** 1.2.3 Returning to the Main System command line Return to the main system command line by pressing . ======================================================================================== DOCUMENT :usus Folder:VOL26:ude.2.text ======================================================================================== 1.3 Defining a UDE Data File The format of a data file must be defined by the user. To define a data file format, press from the UDE menu. An explanation of the Define function is found in section 1.8. The format may consist of up to 40 fields, as long as the total number of characters in the format is 250 or less. Because the last two lines of the screen are used for messages, they should not be used in the format. 1.4 MAINTAINING A UDE DATA FILE Maintaining a UDE data file includes adding, changing, or deleting records that have been defined. 1.4.1 Accessing the Data File When an is pressed while in the main UDE display, the following screen appears: ***************************************************************** MAINTAIN A DATA BASE ==================== Volume : _________ Name : ____________ Type : SCRN and TEXT to execute, to abort ***************************************************************** The UDE data is kept in two different files: a file ending in .TEXT for storing data, and a file ending in .SCRN for storing the UDE screen description. After entering the volume and name fields, press . If the SCRN file is not found, an error message is displayed. If the TEXT file is not found, the program asks if it should create a new data file. If the answer is yes, the next prompt is: Maximum number of records ?_0_______ The absolute maximum number of records in a data file is 32767. Enter whatever number is most appropriate for that data file, keeping in mind that the only way to expand a data file with all its records filled is to copy it into a new, larger data file. Entering an unacceptable number will result in an error message. When the TEXT file is available for storing data, the UDE screen layout, created with the Define program, is displayed and the following prompt appears at the lower left of the screen: Rec # <1__>, Add, Mash, Store, Examine, Change, Delete, Quit ? 1.4.2 Performing Maintain Operations Select the operation to be performed by pressing the appropriate key, either , , , , , or . When all operations have been performed, will return the user to the main menu. 1.4.3 Setting the Record Number Select the Rec # command by pressing . This allows access to the data file by record number. The current record number is displayed in this field as the data file is being maintained. When a new record number is entered, press to get to the main prompt line. To view the record, press to examine. If an incorrect number is entered, an error message is displayed. 1.4.4 Adding New Records Select the Add command by pressing . This puts the operator in the Add mode of operation, finds the first blank record after the current record number and clears all the data fields to blanks or to the proper default values. When all the data fields have been properly filled in, press to add the record to the data file and automatically find the next blank record. This will also perform any calculations defined in the record and put the results in the proper fields. Press to leave the Add operation. If the end of available space is reached, Add terminates with a message. There may, however, be more empty records available for input. To find them, return to record number one by using the command and press to add. 1.4.5 Examining Records Select the Examine command by pressing to display the record whose number is in the Rec # field. That number can be changed by using the Rec # command. Continuing to press the increments the record number by one, allowing examination of successive records. 1.4.6 Changing Records The user may change the contents of any record by displaying the record on the screen and pressing the to Change. This will move the cursor to the beginning of the first field and the user may go from field to field, changing whatever information is desired. When complete, press the key to return to the UDE Maintain prompts. The calculations defined for that record will be performed and the results displayed. In order to save the changed information in the file, the Store command must be performed. 1.4.7 Storing Records Select the Store command by pressing to store the data on the screen in the record number indicated. This command is used to modify existing records or to add single records to the data file without going into add mode. 1.4.8 Deleting Records Select the Delete command by pressing to delete the record pointed to by the record number. The fields of the deleted record are filled with blanks on the screen and a blank record is written on the disk. It is not possible to recover data that has been deleted with this command. 1.4.9 Mashing the File When the user wants to move all non-blank records to the beginning of the file, this can be done by pressing . This will consolidate all empty records at the end of the file. It is very important that the user not disturb this operation until it is complete. 1.4.10 Performing Calculations If a field is defined as calculated, the calculation will be performed when the record is Added or Changed. A few things must be kept in mind when a field is calculated. The maximum size of a number that can be calculated is nine digits to the left of the decimal point and four digits to the right. This means that it is not possible to calculate numbers smaller than .0001 or greater than 999999999. An overflow message will appear if too large a number is calculated and the result will be set to 0. The field size must be large enough to store the integer part of the calculated value or an error message will appear and the field value will be set to 0. There will always be at least one digit to the left of the decimal point, ie. 1/3 is calculated as 0.3333. If the field is not wide enough to hold the calculated number and there are any digits to the right of the decimal point, the program will attempt to store it anyway. For instance, if the calculated value is 100.2365 and the field width is only six, the program will truncate digits to the right of the decimal point until the value fits in the field. In this case, 100.23 will be the stored value. No rounding of the number is attempted. To avoid the problem, define fields with enough width to contain the calculated numbers. 1.5 DEFINING A PRINTED LISTING FORMAT The format for listing UDE data records includes the fields to be listed, their order, and the titles and footings to be put on each page. 1.5.1 Accessing the Data File When an is pressed while in the UDE main display, the following screen will appear: ******************************************************** PRINT A DATA FILE ================= Volume : ________ Name : ____________ Type : SCRN and TEXT to execute, to abort ******************************************************** Two types of files are required to print a data list: a TEXT file for storing data, and a SCRN file for storing the UDE definition. Input the volume and name fields, then press . If the SCRN file or TEXT file is not found, an error message is displayed. 1.5.2 Creating a Printed Listing Format When the desired data list has been found, the following screen will appear: ************************************************************* PRINTED LISTING FORMAT ====================== Printer Width : 132 Heading Number 1 : _____________________________________________ Heading Number 2 : _____________________________________________ Heading Number 3 : _____________________________________________ Col # Field Id Column Title 1 ________ ________________________________________ 2 ________ ________________________________________ 3 ________ ________________________________________ 4 ________ ________________________________________ 5 ________ ________________________________________ 6 ________ ________________________________________ 7 ________ ________________________________________ 8 ________ ________________________________________ Footing Number 1 : _____________________________________________ Footing Number 2 : _____________________________________________ Footing Number 3 : _____________________________________________ Get,Save format,Output file, Change,Export,List,Tests,Quit ? ************************************************************* Printer Width specifies the maximum number of characters that may be printed across the page. If the field widths or column title widths add up to more than this value, an error message is given. Up to three page headings may be specified in the Heading data fields. These headings will appear centered on the top of each report page. The Field ID's to be listed and the Column Title's to appear above each column of printed data are entered in their respective columns. If a "#" is placed instead of a Field ID, the record number will be printed when the report is generated. Up to three page footings may be specified in the Footing data fields. If a "#" is entered in place of a normal footing, the pages of the report will be numbered at the bottom when the report is generated. The footings and page number are centered at the bottom of each page. The commands available at the bottom of the screen allow the user to save the data on the screen, get data to fill in this screen from disk, change the data fields on the screen and return to the main system. The Get, Save, Change and Quit commands are described in section 1.1.4 of this document. 1.5.2.1 Specifying an Output File The Output file command allows the user to name the file in which to place the listing. It needs to be performed only if the user wants to send the listing to a file, rather than directly to the printer. If no Output file command is performed, the List output will be sent to the printer. If the user presses , the following display appears: ***************************************************************** OUTPUT FILE NAME ================ Volume : ________ Name : ____________ Type : ____________ to execute, to abort ***************************************************************** Any file name or type is acceptable here. However, it is possible to destroy files that already exist; it would be very easy at this point to copy over the UDE data file. BE CAREFUL! The user may perform the Output file command any number of times. To make the output go directly to the printer after a file has been defined, perform the Output file command and clear all the fields of the file name. ======================================================================================== DOCUMENT :usus Folder:VOL26:ude.3.text ======================================================================================== 1.5.2.2 Listing Records with Certain Values It is also possible to list or export only certain records of a data file. If for Tests is pressed, the following screen will appear: ***************************************************************** Comparison tests to be made on fields of each record: Choose from the following fields: FIELD ID OPERATOR VALUE ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ ________ _____ _____________________________________ Valid operators are: < , > , = , <= , >= , or <> Currently viewing tests 1 - 13 Get, Save tests, Change, Next, Back, Quit: ***************************************************************** Up to 52 tests can be performed on the fields of each record to determine whether or not that record should be listed (or exported). If the Tests command is not used before a List or an Export, or if the user leaves all of the 52 tests blank, the program will assume it is to list or export all records. Each test consists of a field id, an operator and a value. On the right hand side of the screen is a list of all valid field ids. Any of the field ids in that list may be used in the tests and any may be used more than once. The valid operators given on the screen have the following meanings: < less than > greater than = equal to <= less than or equal to >= greater than or equal to <> not equal to As an example, the field id ZIPCODE could be tested for ZIPCODE > 10000 and ZIPCODE < 20000 These tests would select all records with ZIPCODE fields between 10000 and 20000. An error message will be displayed if an invalid field id or operator is entered or if the length of an entered value exceeds the maximum allowable. To recover from an error, reenter the correct field id, operator or value. Only thirteen tests appear on the screen at one time, the rest may be entered or examined by using the Next and Back commands. When first displayed, tests 1 - 13 are available for viewing and the line "Currently viewing tests 1 - 13" is displayed. If the user presses N for Next, tests 14 - 26 appear. If B for Back is pressed, tests 1 - 13 reappear. The Get and Save commands allow tests to be saved to a disk file for subsequent reuse. The operation of these commands is the same as that of the commands described in sections 1.1.4.4. and 1.1.4.5. When all of the tests have been entered, press . If two or more tests have been entered, the following screen will be displayed: ***************************************************************** List or export each record if: 1) All of the above tests have been met 2) Any of the above tests has been met Enter 1 or 2 : ***************************************************************** The user must respond correctly to the above prompt to get the desired result. For example, to select all records with ZIPCODE fields between 10000 and 20000, as in a previous example, the following tests would be entered: ZIPCODE > 10000 and ZIPCODE < 20000 The proper response to the above prompt would be a 1 in this case because both tests should be true if the record is to be copied. If a 2 were entered, all records would be listed because all records would pass either one or the other or both of the tests. To select all records with ZIPCODE fields equal to either 10000 or 20000 the following tests would be entered: ZIPCODE = 10000 and ZIPCODE = 20000 Since a record should be listed if either of the two tests is met, the proper response to the above prompt would be a 2. A response of 1 would result in no records being listed because no record could have a ZIPCODE field equal to both 10000 and 20000. After a response is received to the above prompt, the program will return to the "Printed Listing Format" screen. A subsequent List or Export will use only those records that pass the comparison tests. 1.5.2.3 Listing the Records Pressing to execute the List command will list all active data list records or the records determined by the tests. The listing will go to the printer unless a file name was specified in the Output file command. If the width of all the user fields is longer than the Print Width, an error is given. The user may then change the number of fields to be listed, or if possible, change the printer width field. If the output is sent to a file, the file is closed and saved when the command is complete. It may be printed later. If this file name is used again as an output file, the contents of the first list will be overwritten by the contents of the second. 1.5.2.4 Exporting the Records By pressing for Export, the user can take selected fields from the data file and print them as part of another form or letter. The format in which the exported records are printed is determined by a special text file which must have been created previously by the user with the text editor. Upon entering the Export command the user will be prompted with: ***************************************************************** EXPORT FILE NAME ================ Volume : _________ Name : ------------- Type : TEXT to execute, to abort ***************************************************************** Enter the name of the export format file. Its name must end in .TEXT. When is pressed the export will begin. If the Output file command was used, the exported output will be written to the file specified, otherwise it will be sent to the printer. When the export is complete, the user will be returned to the Printed Listing Format display. 1.5.2.5 Creating an Export file. Prior to executing Export the user must create a special file using the text editor. The file may contain anything desired from a business letter to a simple format for an insertion file. 1.5.2.6 Export File Example An example of an export file that is a format for a business letter is: June 20,19__ {*FIRST*} {*LAST} {*CONAME} {*ADDR} {*CITY*}, {STATE} {ZIP} Dear {*FIRST}, Thank you for inquiring about the line of quality products. I'm sure that you will find that our line of {*ITEM*} is just what you need. Enclosed is a current price list along with a general description of each item on the list. I look forward to doing business with you, {*FIRST*} and {*CONAME*} in the near future. If you need any futher information, please feel free to call me. Bob Updyke{12} The output then, might look like this: June 20,19__ John Customer INT.ENT. 1111 N.W. Hwy Dallas, Tx 75211 Dear John, Thank you for inquiring about our line of quality products. I'm sure that you will find that our line of microscopes is just what you need. Enclosed is a current price list along with a general description of each item on the list. I look forward to doing business with you, John and INT.ENT. in the near future. If you need any futher information, please feel free to call me. Bob Updyke The names in the curly braces indicate that the value of the field by the name enclosed should be inserted in the text at that point. On the third line, the first and last name of the customer was to be printed one line below the date. An asterisk before the ID name indicates that any blanks before the field should not be printed (" John " would be printed "John"). An asterisk after the ID name indicates that any blanks to the right of the field should not be printed (" John " would be printed " John"). An asterisk before and after the ID name indicates that blanks on either side of the field should not be printed (" John " would be printed "John"). Placing a number inside a set of curly braces causes the insertion of a character whose ASCII code is that number. It is primarily used to generate special characters required by other computers for communications. It is used here to send a top of form character to the printer after each letter is printed. 1.6 SORTING A DATA FILE 1.6.1 Accessing the Data File When is pressed while in the UDE main display, the following screen appears: ******************************************************** SORT A DATA BASE ================ Volume : _________ Name : ______________ Type : SCRN and TEXT to execute, to abort ******************************************************** Two types of files are required to sort a data file, a TEXT file that contains data, and a SCRN file containing the UDE definition. Enter the volume and name, then press . If the file ending in .SCRN or the file ending in .TEXT is not found, an error message is displayed. 1.6.2 Creating a Sorting Specification After the data file has been located, the following screen will appear: *********************************************************** SORT A DATA BASE ================ Sort Seq. Field Id Asc/Dsc OUTPUT FILE (If different) 1 _______ A 2 _______ A Volume : _______ 3 _______ A 4 _______ A Name : __________ 5 _______ A 6 _______ A Type : TEXT 7 _______ A 8 _______ A 9 _______ A VOLUME FOR WORK FILES 10 _______ A (If different) Volume : ________ Get format, Save format Change, eXecute, Quit ? *********************************************************** The Field ID's to be sorted and the sort sequence are defined in the Field Id column. The names entered must be spelled exactly the way they were in the Define program. The sorting sequence for each data field, either ascending order or descending order, is specified in the Asc/Dsc column. A D (or d) indicates descending order. An A, a blank or any other character indicates ascending order. A new UDE data file of the sorted material can be created by entering the OUTPUT FILE information. The volume entered under OUTPUT FILE does not need to be on-line when the program is executed. When it is time for the output file to be written, the program will ask the user to put the volume that is to receive the output file into the disk drive. In any case, the workfiles, if any, must be written to a disk that is to remain on line at all times. If the OUTPUT FILE fields are left blank, the new sorted data file replaces the old unsorted file. It should be noted, however, that the program does not create a new SCRN file. To use the new data file, the user must make a copy of the old SCRN file by transferring it to a file with the new output file name and a SCRN type. The standard commands available at the bottom of the screen allow the operator to save the data on this screen, get data to fill in this screen from disk, change the data fields on the screen and return to the main command line. These standard UDE commands are described in section 1.1.4 of this document. While sorting, the computer may not be able to store all the records in memory. When this occurs, temporary work files must be written to a disk. If the prefixed disk is short on space, specify another disk as the work file volume using the VOLUME FOR WORK FILES field. The workfiles require approximately as much space as that taken up by the file to be sorted. Press the to execute the sort operation. Approximately 200 records can be sorted in 15 minutes and 1000 records in one hour. The maximum file size that can be sorted is limited only by disk space. There must be sufficient space for the workfiles on their destination disk and for the output file on its destination disk. The final sorted file will be the same size as the previously unsorted database. 1.7 COPYING A UDE DATA FILE The Copy Data File program has the following features: * Data may be copied from a UDE data file into a UDE data file * Data may be copied from any or all records of a data file * Data may be copied from any or all fields of a record * Fields may be tested for certain values before copying * Additional records may be copied to an existing data file * Fields from records of one data file may be combined with fields from records of another The data file that is to be copied from must, of course, already exist. The UDE data file that is to be copied into must be defined before the copy is begun. This is done with the UDE Define function. Data may be copied into a file with no existing data records or into one that already has data. ======================================================================================== DOCUMENT :usus Folder:VOL26:ude.4.text ======================================================================================== 1.7.1 Definition of terms The following terms are used frequently in describing Copy Data File. Data file - A set of two files, one thats name ends with .SCRN and one that ends with .TEXT, used by the UDE programs to store data. UDE SCRN file - A file created by the UDE Define program thats name ends with .SCRN. This file contains all the necessary information describing the screen prompts and the size, number, type and length of data fields in a UDE data file. UDE TEXT file - A file created by the UDE maintain program ending with .TEXT. This file contains the actual data of a UDE data file, arranged in records. Data field - The individual pieces of data that the user enters into the UDE data file from the screen. The user defines the characteristics of a data field in the screen definition program which is described in Section 1.8. Record - All the data fields together on the screen make up one UDE record. A record may have up to forty data fields. Field id - The name given to a data field in the screen definition program. These names are used in the List, Sort and Copy routines. 1.7.2 Screen definition requirements Data from a field in one data file can be copied to a field in another data file only if the two fields have the same field id. This does not mean that the screen definitions of the two data files must be identical. Each of the data files may contain field ids not present in the other, but only fields common to both of the data files will be eligible for copying. Data may be copied between two fields of different types as long as the actual data to be copied is of the proper type. For example, numeric data from an alphanumeric type field may be copied to a numeric type field. An error message will be displayed and the program will terminate if an attempt is made to copy improper type data to a field. Data may also be copied between two fields of different lengths. If a field is not large enough to hold all of the data being copied to it, the following prompt will appear: One or more of the fields is not large enough to hold all of the data being copied to it. Proceed anyway? (Y/N): If the response is , as many characters as the field will hold will be copied, starting from the left. All excess characters on the right will be ignored. If the response is the program will terminate. This prompt will be displayed only once during the execution of the program. 1.7.3 Accessing the data files Before the copy is started, the user will normally define a new UDE form by using the UDE Define function. After the new form has been defined, press a while in the main UDE display and the following screen appears: **************************************************************** COPY A DATA FILE ================ DATA FILE TO COPY FROM Volume : ________ Name : ____________ Type : SCRN and TEXT DATA FILE TO COPY TO Volume : ________ Name : ____________ Type : SCRN and TEXT to execute, to abort **************************************************************** After entering the volume and name fields for each data file, press . If the program cannot find the "from" text file or either of the files ending in .SCRN, an error message is displayed. If the data file to be copied to contains no TEXT file, the program asks if it should create one. If the answer is yes, the next prompt is: Maximum number of records? _0__________ The absolute maximum number of records in a data file is 32767. The maximum number of records in the new TEXT file may be greater than, less than, or equal to the number of records in the TEXT file to be copied from. 1.7.4 Status messages When the program begins copying, the following message will appear as each record is copied: STATUS: Copying record# X where X is the number of the record that data is currently being copied from. By watching the messages, the user will be able to estimate the amount of time the copy will take. The amount of time required is heavily dependent upon the size and number of fields in the data file records. When finished copying, the program will display a message indicating the number of records copied. If there was not room to copy all records to the output file, the program will display a message indicating the number of records copied before the output file became full. 1.7.5 Copying all fields of all records into a new data file This section describes how to copy one data file, as is, into a new, larger or smaller data file. The user begins by either creating a new .SCRN file with UDE Define, or, if the definition of the new file will be exactly the same as the old, the Filer may be used to make a copy of the .SCRN file into another file that ends in .SCRN. Because this is a new data file, the user will be asked how many records are to be in the data file; it will then create that many records in a file thats name ends in .TEXT. The program will display the following prompt: Do you wish to copy all fields common to both data files? (Y/N): Y Since all fields are to be copied, press either or . The next prompt will be: Are fields to be tested for certain values before record is copied? (Y/N):N Press either or since all records are to be copied. The following prompt will then appear: Copy blank records? (Y/N): N In a UDE file, blank records are defined to be those records deleted with the Delete function of the UDE maintain program or those records of a file that have never been used. If the reponse to the above prompt is a , the program will copy blank records to the output file, if the response is an it will not. If the data file being copied from has no blank (deleted) records among the non-blank records, this operation will have no effect. Upon recieving a response to the above prompt the program will begin copying. 1.7.6 Copying only certain fields into a new data file To copy only certain fields of all records into a new data file, follow this procedure. Any fields that are not copied to will be left blank. Again, begin by defining a new .SCRN file with UDE Define. Then begin the Copy command and tell how many records are to be in the data file. After creating the new .TEXT file, the program will display the following prompt: Do you wish to copy to all fields common to both data files? (Y/N): Press and the following screen will appear: **************************************************************** The following fields are common to both data files. Indicate those fields whose information is to be copied (Y/N) FIELD1 Y FIELD2 Y FIELD3 Y FIELD4 Y . . . . . . to execute, to abort **************************************************************** If the information in the field is to be copied into the new file, there must be a Y in the the space next to the field id. Otherwise the information in that field will not be copied. The remaining prompts will be the same as those for copying all fields as described in section 1.7.5. 1.7.7 Copying only certain records into a new data file The prompts are the same as those described in section 1.7.5 for copying all fields. Respond the same way but with one exception. When the following prompt appears: Are fields to be tested for certain values before record is copied? (Y/N): Respond and the following screen will appear: ***************************************************************** Comparison tests to be made on fields of each record: Choose from the following fields: FIELD ID OPERATOR VALUE ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ ________ ____ _______________________________ Valid operators are: < , > , = , <= , >= , or <> Currently viewing tests 1 - 13 Get, Save tests, Change, Next, Back, Quit: ***************************************************************** Up to 52 tests can be performed on the fields of each record to determine whether or not that record should be copied. It should be emphasized that these tests determine whether or not the record is copied, they do not determine which fields of the record are copied. Refer to section 1.7.6 for instructions on indicating which fields of a record are to be copied. The operation of these tests is the same as that of the tests described in detail in section 1.5.2.2 on the UDE List function. When all of the tests have been entered, press . If two or more tests have been entered the following screen will be displayed: ***************************************************************** Copy each record if: 1) All of the above tests have been met 2) Any of the above tests has been met Enter 1 or 2 : ***************************************************************** The user must respond correctly to the above prompt to get the desired result. Please refer to section 1.5.2.2 for an explanation of this prompt. The remaining prompts in the series will be the same as those described in section 1.7.5. 1.7.8 Copying additional records to an existing data file The program allows additional records to be appended to the end of an existing UDE data file. After the program accesses the data files, the following prompt will be displayed: Data file has existing records. Do you wish to delete them? (Y/N): Enter an so that the records will not be deleted. The next prompt will be: Do you wish to add the new records at the end of the data file? (Y/N): Y Press either or . The additional records will be copied to a location in the data file just after the last non-blank record (regardless of any blank records that are mixed in with the non-blank records). Blank records are defined to be those records deleted with the Delete function of UDE Maintain or those records of a file that have never been used. The remaining prompts will be the same as those described in section 1.7.5. If there is not enough room to copy all records to the file, a message will be displayed indicating the number of records copied before the file became full. 1.7.9 Merging selected fields into an existing data file The program will allow data to be copied to selected fields of an existing UDE data file, leaving those fields not copied into undisturbed. Be very careful when using this feature. When using the program for this purpose, the user should be sure that each record to be copied from the first data file will merge with the proper record from the second data file. After accessing the data files, the program will display the same two prompts as described in the section on copying additional records to an existing data file, section 1.7.8 above. Respond with an to both of the prompts and the following note will appear: NOTE: Any fields of the existing data file that are not copied to will be left intact. Do you wish to proceed? (Y/N): Press to continue, to terminate the program. The remaining prompts will be the same as those described in section 1.7.5. Respond as necessary to copy the desired fields and records to the existing data file. 1.7.10 Deleting unwanted records from a data file The program may be used to remove unwanted records by copying to and from the same UDE data file. After accessing the data files, the program will display the following prompt: Data file being copied to has existing records. Do you wish to delete them? (Y/N): It is appropriate to respond to this prompt even when copying to and from the same data file. None of the original records of the file will be deleted until all of the desired records have been copied. The program copies the new records to the beginning of the data file, writing over any of the original records. Only after copying all of the desired records are the remaining original records deleted. Refer to section 1.7.7 for instructions on testing fields of records for certain values. Warning: Copying to and from the same file is a dangerous operation. It is not possible to recover accidentally deleted records. See section 1.7.4 for an explanation of the STATUS messages displayed while the program is copying. 1.8 DEFINING A SCREEN FORMAT 1.8.1 Introduction The define program may be run by executing the file SD/DEFINE.CODE. This program will allow the user to define an input mask by entering a description of the input fields required and their position on the screen. This definition also serves as the model for creating data files in the Universal Data Entry program. 1.8.1.1 Main Option Menu SCREEN DEFINITION ================= Version IV.0 Clear current screen definition Edit screen definition file Get old screen definition file Print screen definition file Quit Save current screen definition SELECTION : _ The Define program has a Main menu that allows access to the various functions neccessary to define, maintain, and store a screen definition file. The bold capital letters in the Main menu and lower level prompt lines indicate the keys which must be pressed to execute the options at that level. A description of each function follows. 1.8.2 Clear current screen definition Pressing the key from the Main menu clears all files and variables in the define program as if the user had just executed the program. It is recommended that users execute the clear function after saving a screen definition before defining another. ======================================================================================== DOCUMENT :usus Folder:VOL26:ude.5.text ======================================================================================== 1.8.3 Edit screen definition file 1.8.3.1 Field definition input mask The Edit option uses the following Data Field input mask to input information required for defining a data field: DEFINE DATA FIELD - - - - - - - - - Field ID Name : _______ Auto Skip (T/F) : _____ Field Type (C/D/I/V) : __ Justify (L/R/N) : __ Row / Column Number : __/__ Alpha-Numeric (A/L/N/S) : __ Field Length : __ Minimum Input : ___ Default/Calculation : ________________________ The field ID name is a mnemonic used to identify the various data fields in a screen definition file. The ID name may be any combination of 8 letters or numbers but must be unique for each data input field. The auto skip option determines whether the cursor should automatically skip to the next field in the screen file when the last character in that field is input or whether the cursor should stop on that last character and signal that the end of the field has been reached by ringing the alarm bell. A data field may be one of four possible types: Calculation, Duplicate, Index, Variable. A Variable field allows the information in the the field to vary as the user likes. An Index field allows the field value to vary. Some programs, such as the Data Base Manager, use this field as an index into the data base, requiring that the value of this field be unique for each record. A Duplicate field is an index field that is not required to be unique for the data base. A Calulation field does not allow input but reflects the result of a numeric expression involving other numeric data fields in the file. All fields in a screen definition file should be Variable unless another type is specifically required. The default field type is Variable. The data field contents may be displayed right or left justified within the field by specifying jusification as Left, Right, or None. Numeric fields are usually right justified while alphabetic fields are normally left justified. Be aware that justification of numbers, especially decimal values, may affect sorting. The row and column numbers indicate the location of the field on the console screen and are restricted by the console screen size. Row numbers are normally between 0 and 23 inclusive while column numbers are between 0 and 79 inclusive. Information accepted by the data field may be restricted by specifying the input type as follows: Alphanumeric - Accepts any Numeric or Letter character. Numeric - Accepts number 0-9,a decimal point, or a plus or minus sign. Letters - Accepts letters of the alphabet, a hyphen, or a period. Special - Accepts any character on the keyboard except vector keys. The field length indicates the maximum number of characters the field may accept. The maximum data field length is forty(40), the default is zero(0). The user may also specify the minimum number of characters the field must accept which may not be less than zero or more than the field length. The default minimum is zero (0). The user may specify a constant default value for the Variable, Index, and Duplicate fields by entering a string whose length is less than the maximum field length in the Default/Calculation input field. The value of another data field may be used as the default by entering the name of the default field enclosed in square brackets in the Default/Calculation input field instead of a constant default string. Numeric expressions for Calculation fields may be any valid algebraic expression using the four basic operators: addition (+), subtraction (-), multiplication (*), and division (/), the ID names of any numeric data fields in the current file, numeric constants, and parenthesis. The value of a data field ID name in the expression is assumed to be zero if the data field ID name is not a member of the screen file or is not a valid number. When all the necessary information has been entered, the user may press the key to return to the edit option level. If the key is pressed, the information entered is ignored and the previous field definition is redisplayed. 1.8.3.2 Prompt definition input mask DEFINE PROMPT FIELD - - - - - - - - - - Prompt Number : __ Row Number : __ Column Number : __ Prompt : __________________________________________ The prompt definition input screen functions similarly to the data field definition input screen. The prompts are numbered according to their positions on the console screen and may be referenced by this number. The row and column numbers indicate the location of the prompt field on the console screen and are restricted by the console screen size. Row numbers are normally between 0 and 23 inclusive while column numbers usually are between 0 and 79 inclusive. The prompt text may be any string of up to forty(40) characters. Prompt fields may be used for any purpose the user desires (i.e. as prompts for data fields, titles, borders, or decoration). They do not affect the value of the data fields in any manner but may affect their display if their locations overlap. Pressing the key returns the user back to the edit option prompt line. Pressing the key causes the information to be erased and replaced with the previously displayed prompt field definition. 1.8.3.3 Edit options The input mask displayed on the screen at run time indicates whether the user is in the Field or Prompt mode. Just below either one is the edit prompt line whose bold letters indicate which keys must be pressed to execute the various edit options. The edit prompt line appears as follows : Upper Field Add Back Examine Test Lower Prompt Delete Next Change Quit: The edit options are described as follows: Add - Instructs the program to add the prompt or field definition shown to the screen definition file. Back - Displays the previous prompt or field definition. Change - Allows the user to change the prompt or field definition shown. Delete - Instructs the program to search for the ID name or prompt number shown and remove it from the screen definition file. However, the field or prompt definition remains on the screen, allowing the user to change it and then add it back to the file. Examine - Instructs the program to display the definition of the ID name or prompt number currently showing on the console screen. (i.e. Press the key, change the field name, press the key, then press the key to examine the field definition for the ID name just entered). Field - Instructs the program to display the field definition input mask. Lower - Instructs the program to position the field or prompt input mask on the upper half of the console screen thus allowing the user to view the lower half of the screen file currently being defined. Next - Displays the next prompt or field definition. Prompt - Instructs the program to display the prompt definition input mask. Quit - Instructs the program to return to the Main menu level. Test - Allows the user to see how the screen definition file will run when used by an outside program. The input mask is removed from the console screen and the user may test the current screen definition. When the or key is pressed the input mask is redisplayed and more prompts or fields may be added, changed or deleted. Upper - Instructs the program to position the field or prompt input mask on the lower half of the console screen thus allowing the user to view the upper half of the screen file currently being defined. 1.8.4 Get old screen defintion When the key is pressed at the Main menu level the following screen will be displayed: GET SCREEN DEFINITION ======================= Volume : _______ File : __________ Type : SCRN to execute, to abort The cursor will be placed at the begining of the Volume input field, the user may then change the file information on the screen. Pressing the key causes the program to locate the file specified and copy its contents into a temporary file that may be edited. If the file is found and the copy successful, the program will return to the Main menu level after displaying the message : STATUS: File loaded. Otherwise an error message will be displayed explaining the problem in finding or copying the file. If the key is pressed, the program returns to the Main menu level. 1.8.4.1 Screen Definition Example The following is an example of the inputs normally required to create, test, and update an input screen definition file: (1) Press the key from the Main menu to Edit the screen definition. The Data Field input mask will be displayed on the upper half of the screen, the lower half should be blank. (2) Press key to change the field definition. The cursor will be placed in the first input field. (3) Enter the Data Field definition as follows: {Identifies the field name as "FIRST".} {Uses default field type of Variable and sets justification (left).} <4> {Sets field row location.} <8> {Sets field column location.} {Requires alphabetic input only.} <1> <0> {Allows up to 10 characters input but uses default minimum of zero and default value of blanks.} {returns to the edit option prompt line.} (4) Press the key to Add the field to the current screen definition file. (5) Press the key to show the upper half of the current screen definition file. The field previously defined will appear on the forth row and the eighth column as fifteen blanks represented by underscores. The Data Field definition input mask will be displayed on the lower half of the console screen. (6) Press the

key to display the Prompt Field definition input mask on the lower half of the screen. (7) Press the key to change the prompt definition shown (blank). (8) Enter the Prompt Field definition as follows: {Prompt field number is not required.} <4> {Sets row location.} <0> {Sets column location.} <:> {Inputs prompt text and returns to edit option prompt line.} (9) Press the key to add the prompt field to the current screen definition file. The prompt will be displayed at the row and column location defined. (10) Enter the rest of the prompt field definitions. Press the key to change the information as before and then the and keys; enter the location and text as follows: Row Column Prompt 5 0 GREETING: 6 0 COMPANY : 7 0 ADDRESS : 8 0 CITY : 8 22 STATE : 8 34 ZIP : 10 0 ITEM OF INTEREST : (11) Press the key to display the Data Field definition input mask on the lower half of the screen. The upper half of the console screen should still show the prompts and data field previously defined. (12) Enter the rest of the data field descriptions. Press the key to change the information as before and then the key; enter the information as follows: ID Name Just. Row/Col. A/L/N/S Length LAST L 4 / 26 L 15 GREET L 5 / 10 L 20 CONAME L 6 / 10 S 15 ADDR L 7 / 10 S 20 CITY L 8 / 10 L 10 STATE N 8 / 30 L 2 ZIP R 8 / 39 N 7 ITEM L 10 / 15 S 15 (13) To change the default in GREETING to contain the value of "FIRST: " {Puts the cursor on the first data field definition input field.} {Clears input mask.} {Identifies field and returns to edit option prompt line.} {Examines data field. The lower half of the console screen should now show the definition of the GREET field.} {Deletes the field from the screen file.} {Puts the cursor on the first Data Field definition input field.} {Moves cursor to default/calculation input field.} <[> <]> {Sets the default to the value of FIRST.} {Adds the new field definiton back into the current screen file.} (14) To change the "NAME :" prompt:

{Displays the Prompt Field definition input mask.} Press the and/or keys until the "NAME :" prompt definition is displayed. {deletes the prompt from the current screen definition file.} {Puts the cursor on the first input field in the Prompt Field definition input mask.} {Moves the cursor to the prompt text input field.} Insert four (4) blanks just before the colon using the to position the cursor and the key to insert the blanks. {Returns to the edit option prompt line.} {Adds the new prompt back into the current screen file.} (15) The console screen should now look like this: NAME : _______ ___________ GREETING : _______________ COMPANY : ___________ ADDRESS : ______________ CITY : _______ STATE :___ ZIP : _______ ITEM OF INTEREST : ________________ DEFINE PROMPT FIELD - - - - - - - - - - Prompt Number :_1 Row Number :_4 Column Number :_0 Prompt : NAME__:_______________ Upper Field Add Back Examine Test Lower Prompt Delete Next Change Quit: A (16) Pressing the key will cause the console screen to look like this: NAME : ______ ___________ GREETING : ______________ COMPANY : ___________ ADDRESS : ______________ CITY : _______ STATE :___ ZIP : _______ ITEM OF INTEREST : _________________ ======================================================================================== DOCUMENT :usus Folder:VOL26:ude.6.text ======================================================================================== SCREEN DEFINITION - - - - - - - - - Field ID Name : ZIP_____ Auto Skip (T/F) : F Field Type (C/D/I/V) : V Justify (L/R/D) : R Row / Column Number : _7/ 39 Alpha-Numeric (A/N/D) : N Field Length : _7 Minimum Input : _0 Default/Calculation : ______________________________ Upper Field Add Back Examine Test Lower Prompt Delete Next Change Quit: F (17) Pressing the key will erase the Data Field Definition input mask from the console and allow input into the current screen definition file until the or key is pressed. (18) Pressing the key returns the user back to the Main menu level. 1.8.5 Print screen definition file 1.8.5.1 Printing the current screen definition When the

key is pressed at the Main menu, the program will ask: Printer width (80/132):132 The user should then enter the number of characters the line printer is capable of printing on one line. One hundred-thirty two (132) characters is assumed. The current screen definition will then be sent to the line printer. When the printout is complete, the user is returned to the Main menu level. 1.8.6 Quit When the key is pressed from the Main menu level the user is returned to the System command line. The current temporary file will be lost unless the save option is used prior to the exit. To prevent the user from accidentially leaving the program before saving the current file, the program will ask: Do you want to save the current definition file? The user may then press the key to save the file or the key to leave the program. 1.8.7 Save current screen definition file When the key is pressed at the Main menu level the following screen will be displayed: SAVE SCREEN DEFINITION ======================== Volume : _______ File : ___________ Type : SCRN to execute, to abort The user may now change the file information shown on the screen. Pressing the key causes the program to copy the current temporary file onto the volume and file specified. If a file by the name specified already exists its contents will be replaced by the current temporary file. If the copy is successful, the program will return to the Main menu level after displaying the message : STATUS: File saved. Total length : ##. Otherwise an error message will be displayed explaining the problem in copying the file. If the key is pressed the program returns to the Main menu level. ======================================================================================== DOCUMENT :usus Folder:VOL26:ud_copy.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL26:ud_list.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL26:ud_list.scrn ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL26:ud_maint.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL26:ud_sort.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL26:ud_sort.scrn ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL26:ud_ude.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL26:userlib.text ======================================================================================== sh.screen.code ======================================================================================== DOCUMENT :usus Folder:VOL26:vol26.doc.text ======================================================================================== USUS Volume 26 Universal Data Entry Documentation and Code Files -->Version VI.x ONLY<-- Sources on Volume 25 VOL26: UD.INTRDOC.TEXT 16 UDE Documentation UDE.1.TEXT 32 UDE.2.TEXT 26 UDE.3.TEXT 32 UDE.4.TEXT 34 UDE.5.TEXT 32 UDE.6.TEXT 8 SD/DEFINE.CODE 30 UDE Sub-programs SH.SCREEN.CODE 21 UD.SORT.CODE 45 UD/COPY.CODE 41 UD/LIST.CODE 39 UD/MAINT.CODE 23 UD/SORT.CODE 25 UD/UDE.CODE 3 UDE Main Program SH/SCREEN.UNIT 21 A necessary unit USERLIB.TEXT 4 Install this as your USERLIB.TEXT UD/LIST.SCRN 8 A couple of data files UD/SORT.SCRN 8 README.1ST 8 Read this FIRST!!! VOL26.DOC.TEXT 6 You're reading it --------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 26 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.basics1.text ======================================================================================== SEGMENT PROCEDURE SETPREFIX; VAR ANS: INTEGER; BEGIN REPEAT IF DISKDRIVE = '' THEN ANS := -1 ELSE VALUE(TRUE,COPY(DISKDRIVE,2,LENGTH(DISKDRIVE)-1),FAKE,ANS); (*$B 40COL- *) GETNUM(4,30,ANS,'Enter Prefix Disk Drive # ',ANS) (*$E 40COL *) (*$B 40COL+ *) GETNUM(4,30,ANS,'Enter Prefix Drive # ',ANS) (*$E 40COL *) UNTIL ANS IN [4,5,9..30]; ENCODE(ANS,DISKDRIVE); DISKDRIVE := CONCAT('#',DISKDRIVE) END; (* of setprefix *) SEGMENT PROCEDURE PRINT_MENU; (* Prints main menu to screen *) BEGIN {WRITE(OUTPUT,CLEAR);} sc_clr_screen; MEMORY; WRITELN(OUTPUT); WRITELN(OUTPUT); WRITELN(OUTPUT); (*$B 40COL- *) WRITELN(OUTPUT,'F R E E F O R M The Electronic Worksheet [F.4reals]'); WRITELN(OUTPUT,'=========================================='); WRITELN(OUTPUT,' ',VERSIONDATE); (*$E 40COL *) (*$B 40COL+ *) WRITELN(OUTPUT,'FREEFORM The Electronic Worksheet [F.4]'); WRITELN(OUTPUT,'========================================'); WRITELN(OUTPUT,' ',VERSIONDATE); (*$E 40COL *) WRITELN(OUTPUT); WRITELN(OUTPUT); WRITELN(OUTPUT,' 0. Data Entry Procedure'); WRITELN(OUTPUT,' 1. Define new FORM controls'); WRITELN(OUTPUT,' 2. Modify FORM controls'); WRITELN(OUTPUT,' 3. Display or List directory'); WRITELN(OUTPUT,' 4. Display or List FORM controls'); WRITELN(OUTPUT,' 5. Consolidate Procedure'); WRITELN(OUTPUT,' 6. Roll a FORM'); WRITELN(OUTPUT,' 7. Copy a FORM'); WRITELN(OUTPUT,' 8. Delete a FORM'); WRITELN(OUTPUT,' 9. Help and User''s Guide'); END; (* of print_menu *) SEGMENT PROCEDURE CHOOSE_OPTION; (* Elect desired option *) BEGIN REPEAT (*$B 40COL- *) GETRESPONSE(TRUE,'Enter desired option # ','', ' Press ESC to leave',1,IS); (*$E 40COL *) (*$B 40COL+ *) GETRESPONSE(TRUE,'Enter option # ','',' Press ESC to exit',1,IS); (*$E 40COL *) IF (IS='@') THEN IS := '10'; (* Debug switch, char is @ SDA 11/17 *) IF (IS='P') OR (IS='p') THEN IS := '11'; UNTIL (IS='0') OR (IS='1') OR (IS='2') OR (IS='3') OR (IS='4') OR (IS='5') OR (IS='6') OR (IS='7') OR (IS='8') OR (IS='9') OR (IS='10') OR (IS='11') OR (IS='ESCAPE'); IF IS='ESCAPE' THEN BEGIN PROMPT('Returning to Pascal O/S',MSG_LINE); EXIT(FREEFORM); END; VALUE(TRUE,IS,FAKE,OPTION); END; (* of choose_option *) (*$R- *) SEGMENT FUNCTION FIGURE{ VAR Z: NUMBERTYPE; X, Y: NUMBERTYPE; OP: CHAR ): BOOLEAN}; (* Dale Ander May 28, 1980 This Function calculates Z given X and Y and the operation in Op. If an overflow occurs it returns false and sets Z to OVERFLOW. Otherwise it returns true. *) VAR ANS: BIGNUMTYPE; I, POWER: INTEGER; PROCEDURE LEAVE(ANS: NUMBERTYPE); BEGIN Z := ANS; FIGURE := ANS <> OVERFLOW; EXIT(FIGURE) END; BEGIN (* Look for special math cases SDA 11/13/80 *) IF (X = OVERFLOW) OR (Y = OVERFLOW) THEN LEAVE(OVERFLOW) ELSE IF (X = EMPTY) AND (Y = EMPTY) THEN LEAVE(EMPTY) ELSE IF Y = EMPTY THEN IF (OP = '+') OR (OP = '-') THEN Y := 0 ELSE LEAVE(EMPTY) ELSE IF X = EMPTY THEN IF (OP = '+') OR (OP = '-') THEN X := 0 ELSE LEAVE(EMPTY); CASE OP OF '=': ANS := Y; '+': ANS := X + Y; '-': ANS := X - Y; '*': ANS := X * Y; '/': IF Y <> 0 THEN ANS := X / Y ELSE ANS := MAX; 'S': ANS := SIN( Y ); 'C': ANS := COS( Y ); 'T': BEGIN X := COS( Y ); IF X <> 0 THEN ANS := SIN( Y ) / X ELSE ANS := MAX END; 'A': ANS := ATAN( Y ); 'L': IF Y > 0 THEN ANS := LOG( Y ) ELSE ANS := MAX; 'N': IF Y > 0 THEN ANS := LN ( Y ) ELSE ANS := MAX; '^': BEGIN IF ABS(Y) > MAXINT THEN ANS := MAX (* Will not take power *) ELSE IF Y = 0 THEN ANS := 1 ELSE BEGIN POWER := TRUNC( ABS(Y) ); I := 1; ANS := X; WHILE (I < POWER) AND (ANS < MAX) DO BEGIN ANS := ANS * X; I := I + 1 END; IF Y < 0 THEN ANS := 1 / ANS END END END; IF (ANS >= MAX) OR (-ANS >= MAX) THEN LEAVE (OVERFLOW) ELSE LEAVE (ANS) END (* of figure *); (*$R^ *) (*$R- *) SEGMENT PROCEDURE NUMTOSTR { VAR ANS: ASTRING; NUM: NUMBERTYPE; BEFORE, AFTER: INTEGER }; (* Dale Ander Mar 27, 1981 Numtostr takes the Real number in Num and creates a string representation of it and puts this string into Ans. The form of the string is dependant upon the values of Before and After. Before is the number of digits to put before the decimal point and After is the number after. *) VAR MAGNITUDE, ROUND: NUMBERTYPE; I, L, PT, PLACES, ORDZERO: INTEGER; NEGATIVE, MINUSZERO: BOOLEAN; SIGN: CHAR; BEGIN IF NOT (BEFORE IN [1..MAXWHOLE]) THEN BEFORE := MAXWHOLE; BEFORE := BEFORE+1; (* Allow room for Sign *) IF NOT (AFTER IN [0..MAXFRAC]) THEN AFTER := MAXFRAC; IF NUM = EMPTY THEN (* return a dash ! SDA 11/13/80 *) BEGIN { Old way of doing things SDA 04/02/81 ANS := COPY(BLANKS,1,BEFORE+AFTER+1); IF AFTER > 0 THEN ANS := CONCAT(ANS,' '); (* blank for dec pt *) ANS[LENGTH(ANS)-1] := '-'; (* put dash in next to last position *) and the New way } IF AFTER > 0 THEN PT := BEFORE + AFTER + 2 ELSE PT := BEFORE + AFTER + 1; FILLCHAR(ANS[1],PT,' '); ANS[PT - 1] := '-'; ANS[0] := CHR( PT ); EXIT(NUMTOSTR) END; NEGATIVE := NUM < 0; (* Round off NUM to precision neccessary, make NUM positive and set SIGN *) ROUND := 0.5 / PWROFTEN( AFTER ); IF NEGATIVE THEN BEGIN SIGN := '-'; NUM := NUM - ROUND; NUM := ABS( NUM ) END ELSE BEGIN SIGN := ' '; NUM := NUM + ROUND END; (* Get all the significant digits to the left of the decimal point *) NUM := NUM * PWROFTEN( AFTER ); (* Get NUMs order of magnitude *) PLACES := MAXWHOLE + AFTER - 1; WHILE ( PWROFTEN( PLACES ) > NUM ) AND ( PLACES > 0 ) DO PLACES := PLACES - 1; ORDZERO := ORD('0'); PT := 1; ANS[1] := SIGN; FOR I := PLACES DOWNTO 0 DO BEGIN MAGNITUDE := PWROFTEN( I ); L := TRUNC( NUM / MAGNITUDE ); (* Get digit at that pwr of 10 *) PT := PT + 1; ANS[PT] := CHR( L + ORDZERO ); (* Put the digit into Ans *) NUM := NUM - ( L * MAGNITUDE) (* Remove the digit from Num *) END; ANS[0] := CHR(PT); (* Set the length byte in Ans *) L := LENGTH( ANS ) - AFTER; PT := 2 - L; IF PT > 0 THEN (* Need to insert leading zeros *) BEGIN { The old way SDA 4/2/81 INSERT( COPY( ZEROS, 1, 3-L ), ANS, 2); and the new } PLACES := LENGTH( ANS ); MOVERIGHT(ANS[2],ANS[PT+2],PLACES); FILLCHAR( ANS[2],PT,'0'); ANS[0] := CHR( PLACES + PT ); L := LENGTH( ANS ) - AFTER END; PT := BEFORE - L; IF PT > 0 THEN (* insert leading blanks *) BEGIN { The old way INSERT( COPY( BLANKS, 1, BEFORE-L+1), ANS, 1 ) and the new } PLACES := LENGTH( ANS ); MOVERIGHT(ANS[1],ANS[PT+1],PLACES); FILLCHAR( ANS[1],PT,' '); ANS[0] := CHR( PLACES + PT ) END ELSE (* if field given not wide enough for number then return *'s *) IF PT < 0 THEN BEGIN { The old way ANS := COPY( STARS, 1, BEFORE+AFTER ); and the New } FILLCHAR(ANS[1],BEFORE+AFTER,'*'); ANS[0] := CHR( BEFORE + AFTER ) END; IF NEGATIVE THEN (* look for -0 case *) BEGIN I := 1; L := LENGTH(ANS); REPEAT I := I + 1; MINUSZERO := ANS[I] In ['0',' ','-'] UNTIL (I=L) OR NOT MINUSZERO; IF MINUSZERO THEN ANS[ POS('-',ANS) ] := ' ' END; IF AFTER > 0 THEN (* put in decimal point *) BEGIN { The old way INSERT( '.', ANS, LENGTH( ANS )-AFTER+1 ); and the New } PT := LENGTH( ANS ) - AFTER + 1; MOVERIGHT(ANS[PT],ANS[PT+1],AFTER); ANS[PT] := '.'; ANS[0] := CHR( LENGTH( ANS ) + 1 ) END END; (* of numtostr *) (*$R^ *) SEGMENT PROCEDURE MOVEFORMDATA { AROW: BOOLEAN; PAGE, SOURCE, DEST: INTEGER }; VAR I: INTEGER; ANUM: NUMBERTYPE; ERR: BOOLEAN; BEGIN WITH DIRECTORY^ DO IF AROW THEN FOR I := 1 TO NO_COLS DO BEGIN NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGE,SOURCE,I,ANUM,ANDGET,ERR); NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGE,DEST ,I,ANUM,ANDPUT,ERR) END ELSE FOR I := 1 TO NO_ROWS DO BEGIN NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGE,I,SOURCE,ANUM,ANDGET,ERR); NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGE,I,DEST, ANUM,ANDPUT,ERR) END END; (* of moveformdata *) SEGMENT PROCEDURE SETPRINTER; BEGIN IF NOT PRINTER_ON THEN BEGIN UNITCLEAR( 6 ); (* Addition SDA 12/16/81 *) REWRITE(PRINTER,'PRINTER:'); PRINTER_ON := IORESULT = 0; END; IF PRINTER_ON THEN BEGIN GETNUM(1,999,PAPER_LENGTH,'How many lines long is the paper ?', PAPER_LENGTH); (*$B 40COL- *) PRESSRETURN('Set Printer Alignment, then',MSG_LINE) (*$E 40COL *) (*$B 40COL+ *) PRESSRETURN('Align Printer paper then',MSG_LINE) (*$E 40COL *) END ELSE ERROR(3) END; SEGMENT FUNCTION DISK_DIR{: BOOLEAN}; (* Returns true if it finds a freeform directory and returns false and sets Quit to true if it doesn't find a directory. *) VAR ANS: INTEGER; BEGIN REPEAT QUIT := FALSE; OPEN_DIR; IF NOT FILEOPEN THEN BEGIN ERROR(6); QUIT := NOT YESNO('Try another disk','Y'); IF NOT QUIT THEN BEGIN (* prompt to insert another disk *) REPEAT (* Changed range of legal drive numbers SDA 4/6/81 *) GETNUM(4,30,-1,'Enter Disk Drive # ',ANS) UNTIL ANS IN [4,5,9..30]; ENCODE(ANS,DISKDRIVE); DISKDRIVE := CONCAT('#',DISKDRIVE); (*$B 40COL- *) PRESSRETURN(CONCAT('Insert FREEFORM disk in drive ',DISKDRIVE, ' and'),MSG_LINE); (*$E 40COL *) (*$B 40COL+ *) PRESSRETURN(CONCAT('Put disk in ',DISKDRIVE,' and'),MSG_LINE); (*$E 40COL *) sc_clr_screen; {WRITE(OUTPUT,CLEAR);} END; END; (* IF NOT FILEOPEN *) UNTIL FILEOPEN OR QUIT; DISK_DIR := FILEOPEN END; (* of disk_dir *) SEGMENT FUNCTION NAME_FORM{ VAR REQUESTED_FORM: STRING; VAR RECNUMBER: INTEGER ): BOOLEAN }; (* Prompts for a form name and sets REQUESTED_FORM. If it finds the form it returns true and sets RECNUMBER, otherwise it returns false and sets QUIT to true. If possible it leaves directory^ pointing to requested record. *) VAR DIRINDEX: INTEGER; BEGIN NAME_FORM := FALSE; DIRINDEX := 0; WITH DIRECTORY^ DO REPEAT REPEAT (*$B 40COL- *) GETRESPONSE(FALSE,'Form Name (8 alpha max.) ',REQUESTED_FORM, ' Press ESC to leave',L_NAME,REQUESTED_FORM); (*$E 40COL *) (*$B 40COL+ *) GETRESPONSE(FALSE,'Enter Form Name ',REQUESTED_FORM, ' ESC exits',L_NAME,REQUESTED_FORM); (*$E 40COL *) UNTIL (REQUESTED_FORM<>'') AND (REQUESTED_FORM<>'INVALID'); IF REQUESTED_FORM = 'ESCAPE' THEN (* SDA 4/21/81 *) BEGIN REQUESTED_FORM := ''; QUIT := TRUE END ELSE BEGIN (* search for requested form *) LCTOUC(REQUESTED_FORM); QUIT := SEARCH(RECNUMBER,REQUESTED_FORM) AND (THEVERSION = VERSION); IF QUIT THEN BEGIN NAME_FORM := TRUE; PROMPT(CONCAT('Form Name is => ',REQUESTED_FORM),3); END ELSE BEGIN IF REQUESTED_FORM = '?' THEN (* give a default from the dir *) BEGIN QUIT := FALSE; REPEAT SEEKDIR(DIRINDEX,ANDGET); REQUESTED_FORM := FORM_NAME; IF REQUESTED_FORM = '' THEN DIRINDEX := 0 ELSE DIRINDEX := DIRINDEX + 1 UNTIL ( VERSION = THEVERSION ) OR ( REQUESTED_FORM = '' ) END ELSE BEGIN PROMPT(CONCAT('FORM named ',REQUESTED_FORM,' not found...'), MSG_LINE-1); QUIT := NOT YESNO('Try another FORM name','Y'); ERASE(MSG_LINE-1) END END END UNTIL QUIT END; (* of name_form *) SEGMENT FUNCTION GET_FORM_NAME{ VAR REQUESTED_FORM: STRING VAR RECNUMBER: INTEGER): BOOLEAN }; (* This function will return true if it gets a form name that can go into the freeform directory. It also returns the spot in the directory for the entry to go into. Also sets the variable REQUESTED_FORM. If no form name is given or the directory is full then false is returned. *) VAR POS: INTEGER; BEGIN (* GET_FORM_NAME *) GET_FORM_NAME := FALSE; IF NOT SEARCH(RECNUMBER,'') THEN (* no empty hole in directory *) ERROR(1) ELSE BEGIN REPEAT (*$B 40COL- *) GETRESPONSE(FALSE,'Form Name (8 alpha max.) ',REQUESTED_FORM, ' Press ESC to leave',L_NAME,REQUESTED_FORM); (*$E 40COL *) (*$B 40COL+ *) GETRESPONSE(FALSE,'Enter Form Name ',REQUESTED_FORM, ' ESC exits',L_NAME,REQUESTED_FORM); (*$E 40COL *) UNTIL (REQUESTED_FORM<>'') AND (REQUESTED_FORM<>'INVALID') AND (REQUESTED_FORM<>'?'); QUIT := REQUESTED_FORM = 'ESCAPE'; (* BUG FIX SDA 8/28/80 *) IF QUIT THEN REQUESTED_FORM := '' (* SDA 4/21/81 *) ELSE BEGIN GET_FORM_NAME := TRUE; LCTOUC(REQUESTED_FORM); (* make form name uppercase *) PROMPT(CONCAT('Form Name is => ',REQUESTED_FORM),3); (* Check for duplicate form on current diskette *) IF SEARCH(POS,REQUESTED_FORM) THEN (* found duplicate *) BEGIN PROMPT(CONCAT('A FORM named ',REQUESTED_FORM,' already exists'), MSG_LINE-1); IF YESNO('*** Replace existing FORM','N') THEN RECNUMBER := POS ELSE GET_FORM_NAME := FALSE; ERASE(MSG_LINE-1) END END END END; (* of get_form_name *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.basics2.text ======================================================================================== SEGMENT PROCEDURE ACCEPTNUM { ARROW: BOOLEAN; MAX_LENGTH: INTEGER; VAR IS: STRING; VAR CH: CHAR, var which_key : sc_key_command };(**gws*) VAR ACHAR: STRING[1]; DONE, DECPT, PLUSMINUS: BOOLEAN; PROCEDURE BAD; BEGIN IS := 'INVALID'; WRITE(OUTPUT,THEBELL); END; PROCEDURE PUTIN; BEGIN IF LENGTH(IS) < MAX_LENGTH THEN BEGIN ACHAR[1] := CH; IS := CONCAT(IS, ACHAR); WRITE(OUTPUT,CH); END; END; PROCEDURE TAKEOUT; BEGIN CASE IS[ LENGTH(IS) ] OF '+','-': BEGIN PLUSMINUS := FALSE; MAX_LENGTH := MAX_LENGTH-1 END; '.': BEGIN IF LENGTH(IS) = 1 THEN PLUSMINUS := FALSE; DECPT := FALSE; END; END; DELETE(IS,LENGTH(IS),1); WRITE(OUTPUT,CRT_CURSOR_LEFT,SPACE,CRT_CURSOR_LEFT); (* SDA 12/17/81 *) END; PROCEDURE HANDLEIT; BEGIN CASE CH OF '+','-': IF PLUSMINUS THEN BAD ELSE MAX_LENGTH := MAX_LENGTH + 1; '.' : IF DECPT THEN BAD ELSE DECPT := TRUE; END; IF IS <> 'INVALID' THEN BEGIN PUTIN; PLUSMINUS := TRUE END END; (* handleit *) BEGIN (* ACCEPTNUM *) IS := ''; ACHAR := ' '; PLUSMINUS := FALSE; DECPT := FALSE; DONE := FALSE; { REPEAT READ(KEYBOARD, CH); IF EOF(KEYBOARD) OR EOLN(KEYBOARD) THEN BEGIN RESET(KEYBOARD); CH := CURSOR_DOWN END; IF CH = ABACKSPACE THEN CH := CURSOR_LEFT; (* SDA 12/17/81 *) IF CH IN (DIGITS + ['+','-','.']) THEN HANDLEIT ELSE IF CH IN [' ',CURSOR_DOWN,CURSOR_RIGHT,CURSOR_UP,TAB,HOME, ENTER,ESCAPE] THEN DONE := TRUE ELSE IF CH IN ['A','a','M','m'] THEN IF ARROW THEN DONE := TRUE ELSE BAD ELSE IF CH = CURSOR_LEFT THEN IF LENGTH(IS) > 0 THEN TAKEOUT ELSE DONE := ARROW ELSE IF CH IN [ERASEINPUT,ERASEFIELD] THEN WHILE LENGTH(IS) > 0 DO TAKEOUT ELSE BAD UNTIL DONE OR (IS = 'INVALID'); } (**taken out gws*) REPEAT READ(KEYBOARD, CH); which_key := sc_map_crt_command ( ch ); IF EOF(KEYBOARD) OR EOLN(KEYBOARD) THEN BEGIN RESET(KEYBOARD); which_key := sc_down_key; END; IF CH IN (DIGITS + ['+','-','.']) THEN HANDLEIT ELSE if ( ch in [ ' ',tab ] ) or ( which_key IN [sc_escape_key, sc_etx_key, sc_down_key, sc_right_key, sc_up_key] ) THEN DONE := TRUE ELSE IF CH IN ['A','a','M','m'] THEN IF ARROW THEN DONE := TRUE ELSE BAD ELSE IF which_key in [ sc_backspace_key, sc_left_key ] then IF LENGTH(IS) > 0 THEN TAKEOUT ELSE DONE := ARROW ELSE IF which_key = sc_del_key THEN WHILE LENGTH(IS) > 0 DO TAKEOUT ELSE BAD UNTIL DONE OR (IS = 'INVALID'); (* A minus sign ( a dash ) is now acceptable input sometimes. SDA 11/13/80 *) IF (IS='+') OR ( (NOT ARROW) AND (IS='-') ) OR (IS='.') OR (IS='+.') OR (IS='-.') THEN BAD; END; (* of acceptnum *) SEGMENT PROCEDURE ACCEPTSTR { ANY: BOOLEAN; MAX_LENGTH, X, Y: INTEGER; DEFAULT: STRING; VAR IS: STRING }; VAR which_key : sc_key_command; ULINE: STRING[1]; BOOL, INSMODE: BOOLEAN; CH: CHAR; PT: INTEGER; PROCEDURE CHANGE; BEGIN GOTOXY(X,Y); WRITE(OUTPUT,IS); GOTOXY(X+PT,Y) END; PROCEDURE INIT; BEGIN ULINE := COPY(DASHES,1,1); (* Set Uline to one dash *) IS := COPY(DASHES,1,MAX_LENGTH); (* fill IS with Dashes *) WHILE POS(' ',DEFAULT) <> 0 DO (* Change spaces in default to dashes *) DEFAULT[POS(' ',DEFAULT)] := ULINE[1]; IF DEFAULT <> '' THEN MOVELEFT(DEFAULT[1],IS[1],LENGTH(DEFAULT)); (* overlay default *) GOTOXY(X,Y); WRITE(OUTPUT,IS); GOTOXY(X,Y); PT := 0; INSMODE := FALSE; END; BEGIN (* ACCEPTSTR *) INIT; REPEAT READ(KEYBOARD, CH); which_key := sc_map_crt_command ( ch ); IF EOF(KEYBOARD) OR EOLN(KEYBOARD) THEN BEGIN RESET(KEYBOARD); which_key := sc_down_key; END; IF (CH >= SPACE) AND (ORD(CH) <= 127) and ( which_key = sc_not_legal ) then IF NOT ANY AND (CH IN ['?','/']) THEN (* got ? while getting form name *) BEGIN PT := 1; IS := '?' END ELSE IF ANY OR (CH IN (['A'..'Z','a'..'z'] + DIGITS)) THEN BEGIN PT := PT + 1; IF INSMODE THEN (* put extra char to write over *) IF PT < LENGTH(IS) THEN BEGIN DELETE(IS,LENGTH(IS),1); INSERT(' ',IS,PT) END; IF CH = SPACE THEN CH := ULINE[1]; (* put Dash instead of a space *) IS[PT] := CH; CHANGE; IF (PT = LENGTH(IS)) AND (PT <> 1) THEN BEGIN (* Don't put cursor past end of string *) WRITE(OUTPUT,CRT_CURSOR_LEFT); (* SDA 12/17/81 put in CRT_ *) PT := PT - 1 END END ELSE WRITE(OUTPUT,THEBELL) ELSE IF which_key in [ sc_left_key, sc_backspace_key ] then BEGIN INSMODE := FALSE; IF PT > 0 THEN BEGIN PT := PT - 1; WRITE(OUTPUT,CRT_CURSOR_LEFT) END END ELSE IF which_key = sc_right_key THEN BEGIN INSMODE := FALSE; IF PT < (LENGTH(IS)-1) THEN BEGIN PT := PT + 1; WRITE(OUTPUT,crt_cursor_left ) END END ELSE IF which_key in [ sc_down_key, sc_escape_key ] then BEGIN IF which_key = sc_escape_key THEN IS := 'ESCAPE'; PT := LENGTH(IS) END ELSE IF which_key = sc_delete_key THEN BEGIN FILLCHAR(IS[PT+1],LENGTH(IS)-PT,DASHES[1]); CHANGE END ELSE { IF CH = ERASEFIELD THEN INIT ELSE IF CH = INSKEY THEN INSMODE := TRUE ELSE IF CH = DELKEY THEN BEGIN DELETE(IS,PT+1,1); IS := CONCAT(IS,ULINE); CHANGE END ELSE } (**this stuff not supported by screenops *) WRITE(OUTPUT,THEBELL); UNTIL PT >= LENGTH(IS); (* change all Ulines to Spaces *) FOR PT := 1 TO LENGTH(IS) DO IF IS[ PT ] = ULINE[1] THEN IS[ PT ] := SPACE; (* delete trailing spaces *) BOOL := TRUE; WHILE (LENGTH(IS) > 0) AND BOOL DO BEGIN IF IS[ LENGTH(IS) ] = SPACE THEN DELETE(IS,LENGTH(IS),1) ELSE BOOL := FALSE END END; (* of acceptstr *) (*$R- *) PROCEDURE NUMBER{ VAR DAT_FILE: AFILE; VAR DAT_DESC: FILEDESC; PAGE, ROW, COL: INTEGER; VAR NUM: NUMBERTYPE; WHAT: ACTIONTYPE; VAR ERR: BOOLEAN )}; VAR PTR: LISTRANGE; LOC: INTEGER; MISSING: BOOLEAN; BEGIN WITH DAT_DESC DO BEGIN ERR := FALSE; MISSING := TRUE; PTR := LISTHEAD; (* PTR will point to node in LIST with proper WINDOW *) LOC := (ROW-1) * DIRECTORY^.THEMAXCOL + COL; (* Check in LIST for requested number *) WHILE MISSING AND (PTR <> 0) DO (* PTR = 0 means at end of LIST *) WITH LIST[PTR] DO BEGIN IF DPAGE = PAGE THEN IF (START <= LOC) AND (LOC <= (START+WINDOWSIZE)) THEN BEGIN MISSING := FALSE; IF PTR <> LISTHEAD THEN (* Adjust links so node can be moved to the top of the LIST *) BEGIN IF PTR = LISTTAIL THEN (* Adj. Tail to point to prev. node *) LISTTAIL := BEFORE; LIST[ BEFORE ].AFTER := AFTER; LIST[ AFTER ].BEFORE := BEFORE END END; IF MISSING THEN PTR := AFTER (* Go to the next node in LIST *) END; IF MISSING THEN (* Number not in list so get it there *) BEGIN IF FREEHEAD <> 0 THEN (* Empty nodes in LIST *) BEGIN PTR := FREEHEAD; FREEHEAD := LIST[FREEHEAD].AFTER END ELSE (* No Empty nodes in LIST so a node in use must be used *) BEGIN PTR := LISTTAIL; (* Use the Least Recently Used node *) LISTTAIL := LIST[LISTTAIL].BEFORE; LIST[LISTTAIL].AFTER := 0; (* Set link to null *) WITH LIST[PTR] DO IF CHANGED THEN (* Write window to disk *) ERR := BLOCKWRITE(DAT_FILE,WINDOW^,1,DBLOCK) <> 1 END; WITH LIST[PTR] DO BEGIN (* # of Block to be read in *) DBLOCK := ( (PAGE-1) * BLKSPERPAGE ) + ( (LOC-1) DIV (WINDOWSIZE+1) ); DPAGE := PAGE; START := LOC - ( (LOC-1) MOD (WINDOWSIZE+1) ); CHANGED := FALSE; ERR := BLOCKREAD(DAT_FILE,WINDOW^,1,DBLOCK) <> 1 END END; (* of If MISSING *) IF PTR <> LISTHEAD THEN (* Put node used at the head of LIST *) BEGIN LIST[PTR].AFTER := LISTHEAD; LIST[LISTHEAD].BEFORE := PTR; LISTHEAD := PTR; LIST[LISTHEAD].BEFORE := 0; (* Set link to null *) IF LISTTAIL = 0 THEN LISTTAIL := LISTHEAD END; WITH LIST[PTR] DO IF WHAT = ANDGET THEN NUM := WINDOW^[ LOC - START ] ELSE BEGIN WINDOW^[ LOC - START ] := NUM; CHANGED := TRUE END END END (* of number *); (*$R^ *) PROCEDURE VALUE{ RETURNINTEGER: BOOLEAN; INSTRING: STRING; VAR REALANS: NUMBERTYPE; VAR INTANS: INTEGER }; (* This routine was written by S. Dale Ander on Mar 26, 1981 to replace the original Value routine in Freeform. It takes a string assumed to have a syntactically correct real number in it and puts the value into Realans in the form of a Real Number and the value into Intans in the form of an Integer. *) VAR WSUM, FSUM: NUMBERTYPE; NEGATIVE: BOOLEAN; PTR: INTEGER; CH: CHAR; PROCEDURE GETCHAR; BEGIN CH := INSTRING[ PTR ]; PTR := PTR + 1 END; PROCEDURE SUM( VAR ANS: NUMBERTYPE; NUMBERS: INTEGER ); VAR COUNT, ORDZERO: INTEGER; BEGIN COUNT := 0; ANS := 0; ORDZERO := ORD('0'); WHILE (CH IN DIGITS) AND (COUNT < NUMBERS) DO BEGIN COUNT := COUNT + 1; ANS := 10 * ANS + ORD(CH) - ORDZERO; GETCHAR; END; END; BEGIN (* A dash stands for EMPTY. Added 11/13/80 SDA *) IF INSTRING = '-' THEN (* this symbol stands for EMPTY *) BEGIN REALANS := EMPTY; EXIT(VALUE) END; NEGATIVE := FALSE; FSUM := 0; WSUM := 0; INSTRING := CONCAT ( INSTRING, ' ' ); PTR := 1; GETCHAR; IF CH IN ['+','-'] THEN (* Check for a signed number *) BEGIN NEGATIVE := CH = '-'; GETCHAR (* Throw away sign *) END; SUM( WSUM, MAXWHOLE ); (* Get Whole part of number *) IF CH = '.' THEN (* Get Fractional part *) BEGIN (* Put trailing zeros on *) INSERT( COPY( ZEROS, 1, MAXFRAC+1 ), INSTRING, LENGTH(INSTRING) ); GETCHAR; (* Skip period *) SUM( FSUM, MAXFRAC+1 ) END; IF RETURNINTEGER THEN BEGIN (* BUG fix by SDA 11/25/80 *) IF WSUM > MAXINT THEN WSUM := MAXINT; INTANS := TRUNC(WSUM); REALANS := -77 END ELSE BEGIN REALANS := WSUM + (FSUM / PWROFTEN(MAXFRAC+1)); INTANS := -77 END; IF NEGATIVE THEN BEGIN INTANS := -INTANS; REALANS := -REALANS END; END (* of value *); ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.basics3.text ======================================================================================== PROCEDURE ERASE { LINE: INTEGER }; BEGIN {GOTOXY(0,LINE); WRITE(OUTPUT, ERASELINE);} sc_erase_to_eol ( 0, line ); END; PROCEDURE PROMPT{ MSG: STRING; Y: INTEGER }; BEGIN sc_erase_to_eol ( 0, y ); GOTOXY(0,Y); WRITE(OUTPUT,{ERASELINE,}MSG); END (* of Prompt *); PROCEDURE ONEMOMENT{ REASON: STRING }; BEGIN (*$B 40COL- *) PROMPT(CONCAT(REASON,'...one moment, please'),MSG_LINE); (*$E 40COL *) (*$B 40COL+ *) PROMPT(CONCAT(REASON,'...please wait'),MSG_LINE); (*$E 40COL *) END; PROCEDURE GETRESPONSE{ ANY: BOOLEAN; LMSG, DEFAULT, RMSG: STRING; LEN: INTEGER; VAR RESPONSE: STRING }; (* This procedure solicits for a response on line MSG_LINE with the question LMSG. It puts up LMSG, the DEFAULT, and then RMSG, puts the cursor after LMSG, and then calls ACCEPTSTR *) BEGIN PROMPT(CONCAT(LMSG,COPY(DASHES,1,LEN),' ',RMSG),MSG_LINE); ACCEPTSTR(ANY,LEN,LENGTH(LMSG),MSG_LINE,DEFAULT,RESPONSE); END; (* of getresponse *) FUNCTION YESNO{ MSG, DEFAULT: STRING ): BOOLEAN; SDA 6/23/80 }; (* This function will keep asking whatever MSG is at the coordinates 0, MSG_LINE until getting a yes or no answer. It returns true if the answer was yes. It also sets the global variable IS. *) BEGIN REPEAT PROMPT(CONCAT(MSG,' ? (Y/N) '),MSG_LINE); ACCEPTSTR(TRUE,1,9+LENGTH(MSG),MSG_LINE,DEFAULT,IS); LCTOUC(IS); UNTIL (IS='N') OR (IS='Y'); YESNO := (IS='Y'); END; PROCEDURE LCTOUC{ VAR INSTRING: STRING }; VAR I: INTEGER; BEGIN FOR I := 1 TO LENGTH(INSTRING) DO IF INSTRING[I] IN ['a'..'z'] THEN INSTRING[I] := CHR(ORD(INSTRING[I])-32); END; PROCEDURE PRESSRETURN{ MSG: STRING; Y: INTEGER }; BEGIN PROMPT(CONCAT(MSG,' press RETURN'),Y); READLN(KEYBOARD); IF EOF(KEYBOARD) THEN RESET(KEYBOARD); END; PROCEDURE OPEN_DIR; (* Opens Freeform directory *) BEGIN IF FILEOPEN THEN CLOSE(DIRECTORY); RESET(DIRECTORY,CONCAT(DISKDRIVE,':',DIRNAME)); FILEOPEN := IORESULT = 0; END; (* of open_dir *) PROCEDURE FREEMEM{ VAR DAT_DESC: FILEDESC }; PROCEDURE DODISPOSE( HEAD: INTEGER ); VAR I: INTEGER; BEGIN WITH DAT_DESC DO BEGIN I := HEAD; WHILE I <> 0 DO WITH LIST[I] DO BEGIN DISPOSE(WINDOW); I := AFTER END END END; BEGIN (* FREEMEM *) DODISPOSE( DAT_DESC.LISTHEAD ); DODISPOSE( DAT_DESC.FREEHEAD ) END; (* of freemem *) FUNCTION OPEN_DAT{(REQUESTED_FORM: STRING; VAR DAT_FILE: AFILE; VAR DAT_DESC: FILEDESC; ISEGS: STRING; MAX: BOOLEAN ): BOOLEAN}; (* Will return true and set DAT_OPEN to true if it can open the DATA file associated with REQUESTED_FORM otherwise it will return false. Also sets BLKSPERPAGE for the file and all the other variables associated with DAT_DESC. If MAX is true all available heap will be used for the LIST table other wise just half *) VAR SIZE, I: INTEGER; BEGIN RESET(DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT')); DAT_DESC.USEDHEAP := FALSE; IF IORESULT = 0 THEN BEGIN OPEN_DAT := TRUE; DAT_OPEN := TRUE; WITH DAT_DESC, DIRECTORY^ DO BEGIN LISTHEAD := 0; LISTTAIL := 0; FREEHEAD := 1; FOR I := 0 TO MAXLISTSIZE-1 DO LIST[I].AFTER := I + 1; { GOTOXY(0,4); WRITELN('OPEN_DAT called with ISEGS = |',ISEGS,'|'); WRITE('Input Segment Names : '); READLN(ISEGS); } IS := 'FREEFORM,GOTOXY,FILEOPS,STRINGOP,EXTRAIO,PASCALIO,REALOPS,ACCEPTNU,ACCEPTST'; I := VARAVAIL(IS); IF DEBUGMODE THEN BEGIN GOTOXY(0,4); WRITELN('VARAVAIL list below:'); WRITELN(IS,' and '); WRITELN(ISEGS); WRITE('Enter any additions - '); READLN(IS); IF IS <> '' THEN ISEGS := CONCAT(ISEGS,',',IS) END; (* 2048 words of Slop *) SIZE := ( VARAVAIL( ISEGS ) + ( I - VARAVAIL( '' ) ) - 2048 ) DIV 256; IF NOT MAX THEN SIZE := SIZE DIV 2; IF SIZE > MAXLISTSIZE THEN SIZE := MAXLISTSIZE; IF DEBUGMODE THEN BEGIN GOTOXY(37,0); WRITE('SIZE OF LIST = ',SIZE:2) END; LIST[SIZE].AFTER := 0; USEDHEAP := TRUE; (* SDA Mar 31, 1981 *) IF SIZE = 0 THEN (*$B 40COL- *) PRESSRETURN('*** Not enough Memory for Form. Abort after you', MSG_LINE); (*$E 40COL *) (*$B 40COL+ *) BEGIN PRESSRETURN('*** Not enough Memory,',MSG_LINE); PRESSRETURN('*** Abort after you',MSG_LINE); END; (*$E 40COL *) FOR I := 1 TO SIZE DO NEW(LIST[I].WINDOW); (* BUG fix I = 1 not 0 *) BLKSPERPAGE := ((THEMAXROW*THEMAXCOL)+WINDOWSIZE) DIV (WINDOWSIZE+1) END END ELSE OPEN_DAT := FALSE; END; (* of open_dat *) PROCEDURE CLOSE_DAT {( VAR DAT_FILE: AFILE; VAR DAT_DESC: FILEDESC; VAR ERR: BOOLEAN )}; VAR I,J: INTEGER; BEGIN WITH DAT_DESC DO BEGIN ERR := FALSE; IF USEDHEAP THEN BEGIN I := LISTHEAD; WHILE I <> 0 DO WITH LIST[I] DO BEGIN IF CHANGED THEN IF BLOCKWRITE(DAT_FILE,WINDOW^,1,DBLOCK) <> 1 THEN ERR := TRUE; I := AFTER END; FREEMEM( DAT_DESC ) END; CLOSE(DAT_FILE,LOCK); DAT_OPEN := FALSE END END; (* of close_dat *) FUNCTION OPEN_CON{( REQUESTED_FORM: STRING ): BOOLEAN}; (* Will return true and set CON_OPEN to true if it can open the CONSTANT file associated with REQUESTED_FORM otherwise it will return false *) BEGIN RESET(FORM_CON_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.CON')); IF IORESULT = 0 THEN BEGIN OPEN_CON := TRUE; CON_OPEN := TRUE END ELSE OPEN_CON := FALSE; END; (* of open_con *) FUNCTION OPEN_CTL{(REQUESTED_FORM: STRING): BOOLEAN}; (* Will return true and set CTL_OPEN to true if it can open the CONTROL file associated with REQUESTED_FORM otherwise it will return true *) BEGIN RESET(FORM_CTL_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.CTL')); IF IORESULT = 0 THEN BEGIN OPEN_CTL := TRUE; CTL_OPEN := TRUE END ELSE OPEN_CTL := FALSE; END; (* of open_ctl *) FUNCTION OPEN_TIT{(REQUESTED_FORM: STRING): BOOLEAN}; (* Will return true and set TIT_OPEN to true if it can open the TITLE file associated with REQUESTED_FORM otherwise it will return true *) BEGIN RESET(FORM_TIT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.TIT')); IF IORESULT = 0 THEN BEGIN OPEN_TIT := TRUE; TIT_OPEN := TRUE END ELSE OPEN_TIT := FALSE; END; (* of open_tit *) PROCEDURE SEEKDIR{ REC: INTEGER; WHAT: ACTIONTYPE }; BEGIN SEEK(DIRECTORY, REC); IF WHAT = ANDGET THEN GET(DIRECTORY) ELSE IF WHAT = ANDPUT THEN PUT(DIRECTORY); END; (* of seekdir *) PROCEDURE SEEKCON{ REC: INTEGER; WHAT: ACTIONTYPE }; BEGIN SEEK(FORM_CON_FILE, REC); IF WHAT = ANDGET THEN GET(FORM_CON_FILE) ELSE IF WHAT = ANDPUT THEN PUT(FORM_CON_FILE); END; (* of seekcon *) PROCEDURE SEEKCTL{ VAR CTL_FILE: CFILE; COL: BOOLEAN; REC: INTEGER; WHAT: ACTIONTYPE }; BEGIN IF COL THEN REC := REC + DIRECTORY^.THEMAXROW; SEEK(CTL_FILE, REC); IF WHAT = ANDGET THEN GET(CTL_FILE) ELSE IF WHAT = ANDPUT THEN PUT(CTL_FILE); END; (* of seekctl *) PROCEDURE SEEKTIT{ VAR TIT_FILE: TFILE; REC: INTEGER; WHAT: ACTIONTYPE }; BEGIN SEEK(TIT_FILE, REC); IF WHAT = ANDGET THEN GET(TIT_FILE) ELSE IF WHAT = ANDPUT THEN PUT(TIT_FILE); END; (* of seektit *) PROCEDURE FINISH_UP; (* Completes bookkeeping *) VAR ERR: BOOLEAN; BEGIN IF FILEOPEN THEN CLOSE(DIRECTORY); FILEOPEN := FALSE; IF PRINTER_ON THEN CLOSE(PRINTER); PRINTER_ON := FALSE; IF CON_OPEN THEN CLOSE(FORM_CON_FILE); CON_OPEN := FALSE; IF CTL_OPEN THEN CLOSE(FORM_CTL_FILE); CTL_OPEN := FALSE; IF DAT_OPEN THEN CLOSE_DAT(FORM_DAT_FILE,FORM_DAT_DESC,ERR); DAT_OPEN := FALSE; IF TIT_OPEN THEN CLOSE(FORM_TIT_FILE); TIT_OPEN := FALSE END; (* of finish_up *) PROCEDURE ERROR{INDEX:INTEGER}; VAR MSG: STRING; BEGIN MSG := 'ERROR'; CASE INDEX OF (*$B 40COL- *) 1: MSG := 'FREEFORM directory is full'; 2: MSG := 'FREEFORM diskette is full'; 3: MSG := 'Printer is not on line'; 4: MSG := 'No Control file found'; 5: MSG := 'No Data file found'; 6: MSG := 'No directory on disk'; 8: MSG := 'No Title file found'; 9: MSG := 'ERROR on Read'; 10: MSG := 'ERROR on Write'; 11: MSG := 'Unable to open Temp file'; 12: MSG := 'No Constant file found'; (*$E 40COL *) (*$B 40COL+ *) 1: MSG := 'FREEFORM dir full'; 2: MSG := 'FREEFORM disk full'; 3: MSG := 'Printer offline'; 4: MSG := 'No Control file'; 5: MSG := 'No Data file'; 6: MSG := 'No directory'; 8: MSG := 'No Title file'; 9: MSG := 'ERROR on Read'; 10: MSG := 'ERROR on Write'; 11: MSG := 'Can''t open Temp file'; 12: MSG := 'No Constant file'; (*$E 40COL *) END; PRESSRETURN(CONCAT('*** ',MSG,'... '),MSG_LINE); QUIT := TRUE; END; (* of error *) FUNCTION SEARCH{VAR LOC: INTEGER; NAME: STRING): BOOLEAN}; (* This function will return true if it finds NAME in the freeform directory and the location NAME was found at in LOC. It returns false otherwise. *) BEGIN OPENDIR; LOC := 0; WITH DIRECTORY^ DO BEGIN WHILE (FORM_NAME <> NAME) AND (FORM_NAME <> '') AND (LOC < DIRSIZE-1) DO BEGIN GET(DIRECTORY); LOC := LOC + 1 END; SEARCH := FORM_NAME = NAME END END; (* of search *) PROCEDURE GETNUM{MIN,THEMAX,DEFAULT: INTEGER; WHAT: STRING; VAR ANS: INTEGER}; VAR MAXSTR,DEFSTR: STRING[7]; DUMY: CHAR; xdummy : sc_key_command; BEGIN (* If MIN = THEMAX just set ANS to one of them and exit SDA 3/2/81 *) IF MIN = THEMAX THEN BEGIN ERASE(MSG_LINE); ANS := MIN; EXIT(GETNUM) END; ENCODE(THEMAX,MAXSTR); IF DEFAULT IN [MIN..THEMAX] THEN ENCODE(DEFAULT,DEFSTR) ELSE DEFSTR := COPY(DASHES,1,LENGTH(MAXSTR)); REPEAT PROMPT(CONCAT(WHAT,' ',DEFSTR,' (max. is ',MAXSTR,')'),MSG_LINE); GOTOXY(LENGTH(WHAT)+1,MSG_LINE); ACCEPTNUM(FALSE,LENGTH(MAXSTR),IS,DUMY,xdummy); IF (IS = '') OR (IS = 'INVALID') THEN ANS := DEFAULT ELSE VALUE(TRUE,IS,FAKE,ANS); UNTIL ANS IN [MIN..THEMAX] END; (* of getnum *) PROCEDURE ENCODE{ NUM: INTEGER; VAR ANS: STRING }; VAR CH: STRING[1]; ORDZERO, I: INTEGER; BEGIN ANS := ''; CH := ' '; ORDZERO := ORD('0'); REPEAT I := NUM MOD 10; CH[1] := CHR( I + ORDZERO ); INSERT(CH, ANS, 1); NUM := NUM DIV 10 UNTIL NUM = 0 END; (* of encode *) PROCEDURE MEMORY; BEGIN IF DEBUGMODE THEN BEGIN GOTOXY(0,0); WRITE('MEMAVAIL = ',MEMAVAIL,' VARAVAIL = ',VARAVAIL('FREEFORM'),' ') END END; ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.copy1.text ======================================================================================== SEGMENT PROCEDURE COPYFORM; CONST SEGSTOLOCK = 9; (* Added 2 more Segments to lock SDA 1/5/82 *) TYPE MOVETYPE = (CTLROW, CTLCOL, DATAPAGE, DATAROW, DATACOL); VAR TEMP, SOURCEDRIVE, DESTDRIVE: STRING[3]; ERR, ZERO, JUSTPAGES: BOOLEAN; DESTFORM, SOURCEFORM: STRING[L_NAME]; I, DESTREC, SOURCEREC, DESTPAGE, DESTROW, DESTCOL, ROW_CNT, COL_CNT, PAGE_CNT, PAGE, ROW, COL, ST_PAGE, ST_COL, ST_ROW, TOPAGE, TOROW, TOCOL: INTEGER; SOURCE: STRING[6]; DEST: STRING[11]; PAGELIST, COLLIST, ROWLIST: STRING[60]; SEGLIST: ARRAY[0..SEGSTOLOCK] OF STRING[8]; SOURCEDIRENTRY, DESTDIRENTRY: DIRRECORD; FORM_CON_TEMP: FILE OF NUMBERTYPE; FORM_TIT_TEMP: TFILE; FORM_CTL_TEMP: CFILE; FORM_DAT_TEMP: AFILE; TEMP_DAT_DESC: FILEDESC; SEGMENT PROCEDURE INITIALIZE; FORWARD; SEGMENT PROCEDURE DOTHECOPY; FORWARD; SEGMENT PROCEDURE INITIALIZE; VAR I, J: INTEGER; PROCEDURE GETDRIVE(WHERE: STRING; VAR PLACE: STRING); VAR ANS: INTEGER; BEGIN REPEAT (* Changed range of legal drive numbers SDA 4/6/81 *) (*$B 40COL- *) GETNUM(4,30,-1,CONCAT('Enter ',WHERE,' disk drive # '), ANS) (*$E 40COL *) (*$B 40COL+ *) GETNUM(4,30,-1,CONCAT('Enter ',WHERE,' drive # '), ANS) (*$E 40COL *) UNTIL ANS IN [4,5,9..30]; ENCODE(ANS,PLACE); (* change drive # read in into a string *) PLACE := CONCAT('#',PLACE); (* put pound sign in front of drive # *) END; BEGIN TEMP := DISKDRIVE; SOURCE := 'Source'; (*$B 40COL- *) DEST := 'Destination'; (*$E 40COL *) (*$B 40COL+ *) DEST := 'Dest'; (*$E 40COL *) DESTFORM := ''; (* Bug Fix SDA 5/19/81 *) SOURCEFORM := REQUESTED_FORM; sc_clr_screen; {WRITELN(OUTPUT,CLEAR);} WRITELN(OUTPUT,'F R E E F O R M C O P Y'); WRITELN(OUTPUT,'Copy existing Forms'); MEMORY; IF NOT DISKDIR THEN EXIT(COPYFORM); SEGLIST[0] := 'EXTRAHEA'; SEGLIST[1] := 'HEAPOPS '; SEGLIST[2] := 'PASCALIO'; SEGLIST[3] := 'EXTRAIO '; SEGLIST[4] := 'STRINGOP'; SEGLIST[5] := 'FILEOPS '; SEGLIST[6] := 'REALOPS '; SEGLIST[7] := 'GOTOXY '; SEGLIST[8] := 'ACCEPTNU'; SEGLIST[9] := 'ACCEPTST'; FOR I := 0 TO SEGSTOLOCK DO BEGIN IS := CONCAT('FREEFORM,COPYFORM,DOTHECOPY,',SEGLIST[I]); J := VARAVAIL(IS); IF DEBUGMODE THEN BEGIN GOTOXY(0,4+I); WRITE('VARAVAIL(''',IS,''') = ',J,' PRESS '); READLN(IS) END ELSE (* Don't Lock in Fileops and don't ask why, *) IF I = 5 THEN IS := 'N'; (* it just works. SDA 4/7/81 *) IF (J>0) AND (IS<>'N') THEN MEMLOCK(SEGLIST[I]) ELSE SEGLIST[I] := ''; MEMORY; END; IF YESNO('Copy from one disk to another','N') THEN BEGIN (* set source and dest drives to different places *) GETDRIVE(SOURCE,SOURCEDRIVE); (* get drive # for source *) REPEAT GETDRIVE(DEST,DESTDRIVE) (* get drive # for dest. *) UNTIL DESTDRIVE <> SOURCEDRIVE END ELSE (* set source and dest drives to the same place *) BEGIN SOURCEDRIVE := TEMP; DESTDRIVE := TEMP END; REPEAT GETRESPONSE(TRUE,'Copy a Form or just Pages ? (F/P) ','F','',1,IS); LCTOUC(IS); UNTIL (IS='F') OR (IS='P'); JUSTPAGES := IS = 'P'; END; (* of initialize *) SEGMENT PROCEDURE DOTHECOPY; PROCEDURE INSERTDISK(DRIVE, WHERE: STRING); BEGIN DISKDRIVE := DRIVE; (* set global used to point to Freeform disk *) MEMORY; IF DESTDRIVE <> SOURCEDRIVE THEN (* copying between disks *) BEGIN (*$B 40COL- *) PRESSRETURN( CONCAT('Insert ',WHERE,' disk into drive ',DRIVE),MSG_LINE ); (*$E 40COL *) (*$B 40COL+ *) PRESSRETURN( CONCAT('Put ',WHERE,' disk in ',DRIVE),MSG_LINE ); (*$E 40COL *) ERASE(MSG_LINE) END END; PROCEDURE RETURNDISKS(WHY: STRING); BEGIN (*$B 40COL- *) PRESSRETURN(CONCAT('Copy ',WHY,', return all disks to original drives and'), MSG_LINE); (*$E 40COL *) (*$B 40COL+ *) PRESSRETURN(CONCAT('Copy ',WHY,', return disks &'), MSG_LINE); (*$E 40COL *) FOR I := 0 TO SEGSTOLOCK DO MEMSWAP(SEGLIST[I]) END; PROCEDURE LEAVE(ERR: INTEGER; DONTDELETE: BOOLEAN); BEGIN ERASE(MSG_LINE-1); ERASE(MSG_LINE); ERASE(MSG_LINE+1); IF ERR > 0 THEN ERROR(ERR); IF NOT DONTDELETE THEN (* Delete all files belonging to Destform *) BEGIN DISKDRIVE := DESTDRIVE; OPEN_DIR; (* blank directory entry and remove control and data files *) DIRECTORY^.FORM_NAME := ''; SEEKDIR(DESTREC,ANDPUT); IS := CONCAT(DISKDRIVE,':',DESTFORM,'.'); RESET(FORM_CTL_TEMP,CONCAT(IS,'CTL')); CLOSE(FORM_CTL_TEMP, PURGE); RESET(FORM_CON_TEMP,CONCAT(IS,'CON')); CLOSE(FORM_CON_TEMP, PURGE); RESET(FORM_TIT_TEMP,CONCAT(IS,'TIT')); CLOSE(FORM_TIT_TEMP, PURGE); RESET(FORM_DAT_TEMP,CONCAT(IS,'DAT')); CLOSE(FORM_DAT_TEMP, PURGE) END; DISKDRIVE := TEMP; (* Close all source files *) OPEN_DIR; FINISHUP; RETURNDISKS('Aborted'); EXIT(COPYFORM) END; PROCEDURE SETDEST( WHAT: STRING; MAX: INTEGER; VAR ANS: INTEGER ); BEGIN IF MAX = 1 THEN ANS := 1 ELSE GETNUM(1,MAX,1,CONCAT('Enter ',WHAT,' # to start putting the Copy ->'),ANS) END; (* of setdest *) PROCEDURE OPEN_NEW_FORM_FILES; VAR ALLOK: BOOLEAN; AWINDOW: WINDOWTYPE; I, J: INTEGER; PROCEDURE CHECKERR; BEGIN IF IORESULT <> 0 THEN LEAVE(2,FALSE) END; BEGIN (* Initialize number of pages and where to start putting the pages, rows, and columns in the new form *) DESTPAGE := SOURCEDIRENTRY.NO_PAGES; STPAGE := 1; STCOL := 1; STROW := 1; MEMORY; (* Open up new FORM files *) REPEAT (* Get the size of the new Form *) ALLOK := TRUE; (* Copy can't be smaller than the original *) WITH SOURCEDIRENTRY DO BEGIN DESTCOL := ( MAXINT-WINDOWSIZE ) DIV NO_ROWS; IF DESTCOL > MAXCOL THEN DESTCOL := MAXCOL; (* BUG FIX SDA 10/3/81 *) (*$B 40COL- *) GETNUM(NO_COLS,DESTCOL,THEMAXCOL, 'How many Columns might ever be in the FORM ?', DESTCOL); DESTROW := ( MAXINT-WINDOWSIZE ) DIV DESTCOL; GETNUM(NO_ROWS,DESTROW,THEMAXROW, 'How many Rows might ever be in the FORM ?', DESTROW) (*$E 40COL *) (*$B 40COL+ *) GETNUM(NO_COLS,DESTCOL,THEMAXCOL,'Max Cols in FORM ?', DESTCOL); DESTROW := ( MAXINT-WINDOWSIZE ) DIV DESTCOL; GETNUM(NO_ROWS,DESTROW,THEMAXROW,'Max Rows in FORM ?', DESTROW) (*$E 40COL *) END; PROMPT('Maximum Cols = ',MSG_LINE+1); WRITE(OUTPUT,DESTCOL,', Rows = ',DESTROW); (*$B 40COL- *) ALLOK := YESNO('Are the dimensions ok as specified','Y'); (*$E 40COL *) (*$B 40COL+ *) ALLOK := YESNO('Are the dimensions ok','Y'); (*$E 40COL *) ERASE(MSG_LINE+1) UNTIL ALLOK; ONEMOMENT('Opening new FORM files'); IS := CONCAT(DESTDRIVE,':',DESTFORM,'.'); REWRITE(FORM_CTL_TEMP,CONCAT(IS,'CTL')); (* The new Control file *) CHECKERR; FOR I := 0 TO DESTROW+DESTCOL DO BEGIN PUT(FORM_CTL_TEMP); CHECKERR END; CLOSE(FORM_CTL_TEMP,LOCK); REWRITE(FORM_TIT_TEMP,CONCAT(IS,'TIT')); (* The new Title file *) CHECKERR; FOR I := 0 TO MAXPAGES DO BEGIN PUT(FORM_TIT_TEMP); CHECKERR END; CLOSE(FORM_TIT_TEMP,LOCK); REWRITE(FORM_CON_TEMP,CONCAT(IS,'CON')); (* The new Constant file *) CHECKERR; FOR I := 0 TO MAXCONSTS DO BEGIN PUT(FORM_CON_TEMP); CHECKERR END; CLOSE(FORM_CON_TEMP,LOCK); REWRITE(FORM_DAT_TEMP,CONCAT(IS,'DAT')); (* The new Data file *) CHECKERR; FOR I := 0 TO WINDOWSIZE DO AWINDOW[I] := EMPTY; WITH TEMP_DAT_DESC DO BEGIN BLKSPERPAGE := ( (DESTROW*DESTCOL) + WINDOWSIZE ) DIV (WINDOWSIZE + 1); USEDHEAP := FALSE; FOR I := 1 TO DESTPAGE DO FOR J := 1 TO BLKSPERPAGE DO IF BLOCKWRITE(FORM_DAT_TEMP,AWINDOW,1) <> 1 THEN LEAVE(2,FALSE) END; CLOSE(FORM_DAT_TEMP,LOCK) END; (* of open new form files *) PROCEDURE SETUP( VAR CNT: INTEGER; VAR COPYLIST: STRING; WHAT: STRING; MAX, HIGH: INTEGER ); VAR FIRST, START, NUM, INC, PT, BEG: INTEGER; FIRSTONE, A_OK: BOOLEAN; INSTRING: STRING; PROCEDURE SET_OUT(NUM: INTEGER); PROCEDURE SHOWERR(ERRNUM: INTEGER); BEGIN A_OK := FALSE; GOTOXY(PT-1,MSG_LINE+1); WRITE(OUTPUT,' <- '); DELETE(COPYLIST,LENGTH(COPYLIST),1); (* Delete the inserted comma *) FOR I := PT TO LENGTH(COPYLIST) DO WRITE(OUTPUT,COPYLIST[I]); CASE ERRNUM OF 1: PRESSRETURN('Sorry, too many',MSG_LINE+2); 2: PRESSRETURN('Illegal value',MSG_LINE+2) END; ERASE(MSG_LINE+2) END; BEGIN CNT := CNT + 1; IF CNT > MAX THEN SHOWERR(1) ELSE IF NOT (NUM IN [1..HIGH]) THEN SHOWERR(2) END; BEGIN (* SETUP *) (* Default list to all rows or columns in the source or the number of pages *) (* chosen to be in the destination. *) (* Note list of rows or cols may be more than will fit in the destination ! *) ENCODE(HIGH,COPYLIST); COPYLIST := CONCAT('1 - ',COPYLIST); MEMORY; INSTRING := ''; (*$B 40COL- *) PROMPT(CONCAT('Enter sequences of ',WHAT,'s (XX-XX,YY-YY) to copy below'), MSG_LINE); WRITE(OUTPUT,' (there are ',HIGH,')'); (*$E 40COL *) (*$B 40COL+ *) PROMPT(CONCAT('Enter ',WHAT,'s to copy'),MSG_LINE); WRITE(OUTPUT,' (max ',HIGH,')'); (*$E 40COL *) REPEAT CNT := 0; PT := 1; FIRSTONE := TRUE; A_OK := TRUE; ACCEPTSTR(TRUE,59,0,MSG_LINE+1,COPYLIST,INSTRING); IF INSTRING = 'ESCAPE' THEN LEAVE(0,JUSTPAGES) ELSE COPYLIST := INSTRING; COPYLIST := CONCAT(COPYLIST,','); (* comma stopper at end of string *) REPEAT WHILE NOT ( (COPYLIST[PT] IN DIGITS) OR (COPYLIST[PT]=',') ) DO PT := PT + 1; IF COPYLIST[PT] = ',' THEN BEGIN PT := PT + 1; FIRSTONE := TRUE END ELSE (* must be a number *) BEGIN START := PT; WHILE COPYLIST[PT] IN DIGITS DO PT := PT+1; (* find end of number *) VALUE(TRUE,COPY(COPYLIST,START,PT-START),FAKE,NUM); IF FIRSTONE THEN BEGIN SET_OUT(NUM); BEG := NUM; FIRSTONE := FALSE END ELSE (* second number so generate a sequence *) BEGIN FIRST := BEG; IF FIRST <> NUM THEN (* legitimate sequence *) BEGIN IF FIRST > NUM THEN INC := -1 ELSE INC := 1; REPEAT FIRST := FIRST + INC; SET_OUT(FIRST) UNTIL (NOT A_OK) OR (FIRST = NUM) END; FIRSTONE := TRUE END END UNTIL (NOT A_OK) OR (PT >= LENGTH(COPYLIST)) UNTIL A_OK; IF CNT = 0 THEN LEAVE(0,JUSTPAGES); (* Bug fix SDA 3/4/81 *) ERASE(MSG_LINE+1) END; (* of setup *) PROCEDURE ONEPAIR( VAR PT, BEG, LAST: INTEGER; COPYLIST: STRING ); VAR FIRSTONE, SECOND: BOOLEAN; NUM, START: INTEGER; BEGIN FIRSTONE := TRUE; SECOND := FALSE; LAST := -1; REPEAT WHILE NOT ( (COPYLIST[PT] IN DIGITS) OR (COPYLIST[PT]=',') ) DO PT := PT + 1; IF COPYLIST[PT] = ',' THEN BEGIN PT := PT + 1; FIRSTONE := TRUE; SECOND := LAST <> -1 END ELSE (* must be a number *) BEGIN START := PT; WHILE COPYLIST[PT] IN DIGITS DO PT := PT + 1; (* find end of number *) VALUE(TRUE,COPY(COPYLIST,START,PT-START),FAKE,NUM); IF FIRSTONE THEN BEGIN BEG := NUM; LAST := NUM; FIRSTONE := FALSE END ELSE BEGIN SECOND := TRUE; LAST := NUM END END UNTIL (LAST <> -1) AND SECOND END; (* of onepair *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.copy2.text ======================================================================================== PROCEDURE DOMOVE( VAR LOC, CNT: INTEGER; WHAT: MOVETYPE; LIST: STRING; LOOPCNT: INTEGER ); VAR OFFSET, BEG, LAST, PT, ST: INTEGER; ANUMBER: NUMBERTYPE; BEGIN MEMORY; CNT := 0; PT := 1; IF WHAT = CTLCOL THEN ST := STCOL ELSE ST := STROW; REPEAT ONEPAIR(PT, BEG, LAST, LIST); IF BEG <= LAST THEN OFFSET := 1 ELSE OFFSET := -1; LOC := BEG - OFFSET; REPEAT LOC := LOC + OFFSET; CASE WHAT OF CTLROW, CTLCOL: BEGIN DIRECTORY^ := SOURCEDIRENTRY; SEEKCTL(FORM_CTL_FILE, WHAT=CTLCOL, LOC, ANDGET); FORM_CTL_TEMP^ := FORM_CTL_FILE^; DIRECTORY^ := DESTDIRENTRY; SEEKCTL(FORM_CTL_TEMP, WHAT=CTLCOL, ST+CNT, ANDPUT) END; DATAPAGE: BEGIN ENCODE(LOC,IS); ONEMOMENT(CONCAT('Copying Page # ',IS)); SEEKTIT(FORM_TIT_FILE,LOC,ANDGET); FORM_TIT_TEMP^ := FORM_TIT_FILE^; SEEKTIT(FORM_TIT_TEMP,CNT+STPAGE,ANDPUT); IF NOT ZERO THEN (* If zero no need to copy *) DOMOVE(ROW, TOROW, DATAROW, ROWLIST, ROW_CNT) END; DATAROW: DOMOVE(COL, TOCOL, DATACOL, COLLIST, COL_CNT); DATACOL: BEGIN DIRECTORY^ := SOURCEDIRENTRY; NUMBER(FORM_DAT_FILE, FORM_DAT_DESC, PAGE, ROW, LOC, ANUMBER, ANDGET, ERR); DIRECTORY^ := DESTDIRENTRY; NUMBER(FORM_DAT_TEMP, TEMP_DAT_DESC, TOPAGE+STPAGE, TOROW+STROW, CNT+STCOL, ANUMBER, ANDPUT, ERR) END END; CNT := CNT + 1 UNTIL LOC = LAST UNTIL CNT = LOOPCNT END; (* of domove *) PROCEDURE COPYPAGES; VAR I: INTEGER; BEGIN IF JUSTPAGES THEN ZERO := FALSE (* Addition by SDA 9/22/81 *) ELSE BEGIN REPEAT GETRESPONSE(TRUE,'Copy or Empty data fields ? (C/E) ','','',1,IS); LCTOUC(IS); UNTIL (IS='E') OR (IS='C'); ZERO := IS = 'E' END; DISKDRIVE := SOURCEDRIVE; IF NOT OPEN_TIT(SOURCEFORM) THEN LEAVE(8,JUSTPAGES); RESET(FORM_TIT_TEMP,CONCAT(DESTDRIVE,':',DESTFORM,'.TIT')); IF IORESULT <> 0 THEN LEAVE(8,JUSTPAGES); IF NOT ZERO THEN BEGIN DISKDRIVE := DESTDRIVE; DIRECTORY^ := DESTDIRENTRY; IF NOT OPEN_DAT(DESTFORM,FORM_DAT_TEMP,TEMP_DAT_DESC,'COPYFORM,DOTHECOPY', FALSE) THEN LEAVE(5, JUSTPAGES); DISKDRIVE := SOURCEDRIVE; DIRECTORY^ := SOURCEDIRENTRY; IF NOT OPEN_DAT(SOURCEFORM,FORM_DAT_FILE,FORM_DAT_DESC, 'COPYFORM,DOTHECOPY',TRUE) THEN LEAVE(5, JUSTPAGES) END; DOMOVE(PAGE, TOPAGE, DATAPAGE, PAGELIST, PAGE_CNT); IF NOT ZERO THEN BEGIN CLOSE_DAT(FORM_DAT_FILE, FORM_DAT_DESC, ERR); CLOSE_DAT(FORM_DAT_TEMP, TEMP_DAT_DESC, ERR) END; CLOSE(FORM_TIT_FILE); CLOSE(FORM_TIT_TEMP); TIT_OPEN := FALSE END; (* of copydata *) PROCEDURE COPYCONTROLS; VAR I: INTEGER; BEGIN ONEMOMENT('Copying Control file'); DISKDRIVE := SOURCEDRIVE; IF NOT OPEN_CTL(SOURCEFORM) THEN LEAVE(4,FALSE); RESET(FORM_CTL_TEMP,CONCAT(DESTDRIVE,':',DESTFORM,'.CTL')); IF IORESULT <> 0 THEN LEAVE(4,FALSE); DOMOVE(I, TOROW, CTLROW, ROWLIST, ROW_CNT); DOMOVE(I, TOCOL, CTLCOL, COLLIST, COL_CNT); CLOSE(FORM_CTL_FILE); CLOSE(FORM_CTL_TEMP); CTL_OPEN := FALSE; ONEMOMENT('Copying Constants'); IF NOT OPEN_CON(SOURCEFORM) THEN LEAVE(12,FALSE); RESET(FORM_CON_TEMP,CONCAT(DESTDRIVE,':',DESTFORM,'.CON')); IF IORESULT <> 0 THEN LEAVE(12,FALSE); FOR I := 1 TO MAXCONSTS DO BEGIN GET(FORM_CON_FILE); FORM_CON_TEMP^ := FORM_CON_FILE^; PUT(FORM_CON_TEMP) END; CLOSE(FORM_CON_FILE); CLOSE(FORM_CON_TEMP); CON_OPEN := FALSE; DISKDRIVE := DESTDRIVE; OPEN_DIR; DIRECTORY^ := DESTDIRENTRY; SEEKDIR(DESTREC,ANDPUT); CLOSE(DIRECTORY); FILEOPEN := FALSE END; (* of copycontrols *) BEGIN (* DOTHECOPY *) INSERTDISK(DESTDRIVE,DEST); (* put in dest disk *) OPEN_DIR; (* attempt to open directory *) IF NOT (FILEOPEN OR JUSTPAGES) THEN (* copying whole form so make a dir *) BEGIN ONEMOMENT('Creating Freeform Directory'); REWRITE(DIRECTORY,CONCAT(DISKDRIVE,':',DIRNAME)); IF IORESULT <> 0 THEN LEAVE(2,TRUE); DIRECTORY^.FORM_NAME := ''; (* initialize to empty *) FOR I := 0 TO DIRSIZE DO BEGIN PUT(DIRECTORY); IF IORESULT <> 0 THEN LEAVE(2,TRUE) END; CLOSE(DIRECTORY,LOCK); OPEN_DIR END; IF FILEOPEN THEN (* make sure a Freeform directory is on the disk *) BEGIN PROMPT(CONCAT(DEST,' Form Name'),MSG_LINE-2); IF JUSTPAGES THEN (* get name of existing Form to put page in *) IF NAME_FORM(DESTFORM,DESTREC) THEN (* set max dest page, row & col # *) WITH DIRECTORY^ DO BEGIN DESTDIRENTRY := DIRECTORY^; DESTPAGE := NO_PAGES; DESTCOL := NO_COLS; DESTROW := NO_ROWS END ELSE LEAVE(0,TRUE) ELSE BEGIN (* get a new Form name to copy old form to *) REPEAT UNTIL GET_FORM_NAME(DESTFORM,DESTREC) OR QUIT; IF QUIT THEN LEAVE(0,TRUE) (* BUG FIX SDA 10/16/80 *) END END ELSE LEAVE(6,TRUE); (* no directory could be found *) ERASE(MSG_LINE-2); INSERTDISK(SOURCEDRIVE,SOURCE); (* put in source disk *) OPEN_DIR; IF FILEOPEN THEN (* make sure a Freeform directory is on the disk *) BEGIN PROMPT(CONCAT(SOURCE,' Form Name'),MSG_LINE-2); REPEAT IF NOT NAME_FORM(SOURCEFORM,SOURCEREC) THEN LEAVE(0,TRUE); IF (SOURCEFORM=DESTFORM) AND (SOURCEDRIVE=DESTDRIVE) AND (NOT JUSTPAGES) (*$B 40COL- *) THEN PRESSRETURN('Not Allowed to Copy the Source into itself',MSG_LINE) (*$E 40COL *) (*$B 40COL+ *) THEN PRESSRETURN('Can''t Copy Source into itself',MSG_LINE) (*$E 40COL *) UNTIL (SOURCEFORM<>DESTFORM) OR (SOURCEDRIVE<>DESTDRIVE) OR JUSTPAGES; ERASE(MSG_LINE-2); (* make sure that the source has control and data files *) ONEMOMENT('Searching for Source FORM files'); IF OPEN_CTL(SOURCEFORM) THEN BEGIN CLOSE(FORM_CTL_FILE); CTL_OPEN := FALSE END ELSE LEAVE(4,TRUE); IF OPEN_CON(SOURCEFORM) THEN BEGIN CLOSE(FORM_CON_FILE); CON_OPEN := FALSE END ELSE LEAVE(12,TRUE); IF OPEN_TIT(SOURCEFORM) THEN BEGIN CLOSE(FORM_TIT_FILE); TIT_OPEN := FALSE END ELSE LEAVE(8,TRUE); RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',SOURCEFORM,'.DAT')); IF IORESULT = 0 THEN BEGIN CLOSE(FORM_DAT_FILE); DAT_OPEN := FALSE END ELSE LEAVE(5,TRUE); MEMORY; SOURCEDIRENTRY := DIRECTORY^; IF JUSTPAGES THEN (* Get destination for pages, rows and cols *) BEGIN SETDEST('Page', DESTPAGE, STPAGE); SETDEST('Row', DESTROW, STROW); SETDEST('Column', DESTCOL, STCOL) END ELSE OPEN_NEW_FORM_FILES; (* Open new files and set dests to 1 *) (* Set PAGELIST to pages to copy, set ROWLIST to rows to copy, and set COLLIST to columns to copy. *) WITH SOURCEDIRENTRY DO BEGIN SETUP(PAGE_CNT, PAGELIST, 'Page', DESTPAGE-STPAGE+1, NO_PAGES); SETUP(ROW_CNT, ROWLIST, 'Row', DESTROW-STROW+1, NO_ROWS ); SETUP(COL_CNT, COLLIST, 'Col', DESTCOL-STCOL+1, NO_COLS ) END; IF NOT JUSTPAGES THEN (* Set dest dir record *) WITH DESTDIRENTRY DO BEGIN DESTDIRENTRY := SOURCEDIRENTRY; (* Set it to source entry *) FORM_NAME := DESTFORM; (* Then modify certain parts *) THEMAXROW := DESTROW; THEMAXCOL := DESTCOL; NO_PAGES := PAGE_CNT; NO_ROWS := ROW_CNT; NO_COLS := COL_CNT END END ELSE LEAVE(6,TRUE); (* no directory could be found *) COPYPAGES; IF NOT JUSTPAGES THEN COPYCONTROLS; DISKDRIVE := TEMP; (*$B 40COL- *) RETURNDISKS('Complete'); (*$E 40COL *) (*$B 40COL+ *) RETURNDISKS('Done'); (*$E 40COL *) FINISHUP END; (* of dothecopy *) BEGIN (* COPYFORM *) INITIALIZE; DOTHECOPY END; (* of copyform *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.data1.text ======================================================================================== SEGMENT PROCEDURE DATAIN; (* The Segment structure for Datain is as follows: |-- Help | |-- Setup | | |-- Openoutputfile |-- ListorZero --|-- List --|-- Closefile | | |-- Listit --------|-- Headings Datain --| | |-- Dobottom | |-- Zeroit |-- Math |-- Init ----------- Openupdatafiles |-- Update |-- Anchor *) CONST GAP = 2; (* spacing between columns *) TITLELINE = 1; (* line to display title on *) DESCLINE = 2; (* line to put col headings on *) MAXLINES = 63; (* Max num of lines and cols on a screen *) T_LENGTH = 59; MAP_FORMAT = '#####'; (* Integer Format used for Map pages *) TYPE FORMATDESC = PACKED RECORD BEF: 0..L_CFORMAT; AFT: 0..L_CFORMAT END; VIEWS = (NOTSET, ROWCOL, PAGECOL, ROWPAGE); TYPE_CALC = (NO_C, INIT_C, FINL_C); CALC_ARRAY = PACKED ARRAY[0..0] OF TYPE_CALC; BOOL_ARRAY = PACKED ARRAY[0..0] OF BOOLEAN; VAR BEFORE, AFTER: INTEGER; MAP_PAGE, WORK_PAGE, DIDDLED, ERR: BOOLEAN; ANUMBER: NUMBERTYPE; LEGAL: PACKED ARRAY[0..MAXLINES] OF BOOLEAN; CROSS_CALC: ^BOOL_ARRAY; CALC_LIST: ^CALC_ARRAY; THEFORMAT: PACKED ARRAY[0..MAXLINES] OF FORMATDESC; COL_POS: ARRAY[0..MAXCOL] OF INTEGER; CALC_CASE, REAL_PAGE, CUR_PAGE, CUR_COL, CUR_ROW, ST_COL, LAST_COL, ST_ROW, LAST_ROW, XOFFSET, YOFFSET, SIZE_CROSS_CALC, SIZE_CALC_LIST, NUM_COLS, NUM_ROWS: INTEGER; PLANE: VIEWS; COMMAND: CHAR; LISTCOL, LISTROW, FOOTING, TITLE1, TITLE2, TITLE3: STRING[T_LENGTH]; PAGE_TITLE: STRING[L_TITLE]; TRUE_DAT_FILE: AFILE; PROCEDURE SET_WORK_PAGE; FORWARD; PROCEDURE SAVEPAGE; FORWARD; PROCEDURE SET_TITLE; FORWARD; PROCEDURE GETPNUM( DEFAULT: INTEGER; VAR ANS: INTEGER ); FORWARD; PROCEDURE GETCTLREC( COL: BOOLEAN; REC: INTEGER ); FORWARD; PROCEDURE BEFOREAFTER( FORMAT: STRING ); FORWARD; PROCEDURE CALLNUMBER( Z,Y,X: INTEGER; WHAT: ACTIONTYPE ); FORWARD; PROCEDURE WRITENUM( ROW, COL: INTEGER ); FORWARD; PROCEDURE DISPLAY( CLEARFIRST: BOOLEAN ); FORWARD; SEGMENT PROCEDURE HELP; FORWARD; SEGMENT PROCEDURE LISTORZERO; FORWARD; SEGMENT PROCEDURE MATH; FORWARD; SEGMENT PROCEDURE INIT; FORWARD; SEGMENT PROCEDURE UPDATE; FORWARD; SEGMENT PROCEDURE ANCHOR; FORWARD; SEGMENT PROCEDURE HELP; BEGIN (* HELP *) PROMPT('Help',MSG_LINE-1); (*$B 40COL- *) PRESSRETURN('A => Anchor: Set screen display coordinates,', MSG_LINE); PRESSRETURN('U => Update: Enter data into FORM,', MSG_LINE); PRESSRETURN('M => Math: Perform prescribed calculations,', MSG_LINE); PRESSRETURN('Z => Zero: Set selected FORM elements to Zero,', MSG_LINE); PRESSRETURN('N => Nullify: Set selected FORM elements to Null,', MSG_LINE); PRESSRETURN('L => List: List selected FORM elements,', MSG_LINE); PRESSRETURN('S => Save: Save current page on diskette,', MSG_LINE); (*$E 40COL *) (*$B 40COL+ *) PRESSRETURN('Anchor: Change Anchor,', MSG_LINE); PRESSRETURN('Update: Enter data,', MSG_LINE); PRESSRETURN('Math: Perform Math,', MSG_LINE); PRESSRETURN('Zero: Zero FORM cells,', MSG_LINE); PRESSRETURN('Nullify: Null FORM cells,', MSG_LINE); PRESSRETURN('List: List FORM cells,', MSG_LINE); PRESSRETURN('Save: Save page,', MSG_LINE); (*$E 40COL *) END; (* of help *) SEGMENT PROCEDURE LISTORZERO; TYPE OUT_DESC = RECORD COL_NUMBER, COL_WIDTH: INTEGER END; VAR OUT_COL: ARRAY[1..MAXCOL] OF OUT_DESC; WIDTH,PRINT_LINE,PAGE,I,J,ROW,ROW_CNT,COL_CNT: INTEGER; WPFILE, TOPRINTER: BOOLEAN; VOL: STRING[7]; FNAME: STRING[10]; THELIST: STRING[T_LENGTH]; PROCEDURE LEAVE; FORWARD; PROCEDURE ONEPAIR( VAR PT, BEG, LAST: INTEGER ); FORWARD; SEGMENT PROCEDURE SETUP( VAR CNT: INTEGER; THEROWS: BOOLEAN; VAR PRINTLIST: STRING; DOWHAT: STRING ); FORWARD; SEGMENT PROCEDURE LIST; FORWARD; SEGMENT PROCEDURE ZEROIT( DOWHAT: STRING; TOZEROS: BOOLEAN ); FORWARD; SEGMENT PROCEDURE SETUP{ VAR CNT: INTEGER; THEROWS: BOOLEAN; VAR PRINTLIST: STRING; DOWHAT: STRING }; VAR MAX, HIGH, FIRST, START, NUM, INC, PT, BEG: INTEGER; FIRSTONE, A_OK: BOOLEAN; WHAT: STRING[7]; PROCEDURE SET_OUT(NUM: INTEGER); PROCEDURE SHOWERR(ERRNUM: INTEGER); BEGIN A_OK := FALSE; GOTOXY(PT-1,MSG_LINE+1); WRITE(OUTPUT,' <- '); DELETE(PRINTLIST,LENGTH(PRINTLIST),1); (* Delete the inserted comma *) FOR I := PT TO LENGTH(PRINTLIST) DO WRITE(OUTPUT,PRINTLIST[I]); IS := ''; CASE ERRNUM OF 1: IF CNT <= 1 THEN (* Additional check on CNT added SDA 6/26/81 *) (*$B 40COL- *) IS := 'Line width is too small for ANY Columns to fit' (*$E 40COL *) (*$B 40COL+ *) IS := 'No Columns will fit' (*$E 40COL *) ELSE BEGIN (* Change SDA 5/7/81 *) ENCODE(OUT_COL[ CNT-1 ].COL_NUMBER,IS); (*$B 40COL- *) IS := CONCAT('Can only fit thru ',WHAT,' ',IS,',') (*$E 40COL *) (*$B 40COL+ *) IS := CONCAT('Can fit thru ',WHAT,' ',IS,',') (*$E 40COL *) END; 2: IS := 'Illegal value,' END; PRESSRETURN(IS,MSG_LINE+2); ERASE(MSG_LINE+2); ERASE(MSG_LINE+1) END; BEGIN CNT := CNT + 1; (* MOD by SDA 9/22/81 *) IF (CNT > MAXCOL) AND (NOT THEROWS) THEN SHOWERR(1) ELSE IF NOT (NUM IN [1..HIGH]) THEN SHOWERR(2) ELSE IF NOT THEROWS THEN WITH OUT_COL[ CNT ] DO BEGIN COL_NUMBER := NUM; IF COMMAND = 'L' THEN (* Listing so checkout total width of line so far *) BEGIN COL_WIDTH := COL_POS[ NUM ] - COL_POS[ NUM - 1 ]; WIDTH := WIDTH + COL_WIDTH; IF TOPRINTER AND (WIDTH >= CHARS_PER_LINE) THEN SHOWERR(1) END END END; BEGIN (* SETUP *) WITH DIRECTORY^ DO IF THEROWS THEN (* Change SDA 5/5/81 *) IF PLANE = PAGECOL THEN BEGIN WHAT := 'Page'; HIGH := NO_PAGES; MAX := NO_PAGES END ELSE BEGIN WHAT := 'Row'; HIGH := NO_ROWS; MAX := THEMAXROW END ELSE IF PLANE = ROWPAGE THEN BEGIN WHAT := 'Page'; HIGH := NO_PAGES; MAX := NO_PAGES END ELSE BEGIN WHAT := 'Column'; HIGH := NO_COLS; MAX := THEMAXCOL END; (*$B 40COL- *) PROMPT(CONCAT('Enter sequences of ',WHAT,'s (XX-XX,YY-YY) to ',DOWHAT, ' below'),MSG_LINE); WRITE(OUTPUT,' (there are ',HIGH,')'); (*$E 40COL *) (*$B 40COL+ *) PROMPT(CONCAT('Enter ',WHAT,'s to ',DOWHAT),MSG_LINE); WRITE(OUTPUT,' (max ',HIGH,')'); (*$E 40COL *) REPEAT CNT := 0; PT := 1; FIRSTONE := TRUE; A_OK := TRUE; WIDTH := COL_POS[0]; ACCEPTSTR(TRUE,T_LENGTH-1,0,MSG_LINE+1,PRINTLIST,IS); IF IS = 'ESCAPE' THEN LEAVE ELSE PRINTLIST := IS; PRINTLIST := CONCAT(PRINTLIST,','); (* comma stopper at end of string *) REPEAT WHILE NOT ( (PRINTLIST[PT] IN DIGITS) OR (PRINTLIST[PT]=',') ) DO PT := PT + 1; IF PRINTLIST[PT] = ',' THEN BEGIN PT := PT + 1; FIRSTONE := TRUE END ELSE (* must be a number *) BEGIN START := PT; WHILE PRINTLIST[PT] IN DIGITS DO PT := PT+1; (* find end of number *) VALUE(TRUE,COPY(PRINTLIST,START,PT-START),FAKE,NUM); IF FIRSTONE THEN BEGIN SET_OUT(NUM); BEG := NUM; FIRSTONE := FALSE END ELSE (* second number so generate a sequence *) BEGIN IF THEROWS THEN FIRST := BEG ELSE (*thecols*) FIRST := OUT_COL[ CNT ].COL_NUMBER; IF FIRST <> NUM THEN (* legitimate sequence *) BEGIN IF FIRST > NUM THEN INC := -1 ELSE INC := 1; REPEAT FIRST := FIRST + INC; SET_OUT(FIRST) UNTIL (NOT A_OK) OR (FIRST = NUM) END; FIRSTONE := TRUE END END UNTIL (NOT A_OK) OR (PT >= LENGTH(PRINTLIST)) UNTIL A_OK; DELETE(PRINTLIST,LENGTH(PRINTLIST),1); (* get rid of added comma *) IF CNT = 0 THEN LEAVE; (* Bug fix SDA 3/4/81 *) ERASE(MSG_LINE+1) END; (* of setup *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.data2.text ======================================================================================== SEGMENT PROCEDURE LIST; SEGMENT PROCEDURE OPENOUTPUTFILE( OLD: BOOLEAN ); BEGIN REPEAT GETRESPONSE(TRUE,'Volume Name: ',VOL,':',7,VOL); IF VOL = 'ESCAPE' THEN LEAVE; GETRESPONSE(TRUE,'File Name: ',FNAME,'.TEXT',10,FNAME); IF FNAME = 'ESCAPE' THEN LEAVE; IF OLD THEN RESET(PRINTER,CONCAT(VOL,':',FNAME,'.TEXT')) ELSE REWRITE(PRINTER,CONCAT(VOL,':',FNAME,'.TEXT')); PRINTER_ON := IORESULT = 0; IF NOT PRINTER_ON THEN PRESSRETURN(CONCAT('Unable to open ',VOL,':',FNAME,'.TEXT'),MSG_LINE) UNTIL PRINTER_ON; END; (* of open output file *) SEGMENT PROCEDURE CLOSEFILE; BEGIN CLOSE(PRINTER,LOCK); PRINTER_ON := FALSE; END; SEGMENT PROCEDURE LISTIT; CONST RUNOFFCH = ''; (* CHR(31), which is the same as the Editor uses *) VAR OFFSET, CNT, PT, BEG, LAST: INTEGER; PROCEDURE DOWRITELN; FORWARD; SEGMENT PROCEDURE HEADINGS; FORWARD; SEGMENT PROCEDURE DOBOTTOM; FORWARD; SEGMENT PROCEDURE HEADINGS; VAR TEMP, TABSTOP: INTEGER; FUNCTION MAX( X, Y: INTEGER ): INTEGER; BEGIN IF X > Y THEN MAX := X ELSE MAX := Y END; BEGIN IF WPFILE THEN (* Set up tab stops after a Save settings command *) BEGIN WRITE(PRINTER,'[SS/TA='); TABSTOP := COL_POS[0]; FOR TEMP := 1 TO COL_CNT DO WITH OUT_COL[TEMP] DO BEGIN TABSTOP := TABSTOP + COL_WIDTH; WRITE(PRINTER,'R',TABSTOP); IF TEMP <> COL_CNT THEN WRITE(PRINTER,',') END; WRITE(PRINTER,']') END; DOWRITELN; TEMP := LENGTH(TITLE1); WRITE(PRINTER,TITLE1: MAX( TEMP, TEMP + ( (WIDTH-TEMP) DIV 2 ) )); DOWRITELN; TEMP := LENGTH(TITLE2); WRITE(PRINTER,TITLE2: MAX( TEMP, TEMP + ( (WIDTH-TEMP) DIV 2 ) )); DOWRITELN; TEMP := LENGTH(TITLE3); WRITE(PRINTER,TITLE3: MAX( TEMP, TEMP + ( (WIDTH-TEMP) DIV 2 ) )); DOWRITELN; DOWRITELN; TEMP := LENGTH(PAGE_TITLE); WRITE(PRINTER,PAGE_TITLE: MAX( TEMP, TEMP + ( (WIDTH-TEMP) DIV 2 ) )); DOWRITELN; DOWRITELN; IF NOT WPFILE THEN WRITE(PRINTER,' ':COL_POS[0]); FOR TEMP := 1 TO COL_CNT DO WITH OUT_COL[TEMP] DO BEGIN IF PLANE = ROWPAGE THEN (* Addtion SDA 5/5/81 *) BEGIN ENCODE(COL_NUMBER,IS); IS := CONCAT('Page ',IS) END ELSE BEGIN SEEKCTL(FORM_CTL_FILE,TRUE,COL_NUMBER,ANDGET); IS := FORM_CTL_FILE^.CTL_DESC END; IF WPFILE THEN WRITE(PRINTER,TAB) ELSE WRITE(PRINTER,' ':COL_WIDTH-LENGTH(IS)); WRITE(PRINTER,IS); END; DOWRITELN; PRINT_LINE := 8; END; SEGMENT PROCEDURE DOBOTTOM; BEGIN DOWRITELN; DOWRITELN; DOWRITELN; WRITE(PRINTER, FOOTING); IF TOPRINTER THEN {WRITE(PRINTER,CLEAR)} (** ??? *) ELSE IF WPFILE THEN BEGIN DOWRITELN; WRITE(PRINTER,'[PA/RS]') END; DOWRITELN END; PROCEDURE DOWRITELN; BEGIN IF WPFILE THEN WRITE(PRINTER,RUNOFFCH); WRITELN(PRINTER); IF IORESULT <> 0 THEN BEGIN IF TOPRINTER THEN ERROR(0) ELSE ERROR(2); LEAVE END END; BEGIN (* LISTIT *) ONEMOMENT('Listing'); WITH FORM_CTL_FILE^, DIRECTORY^ DO BEGIN HEADINGS; (* write out titles and column headings *) CNT := 0; PT := 1; THELIST := CONCAT(LISTROW,','); REPEAT ONEPAIR(PT,BEG,LAST); IF BEG <= LAST THEN OFFSET := 1 ELSE OFFSET := -1; ROW := BEG - OFFSET; REPEAT ROW := ROW + OFFSET; IF PLANE = PAGECOL THEN (* BUG FIX SDA 11/6/81 *) BEGIN SEEKCTL(FORM_CTL_FILE,FALSE,CUR_PAGE,ANDGET); ENCODE(ROW,IS); IS := CONCAT('Page ',IS) END ELSE BEGIN SEEKCTL(FORM_CTL_FILE,FALSE,ROW,ANDGET); IS := CTL_DESC END; WRITE(PRINTER,IS); IF NOT WPFILE THEN WRITE(PRINTER,' ':COL_POS[0]-LENGTH(IS)); IF CTL_TYPE <> HEADING THEN FOR J := 1 TO COL_CNT DO WITH OUT_COL[J] DO BEGIN IF FORMAT = FCOL THEN (* BUG FIX SDA 11/6/81 *) IF PLANE = ROWPAGE THEN SEEKCTL(FORM_CTL_FILE,TRUE,CUR_PAGE, ANDGET) ELSE SEEKCTL(FORM_CTL_FILE,TRUE,COL_NUMBER,ANDGET); IF MAP_PAGE THEN CTL_FORMAT := MAP_FORMAT; BEFOREAFTER(CTL_FORMAT); NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CUR_PAGE,ROW,COL_NUMBER, ANUMBER,ANDGET,ERR); CALLNUMBER(CUR_PAGE,ROW,COL_NUMBER,ANDGET); (* New SDA 5/5/81 *) NUMTOSTR(IS,ANUMBER,BEFORE,AFTER); IF WPFILE THEN WRITE(PRINTER,TAB) ELSE WRITE(PRINTER,' ':COL_WIDTH-LENGTH(IS)); WRITE(PRINTER,IS) END; DOWRITELN; PRINT_LINE := PRINT_LINE + 1; IF PRINT_LINE > PAPER_LENGTH-12 THEN BEGIN DOBOTTOM; HEADINGS END; CNT := CNT + 1 UNTIL ROW = LAST UNTIL CNT = ROW_CNT; DOBOTTOM; END; END; (* of listit *) BEGIN (* LIST *) PROMPT('List',MSG_LINE-1); MEMORY; VOL := DISKDRIVE; FNAME := ''; TOPRINTER := YESNO('List to the Printer','Y'); IF TOPRINTER THEN (*$B 40COL- *) GETNUM(1,999,CHARS_PER_LINE,'How many characters wide is the paper ?', CHARS_PER_LINE); (*$E 40COL *) (*$B 40COL+ *) GETNUM(1,999,CHARS_PER_LINE,'How wide is paper ?',CHARS_PER_LINE); (*$E 40COL *) IF YESNO('Is there a Control file to use','N') THEN BEGIN OPENOUTPUTFILE(TRUE); READLN(PRINTER,TITLE1); READLN(PRINTER,TITLE2); READLN(PRINTER,TITLE3); READLN(PRINTER,FOOTING); READLN(PRINTER,LISTROW); READLN(PRINTER,LISTCOL); CLOSEFILE END; SETUP(ROW_CNT,TRUE,LISTROW,'List'); (* get list of rows to print *) SETUP(COL_CNT,FALSE,LISTCOL,'List'); (* get list of columns to print *) GETRESPONSE(TRUE,'Title 1 -> ',TITLE1, '',T_LENGTH,TITLE1); GETRESPONSE(TRUE,'Title 2 -> ',TITLE2, '',T_LENGTH,TITLE2); GETRESPONSE(TRUE,'Title 3 -> ',TITLE3, '',T_LENGTH,TITLE3); GETRESPONSE(TRUE,'Footing -> ',FOOTING,'',T_LENGTH,FOOTING); (*$B 40COL- *) IF YESNO('Save this information in a Control file','N') THEN (*$E 40COL *) (*$B 40COL+ *) IF YESNO('Save info in a Control file','N') THEN (*$E 40COL *) BEGIN OPENOUTPUTFILE(FALSE); WRITELN(PRINTER,TITLE1); WRITELN(PRINTER,TITLE2); WRITELN(PRINTER,TITLE3); WRITELN(PRINTER,FOOTING); WRITELN(PRINTER,LISTROW); WRITELN(PRINTER,LISTCOL); CLOSEFILE END; IF TOPRINTER THEN BEGIN WPFILE := FALSE; SETPRINTER; IF NOT PRINTER_ON THEN LEAVE END ELSE BEGIN FNAME := 'LISTING'; OPENOUTPUTFILE(FALSE); (*$B 40COL- *) WPFILE := YESNO('Create output for Word Processing','Y'); (*$E 40COL *) (*$B 40COL+ *) WPFILE := YESNO('Output for Word Processing','Y'); (*$E 40COL *) END; LISTIT; CLOSEFILE END; (* of list *) SEGMENT PROCEDURE ZEROIT{ DOWHAT: STRING; TOZEROS: BOOLEAN }; VAR OFFSET, CNT, PT, BEG, LAST: INTEGER; DUMYLIST: STRING[T_LENGTH]; BEGIN MEMORY; PROMPT(DOWHAT, MSG_LINE-1); THELIST := ''; DUMYLIST := ''; SETUP(ROW_CNT, TRUE, THELIST, DOWHAT); (* Gather rows to ZERO *) SETUP(COL_CNT, FALSE, DUMYLIST, DOWHAT); (* Gather columns to ZERO *) ONEMOMENT(CONCAT(DOWHAT,'ing')); DIDDLED := TRUE; IF TOZEROS THEN ANUMBER := ZERO ELSE ANUMBER := EMPTY; CNT := 0; PT := 1; THELIST := CONCAT(THELIST, ','); REPEAT ONEPAIR(PT, BEG, LAST); IF BEG <= LAST THEN OFFSET := 1 ELSE OFFSET := -1; ROW := BEG - OFFSET; REPEAT ROW := ROW + OFFSET; CNT := CNT + 1; FOR I := 1 TO COL_CNT DO (* Change SDA 5/5/81 *) CALLNUMBER(CUR_PAGE,ROW,OUT_COL[I].COL_NUMBER,ANDPUT) UNTIL ROW = LAST UNTIL CNT = ROW_CNT; DISPLAY(FALSE) END; (* of zeroit *) PROCEDURE LEAVE; BEGIN ERASE(MSG_LINE+1); EXIT(LISTORZERO) END; PROCEDURE ONEPAIR{ VAR PT, BEG, LAST: INTEGER }; VAR FIRSTONE, SECOND: BOOLEAN; NUM, START: INTEGER; BEGIN FIRSTONE := TRUE; SECOND := FALSE; LAST := -1; REPEAT WHILE NOT ( (THELIST[PT] IN DIGITS) OR (THELIST[PT]=',') ) DO PT := PT + 1; IF THELIST[PT] = ',' THEN BEGIN PT := PT + 1; FIRSTONE := TRUE; SECOND := LAST <> -1 END ELSE (* must be a number *) BEGIN START := PT; WHILE THELIST[PT] IN DIGITS DO PT := PT+1; (* find end of number *) VALUE(TRUE,COPY(THELIST,START,PT-START),FAKE,NUM); IF FIRSTONE THEN BEGIN BEG := NUM; LAST := NUM; FIRSTONE := FALSE END ELSE (* second number *) BEGIN SECOND := TRUE; LAST := NUM END END UNTIL (LAST <> -1) AND SECOND; END; (* of onepair *) BEGIN (* LISTORZERO *) CASE COMMAND OF 'L': LIST; 'Z': ZEROIT('Zero',TRUE); 'N': ZEROIT('Nullify',FALSE) END END; (* of listorzero *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.data3.text ======================================================================================== (*$R- *) SEGMENT PROCEDURE MATH; VAR SKIPOMSG, LEAVE: BOOLEAN; CURCONST, ROW, COL: INTEGER; PROCEDURE DOIT(DOINGROW: BOOLEAN); VAR CNT, MAX: INTEGER; C_STRING: STRING[L_CALC]; PROCEDURE OOPS(NUM: INTEGER); BEGIN IF SKIPOMSG AND (NUM=1) THEN EXIT(OOPS); (* Told to ignore Overflow msgs ? *) PROMPT('ERROR: ',MSG_LINE-1); CASE NUM OF 1: WRITE(OUTPUT,'OVERFLOW'); 2: WRITE(OUTPUT,'Heading'); 3: BEGIN WRITE(OUTPUT,'Illegal '); IF DOINGROW THEN WRITE(OUTPUT,'row') ELSE WRITE(OUTPUT,'column') END END; IF NUM <> 1 THEN WRITE(OUTPUT,' specified'); WRITELN(OUTPUT,', Calc. at Row = ',ROW,' Col = ',COL); IF NUM = 1 THEN (* Continue?, if so should Overflows be ignored *) BEGIN LEAVE := NOT YESNO('Continue Calculations','Y'); IF NOT LEAVE THEN SKIPOMSG := YESNO('Ignore future Overflows','Y') END; IF LEAVE OR (NUM <> 1) THEN BEGIN PRESSRETURN('Math being aborted,',MSG_LINE); CLOSE(FORM_CON_FILE); CON_OPEN := FALSE; (* Bug fix SDA 12/18/81 *) DISPLAY(FALSE); (* Forgot to close Con_file *) EXIT(MATH); END; ERASE(MSG_LINE); PROMPT('Math in progress....',MSG_LINE-1); END; (* of err *) PROCEDURE DOMATH; TYPE TOKENKINDS = (CONSTV, EOFV, LPARENV, MINUSV, PLUSV, UPARROWV, RPARENV, VALUEV, SLASHV, STARV); VAR SCANRSLT: NUMBERTYPE; TOKENTYPE: TOKENKINDS; PT: INTEGER; PROCEDURE SCANNER; VAR NUM: INTEGER; CH, DUMY: CHAR; PROCEDURE SETNUM; VAR ENDOFNUM: INTEGER; BEGIN ENDOFNUM := PT; REPEAT ENDOFNUM := ENDOFNUM + 1; DUMY := C_STRING[ ENDOFNUM ] UNTIL NOT (( DUMY >= '0' ) AND ( DUMY <= '9' )); VALUE(TRUE,COPY(C_STRING,PT,ENDOFNUM-PT),FAKE,NUM); PT := ENDOFNUM; END; (* of setnum *) PROCEDURE GETCONSTANT; BEGIN PT := PT + 1; DUMY := C_STRING[ PT ]; IF (DUMY >= '0') AND (DUMY <= '9') THEN BEGIN SETNUM; IF NUM <> CURCONST THEN BEGIN SEEKCON(NUM,ANDGET); CURCONST := NUM END; SCANRSLT := FORM_CON_FILE^; TOKENTYPE := CONSTV END END; (* of getconstant *) PROCEDURE GETVALUE; BEGIN SETNUM; WITH DIRECTORY^ DO IF DOINGROW THEN BEGIN IF NUM > NO_ROWS THEN OOPS(3); NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CUR_PAGE,NUM,COL,SCANRSLT,ANDGET,ERR) END ELSE BEGIN IF NUM > NO_COLS THEN OOPS(3); NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CUR_PAGE,ROW,NUM,SCANRSLT,ANDGET,ERR) END; TOKENTYPE := VALUEV; END; (* getvalue *) BEGIN (* SCANNER *) IF C_STRING[ PT ] = ' ' THEN REPEAT PT := PT + 1 UNTIL C_STRING[ PT ] <> ' '; (* get non blank *) CH := C_STRING[ PT ]; IF CH = 'C' THEN GETCONSTANT ELSE IF (CH >= '0') AND (CH <= '9') THEN GETVALUE ELSE BEGIN CASE CH OF '+': TOKENTYPE:=PLUSV; '-': TOKENTYPE:=MINUSV; '*': TOKENTYPE:=STARV; '/': TOKENTYPE:=SLASHV; '^': TOKENTYPE:=UPARROWV; '(': TOKENTYPE:=LPARENV; ')': TOKENTYPE:=RPARENV; '#': TOKENTYPE:=EOFV END; PT := PT + 1 END; IF TOKENTYPE = EOFV THEN PT := PT - 1; END; (* of scanner *) PROCEDURE EXPRESSION( VAR ANS: NUMBERTYPE ); VAR SAVEOP: CHAR; CHANGESIGN: BOOLEAN; RESULT: NUMBERTYPE; PROCEDURE PARENEXPRESSION( VAR ANS: NUMBERTYPE ); BEGIN SCANNER; (* throw away left paren *) EXPRESSION( ANS ); SCANNER (* throw away right paren *) END; (* of parenexpression *) PROCEDURE PRIMARY( VAR ANS: NUMBERTYPE ); BEGIN (* PRIMARY *) IF (TOKENTYPE = CONSTV) OR (TOKENTYPE = VALUEV) THEN BEGIN ANS := SCANRSLT; SCANNER END ELSE IF TOKENTYPE = LPARENV THEN PARENEXPRESSION( ANS ) END; (* of primary *) PROCEDURE FACTOR( VAR ANS: NUMBERTYPE ); VAR RESULT: NUMBERTYPE; BEGIN (* FACTOR *) PRIMARY( ANS ); WHILE TOKENTYPE = UPARROWV DO BEGIN SCANNER; PRIMARY( RESULT ); IF NOT FIGURE(ANS,ANS,RESULT,'^') THEN OOPS(1); END END; (* of factor *) PROCEDURE TERM( VAR ANS: NUMBERTYPE ); VAR SAVEOP: CHAR; RESULT: NUMBERTYPE; BEGIN (* TERM *) FACTOR( ANS ); WHILE (TOKENTYPE = STARV) OR (TOKENTYPE = SLASHV) DO BEGIN IF TOKENTYPE = STARV THEN SAVEOP := '*' ELSE SAVEOP := '/'; SCANNER; FACTOR( RESULT ); IF NOT FIGURE(ANS,ANS,RESULT,SAVEOP) THEN OOPS(1); END END; (* of term *) BEGIN (* EXPRESSION *) IF (TOKENTYPE = PLUSV) OR (TOKENTYPE = MINUSV) THEN BEGIN CHANGESIGN := TOKENTYPE = MINUSV; SCANNER END ELSE CHANGESIGN := FALSE; TERM( ANS ); IF CHANGESIGN THEN IF FIGURE(ANS,ZERO,ANS,'-') THEN; (* do the unary minus *) WHILE (TOKENTYPE = PLUSV) OR (TOKENTYPE = MINUSV) DO BEGIN IF TOKENTYPE = PLUSV THEN SAVEOP := '+' ELSE SAVEOP := '-'; SCANNER; TERM( RESULT ); IF NOT FIGURE(ANS,ANS,RESULT,SAVEOP) THEN OOPS(1) END END; (* of expression *) BEGIN (* DOMATH *) PT := 1; SCANNER; EXPRESSION( ANUMBER ); NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CUR_PAGE,ROW,COL,ANUMBER,ANDPUT,ERR) END; (* of domath *) BEGIN WITH DIRECTORY^, FORM_CTL_FILE^ DO BEGIN C_STRING := CTL_CALC; LCTOUC(C_STRING); (* Convert to caps *) C_STRING := CONCAT(C_STRING,'#'); (* The first version of Freeform left an equals sign in the first position of the calc string. Must get rid of this for this version to work *) IF POS('=',C_STRING) = 1 THEN DELETE(C_STRING,1,1); IF DOINGROW THEN MAX := NO_COLS ELSE MAX := NO_ROWS; (*$R- *) FOR CNT := 1 TO MAX DO IF DOINGROW THEN IF CROSS_CALC^[ CNT + NO_ROWS ] THEN BEGIN COL := CNT; DOMATH END ELSE (* No math then *) ELSE IF CROSS_CALC^[ CNT ] THEN BEGIN ROW := CNT; DOMATH END ELSE (* No math then *) (*$R^ *) END END; (* of doit *) (*$R- *) PROCEDURE DO_COLS(WHICH: TYPE_CALC); BEGIN WITH FORM_CTL_FILE^, DIRECTORY^ DO FOR COL := 1 TO NO_COLS DO IF WHICH = CALC_LIST^[ COL + NO_ROWS ] THEN BEGIN SEEKCTL(FORM_CTL_FILE,TRUE,COL,ANDGET); DOIT(FALSE) END END; (* of do_cols *) PROCEDURE DO_ROWS(WHICH: TYPE_CALC); BEGIN WITH FORM_CTL_FILE^, DIRECTORY^ DO FOR ROW := 1 TO NO_ROWS DO IF WHICH = CALC_LIST^[ ROW ] THEN BEGIN SEEKCTL(FORM_CTL_FILE,FALSE,ROW,ANDGET); DOIT(TRUE) END END; (* of do_rows *) (*$R^ *) BEGIN IF NOT OPEN_CON(REQUESTED_FORM) THEN (* Open file that has constants *) BEGIN ERROR(12); EXIT(MATH) END; PROMPT('Math in progress....',MSG_LINE-1); SKIPOMSG := FALSE; CURCONST := 0; DIDDLED := CALC_CASE <> 0; MEMORY; WITH DIRECTORY^ DO CASE CALC_CASE OF 0: (* no calculations to do! *) ; 1: DOCOLS(INIT_C); 2: DOROWS(INIT_C); 3: IF FORMAT = FCOL THEN BEGIN DO_COLS(INIT_C); DO_ROWS(INIT_C) END ELSE BEGIN DO_ROWS(INIT_C); DO_COLS(INIT_C) END; 4: DOCOLS(FINL_C); 5: BEGIN DOCOLS(INIT_C); DOCOLS(FINL_C) END; 6: BEGIN DOROWS(INIT_C); DOCOLS(FINL_C) END; 7: IF FORMAT = FCOL THEN BEGIN DOCOLS(INIT_C); DOROWS(INIT_C); DOCOLS(FINL_C) END ELSE BEGIN DOROWS(INIT_C); DOCOLS(INIT_C); DOCOLS(FINL_C) END; 8: DOROWS(FINL_C); 9: BEGIN DOCOLS(INIT_C); DOROWS(FINL_C) END; 10: BEGIN DOROWS(INIT_C); DOROWS(FINL_C) END; 11: IF FORMAT = FCOL THEN BEGIN DOCOLS(INIT_C); DOROWS(INIT_C); DOROWS(FINL_C) END ELSE BEGIN DOROWS(INIT_C); DOCOLS(INIT_C); DOROWS(FINL_C) END; 12: IF FORMAT = FCOL THEN BEGIN DOCOLS(FINL_C); DOROWS(FINL_C) END ELSE BEGIN DOROWS(FINL_C); DOCOLS(FINL_C) END; 13: IF FORMAT = FCOL THEN BEGIN DOCOLS(INIT_C); DOCOLS(FINL_C); DOROWS(FINL_C) END ELSE BEGIN DOCOLS(INIT_C); DOROWS(FINL_C); DOCOLS(FINL_C) END; 14: IF FORMAT = FCOL THEN BEGIN DOROWS(INIT_C); DOCOLS(FINL_C); DOROWS(FINL_C) END ELSE BEGIN DOROWS(INIT_C); DOROWS(FINL_C); DOCOLS(FINL_C) END; 15: IF FORMAT = FCOL THEN BEGIN DOCOLS(INIT_C); DOROWS(INIT_C); DOCOLS(FINL_C); DOROWS(FINL_C) END ELSE BEGIN DOROWS(INIT_C); DOCOLS(INIT_C); DOROWS(FINL_C); DOCOLS(FINL_C) END END; CLOSE(FORM_CON_FILE); CON_OPEN := FALSE; DISPLAY(FALSE) END; (* of math *) (*$R^ *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.data4.text ======================================================================================== SEGMENT PROCEDURE INIT; VAR FINALC_COL, FINALC_ROW, INITC_COL, INITC_ROW, THEMAX, DESCLENGTH, FORMATLEN, I: INTEGER; SEGMENT PROCEDURE OPENUPDATAFILES; (* If a WORK_PAGE condition exists then the real file will be opened as TRUE_DAT_FILE and the workfile as FORM_DAT_FILE. *) VAR I: INTEGER; AWINDOW: WINDOWTYPE; PROCEDURE LEAVE; BEGIN ERROR(11); VARDISPOSE( CALC_LIST, SIZE_CALC_LIST ); VARDISPOSE( CROSS_CALC, SIZE_CROSS_CALC ); CLOSE(FORM_DAT_FILE, PURGE); DAT_OPEN := FALSE; CLOSE(TRUE_DAT_FILE); CLOSE(FORM_CTL_FILE); CTL_OPEN := FALSE; EXIT(DATAIN) END; (* of leave *) BEGIN (* OPENUPDATAFILES *) ONEMOMENT('Opening Data File'); IF WORK_PAGE THEN BEGIN RESET(TRUE_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT')); IF IORESULT <> 0 THEN BEGIN ERROR(5); EXIT(DATAIN) END; REWRITE(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',TEMP_FILE_NAME,'.DAT')); IF IORESULT <> 0 THEN LEAVE; FOR I := 0 TO WINDOWSIZE DO AWINDOW[I] := EMPTY; WITH FORM_DAT_DESC, DIRECTORY^ DO BEGIN BLKSPERPAGE := ( (THEMAXROW*THEMAXCOL) + WINDOWSIZE ) DIV ( WINDOWSIZE + 1 ); FOR I := 1 TO BLKSPERPAGE DO IF BLOCKWRITE(FORM_DAT_FILE,AWINDOW,1) <> 1 THEN LEAVE END; CLOSE(FORM_DAT_FILE,LOCK); IF OPEN_DAT(TEMP_FILE_NAME,FORM_DAT_FILE, FORM_DAT_DESC,'DATAIN,MATH,LISTORZERO,FIGURE,NUMTOSTR',TRUE) THEN END ELSE IF NOT OPEN_DAT(REQUESTED_FORM,FORM_DAT_FILE,FORM_DAT_DESC, 'DATAIN,MATH,LISTORZERO,FIGURE,NUMTOSTR',TRUE) THEN BEGIN ERROR(5); EXIT(DATAIN) END END; (* of open up data files *) FUNCTION MAX( X, Y: INTEGER ): INTEGER; BEGIN IF X > Y THEN MAX := X ELSE MAX := Y; END; (*$R- *) PROCEDURE COUNT_CALCS(CTL_TYPE: TYPE_CTL; DOINGROW: BOOLEAN; OFFSET: INTEGER); BEGIN CASE CTL_TYPE OF HEADING, DATA: CALC_LIST^[ OFFSET ] := NO_C; INITIALC: BEGIN CALC_LIST^[ OFFSET ] := INIT_C; IF DOINGROW THEN INITC_ROW := INITC_ROW + 1 ELSE INITC_COL := INITC_COL + 1 END; FINALC: BEGIN CALC_LIST^[ OFFSET ] := FINL_C; IF DOINGROW THEN FINALC_ROW := FINALC_ROW + 1 ELSE FINALC_COL := FINALC_COL + 1 END END END; (* of count_calcs *) (*$R^ *) BEGIN WITH DIRECTORY^, FORM_CTL_FILE^ DO BEGIN (* NOTE: You may wonder why on earth there is a plus 2 on both of the expressions below. Well I will tell you! Some genius at Softech Microsystems decided that you cannot Dispose of less than two words but allocating just one with a Varnew is a ok. So for forms where just one word was needed below things would be FUBARed when the Vardispose was done. I have a word for the person who coded the Varnew and Vardispose routines but I will keep it to myself. SDA 9/28/81 *) SIZE_CROSS_CALC := VARNEW( CROSS_CALC, (( NO_ROWS+NO_COLS ) DIV 16 ) + 2 ); SIZE_CALC_LIST := VARNEW( CALC_LIST , (( NO_ROWS+NO_COLS ) DIV 8 ) + 2 ); IF (SIZE_CROSS_CALC = 0) OR (SIZE_CALC_LIST = 0) THEN BEGIN PRESSRETURN('*** Not Enough Memory. Aborting,',MSG_LINE); FINISH_UP; EXIT(DATAIN) END; (* Additions Below SDA 5/5/81 *) PLANE := NOTSET; REPEAT IF YESNO('Access Data by Pages','N') THEN PLANE := ROWCOL ELSE IF YESNO('Access Data by Columns','N') THEN PLANE := ROWPAGE ELSE IF YESNO('Access Data by Rows','N') THEN PLANE := PAGECOL UNTIL PLANE <> NOTSET; IF PLANE <> ROWCOL THEN WORK_PAGE := FALSE ELSE WORK_PAGE := YESNO('Use a Work File','Y'); OPENUPDATAFILES; GETPNUM(1,REAL_PAGE); (* This sets MAP_PAGE boolean *) ONEMOMENT('Setting Up'); (* Addition SDA 6/26/81 *) CASE PLANE OF ROWCOL: BEGIN NUM_COLS := NO_COLS; NUM_ROWS := NO_ROWS; IF WORK_PAGE THEN SET_WORK_PAGE END; PAGECOL: BEGIN NUM_COLS := NO_COLS; NUM_ROWS := NO_PAGES END; ROWPAGE: BEGIN NUM_COLS := NO_PAGES; NUM_ROWS := NO_ROWS END END; IF NOT WORK_PAGE THEN CUR_PAGE := REAL_PAGE; (* Initialize Col pos array, COL_POS[ I-1 ] contains position of Col I Also set num of calculated Rows and Cols, both Initial and Final if PLANE is ROWCOL *) THEMAX := 0; INITC_ROW := 0; FINALC_ROW := 0; INITC_COL := 0; FINALC_COL := 0; IF PLANE = PAGECOL THEN THEMAX := 8 (* All descs are of the form 'Page xxx' *) ELSE FOR I := 1 TO NO_ROWS DO (* set col pos 0 by finding biggest row desc *) BEGIN (* cnt number of initial and final row calcs *) GETCTLREC( FALSE, I ); THEMAX := MAX( THEMAX, LENGTH( CTL_DESC ) ); IF PLANE = ROWCOL THEN BEGIN (*$R- *) CROSS_CALC^[ I ] := CTL_CROSS; (*$R^ *) COUNT_CALCS(CTL_TYPE, TRUE, I) END END; COL_POS[0] := THEMAX + GAP; IF FORMAT = FROW THEN (* spacing determined by row with biggest format *) BEGIN (* and the size of each column description. *) THEMAX := 0; FOR I := 1 TO NO_ROWS DO (* find biggest format *) BEGIN GETCTLREC( FALSE, I ); THEMAX := MAX( THEMAX, LENGTH( CTL_FORMAT ) ) END; THEMAX := THEMAX + 1; (* add one for the sign *) FOR I := 1 TO NUM_COLS DO (* set pos to max of format and desc *) BEGIN (* cnt number of column calcs too *) IF PLANE = ROWPAGE THEN DESCLENGTH := 8 (* Descs are of the form 'Page xxx' *) ELSE BEGIN GETCTLREC( TRUE, I ); DESCLENGTH := LENGTH( CTL_DESC ); IF PLANE = ROWCOL THEN BEGIN (*$R- *) CROSS_CALC^[ I + NO_ROWS ] := CTL_CROSS; (*$R^ *) COUNT_CALCS(CTL_TYPE, FALSE, I + NO_ROWS) END END; COL_POS[I] := COL_POS[I-1] + GAP + MAX( THEMAX, DESCLENGTH ) END END ELSE (* formatting by columns *) BEGIN IF PLANE = ROWPAGE THEN (* If PLANE is ROWPAGE then find the largest *) BEGIN (* col format and use it for the comparisons *) FORMATLEN := 0; (* below. SDA 5/5/81 *) FOR I := 1 TO NO_COLS DO BEGIN GETCTLREC(TRUE,I); FORMATLEN := MAX( FORMATLEN, LENGTH(CTL_FORMAT) ) END; DESCLENGTH := 8 (* All col descs are of the form 'Page xxxx' *) END; FOR I := 1 TO NUM_COLS DO (* set pos to max of col format and desc *) BEGIN (* cnt number of column calcs too *) IF PLANE <> ROWPAGE THEN BEGIN GETCTLREC( TRUE, I ); FORMATLEN := LENGTH(CTL_FORMAT); DESCLENGTH := LENGTH(CTL_DESC); IF PLANE = ROWCOL THEN BEGIN (*$R- *) CROSS_CALC^[ I + NO_ROWS ] := CTL_CROSS; (*$R^ *) COUNT_CALCS(CTL_TYPE, FALSE, I + NO_ROWS) END END; COL_POS[I] := COL_POS[I-1] + GAP + MAX ( DESCLENGTH, FORMATLEN + 1 ) END END END; (* of with directory^, form_ctl_file^ *) (* initialize CALC_CASE *) IF (INITC_COL = 0) AND (INITC_ROW = 0) AND (FINALC_COL = 0) AND (FINALC_ROW = 0) THEN CALC_CASE := 0 ELSE IF (INITC_COL > 0) AND (INITC_ROW = 0) AND (FINALC_COL = 0) AND (FINALC_ROW = 0) THEN CALC_CASE := 1 ELSE IF (INITC_COL = 0) AND (INITC_ROW > 0) AND (FINALC_COL = 0) AND (FINALC_ROW = 0) THEN CALC_CASE := 2 ELSE IF (INITC_COL > 0) AND (INITC_ROW > 0) AND (FINALC_COL = 0) AND (FINALC_ROW = 0) THEN CALC_CASE := 3 ELSE IF (INITC_COL = 0) AND (INITC_ROW = 0) AND (FINALC_COL > 0) AND (FINALC_ROW = 0) THEN CALC_CASE := 4 ELSE IF (INITC_COL > 0) AND (INITC_ROW = 0) AND (FINALC_COL > 0) AND (FINALC_ROW = 0) THEN CALC_CASE := 5 ELSE IF (INITC_COL = 0) AND (INITC_ROW > 0) AND (FINALC_COL > 0) AND (FINALC_ROW = 0) THEN CALC_CASE := 6 ELSE IF (INITC_COL > 0) AND (INITC_ROW > 0) AND (FINALC_COL > 0) AND (FINALC_ROW = 0) THEN CALC_CASE := 7 ELSE IF (INITC_COL = 0) AND (INITC_ROW = 0) AND (FINALC_COL = 0) AND (FINALC_ROW > 0) THEN CALC_CASE := 8 ELSE IF (INITC_COL > 0) AND (INITC_ROW = 0) AND (FINALC_COL = 0) AND (FINALC_ROW > 0) THEN CALC_CASE := 9 ELSE IF (INITC_COL = 0) AND (INITC_ROW > 0) AND (FINALC_COL = 0) AND (FINALC_ROW > 0) THEN CALC_CASE := 10 ELSE IF (INITC_COL > 0) AND (INITC_ROW > 0) AND (FINALC_COL = 0) AND (FINALC_ROW > 0) THEN CALC_CASE := 11 ELSE IF (INITC_COL = 0) AND (INITC_ROW = 0) AND (FINALC_COL > 0) AND (FINALC_ROW > 0) THEN CALC_CASE := 12 ELSE IF (INITC_COL > 0) AND (INITC_ROW = 0) AND (FINALC_COL > 0) AND (FINALC_ROW > 0) THEN CALC_CASE := 13 ELSE IF (INITC_COL = 0) AND (INITC_ROW > 0) AND (FINALC_COL > 0) AND (FINALC_ROW > 0) THEN CALC_CASE := 14 ELSE IF (INITC_COL > 0) AND (INITC_ROW > 0) AND (FINALC_COL > 0) AND (FINALC_ROW > 0) THEN CALC_CASE := 15; SET_TITLE; CUR_COL := 1; ST_COL := 1; CUR_ROW := 1; ST_ROW := 1; DIDDLED := FALSE; TITLE1 := ''; TITLE2 := ''; TITLE3 := ''; FOOTING := ''; LISTROW := ''; LISTCOL := ''; END; (* of init *) SEGMENT PROCEDURE UPDATE; VAR LASTCH: CHAR; OLD_ROW, OLD_COL, POSROW, POSCOL, POSPG, L, X, Y, TRASH: INTEGER; PROMPTLINE: STRING[63]; which_key : sc_key_command; PROCEDURE SETBEFOREAFTER( INDEX: INTEGER ); BEGIN WITH THEFORMAT[ INDEX ] DO BEGIN BEFORE := BEF; AFTER := AFT; L := BEF + AFT + 1; (* Add 1 for a decimal point *) IF AFT = 0 THEN L := L - 1 (* No decimal point so knock off 1 *) END END; (* of setbefore after *) PROCEDURE MOVEHOME; BEGIN CUR_COL := ST_COL; CUR_ROW := ST_ROW; OLD_COL := 0; OLD_ROW := 0; WHILE NOT LEGAL[ CUR_ROW - YOFFSET ] DO BEGIN CUR_COL := CUR_COL + 1; IF CUR_COL > LAST_COL THEN BEGIN CUR_COL := ST_COL; CUR_ROW := CUR_ROW + 1; IF CUR_ROW > LAST_ROW THEN (* no legal place to put cursor *) BEGIN (*$B 40COL- *) PRESSRETURN('*** Re-Anchor, no place to put Cursor,',MSG_LINE); (*$E 40COL *) (*$B 40COL+ *) PRESSRETURN('*** Re-Anchor,',MSG_LINE); (*$E 40COL *) EXIT(UPDATE) END END END; END; (* of movehome *) PROCEDURE UP; BEGIN REPEAT CUR_ROW := CUR_ROW - 1; IF CUR_ROW < ST_ROW THEN BEGIN CUR_ROW := LAST_ROW; CUR_COL := CUR_COL - 1; IF CUR_COL < ST_COL THEN CUR_COL := LAST_COL END UNTIL LEGAL[ CUR_ROW - YOFFSET ]; END; PROCEDURE DOWN; BEGIN REPEAT CUR_ROW := CUR_ROW + 1; IF CUR_ROW > LAST_ROW THEN BEGIN CUR_ROW := ST_ROW; CUR_COL := CUR_COL + 1; IF CUR_COL > LAST_COL THEN CUR_COL := ST_COL END UNTIL LEGAL[ CUR_ROW - YOFFSET ]; END; PROCEDURE RIGHT; BEGIN REPEAT CUR_COL := CUR_COL + 1; IF CUR_COL > LAST_COL THEN BEGIN CUR_COL := ST_COL; CUR_ROW := CUR_ROW + 1; IF CUR_ROW > LAST_ROW THEN CUR_ROW := ST_ROW END UNTIL LEGAL[ CUR_ROW - YOFFSET ]; END; PROCEDURE LEFT; BEGIN REPEAT CUR_COL := CUR_COL - 1; IF CUR_COL < ST_COL THEN BEGIN CUR_COL := LAST_COL; CUR_ROW := CUR_ROW - 1; IF CUR_ROW < ST_ROW THEN CUR_ROW := LAST_ROW END UNTIL LEGAL[ CUR_ROW - YOFFSET ]; END; BEGIN CASE PLANE OF ROWCOL: PROMPTLINE := 'Row Col Pg '; PAGECOL: PROMPTLINE := 'Pg Col Row'; ROWPAGE: PROMPTLINE := 'Row Pg Col'; END; (*$B 40COL- *) PROMPTLINE := CONCAT('Update ',PROMPTLINE,' Press ENTER to leave'); (*$E 40COL *) (*$B 40COL+ *) PROMPTLINE := CONCAT('Update ',PROMPTLINE); (*$E 40COL *) (* set the positions to write at in the promptline *) POSROW := POS( 'Row', PROMPTLINE ) + 3; POSCOL := POS( 'Col', PROMPTLINE ) + 3; POSPG := POS( 'Pg ', PROMPTLINE ) + 3; PROMPT(PROMPTLINE,MSG_LINE-1); (*$B 40COL+ *) PROMPT('Press ENTER to leave',MSG_LINE); (*$E 40COL *) MEMORY; MOVEHOME; REPEAT (* initialize X,Y coordinates on the screen for the field to put the cursor in, and set L which is the length of a number allowed to be entered there and set BEFORE and AFTER for that number *) X := COL_POS[ CUR_COL-1 ] - XOFFSET; Y := CUR_ROW - YOFFSET; IF DIRECTORY^.FORMAT = FROW THEN SETBEFOREAFTER( CUR_ROW - ST_ROW ) (* Two Bug fixes SDA 3/5/81 *) ELSE (* Was minus Y- and X-OFFSET *) SETBEFOREAFTER( CUR_COL - ST_COL ); (* Get a number and/or a movement *) REPEAT GOTOXY(POSROW,MSG_LINE-1); WRITE(OUTPUT,CUR_ROW:5); GOTOXY(POSCOL,MSG_LINE-1); WRITE(OUTPUT,CUR_COL:5); GOTOXY(POSPG, MSG_LINE-1); WRITE(OUTPUT,REAL_PAGE:5); GOTOXY(X,Y); ACCEPTNUM(TRUE,L,IS,LASTCH,which_key); UNTIL IS <> 'INVALID'; IF IS <> '' THEN (* Got a number, display it *) BEGIN DIDDLED := TRUE; VALUE(FALSE,IS,ANUMBER,TRASH); CALLNUMBER(CUR_PAGE,CUR_ROW,CUR_COL,ANDPUT); (* Change SDA 5/6/81 *) WRITENUM(CUR_ROW,CUR_COL); END; (* perform movement *) { IF LASTCH = CURSOR_UP THEN UP ELSE IF LASTCH = CURSOR_DOWN THEN DOWN ELSE IF LASTCH = CURSOR_RIGHT THEN RIGHT ELSE IF LASTCH = CURSOR_LEFT THEN LEFT ELSE IF LASTCH = HOME THEN MOVEHOME ELSE IF LASTCH IN [SPACE,TAB] THEN } if which_key = sc_up_key then up else if which_key = sc_down_key then down else if which_key = sc_right_key then right else if which_key = sc_left_key then left else {screenops don't support home key - gws } IF LASTCH IN [SPACE,TAB] THEN IF DIRECTORY^.FORMAT = FROW THEN RIGHT ELSE DOWN ELSE IF LASTCH IN ['A','a'] THEN BEGIN ST_COL := CUR_COL; ST_ROW := CUR_ROW; DISPLAY(TRUE); PROMPT(PROMPTLINE,MSG_LINE-1); END UNTIL which_key = sc_etx_key; END; (* of update *) SEGMENT PROCEDURE ANCHOR; (* Sets CUR_PAGE, ST_COL, ST_ROW, CUR_COL and CUR_ROW and calls display if a new page is asked for. *) VAR WAS_MAP: BOOLEAN; PAGE: INTEGER; BEGIN (* ANCHOR *) PROMPT('Anchor',MSG_LINE-1); WITH DIRECTORY^ DO BEGIN WAS_MAP := MAP_PAGE; (* Save MAP_PAGE boolean *) GETPNUM(REAL_PAGE, PAGE); IF PAGE <> REAL_PAGE THEN BEGIN IF WORK_PAGE THEN BEGIN IF DIDDLED THEN IF YESNO('Save the current Page','Y') THEN SAVEPAGE; REAL_PAGE := PAGE; SET_WORK_PAGE (* Sets Cur_Page to one *) END ELSE BEGIN REAL_PAGE := PAGE; CUR_PAGE := PAGE END; SET_TITLE; DIDDLED := FALSE END ELSE (* Stayed on same page *) IF WAS_MAP THEN MAP_PAGE := TRUE; (* Stay in Map mode if you were in it *) IF PLANE = PAGECOL THEN IS := 'Page' ELSE IS := 'Row'; GETNUM(1,NUM_ROWS,ST_ROW,CONCAT('Enter ',IS,' #'),ST_ROW); IF PLANE = ROWPAGE THEN IS := 'Page' ELSE IS := 'Column'; GETNUM(1,NUM_COLS,ST_COL,CONCAT('Enter ',IS,' #'),ST_COL) END; CUR_COL := ST_COL; CUR_ROW := ST_ROW; DISPLAY(TRUE) END; (* of anchor *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.data5.text ======================================================================================== PROCEDURE SAVE; BEGIN PROMPT('Save',MSG_LINE-1); SAVEPAGE END; (* of save *) PROCEDURE SET_WORK_PAGE; (* This procedure copies the REAL_PAGE from the real file to the work file and then sets all the page numbers of the blocks in memory to zero so NUMBER will go to the disk to get numbers rather than using those in memory *) VAR I, LOC: INTEGER; AWINDOW: WINDOWTYPE; BEGIN CUR_PAGE := 1; MEMORY; WITH FORM_DAT_DESC DO BEGIN LOC := (REAL_PAGE - 1) * BLKSPERPAGE; FOR I := 0 TO BLKSPERPAGE - 1 DO BEGIN IF BLOCKREAD (TRUE_DAT_FILE, AWINDOW, 1, LOC + I) = 1 THEN; IF BLOCKWRITE(FORM_DAT_FILE, AWINDOW, 1, I) = 1 THEN END; I := LISTHEAD; (* Set Page #'s to 0 & CHANGED to False to fool NUMBER *) WHILE I <> 0 DO WITH LIST[I] DO BEGIN DPAGE := 0; CHANGED := FALSE; I := AFTER END (* SDA 4/24/81 *) END END; (* of set_work_page *) PROCEDURE SAVEPAGE; (* This routine is only called if a WORK_PAGE condition exists. The first thing it does is make sure that the work file on disk jives with the numbers in memory by writing to disk any numbers that are in a CHANGED window. It then copies the blocks in the workfile to the right place in the real file *) VAR I, LOC: INTEGER; AWINDOW: WINDOWTYPE; BEGIN ONEMOMENT('Saving current Page'); MEMORY; WITH FORM_DAT_DESC DO BEGIN I := LISTHEAD; WHILE I <> 0 DO WITH LIST[I] DO BEGIN IF CHANGED THEN BEGIN IF BLOCKWRITE(FORM_DAT_FILE,WINDOW^,1,DBLOCK) <> 1 THEN; CHANGED := FALSE END; I := AFTER END; LOC := (REAL_PAGE - 1) * BLKSPERPAGE; FOR I := 0 TO BLKSPERPAGE-1 DO BEGIN IF BLOCKREAD (FORM_DAT_FILE,AWINDOW,1,I) = 1 THEN; IF BLOCKWRITE(TRUE_DAT_FILE,AWINDOW,1,LOC+I) = 1 THEN END END; DIDDLED := FALSE END; (* of savepage *) PROCEDURE SET_TITLE; BEGIN IF PLANE = ROWCOL THEN (* Changes made SDA 5/6/81 *) IF OPEN_TIT( REQUESTED_FORM ) THEN BEGIN SEEKTIT(FORM_TIT_FILE,REAL_PAGE,ANDGET); PAGE_TITLE := FORM_TIT_FILE^; CLOSE(FORM_TIT_FILE); TIT_OPEN := FALSE END ELSE BEGIN ERROR(8); PAGE_TITLE := '' END ELSE (* Plane is either Pagecol or Rowpage *) BEGIN GETCTLREC( PLANE=ROWPAGE, REAL_PAGE ); PAGE_TITLE := FORM_CTL_FILE^.CTL_DESC END END; (* of set_title *) PROCEDURE GETPNUM{ DEFAULT: INTEGER; VAR ANS: INTEGER }; (* This is a special edition of GETNUM *) VAR MAX: INTEGER; WHAT: STRING[7]; MAXSTR, DEFSTR: STRING[3]; xdummy : sc_key_command; BEGIN MEMORY; WITH DIRECTORY^ DO CASE PLANE OF (* Addition SDA 5/6/81 *) ROWCOL: BEGIN WHAT := 'Page'; MAX := NO_PAGES END; PAGECOL: BEGIN WHAT := 'Row'; MAX := NO_ROWS END; ROWPAGE: BEGIN WHAT := 'Column'; MAX := NO_COLS END END; IF MAX = 1 THEN (* Set page to edit and the bool MAP_PAGE too *) BEGIN COMMAND := '*'; ANS := 1 END ELSE BEGIN ENCODE(MAX,MAXSTR); ENCODE(DEFAULT, DEFSTR); REPEAT PROMPT(CONCAT('Enter ',WHAT,' # ',DEFSTR,' (max. is ',MAXSTR,')'), MSG_LINE); GOTOXY(9+LENGTH(WHAT),MSG_LINE); (* Change SDA 5/6/81 *) ACCEPTNUM(TRUE,3,IS,COMMAND,xdummy); (* put ending char into COMMAND *) IF (IS = '') OR (IS = 'INVALID') THEN ANS := DEFAULT ELSE VALUE(TRUE, IS, FAKE, ANS) UNTIL ANS IN [1..MAX] END; MAP_PAGE := (COMMAND IN ['M','m']) AND (PLANE = ROWCOL) (* SDA 5/6/81 *) END; (* of getpnum *) PROCEDURE GETCTLREC{ COL: BOOLEAN; REC: INTEGER }; BEGIN SEEKCTL(FORM_CTL_FILE,COL,REC,ANDGET); (* NOTE: May want to check IORESULT here in the future *) (* Set FORMAT to an integer if MAP_PAGE is true *) IF MAP_PAGE THEN FORM_CTL_FILE^.CTL_FORMAT := MAP_FORMAT END; (* of get next ctl rec *) PROCEDURE BEFOREAFTER{ FORMAT: STRING }; (* This procedure, given FORMAT, sets the global variables BEFORE and AFTER to the number of places to be put BEFORE and AFTER the decimal point *) BEGIN BEFORE := SCAN( LENGTH( FORMAT ), ='.', FORMAT[1] ); AFTER := LENGTH( FORMAT ) - BEFORE - 1; IF AFTER < 0 THEN AFTER := 0; END; (* of beforeafter *) PROCEDURE CALLNUMBER{ Z, Y, X: INTEGER; WHAT: ACTIONTYPE }; BEGIN CASE PLANE OF ROWCOL: NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,Z,Y,X,ANUMBER,WHAT,ERR); PAGECOL: NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,Y,Z,X,ANUMBER,WHAT,ERR); ROWPAGE: NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,X,Y,Z,ANUMBER,WHAT,ERR); END END; (* of callnumber *) PROCEDURE WRITENUM{ ROW, COL: INTEGER }; (* Expects the cursor to be at the correct position, and BEFORE and AFTER to be set correctly. It writes out the number specified by ROW and COL from the current page's FORM array *) VAR ANS: STRING[17]; (* 17 picked to be bigger than Maxfrac+Maxwhole+2 *) BEGIN CALLNUMBER(CUR_PAGE,ROW,COL,ANDGET); (* Change SDA 5/6/81 *) NUMTOSTR(ANS, ANUMBER, BEFORE, AFTER); GOTOXY(COL_POS[COL-1]-XOFFSET, ROW-YOFFSET); WRITE(OUTPUT,ANS); END; PROCEDURE DISPLAY{ CLEARFIRST: BOOLEAN }; (* This procedure will display a page on the screen, given ST_COL, and ST_ROW. It will set XOFFSET, YOFFSET, LAST_COL, and LAST_ROW. *) VAR I, J: INTEGER; TOOFAR: BOOLEAN; PROCEDURE SETTHEFORMAT( INDEX: INTEGER ); BEGIN WITH THEFORMAT[ INDEX ] DO BEGIN BEF := BEFORE; AFT := AFTER END END; (* of settheformat *) PROCEDURE COLDESC; BEGIN GOTOXY(COL_POS[J-1]-XOFFSET, DESCLINE); IF PLANE = ROWPAGE THEN (* Change SDA 5/6/81 *) BEGIN WRITE(OUTPUT,'Page ',J); GETCTLREC(TRUE,CUR_PAGE) END ELSE BEGIN GETCTLREC(TRUE, J); WRITE(OUTPUT, FORM_CTL_FILE^.CTL_DESC) END END; PROCEDURE ROWDESC; BEGIN GOTOXY(1, I-YOFFSET); IF PLANE = PAGECOL THEN (* Change SDA 5/6/81 *) BEGIN WRITE(OUTPUT,'Page ',I); GETCTLREC(FALSE,CUR_PAGE) END ELSE BEGIN GETCTLREC(FALSE, I); WRITE(OUTPUT, FORM_CTL_FILE^.CTL_DESC) END; LEGAL[ I - YOFFSET ] := FORM_CTL_FILE^.CTL_TYPE <> HEADING END; BEGIN (* DISPLAY *) (* set last_col and row and x and yoffset *) XOFFSET := COL_POS[ ST_COL-1 ] - COL_POS[ 0 ]; LAST_COL := ST_COL - 1; REPEAT LAST_COL := LAST_COL + 1; TOOFAR := ( COL_POS[ LAST_COL-1 ] - GAP + 1 - XOFFSET ) >= S_WIDTH; UNTIL TOOFAR OR ( LAST_COL > NUM_COLS ); (* Change SDA 5/6/81 *) IF TOOFAR THEN LASTCOL := LASTCOL - 1; LAST_COL := LAST_COL - 1; YOFFSET := ST_ROW - DESCLINE - 1; IF (MSG_LINE-DESCLINE-3) < MAXLINES THEN LAST_ROW := MSG_LINE-DESCLINE-3 ELSE LAST_ROW := MAXLINES; LAST_ROW := LAST_ROW + ST_ROW - 1; IF LAST_ROW > NUM_ROWS THEN LASTROW := NUM_ROWS; (* Change SDA 5/6/81 *) (* display the data now *) WITH FORM_CTL_FILE^ DO BEGIN IF CLEARFIRST THEN {WRITE(OUTPUT, CLEAR)} sc_clr_screen; GOTOXY(1, TITLELINE); WRITE(OUTPUT, PAGE_TITLE); IF DIRECTORY^.FORMAT = FROW THEN (* write stuff out a row at a time *) BEGIN FOR J := ST_COL TO LAST_COL DO COLDESC; (* write all col descs. *) FOR I := ST_ROW TO LAST_ROW DO BEGIN ROWDESC; (* write the row desc for row I *) IF CTL_TYPE <> HEADING THEN BEGIN BEFOREAFTER(CTL_FORMAT); (* set Before and After *) SETTHEFORMAT(I-ST_ROW); (* Bug Fix SDA 3/5/81 *) FOR J := ST_COL TO LAST_COL DO WRITENUM(I,J) END END END ELSE (* write stuff out a col at a time *) BEGIN FOR I := ST_ROW TO LAST_ROW DO ROWDESC; (* write all row descs *) FOR J := ST_COL TO LAST_COL DO BEGIN COLDESC; (* Write the col desc for col J *) BEFOREAFTER(CTL_FORMAT); SETTHEFORMAT(J-ST_COL); (* Bug Fix SDA 3/5/81 *) FOR I := ST_ROW TO LAST_ROW DO (* Bug Fix SDA 4/8/80 *) IF LEGAL[ I - YOFFSET ] THEN WRITENUM(I,J) END END END END; (* of display *) FUNCTION GETCOMMAND(VAR COMMAND: CHAR): BOOLEAN; BEGIN MEMORY; REPEAT (*$B 40COL- *) GETRESPONSE(TRUE,'Enter Command => ','', ' A,U,M,Z,N,L,S, (H for Help)',1,IS); (*$E 40COL *) (*$B 40COL+ *) GETRESPONSE(TRUE,'Command => ','', ' A,U,M,Z,N,L,S,H(elp),ESC',1,IS); (*$E 40COL *) LCTOUC(IS); UNTIL (IS='A') OR (IS='U') OR (IS='M') OR (IS='Z') OR (IS='L') OR (IS='H') OR (IS='N') OR (IS='S') OR (IS='ESCAPE'); IF IS <> 'ESCAPE' THEN BEGIN GETCOMMAND := TRUE; COMMAND := IS[1] END ELSE BEGIN GETCOMMAND := FALSE; IF DIDDLED AND WORK_PAGE THEN IF YESNO('Save page before leaving','Y') THEN SAVEPAGE END END; (* of getcommand *) BEGIN (* DATAIN *) {WRITELN(OUTPUT,CLEAR);} sc_clr_screen; WRITELN(OUTPUT,'F R E E F O R M D A T A E N T R Y'); IF DISK_DIR THEN IF NAME_FORM(REQUESTED_FORM, RECNUMBER) THEN BEGIN ONEMOMENT('Opening Control file'); IF NOT OPEN_CTL(REQUESTED_FORM) THEN ERROR(4) ELSE BEGIN INIT; DISPLAY(TRUE); WHILE GETCOMMAND(COMMAND) DO BEGIN CASE COMMAND OF 'A': ANCHOR; 'U': UPDATE; 'M': IF (NOT MAP_PAGE) AND (PLANE = ROWCOL) THEN MATH; 'Z', 'N', 'L': LISTORZERO; 'S': IF WORK_PAGE THEN SAVE; 'H': HELP END; ERASE(MSG_LINE-1) END; IF WORK_PAGE THEN BEGIN CLOSE(FORM_DAT_FILE,PURGE); DAT_OPEN := FALSE; FREEMEM(FORM_DAT_DESC); CLOSE(TRUE_DAT_FILE) END; VARDISPOSE( CALC_LIST, SIZE_CALC_LIST ); VARDISPOSE( CROSS_CALC, SIZE_CROSS_CALC ) END END; FINISHUP END; (* of datain *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.forms1.text ======================================================================================== SEGMENT PROCEDURE FORMS; TYPE SETTYPE = ( NEWFILE, NEWREC, OLDREC ); VAR MONTHS: ARRAY[1..12] OF STRING[3]; PRINT_LINE: INTEGER; PREV_FORMAT: STRING[L_CFORMAT]; CONTROL_HEADER: STRING[69]; PROCEDURE BLANKREC; FORWARD; PROCEDURE CHECKERR( ERRORNUM: INTEGER; DELENTRY: BOOLEAN; COND: SETTYPE ); FORWARD; FUNCTION ABORT: BOOLEAN; FORWARD; PROCEDURE PUTMAINHEAD; FORWARD; PROCEDURE PUTCTRLHEAD( WHAT: STRING; NUM: INTEGER ); FORWARD; PROCEDURE SETNUM( MIN, MAX: INTEGER; WHAT: STRING; VAR ANS: INTEGER; LINE: INTEGER ); FORWARD; PROCEDURE GETUSERID; FORWARD; PROCEDURE GETFORMDESC; FORWARD; PROCEDURE GETDATE; FORWARD; PROCEDURE GET_CONSTANT( NUM, LINE: INTEGER; OLD: BOOLEAN ); FORWARD; PROCEDURE SET_PAGE( PAGE: INTEGER; NO_PROMPT,NEWPAGE: BOOLEAN; COND: SETTYPE; VAR ERR: INTEGER ); FORWARD; PROCEDURE WRITEAREC( VAR OUTFILE: TXTFILE; NUM: INTEGER; VAR AREC: CTLRECORD ); FORWARD; PROCEDURE SET_CTRL_REC( VAR REC: CTLRECORD; SETTINGROW: BOOLEAN; OFFSET: INTEGER; NO_PROMPT: BOOLEAN; VAR HITESC: BOOLEAN; COND: SETTYPE ); FORWARD; PROCEDURE DISPLAYDIR( VAR OUTFILE: TXTFILE; TOSCREEN, ALL: BOOLEAN; RECNUMBER: INTEGER ); FORWARD; SEGMENT PROCEDURE DEF; FORWARD; SEGMENT PROCEDURE LIST; FORWARD; SEGMENT PROCEDURE CHG; FORWARD; SEGMENT PROCEDURE INITIALIZE; FORWARD; SEGMENT PROCEDURE DEF; (* Form definition *) PROCEDURE CREATE; (* Creates freeform directory *) VAR I: INTEGER; BEGIN ONEMOMENT('Creating Freeform Directory'); REWRITE(DIRECTORY,CONCAT(DISKDRIVE,':',DIRNAME)); CHECKERR(2,FALSE,NEWFILE); (* make sure directory was opened *) FILEOPEN := TRUE; I := 0; BLANKREC; WHILE I <= DIRSIZE DO BEGIN (* fill directory with blank records *) PUT(DIRECTORY); CHECKERR(2,FALSE,NEWFILE);(* escape and give err message if put failed *) I := I + 1 END; CLOSE(DIRECTORY,LOCK); FILEOPEN := FALSE; END; (* of create *) PROCEDURE FORMAT_CHOICE; (* Prompt for choice of format (R/C) *) BEGIN REPEAT GETRESPONSE(TRUE,'Format Rows or Columns? (R/C) ','R','',1,IS); LCTOUC(IS); UNTIL (IS='R') OR (IS='C'); IF IS='C' THEN BEGIN IS := 'COLUMN'; DIRECTORY^.FORMAT := FCOL END ELSE BEGIN IS := 'ROW'; DIRECTORY^.FORMAT := FROW END; PROMPT(CONCAT('Formatting is fixed by ',IS),5); END; (* of format_choice *) PROCEDURE AUTO_CHOICE; (* Automatic month descriptions? *) VAR TEMP: INTEGER; BEGIN (* AUTO_CHOICE *) WITH DIRECTORY^ DO (*$B 40COL- *) IF YESNO('Do you want automatic month descriptions','N') THEN BEGIN (* wantauto *) REPEAT GETRESPONSE(TRUE,'Month descriptions for rows or columns? (R/C) ', 'C','',1,IS); (*$E 40COL *) (*$B 40COL+ *) IF YESNO('Auto month descriptions','N') THEN BEGIN (* wantauto *) REPEAT GETRESPONSE(TRUE,'Descriptions for rows or cols? (R/C) ', 'C','',1,IS); (*$E 40COL *) LCTOUC(IS); UNTIL (IS='C') OR (IS='R'); IF IS='R' THEN AUTO_SWITCH := AROW ELSE AUTO_SWITCH := ACOL; (* select starting month *) GETNUM(1,12,1,'Enter starting month #',TEMP); START_MONTH := TEMP; END ELSE AUTO_SWITCH := NOAUTO; END; (* of auto_choice *) PROCEDURE SET_CONSTANTS; (* Gets desired # of constants and sets them *) VAR I: INTEGER; (* Also creates page in Dat file for Constants *) BEGIN ONEMOMENT('Creating File for Constants'); REWRITE(FORM_CON_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.CON[4]')); CHECKERR(2,TRUE,NEWFILE); CON_OPEN := TRUE; WITH DIRECTORY^ DO BEGIN (*$B 40COL- *) SETNUM(0,MAXCONSTS,'Calculation Constants',NO_CONSTS,6); (*$E 40COL *) (*$B 40COL+ *) SETNUM(0,MAXCONSTS,'Calc Constants',NO_CONSTS,6); (*$E 40COL *) (* initialize all Constants to EMPTY value SDA 12/03/80 *) FORM_CON_FILE^ := EMPTY; FOR I := 1 TO MAXCONSTS DO BEGIN PUT(FORM_CON_FILE); CHECKERR(2,TRUE,NEWFILE) END; (* Gather the constants *) FOR I := 0 TO NO_CONSTS-1 DO GET_CONSTANT(I+1,(I MOD (MSG_LINE-11))+7,FALSE) END; CLOSE(FORM_CON_FILE,LOCK); CON_OPEN := FALSE END; (* of set_constants *) PROCEDURE SET_THE_CTRLS( THEROWS: BOOLEAN ); VAR HITESC: BOOLEAN; I, CNT: INTEGER; WHAT: STRING[7]; BEGIN WITH DIRECTORY^ DO BEGIN IF THEROWS THEN BEGIN WHAT := 'Row'; CNT := NO_ROWS END ELSE BEGIN WHAT := 'Column'; CNT := NO_COLS END; PUTCTRLHEAD(WHAT, CNT); (* load parameters into control file *) I := 0; WHILE I < CNT DO BEGIN I := I + 1; (* give record a value before doing the Put *) SET_CTRL_REC(FORM_CTL_FILE^,THEROWS,I,NO_PROMPT,HITESC,NEWFILE); IF HITESC THEN IF YESNO('Abort Define process','N') THEN CHECKERR(0,TRUE,NEWFILE) ELSE BEGIN IF I = 1 THEN BEGIN I := 0; CNT := 1; (*$B 40COL- *) PRESSRETURN(CONCAT('One ',WHAT,' must be defined'), MSG_LINE) (*$E 40COL *) (*$B 40COL+ *) PRESSRETURN(CONCAT('Must define one ',WHAT), MSG_LINE) (*$E 40COL *) END ELSE CNT := I - 1; IF THEROWS THEN NO_ROWS := CNT ELSE NO_COLS := CNT; SEEKDIR(RECNUMBER,ANDPUT) END ELSE SEEKCTL(FORM_CTL_FILE,NOT THEROWS,I,ANDPUT) END END END; (* of set_the_ctls *) PROCEDURE DEFINE; (* Prompts for form definition attributes and then creates a new entry in the freeform directory *) VAR ALLOK: BOOLEAN; BEGIN (* see if checkpoint prompts are desired *) NO_PROMPT := NOT YESNO('Are checkpoint prompts desired','N'); (* set directory window variable *) SEEKDIR(RECNUMBER,NOTHING); DIRECTORY^.FORM_NAME := REQUESTED_FORM; (* set form name *) DIRECTORY^.VERSION := THEVERSION; (* set version *) GETUSERID; (* prompt for user id *) GETFORMDESC; (* prompt for form description *) GETDATE; (* prompt for date created *) REPEAT ALLOK := TRUE; (* get number of pages, format control, and constants *) SETNUM(1,MAXPAGES,'pages',DIRECTORY^.NO_PAGES,4); FORMAT_CHOICE; (* select row or column formatting *) AUTO_CHOICE; (* automatic month descriptions? *) SET_CONSTANTS; (* get constants desired *) IF NOT NO_PROMPT THEN ALLOK := NOT YESNO('Anything to change','N') UNTIL ALLOK; REPEAT (* Set the Maxes for Rows and Cols as well as actual values *) ALLOK := TRUE; WITH DIRECTORY^ DO BEGIN (* get # of rows and columns *) (*$B 40COL- *) GETNUM(1,MAXCOL,-1,'How many columns might ever be in the FORM ?', THEMAXCOL); THEMAXROW := ( MAXINT - WINDOWSIZE ) DIV THEMAXCOL; GETNUM(1,THEMAXROW,-1,'How many rows might ever be in the FORM ?', THEMAXROW); (*$E 40COL *) (*$B 40COL+ *) GETNUM(1,MAXCOL,-1,'Max cols in FORM ?',THEMAXCOL); THEMAXROW := ( MAXINT - WINDOWSIZE ) DIV THEMAXCOL; GETNUM(1,THEMAXROW,-1,'Max rows in FORM ?',THEMAXROW); (*$E 40COL *) SETNUM(1,THEMAXCOL,'columns',NO_COLS,MSG_LINE-3); SETNUM(1,THEMAXROW,'rows',NO_ROWS,MSG_LINE-2); END; (*$B 40COL- *) ALLOK := YESNO('Are the dimensions ok as specified','Y'); (*$E 40COL *) (*$B 40COL+ *) ALLOK := YESNO('Are the dimensions ok','Y'); (*$E 40COL *) UNTIL ALLOK; ONEMOMENT('Updating Directory'); PUT(DIRECTORY); END; (* of define *) PROCEDURE CREATE_CTLS; (* Creates form controls *) VAR AWINDOW: WINDOWTYPE; I, ERR: INTEGER; BEGIN ONEMOMENT('Creating Form Control File'); REWRITE(FORM_CTL_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.CTL')); CHECKERR(2,TRUE,NEWFILE); CTL_OPEN := TRUE; WITH DIRECTORY^ DO FOR I := 0 TO THEMAXROW+THEMAXCOL DO BEGIN PUT(FORM_CTL_FILE); CHECKERR(2,TRUE,NEWFILE) END; CLOSE(FORM_CTL_FILE, LOCK); CTL_OPEN := FALSE; ONEMOMENT('Creating Form Data and Titles File'); REWRITE(FORM_TIT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.TIT')); CHECKERR(2,TRUE,NEWFILE); FILLCHAR(FORM_TIT_FILE^,L_TITLE+1,0); FOR I := 0 TO MAXPAGES DO BEGIN PUT(FORM_TIT_FILE); CHECKERR(2,TRUE,NEWFILE) END; CLOSE(FORM_TIT_FILE,LOCK); IF OPEN_TIT(REQUESTED_FORM) THEN; MEMORY; WITH DIRECTORY^, FORM_DAT_DESC DO BEGIN REWRITE(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT')); USEDHEAP := FALSE; CHECKERR(2,TRUE,NEWFILE); DAT_OPEN := TRUE; BLKSPERPAGE := ( (THEMAXROW*THEMAXCOL) + WINDOWSIZE ) DIV ( WINDOWSIZE+1 ); (* load page titles into title file *) PUTMAINHEAD; (*$B 40COL- *) WRITE(OUTPUT,'FREEFORM Page Parameter Definition for ',REQUESTED_FORM, ' Pages=',NO_PAGES {,' Memavail=',MEMAVAIL} ); (*$E 40COL *) (*$B 40COL+ *) WRITE(OUTPUT,'FREEFORM Page Def for ',REQUESTED_FORM, ' Pages=',NO_PAGES {,' Memavail=',MEMAVAIL} ); (*$E 40COL *) I := 0; REPEAT I := I + 1; SET_PAGE(I,NO_PROMPT,TRUE,NEWFILE,ERR);(* accept page titles, zero form *) IF ERR = 2 THEN (* User pressed ESC *) IF NOT YESNO('Abort Define process','N') THEN BEGIN ERR := 0; IF I = 1 THEN BEGIN I := 0; NO_PAGES := 1; PRESSRETURN('Must define one Page', MSG_LINE) END ELSE NO_PAGES := I - 1; SEEKDIR(RECNUMBER,ANDPUT); END UNTIL (ERR <> 0) OR (I >= NO_PAGES); IF ERR <> 0 THEN BEGIN IF ERR = 1 THEN ERROR(2); IF (ERR = 2) OR ( (ERR = 1) AND (I = 1) ) THEN CHECKERR(0,TRUE,NEWFILE) ELSE IF YESNO('Is FORM O.K. with fewer Pages','Y') THEN BEGIN NO_PAGES := I - 1; SEEKDIR(RECNUMBER,ANDPUT); (* move file ptr back to end of last page *) IF BLOCKREAD(FORM_DAT_FILE,AWINDOW,1,BLKSPERPAGE*NO_PAGES-1)=1 THEN END ELSE CHECKERR(0,TRUE,NEWFILE); END; CLOSE(FORM_DAT_FILE,CRUNCH); DAT_OPEN := FALSE END; TIT_OPEN := FALSE; CLOSE(FORM_TIT_FILE, LOCK); MEMORY; IF OPEN_CTL(REQUESTED_FORM) THEN; SET_THE_CTRLS( TRUE ); (* load row parameters into control file *) SET_THE_CTRLS( FALSE ); (* load col parameters into control file *) CLOSE(FORM_CTL_FILE); MEMORY; CTL_OPEN := FALSE; END; (* of create_ctls *) BEGIN (* DEF *) PUTMAINHEAD; WRITELN(OUTPUT,'New Forms Definition'); IF NOT DISK_DIR THEN (*$B 40COL- *) IF YESNO('Create a New Freeform directory','Y') THEN (*$E 40COL *) (*$B 40COL+ *) IF YESNO('Create New directory','Y') THEN (*$E 40COL *) BEGIN CREATE; OPEN_DIR END ELSE EXIT(DEF); MEMORY; IF GET_FORM_NAME(REQUESTED_FORM, RECNUMBER) THEN BEGIN DEFINE; (* prompt for form attributes *) CREATE_CTLS; (* prompt for row & col controls *) CLOSE(DIRECTORY,LOCK); FILEOPEN := FALSE END; END; (* of def *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.forms2.text ======================================================================================== SEGMENT PROCEDURE LIST; SEGMENT PROCEDURE DIR; (* Display or list freeform directory *) BEGIN PUTMAINHEAD; WRITELN('FREEFORM Directory Listing'); IF DISK_DIR THEN BEGIN MEMORY; IF YESNO('Listing on Printer','N') THEN BEGIN SETPRINTER; IF PRINTER_ON THEN BEGIN ONEMOMENT('Listing'); DISPLAYDIR(PRINTER,FALSE,TRUE,0) END END ELSE BEGIN DISPLAYDIR(OUTPUT,TRUE,TRUE,0); PRESSRETURN('To continue,',MSG_LINE) END; CLOSE(DIRECTORY); FILEOPEN := FALSE; END END; (* of dir *) SEGMENT PROCEDURE CONTROL; VAR I, BOT_CNT: INTEGER; SEGMENT PROCEDURE DISPLAYCTL(VAR OUTFILE: TXTFILE; TOSCREEN: BOOLEAN); VAR NUM_CONSTANTS, PAGE: INTEGER; PROCEDURE NEWPAGE; FORWARD; PROCEDURE DOHEADING; FORWARD; PROCEDURE CHECKIO( ERR: INTEGER ); FORWARD; SEGMENT PROCEDURE DIS_CONSTS; FORWARD; SEGMENT PROCEDURE DIS_PAGE_CTRLS; FORWARD; SEGMENT PROCEDURE DIS_RC_CTRLS; FORWARD; SEGMENT PROCEDURE DIS_CONSTS; BEGIN WRITELN(OUTFILE); WRITELN(OUTFILE,'Calculation constants : ',DIRECTORY^.NO_CONSTS); PRINT_LINE := PRINT_LINE + 8; FOR I := 1 TO DIRECTORY^.NO_CONSTS DO BEGIN IF PRINT_LINE > BOT_CNT THEN IF TOSCREEN THEN BEGIN PRESSRETURN('More constants..',MSG_LINE); DOHEADING END ELSE NEWPAGE; PRINT_LINE := PRINT_LINE+1; SEEKCON(I,ANDGET); NUMTOSTR(IS, FORM_CON_FILE^, MAXWHOLE, 5); WRITELN(OUTFILE,'Constant # ',I:3,' = ',IS); END; CLOSE(FORM_CON_FILE); CON_OPEN := FALSE END; (* of dis_consts *) SEGMENT PROCEDURE DIS_PAGE_CTRLS; (* Page controls listing *) VAR PAGE: INTEGER; PROCEDURE TITLEIT; BEGIN IF TOSCREEN THEN BEGIN PRESSRETURN('For page titles',MSG_LINE); DOHEADING END; WRITELN(OUTFILE); WRITELN(OUTFILE,'Page Titles are as follows:'); WRITELN(OUTFILE,'## Title Description'); PRINT_LINE := PRINT_LINE+3; END; (* of titleit *) BEGIN (* DIS_PAGE_CTLS *) IF NOT OPEN_TIT(REQUESTED_FORM) THEN CHECKIO(8); TITLEIT; MEMORY; FOR PAGE := 1 TO DIRECTORY^.NO_PAGES DO BEGIN (* Display page titles *) IF PRINT_LINE > BOT_CNT THEN IF TOSCREEN THEN TITLEIT ELSE NEWPAGE; GET(FORM_TIT_FILE); WRITELN(OUTFILE,PAGE:2,' ',FORM_TIT_FILE^); PRINT_LINE := PRINT_LINE + 1 END; MEMORY; CLOSE(FORM_TIT_FILE); TIT_OPEN := FALSE; END; (* of dis_page_ctrls *) SEGMENT PROCEDURE DIS_RC_CTRLS; (* Display row and column controls *) VAR WHAT: STRING[7]; I, J, NUM: INTEGER; PROCEDURE TITLEIT; BEGIN IF TOSCREEN THEN BEGIN PRESSRETURN(CONCAT('For ',WHAT,' controls'),MSG_LINE); DOHEADING END; WRITELN(OUTFILE); WRITELN(OUTFILE,'Controls for the ',NUM,' defined ',WHAT, 's are as follows:'); WRITELN(OUTFILE,CONTROL_HEADER); PRINT_LINE := PRINT_LINE + 3; END; (* of titleit *) PROCEDURE WRITERECORD(RECNUM: INTEGER; DOINGROW: BOOLEAN); BEGIN IF PRINT_LINE > BOT_CNT THEN IF TOSCREEN THEN TITLEIT ELSE NEWPAGE; SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,RECNUM,ANDGET); WRITEAREC(OUTFILE,RECNUM,FORM_CTL_FILE^); PRINT_LINE := PRINT_LINE+1; END; (* of writerecord *) BEGIN (* DIS_RC_CTRLS *) IF NOT OPEN_CTL(REQUESTED_FORM) THEN CHECKIO(4); WHAT := 'row' ; NUM := DIRECTORY^.NO_ROWS; MEMORY; TITLEIT; FOR I := 1 TO NUM DO WRITERECORD(I,TRUE); WHAT := 'column'; NUM := DIRECTORY^.NO_COLS; TITLEIT; FOR I := 1 TO NUM DO WRITERECORD(I,FALSE); MEMORY; CLOSE(FORM_CTL_FILE); CTL_OPEN := FALSE; END; (* of dis_rc_ctrls *) PROCEDURE NEWPAGE; BEGIN {WRITELN(OUTFILE,CLEAR);} sc_clr_screen; PRINT_LINE := 1; END; PROCEDURE DOHEADING; BEGIN PUTMAINHEAD; WRITELN(OUTFILE); WRITELN(OUTFILE,'Form name is -> ',REQUESTED_FORM); PRINT_LINE := PRINT_LINE+2; END; PROCEDURE CHECKIO{ ERR: INTEGER }; BEGIN ERROR(ERR); EXIT(DISPLAYCTL) END; (* of checkio *) BEGIN (* DISPLAYCTL *) IF NOT TOSCREEN THEN (* get printer aligned *) BEGIN SETPRINTER; IF IORESULT <> 0 THEN CHECKIO(3); ONEMOMENT('Listing') END; IF TOSCREEN THEN (* set bot_cnt to point where a tof is needed *) BEGIN BOT_CNT := MSG_LINE-3; PUTMAINHEAD END ELSE BOT_CNT := PAPER_LENGTH-3; WITH DIRECTORY^ DO BEGIN WRITELN(OUTFILE); WRITELN(OUTFILE,'FORM description : ',FORM_DESC); WRITELN(OUTFILE,'FORM name : ', REQUESTED_FORM,' User ID : ',FORM_ID,' Date Created : ',FORM_DATE); WRITELN(OUTFILE); WRITELN(OUTFILE,'# of Pages/Rows/Max Rows/Columns/Max Columns : ', NO_PAGES,'/',NO_ROWS,'/',THEMAXROW,'/',NO_COLS,'/',THEMAXCOL); WRITE(OUTFILE,'Formatted by '); IF FORMAT=FROW THEN WRITE(OUTFILE,'ROW') ELSE WRITE(OUTFILE,'COLUMN'); WRITE(OUTFILE,' --- '); IF AUTO_SWITCH=NOAUTO THEN WRITE(OUTFILE,'No automatic month headings') ELSE BEGIN WRITE(OUTFILE,'Month Headings by '); IF AUTO_SWITCH=AROW THEN WRITE(OUTFILE,'ROW') ELSE WRITE(OUTFILE,'COLUMN'); END; WRITELN(OUTFILE); IF NOT OPEN_CON(REQUESTED_FORM) THEN CHECKIO(12); MEMORY END (* of with Directory^ *); DIS_CONSTS; (* display constants *) DIS_PAGE_CTRLS; (* Display page controls *) DIS_RC_CTRLS; (* display row controls *) IF NOT TOSCREEN THEN {WRITE(OUTFILE, CLEAR)} sc_clr_screen; END; (* of displayctl *) BEGIN (* CONTROL *) PUTMAINHEAD; WRITELN(OUTPUT,'FORM Controls listing'); IF DISK_DIR THEN (* Get a disk with a free directory *) BEGIN IF NAME_FORM(REQUESTED_FORM,RECNUMBER) THEN (* enter name of form *) BEGIN MEMORY; IF YESNO('Listing on Printer','N') THEN DISPLAYCTL(PRINTER,FALSE) ELSE BEGIN DISPLAYCTL(OUTPUT,TRUE); PRESSRETURN('To continue,',MSG_LINE) END END; CLOSE(DIRECTORY); FILEOPEN := FALSE; END END; (* of control *) BEGIN (* LIST *) MEMORY; CASE OPTION OF 3: DIR; 4: CONTROL; END; END; (* of list *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.forms3.text ======================================================================================== SEGMENT PROCEDURE CHG; PROCEDURE MODIFY; VAR ERR: BOOLEAN; I, J, ANS: INTEGER; FUNCTION CHANGE(WHAT: STRING): BOOLEAN; (* This asks if WHAT is to be changed. Returns true if the answer is yes. Returns false otherwise. *) BEGIN CHANGE := YESNO(CONCAT('Change ',WHAT),'N'); END; (* of change *) FUNCTION GETNUMFOR(WHAT: STRING; MAX: INTEGER): INTEGER; (* This function prompts for a number that tells which WHAT is to be changed. It returns a value between 1 and MAX. *) VAR ANS: INTEGER; BEGIN GETNUM(1,MAX,-1,CONCAT('Enter ',WHAT,' # to Change'),ANS); GETNUMFOR := ANS; END; (* of getnumfor *) PROCEDURE CHANGEPAGES; VAR ERR, LASTPAGE, NUMPAGES: INTEGER; AWINDOW: WINDOWTYPE; PAGES: STRING[2]; BEGIN SETNUM(1,MAXPAGES,'Pages',LASTPAGE,MSG_LINE); ONEMOMENT('Opening Data File'); WITH FORM_DAT_DESC, DIRECTORY^ DO BEGIN RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT')); USEDHEAP := FALSE; CHECKERR(5,FALSE,OLDREC); DAT_OPEN := TRUE; BLKSPERPAGE := ( (THEMAXROW*THEMAXCOL) + WINDOWSIZE ) DIV ( WINDOWSIZE+1 ); NUMPAGES := NO_PAGES; IF LASTPAGE > NUMPAGES THEN (* need to add pages *) BEGIN ONEMOMENT('Opening Title file'); IF NOT OPEN_TIT(REQUESTED_FORM) THEN CHECKERR(8,FALSE,OLDREC); REPEAT NUMPAGES := NUMPAGES + 1; SET_PAGE(NUMPAGES,FALSE,TRUE,NEWREC,ERR); (* get info and add page *) IF ERR <> 0 THEN BEGIN IF ERR = 1 THEN ERROR(2); LASTPAGE := NUMPAGES-1 END UNTIL NUMPAGES >= LASTPAGE; CLOSE(FORM_TIT_FILE,LOCK); TIT_OPEN := FALSE END; (* Position file pointer after last block in the file *) IF BLOCKREAD(FORM_DAT_FILE,AWINDOW,1,BLKSPERPAGE*LASTPAGE-1) <> 1 THEN; NO_PAGES := LASTPAGE; CLOSE(FORM_DAT_FILE,CRUNCH); DAT_OPEN := FALSE END; DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER); (* display directory record *) END; (* of changepages *) PROCEDURE ROWCHANGE(NUM: INTEGER; COND: SETTYPE; DISPLAYHEAD: BOOLEAN; VAR ERR: BOOLEAN ); BEGIN IF DISPLAYHEAD THEN PUTCTRLHEAD('Row',DIRECTORY^.NO_ROWS); SEEKCTL(FORM_CTL_FILE,FALSE,NUM,ANDGET); SET_CTRL_REC(FORM_CTL_FILE^,TRUE,NUM,TRUE,ERR,COND); IF NOT ERR THEN SEEKCTL(FORM_CTL_FILE,FALSE,NUM,ANDPUT) END; PROCEDURE COLCHANGE(NUM: INTEGER; COND: SETTYPE; DISPLAYHEAD: BOOLEAN; VAR ERR: BOOLEAN ); BEGIN IF DISPLAYHEAD THEN PUTCTRLHEAD('Col',DIRECTORY^.NO_COLS); SEEKCTL(FORM_CTL_FILE,TRUE,NUM,ANDGET); SET_CTRL_REC(FORM_CTL_FILE^,FALSE,NUM,TRUE,ERR,COND); IF NOT ERR THEN SEEKCTL(FORM_CTL_FILE,TRUE,NUM,ANDPUT) END; PROCEDURE CHANGECTLS(VAR NUM: INTEGER; MAX: INTEGER; DOINGROW: BOOLEAN; WHAT: STRING); VAR CNT: INTEGER; PROCEDURE SWAPRECS(FIRST, LAST, OFFSET, DELTA: INTEGER); VAR CNT, K: INTEGER; BEGIN (* SWAPRECS *) ONEMOMENT(CONCAT('Moving ',WHAT,'s')); CNT := FIRST - OFFSET; WITH FORM_CTL_FILE^, DIRECTORY^ DO WHILE CNT <> (LAST + DELTA + OFFSET) DO (* swap fields in control file *) BEGIN CNT := CNT + OFFSET; SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,CNT-DELTA,ANDGET); SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,CNT ,ANDPUT) END; K := 0; WITH DIRECTORY^ DO (* swap data in each page of dat file *) REPEAT K := K + 1; CNT := FIRST - OFFSET; WHILE CNT <> (LAST + DELTA + OFFSET) DO BEGIN CNT := CNT + OFFSET; MOVEFORMDATA(DOINGROW,K,CNT-DELTA,CNT); END UNTIL K = NO_PAGES; END; (* of swaprecs *) PROCEDURE CHANGECALC(VAR CTLREC: CTLRECORD; FOCALPT, DELTA: INTEGER; DELIT: BOOLEAN); VAR I, ANS: INTEGER; TEMP: STRING[L_CALC]; FUNCTION ENDOFNUM(START: INTEGER): INTEGER; BEGIN WHILE (START < LENGTH(TEMP)) AND (TEMP[START] IN DIGITS) DO START := START + 1; ENDOFNUM := START - 1; END; BEGIN (* CHANGECALC *) IF CTLREC.CTL_TYPE IN [INITIALC,FINALC] THEN WITH CTLREC DO BEGIN TEMP := CONCAT(CTL_CALC,'#'); CTL_CALC := ''; REPEAT IF TEMP[1] IN ['C','c'] THEN I := ENDOFNUM(2) ELSE IF TEMP[1] IN DIGITS THEN BEGIN I := ENDOFNUM(1); VALUE(TRUE,COPY(TEMP,1,I),FAKE,ANS); IF (ANS >= (FOCALPT + DELTA)) AND DELIT THEN ANS := ANS - DELTA ELSE IF (ANS >= FOCALPT) AND NOT DELIT THEN ANS := ANS + DELTA END ELSE BEGIN I := 1; WHILE (I < LENGTH(TEMP)) AND NOT (TEMP[I] IN (DIGITS + ['C','c'])) DO I := I + 1; I := I - 1 END; IF TEMP[1] IN DIGITS THEN ENCODE(ANS,IS) ELSE IS := COPY(TEMP,1,I); CTL_CALC := CONCAT(CTL_CALC,IS); DELETE(TEMP,1,I) UNTIL LENGTH(TEMP) = 1; END; END; (* of changecalc *) PROCEDURE DOINSERT; VAR NEWCNT, NEWNUM: INTEGER; BEGIN GETNUM(0,NUM,-1,CONCAT('Enter ',WHAT,' # to Insert After'),ANS); CNT := MAX - NUM; (* Maximum number that could be inserted *) GETNUM(1,CNT,1,CONCAT('Insert how many ',WHAT,'s ?'),CNT); ANS := ANS + 1; NUM := NUM + CNT; IF (NUM-CNT) >= ANS THEN SWAPRECS(NUM,ANS+1,-1,CNT); I := ANS; WHILE I <= (ANS + CNT - 1) DO BEGIN IF DOINGROW THEN ROWCHANGE(I,NEWREC,I=ANS,ERR) ELSE COLCHANGE(I,NEWREC,I=ANS,ERR); IF ERR THEN BEGIN IF YESNO(CONCAT('Abort all ',WHAT,'s inserted'),'N') THEN BEGIN NEWCNT := 0; NEWNUM := NUM - CNT END ELSE BEGIN NEWCNT := I - ANS; NEWNUM := NUM + NEWCNT - CNT END; IF (NUM - CNT) >= ANS THEN SWAPRECS(ANS+NEWCNT,NUM-1,1,NEWCNT-CNT); NUM := NEWNUM; CNT := NEWCNT END ELSE I := I + 1 END; IF ( (NUM-CNT) >= ANS ) AND (CNT <> 0) THEN BEGIN ONEMOMENT('Adjusting calculation strings'); FOR I := 1 TO NUM DO IF NOT (I IN [ANS..ANS+CNT-1]) THEN BEGIN J := I; SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,J,ANDGET); CHANGECALC(FORM_CTL_FILE^,ANS,CNT,FALSE); SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,J,ANDPUT) END END END; (* of doinsert *) PROCEDURE DODELETE; BEGIN GETNUM(1,NUM,-1,CONCAT('Enter Starting ',WHAT,' # to Delete'),ANS); CNT := NUM - ANS + 1; IF CNT = NUM THEN CNT := CNT - 1; (* don't let all be deleted *) GETNUM(1,CNT,1,CONCAT('Delete how many ',WHAT,'s ?'),CNT); I := 0; REPEAT (* Display all of the items that will be deleted *) GOTOXY(0,MSG_LINE+1); SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,ANS+I,ANDGET); WRITEAREC(OUTPUT,ANS+I,FORM_CTL_FILE^); I := I + 1; IF I < CNT THEN PRESSRETURN(CONCAT('To see the next ',WHAT),MSG_LINE+2) UNTIL I >= CNT; ERASE(MSG_LINE+2); IF YESNO('Do you still want to Delete','N') THEN BEGIN ERASE(MSG_LINE+1); NUM := NUM - CNT; IF (NUM + 1) > ANS THEN BEGIN SWAPRECS(ANS,NUM+CNT-1,1,-CNT); FOR I := 1 TO NUM DO BEGIN J := I; SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,J,ANDGET); CHANGECALC(FORM_CTL_FILE^,ANS,CNT,TRUE); SEEKCTL(FORM_CTL_FILE,NOT DOINGROW,J,ANDPUT) END END END ELSE ERASE(MSG_LINE+1) END; (* of dodelete *) BEGIN (* CHANGECTLS *) WHILE CHANGE(CONCAT('Number of ',WHAT,'s')) DO WITH FORM_CTL_FILE^, DIRECTORY^ DO BEGIN IF NOT DAT_OPEN THEN IF NOT OPEN_DAT(REQUESTED_FORM,FORM_DAT_FILE,FORM_DAT_DESC, 'FORMS,CHG,MOVEFORMDATA',TRUE) THEN CHECKERR(5,FALSE,OLDREC); IF NUM < MAX THEN IF YESNO(CONCAT('Insert ',WHAT,'(s)'),'N') THEN DOINSERT; IF NUM > 1 THEN (* WAS 0, BUG FIX SDA 8/28/80 *) IF YESNO(CONCAT('Delete ',WHAT,'(s)'),'N') THEN DODELETE END END; (* of changectls *) BEGIN (* MODIFY *) DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER); (* display dir record *) ONEMOMENT('Opening Control and Data files'); IF NOT OPEN_CTL(REQUESTED_FORM) THEN CHECKERR(4,FALSE,OLDREC); MEMORY; WITH DIRECTORY^ DO BEGIN REPEAT IF CHANGE('User ID') THEN GETUSERID; IF CHANGE('Form description') THEN GETFORMDESC; IF CHANGE('Form creation date') THEN GETDATE; IF CHANGE('Number of Pages') THEN CHANGEPAGES; IF CHANGE('Number of Constants') THEN SETNUM(0,MAXCONSTS,'Constants',NO_CONSTS,MSG_LINE); IF DIRECTORY^.NO_CONSTS > 0 THEN WHILE CHANGE('Value of a Constant') DO BEGIN IF NOT CON_OPEN THEN (* Open file containing Constants *) BEGIN ONEMOMENT('Opening Constant file'); IF NOT OPEN_CON(REQUESTED_FORM) THEN CHECKERR(12,FALSE,OLDREC) END; GET_CONSTANT(GETNUMFOR('Constant',NO_CONSTS),MSG_LINE,TRUE) END; IF CON_OPEN THEN BEGIN CLOSE(FORM_CON_FILE,LOCK); CON_OPEN := FALSE END; CHANGECTLS(NO_ROWS,THEMAXROW,TRUE,'Row'); CHANGECTLS(NO_COLS,THEMAXCOL,FALSE,'Column'); DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER) (* Show changed Dir record *) (*$B 40COL- *) UNTIL YESNO('Are these new specifications ok','Y'); (*$E 40COL *) (*$B 40COL+ *) UNTIL YESNO('New specifications ok','Y'); (*$E 40COL *) IF DAT_OPEN THEN BEGIN ONEMOMENT('Closing Data File'); CLOSE_DAT(FORM_DAT_FILE,FORM_DAT_DESC,ERR); IF ERR THEN ERROR(10) END; REPEAT WHILE CHANGE('Page Titles') DO BEGIN IF NOT TIT_OPEN THEN (* Open file containing Titles *) BEGIN ONEMOMENT('Opening Title file'); IF NOT OPEN_TIT(REQUESTED_FORM) THEN CHECKERR(8,FALSE,OLDREC) END; ANS := GETNUMFOR('Page',NO_PAGES); SET_PAGE(ANS,FALSE,FALSE,OLDREC,I) END; IF TIT_OPEN THEN BEGIN CLOSE(FORM_TIT_FILE,LOCK); TIT_OPEN := FALSE END; WHILE CHANGE('Row controls') DO ROWCHANGE(GETNUMFOR('Row',NO_ROWS),OLDREC,TRUE,ERR); DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER); (* Show changed Dir record *) WHILE CHANGE('Column controls') DO COLCHANGE(GETNUMFOR('Column',NO_COLS),OLDREC,TRUE,ERR); DISPLAYDIR(OUTPUT,TRUE,FALSE,RECNUMBER) (* Show changed Dir record *) (*$B 40COL- *) UNTIL YESNO('Are these new specifications ok','Y'); (*$E 40COL *) (*$B 40COL+ *) UNTIL YESNO('New specifications ok','Y'); (*$E 40COL *) END; ONEMOMENT('Updating Directory'); SEEKDIR(RECNUMBER,ANDPUT); END; (* of modify *) BEGIN (* CHG *) PUTMAINHEAD; WRITELN(OUTPUT,'Modify FORM controls'); IF DISK_DIR THEN BEGIN IF NAME_FORM(REQUESTED_FORM, RECNUMBER) THEN MODIFY; FINISHUP END END; (* of chg *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.forms4.text ======================================================================================== SEGMENT PROCEDURE INITIALIZE; BEGIN QUIT := FALSE; (* User gave up flag *) NO_PROMPT := TRUE; PREV_FORMAT := '####.##'; CONTROL_HEADER := CONCAT('##### Description D/I/F/H C ', 'Format Calculation'); MONTHS[1] := 'Jan'; MONTHS[2] := 'Feb'; MONTHS[3] := 'Mar'; MONTHS[4] := 'Apr'; MONTHS[5] := 'May'; MONTHS[6] := 'Jun'; MONTHS[7] := 'Jul'; MONTHS[8] := 'Aug'; MONTHS[9] := 'Sep'; MONTHS[10] := 'Oct'; MONTHS[11] := 'Nov'; MONTHS[12] := 'Dec'; END; (* of initialize *) PROCEDURE BLANKREC; (* Creates blank directory record *) BEGIN FILLCHAR(DIRECTORY^,SIZEOF(DIRRECORD),0) END; (* of blankrec *) PROCEDURE CHECKERR{ ERRORNUM: INTEGER; DELENTRY: BOOLEAN; COND: SETTYPE }; VAR I: INTEGER; BEGIN IF (ERRORNUM=0) OR (IORESULT <> 0) THEN BEGIN IF ERRORNUM > 0 THEN ERROR(ERRORNUM); IF DELENTRY AND (COND = NEWFILE) THEN BEGIN OPEN_DIR; SEEKDIR(RECNUMBER,ANDGET); IF NOT DAT_OPEN THEN BEGIN RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT')); FORM_DAT_DESC.USEDHEAP := FALSE END; CLOSE(FORM_DAT_FILE, PURGE); DAT_OPEN := FALSE; IF FORM_DAT_DESC.USEDHEAP THEN FREEMEM(FORM_DAT_DESC); BLANKREC; SEEKDIR(RECNUMBER,ANDPUT); IF OPEN_CTL(REQUESTED_FORM) THEN; CLOSE(FORM_CTL_FILE,PURGE); CTL_OPEN := FALSE; IF OPEN_CON(REQUESTED_FORM) THEN; CLOSE(FORM_CON_FILE,PURGE); CON_OPEN := FALSE; IF OPEN_TIT(REQUESTED_FORM) THEN; CLOSE(FORM_TIT_FILE,PURGE); TIT_OPEN := FALSE END; FINISH_UP; EXIT(FORMS) END END; (* of checkerr *) FUNCTION ABORT{: BOOLEAN }; BEGIN ERASE(MSG_LINE-1); ERASE(MSG_LINE+1); ERASE(MSG_LINE+2); PRESSRETURN('Warning ESC was pressed,',MSG_LINE); ABORT := YESNO('Do you want to Stop','Y'); ERASE(MSG_LINE) END; (* of abort *) PROCEDURE PUTMAINHEAD; BEGIN {WRITELN(OUTPUT,CLEAR);} sc_clr_screen; (*$B 40COL- *) WRITELN(OUTPUT,'F R E E F O R M F O R M S C O N T R O L'); (*$E 40COL *) (*$B 40COL+ *) WRITELN(OUTPUT,'F R E E F O R M FORMS CONTROL'); (*$E 40COL *) MEMORY; PRINT_LINE := 2; END; PROCEDURE PUTCTRLHEAD{ WHAT: STRING; NUM: INTEGER }; BEGIN PUTMAINHEAD; (*$B 40COL- *) WRITELN('FREEFORM ',WHAT,' Parameter Definition for ',REQUESTED_FORM, ' ',WHAT,'s=',NUM); (*$E 40COL *) (*$B 40COL+ *) WRITELN('FREEFORM ',WHAT,' Def. for ',REQUESTED_FORM,' ',WHAT,'s=',NUM); (*$E 40COL *) WRITELN(CONTROL_HEADER) END; PROCEDURE SETNUM{ MIN, MAX: INTEGER; WHAT: STRING; VAR ANS: INTEGER; LINE: INTEGER }; BEGIN GETNUM(MIN,MAX,-1,CONCAT('How many ',WHAT,'?'),ANS); PROMPT(CONCAT('Number of ',WHAT,' -> '),LINE); WRITE(OUTPUT,ANS); END; (* of setnum *) PROCEDURE GETUSERID; BEGIN GETRESPONSE(TRUE,'Enter user initials -> ','',' (optional)', L_ID,DIRECTORY^.FORMID); END; PROCEDURE GETFORMDESC; BEGIN (*$B 40COL- *) GETRESPONSE(TRUE,'Enter descriptive comment -> ','',' (optional)', L_DESC,DIRECTORY^.FORM_DESC); (*$E 40COL *) (*$B 40COL+ *) GETRESPONSE(TRUE,'Form description -> ','',' (optional)', L_DESC,DIRECTORY^.FORM_DESC); (*$E 40COL *) END; PROCEDURE GETDATE; var t_info : sc_info_type; BEGIN sc_use_info ( sc_get, t_info ); WITH DIRECTORY^,t_info DO BEGIN ENCODE(sc_date.DAY,FORM_DATE); FORM_DATE := CONCAT(MONTHS[sc_date.MONTH],' ',FORM_DATE); GETRESPONSE(TRUE,'Enter today''s date (MMDDYY) -> ',FORM_DATE, ' (optional)',L_DATE,FORM_DATE) END END; PROCEDURE GET_CONSTANT{ NUM, LINE: INTEGER; OLD: BOOLEAN }; VAR TRASH: INTEGER; xdummy : sc_key_command; (**gws*) DUMY: CHAR; BEGIN REPEAT GOTOXY(0,MSG_LINE); sc_erase_to_eol ( 0, msg_line ); WRITE(OUTPUT,'CONSTANT(',NUM:3,') = -',CRT_CURSOR_LEFT); (**gws*) ACCEPTNUM(TRUE,MAXFRAC+MAXWHOLE+2,IS,DUMY,xdummy); UNTIL (IS<>'INVALID'); IF IS = '' THEN IS := '-'; VALUE(FALSE, IS, FORM_CON_FILE^, TRASH); SEEKCON(NUM,ANDPUT); (* enter constant into the file SDA 11/25/80 *) NUMTOSTR(IS, FORM_CON_FILE^, MAXWHOLE, 5); (* SDA 9/22/81 *) IF NOT OLD THEN (* SDA 9/22/81 *) BEGIN ERASE(LINE); GOTOXY(2,LINE); WRITELN(OUTPUT,'CONSTANT(',NUM:3,') = ',IS); ERASE(LINE+1) END END; (* of get_constant *) PROCEDURE SET_PAGE{ PAGE: INTEGER; NO_PROMPT, NEWPAGE: BOOLEAN; COND: SETTYPE; VAR ERR: INTEGER }; VAR ALLOK: BOOLEAN; I, J: INTEGER; PAGES: STRING[2]; AWINDOW: WINDOWTYPE; BEGIN ERR := 0; ENCODE(PAGE,PAGES); (* change Page into a string *) IF PAGE<10 THEN PAGES := CONCAT(PAGES); IF NEWPAGE THEN FORM_TIT_FILE^ := '' (* initialize Title to nul string *) ELSE SEEKTIT(FORM_TIT_FILE,PAGE,ANDGET); (* Set Title to current value *) REPEAT ALLOK := TRUE; PROMPT(CONCAT('Enter Title for Page ',PAGES,' (60 chars. max.)'), MSG_LINE-1); GETRESPONSE(TRUE,'',FORM_TIT_FILE^,'',60,FORM_TIT_FILE^); IF FORM_TIT_FILE^ = 'ESCAPE' THEN IF ABORT THEN BEGIN ERR := 2; EXIT( SET_PAGE ) END ELSE BEGIN FORM_TIT_FILE^ := ''; ALLOK := FALSE END ELSE BEGIN ERASE(MSG_LINE-1); ERASE(MSG_LINE); (* Note: If the title is allowed to be longer than 60 chars then this line will cause a string overflow !!!! *) PROMPT('Page ',(PAGE MOD (MSG_LINE-7)) + 4); WRITE(PAGE:2,' Title is -> ',FORM_TIT_FILE^); ERASE( (PAGE MOD (MSG_LINE-7)) + 5 ); IF NOT NO_PROMPT THEN ALLOK := YESNO('Is Title Correct','Y') END UNTIL ALLOK; SEEKTIT(FORM_TIT_FILE,PAGE,ANDPUT); IF NEWPAGE THEN (* Create a page file *) WITH DIRECTORY^, FORM_DAT_DESC DO BEGIN ONEMOMENT(CONCAT('Creating Page ',PAGES)); FOR I := 0 TO WINDOWSIZE DO AWINDOW[I] := EMPTY; J := (PAGE-1) * BLKSPERPAGE; FOR I := 0 TO BLKSPERPAGE-1 DO IF BLOCKWRITE(FORM_DAT_FILE,AWINDOW,1,I+J) <> 1 THEN BEGIN ERR := 1; EXIT(SET_PAGE) END END END; (* of set_page *) PROCEDURE WRITEAREC{ VAR OUTFILE: TXTFILE; NUM: INTEGER; VAR AREC: CTLRECORD }; VAR I: INTEGER; CH: CHAR; BEGIN WITH AREC DO BEGIN WRITE(OUTFILE,NUM:5,' ',CTL_DESC,' '); FOR I := 1 TO L_CDESC-LENGTH(CTL_DESC) DO WRITE(OUTFILE,' '); CASE CTL_TYPE OF DATA: CH := 'D'; INITIALC: CH := 'I'; HEADING: CH := 'H'; FINALC: CH := 'F' END; WRITE(OUTFILE,CH,' '); IF CTL_CROSS THEN CH := 'Y' ELSE CH := 'N'; WRITE(OUTFILE,CH,' ',CTL_FORMAT,' '); FOR I := 1 TO L_CFORMAT-LENGTH(CTL_FORMAT) DO WRITE(OUTFILE,' '); WRITELN(OUTFILE,CTL_CALC); END; END; (* of writearec *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.forms5.text ======================================================================================== PROCEDURE SET_CTRL_REC{ VAR REC: CTLRECORD; SETTINGROW: BOOLEAN; OFFSET: INTEGER; NO_PROMPT: BOOLEAN; VAR HITESC: BOOLEAN; COND: SETTYPE }; VAR OK_KIND: STRING[33]; WHAT: STRING[7]; ALLOK: BOOLEAN; NUM: STRING[2]; DEF_CROSS, DEF_TYPE: STRING[1]; PROCEDURE EVALUATE(VAR CALC:STRING); VAR DUMY: CHAR; FUNCTION VALID_CALC: BOOLEAN; (* Calculate string validation *) (* Returns true if a valid_calc string is given and false otherwise *) TYPE TOKENKINDS = (CONSTV, EOFV, LPARENV, MINUSV, PLUSV, UPARROWV, RPARENV, VALUEV, SLASHV, STARV, BADCONSTV, BADVALUEV, UNRECSYMV); VAR PT: INTEGER; OPERATORS: SET OF CHAR; TOKENTYPE: TOKENKINDS; PROCEDURE ERR( REASON: TOKENKINDS ); VAR I: INTEGER; MSG: STRING[15]; BEGIN IF REASON IN [RPARENV,EOFV,BADCONSTV,BADVALUEV] THEN CASE REASON OF RPARENV: MSG := 'Paren missing'; EOFV: MSG := 'Unexpected end'; BADCONSTV: MSG := 'Invalid Const'; BADVALUEV: IF SETTINGROW THEN MSG := 'Invalid Row' ELSE MSG := 'Invalid Column'; END ELSE MSG := 'Bad character'; GOTOXY(1,MSG_LINE+1); FOR I := 1 TO PT-1 DO WRITE(OUTPUT,CALC[I]); WRITE(OUTPUT,' <-> '); DELETE(CALC,LENGTH(CALC),1); (* remove EOF char *) FOR I := PT TO LENGTH(CALC) DO WRITE(OUTPUT,CALC[I]); PRESSRETURN(MSG,MSG_LINE+2); ERASE(MSG_LINE+2); EXIT(VALID_CALC); END; (* of err *) PROCEDURE SCANNER; VAR NUM: INTEGER; CH: CHAR; PROCEDURE SETNUM; VAR ENDOFNUM: INTEGER; BEGIN ENDOFNUM := PT + 1; WHILE CALC[ ENDOFNUM ] IN DIGITS DO ENDOFNUM := ENDOFNUM + 1; VALUE(TRUE,COPY(CALC,PT,ENDOFNUM-PT),FAKE,NUM); PT := ENDOFNUM; END; (* of setnum *) PROCEDURE GETCONSTANT; BEGIN TOKENTYPE := BADCONSTV; PT := PT + 1; IF CALC[ PT ] IN DIGITS THEN BEGIN SETNUM; IF (NUM > 0) AND (NUM <= DIRECTORY^.NO_CONSTS) THEN TOKENTYPE := CONSTV END END; (* of getconstant *) PROCEDURE GETVALUE; BEGIN SETNUM; IF (NUM > 0) AND ((SETTINGROW AND (NUM <= DIRECTORY^.NO_ROWS)) OR (NOT SETTINGROW AND (NUM <= DIRECTORY^.NO_COLS))) THEN TOKENTYPE := VALUEV ELSE TOKENTYPE := BADVALUEV; END; (* getrcvalue *) BEGIN (* SCANNER *) IF CALC[ PT ] = ' ' THEN REPEAT PT := PT + 1 UNTIL CALC[ PT ] <> ' '; (* get non blank *) CH := CALC[ PT ]; IF CH IN ['C','c'] THEN GETCONSTANT ELSE IF CH IN DIGITS THEN GETVALUE ELSE IF CH IN OPERATORS THEN BEGIN CASE CH OF '+': TOKENTYPE:=PLUSV; '-': TOKENTYPE:=MINUSV; '*': TOKENTYPE:=STARV; '/': TOKENTYPE:=SLASHV; '^': TOKENTYPE:=UPARROWV; '(': TOKENTYPE:=LPARENV; ')': TOKENTYPE:=RPARENV; '#': TOKENTYPE:=EOFV END; PT := PT + 1 END ELSE TOKENTYPE := UNRECSYMV; IF TOKENTYPE = EOFV THEN PT := PT - 1; END; (* of scanner *) PROCEDURE EXPRESSION; PROCEDURE PARENEXPRESSION; BEGIN SCANNER; EXPRESSION; IF TOKENTYPE = RPARENV THEN SCANNER ELSE ERR(RPARENV); END; (* of parenexpression *) PROCEDURE PRIMARY; BEGIN IF TOKENTYPE IN [ CONSTV, VALUEV ] THEN SCANNER ELSE IF TOKENTYPE = LPARENV THEN PARENEXPRESSION ELSE ERR(TOKENTYPE) END; (* of primary *) PROCEDURE FACTOR; BEGIN PRIMARY; WHILE TOKENTYPE = UPARROWV DO BEGIN SCANNER; PRIMARY END END; (* of factor *) PROCEDURE TERM; BEGIN FACTOR; WHILE TOKENTYPE IN [ STARV, SLASHV ] DO BEGIN SCANNER; FACTOR END; END; (* of term *) BEGIN (* EXPRESSION *) IF TOKENTYPE IN [ PLUSV, MINUSV ] THEN SCANNER; TERM; WHILE TOKENTYPE IN [ PLUSV, MINUSV ] DO BEGIN SCANNER; TERM END END; (* of expression *) BEGIN (* VALID_CALC *) VALID_CALC := FALSE; CALC := CONCAT(CALC,'#'); OPERATORS := ['+','*','-','/','^','(',')','#']; PT := 1; SCANNER; EXPRESSION; IF TOKENTYPE <> EOFV THEN ERR(UNRECSYMV); DELETE(CALC,LENGTH(CALC),1); VALID_CALC := TRUE END; (* of valid_calc *) BEGIN (* EVALUATE *) (* First released version of Freeform left an equals sign in the first position of the calc string. This version does not and gets rid of any it finds. SDA 9/15/80 *) IF POS('=',CALC) = 1 THEN DELETE(CALC,1,1); REPEAT PROMPT('=',MSG_LINE+1); ACCEPTSTR(TRUE,L_CALC-1,1,MSG_LINE+1,CALC,CALC); IF CALC='ESCAPE' THEN CALC := '' UNTIL VALID_CALC; ERASE(MSG_LINE+1); END; (* of evaluate *) PROCEDURE SETTYPE; (* Set type *) VAR TEMP: STRING[7]; BEGIN (* SETTYPE *) REPEAT (*$B 40COL- *) GETRESPONSE(TRUE,CONCAT('Enter ',WHAT,' ',NUM, ' Type (Data, Initial calc, ',OK_KIND,' '),DEF_TYPE,'',1,IS); (*$E 40COL *) (*$B 40COL+ *) GETRESPONSE(TRUE,CONCAT('Enter ',WHAT,' ',NUM, ' Type ', OK_KIND,' '),DEF_TYPE,'',1,IS); (*$E 40COL *) LCTOUC(IS); UNTIL (IS='D') OR (IS='I') OR (IS='F') OR ( SETTINGROW AND (IS='H') ); WITH REC DO BEGIN IF IS='D' THEN CTL_TYPE := DATA ELSE IF IS='H' THEN CTL_TYPE := HEADING ELSE BEGIN IF IS='F' THEN CTL_TYPE := FINALC ELSE CTL_TYPE := INITIALC; EVALUATE(CTL_CALC); END; IF CTL_TYPE IN [DATA,HEADING] THEN CTL_CALC := ''; IF CTL_TYPE = HEADING THEN CTL_CROSS := FALSE ELSE BEGIN IF SETTINGROW THEN TEMP := 'Column' ELSE TEMP := 'Row'; (*$B 40COL- *) CTL_CROSS := YESNO(CONCAT('O.K. to set values from ',TEMP, ' calculations'),DEF_CROSS); (*$E 40COL *) (*$B 40COL+ *) CTL_CROSS := YESNO('Cross calculations O.K.',DEF_CROSS); (*$E 40COL *) END; END; END; (* of settype *) PROCEDURE SETDESC; (* Set description *) BEGIN WITH REC DO BEGIN GETRESPONSE(TRUE,CONCAT('Enter Description for ',WHAT,' ',NUM,' '), CTL_DESC,'',L_CDESC,CTL_DESC); IF CTL_DESC='ESCAPE' THEN IF ABORT THEN BEGIN HITESC := TRUE; EXIT( SET_CTRL_REC ) END ELSE BEGIN CTL_DESC := ''; SETDESC END END; END; (* setdesc *) PROCEDURE SETFORMAT; (* Set format *) VAR DECPT, ALLOK: BOOLEAN; I: INTEGER; BEGIN WITH REC DO BEGIN REPEAT REPEAT IF CTL_FORMAT = '' THEN CTL_FORMAT := PREV_FORMAT; GETRESPONSE(TRUE,CONCAT('Enter ',WHAT,' ',NUM,' Editing Format '), CTL_FORMAT,'',L_CFORMAT,CTL_FORMAT); IF CTL_FORMAT = 'ESCAPE' THEN CTL_FORMAT := '' UNTIL CTL_FORMAT <> ''; I := 1; DECPT := FALSE; ALLOK := CTL_FORMAT[1] <> '.'; (* illegal to have no #'s before dec pt *) WHILE (I <= LENGTH(CTL_FORMAT)) AND ALLOK DO BEGIN ALLOK := CTL_FORMAT[I] IN ['#','.']; IF CTL_FORMAT[I]='.' THEN IF NOT DECPT THEN DECPT := TRUE ELSE ALLOK := FALSE; I := I + 1; END; IF NOT ALLOK THEN WRITE(OUTPUT,THEBELL) UNTIL ALLOK; I := POS('.',CTL_FORMAT); IF (I > 0) AND ( ( LENGTH(CTL_FORMAT)-I ) > MAXFRAC ) THEN DELETE(CTL_FORMAT, I+MAXFRAC+1, LENGTH(CTL_FORMAT)-I-MAXFRAC); PREV_FORMAT := CTL_FORMAT; END; END; (* setformat *) PROCEDURE SETPARAMS; BEGIN HITESC := FALSE; WITH REC DO BEGIN IF COND IN [NEWFILE, NEWREC] THEN BEGIN CTL_DESC := ''; CTL_FORMAT := ''; CTL_CALC := ''; CTL_TYPE := DATA; CTL_CROSS := TRUE END; CASE CTL_TYPE OF DATA: DEF_TYPE := 'D'; INITIALC: DEF_TYPE := 'I'; HEADING: DEF_TYPE := 'H'; FINALC: DEF_TYPE := 'F' END; IF CTL_CROSS THEN DEF_CROSS := 'Y' ELSE DEF_CROSS := 'N' END; ENCODE(OFFSET,NUM); (* change Offset into a string *) IF SETTINGROW THEN BEGIN WHAT := 'Row'; (*$B 40COL- *) OK_KIND := 'Final calc, or Heading (D/I/F/H)' (*$E 40COL *) (*$B 40COL+ *) OK_KIND := '(D/I/F/H)' (*$E 40COL *) END ELSE BEGIN WHAT := 'Column'; (*$B 40COL- *) OK_KIND := 'or Final calc (D/I/F)' (*$E 40COL *) (*$B 40COL+ *) OK_KIND := '(D/I/F)' (*$E 40COL *) END; END; PROCEDURE DISPLAYCTLS; VAR Y: INTEGER; BEGIN Y := ( OFFSET MOD ( MSG_LINE-7 ) ) + 5; ERASE(Y); WRITEAREC(OUTPUT,OFFSET,REC); ERASE(Y+1); END; (* of display ctls *) BEGIN (* SET_CTRL_REC *) SETPARAMS; REPEAT ALLOK := TRUE; WITH REC, DIRECTORY^ DO BEGIN IF COND = OLDREC THEN DISPLAYCTLS; IF ( (SETTINGROW AND (AUTO_SWITCH=AROW)) OR ((NOT SETTINGROW) AND (AUTO_SWITCH=ACOL)) ) AND (COND = NEWFILE) THEN CTL_DESC := MONTHS[ ( ( START_MONTH+OFFSET-2 ) MOD 12 ) + 1 ] ELSE BEGIN (* set description up *) SETDESC; SETTYPE END; IF ( (SETTINGROW AND (FORMAT=FROW)) OR ((NOT SETTINGROW) AND (FORMAT=FCOL)) ) AND (CTL_TYPE <> HEADING) THEN SETFORMAT ELSE CTL_FORMAT := ''; DISPLAYCTLS; IF NOT ( NO_PROMPT OR ( ( ( SETTINGROW AND (AUTO_SWITCH=AROW) AND (FORMAT=FCOL) ) OR ( (NOT SETTINGROW) AND (AUTO_SWITCH=ACOL) AND (FORMAT=FROW) ) ) AND (COND=NEWFILE) ) ) THEN ALLOK := YESNO(CONCAT('Are Controls for ',WHAT,' ',NUM,' ok'),'Y'); END; UNTIL ALLOK; END (* of set_ctrl_rec *); PROCEDURE DISPLAYDIR{ VAR OUTFILE: TXTFILE; TOSCREEN, ALL: BOOLEAN; RECNUMBER: INTEGER }; (* Displays freeform directory entries if ALL is true or an entry if ALL is false. Starts displaying with the RECNUMBER entry *) VAR BOT_CNT: INTEGER; CURRENT, AUTOKIND, THEFORMAT: CHAR; SPACES: STRING; PROCEDURE PUTDIRHEAD; BEGIN (*$B 40COL- *) WRITELN(OUTFILE,'F R E E F O R M D I R E C T O R Y L I S T I N G'); (*$E 40COL *) (*$B 40COL+ *) WRITELN(OUTFILE,'F R E E F O R M DIRECTORY LISTING'); (*$E 40COL *) WRITELN(OUTFILE); WRITELN(OUTFILE, ' FORM NAME ID DATE DESCRIPTION PAGES ROWS COLS F M'); WRITELN(OUTFILE, ' ========= == ==== =========== ===== ===== ===== = ='); PRINT_LINE := 4; IF TOSCREEN AND ALL THEN BEGIN PROMPT('* indicates FORM not useable with this Version of FREEFORM', MSG_LINE+2); GOTOXY(0,PRINT_LINE) END END; BEGIN (* DISPLAYDIR *) SPACES := ' '; IF TOSCREEN THEN BOT_CNT := MSG_LINE-3 ELSE BOT_CNT := PAPER_LENGTH-3; IF TOSCREEN THEN {WRITE(OUTFILE,CLEAR)} sc_clr_screen; PUTDIRHEAD; WITH DIRECTORY^ DO WHILE (RECNUMBER'') DO BEGIN PRINT_LINE := PRINT_LINE +1; IF PRINT_LINE > BOT_CNT THEN BEGIN IF TOSCREEN THEN PRESSRETURN('To continue',MSG_LINE); {WRITE(OUTFILE,CLEAR);} sc_clr_screen; PUTDIRHEAD END; IF THEVERSION = VERSION THEN CURRENT := ' ' ELSE CURRENT := '*'; IF FORMAT=FROW THEN THEFORMAT := 'R' ELSE THEFORMAT := 'C'; CASE AUTO_SWITCH OF NOAUTO: AUTOKIND := ' '; AROW : AUTOKIND := 'R'; ACOL : AUTOKIND := 'C' END; WRITELN(OUTFILE, CURRENT, FORM_NAME,COPY(SPACES,1,(L_NAME-LENGTH(FORM_NAME))),' ', FORM_ID, COPY(SPACES,1,(L_ID-LENGTH(FORM_ID))),' ', FORM_DATE,COPY(SPACES,1,(L_DATE-LENGTH(FORM_DATE))),' ', FORM_DESCRIPTION,COPY(SPACES,1, (L_DESC-LENGTH(FORM_DESCRIPTION))),' ', NO_PAGES:3,' ',NO_ROWS:5,' ',NO_COLS:5,' ', THEFORMAT,' ',AUTOKIND); IF ALL THEN BEGIN RECNUMBER := RECNUMBER +1; GET(DIRECTORY) END ELSE RECNUMBER := DIRSIZE END; (* of WHILE *) IF NOT TOSCREEN THEN {WRITE(OUTFILE,CLEAR)} sc_clr_screen; END; (* of displaydir *) BEGIN (* FORMS *) INITIALIZE; CASE OPTION OF 1: DEF; 2: CHG; 3: LIST; 4: LIST; END; FINISHUP; END; (* of forms *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.freefrm.text ======================================================================================== (*XL LISTING.TEXT *) (*$I- *) (*$D 40COL- *) PROGRAM FREEFORM; (**********************************************************************) (* *) (* FREEFORM Jan 5, 1982 *) (* ======== *) (* _________ *) (* / \ *) (* By S. Dale Ander | Version | *) (* Texas Instruments Incorporated | F.4 | *) (* \_________/ *) (* *) (* *) (* *) (* *) (**********************************************************************) {USES (*$U KERNEL.CODE *) KERNEL;} uses screenops ( sc_key_command, sc_map_crt_command, sc_use_info, sc_clr_screen, sc_choice, sc_info_type, sc_date_rec, sc_chset, sc_misc_rec, sc_erase_to_eol); { comment out the selective uses list if you don't have IV.1x gws} CONST MAXWHOLE = 13; (* max digits before decimal point *) MAXFRAC = 11; (* max digits after decimal point *) ZEROS = '000000000000'; (* MAXFRAC + 1 zeros *) MAXCOL = 101; (* max # cols allowed in one form *) MAXCONSTS = 200; (* number of consts allowed to be defined in a form *) MAXPAGES = 100; (* number of pages allowed in one form *) DIRSIZE = 30; (* size of freeform directory *) L_NAME = 8; (* length of a form name *) L_ID = 2; (* length of form id *) L_DATE = 6; (* length of form date *) L_DESC = 20; (* length of form descr. *) L_CDESC = 15; (* length of ctrl descr. *) L_CFORMAT = 13; (* length of ctrl format *) L_CALC = 59; (* length of calc string *) L_TITLE = 60; (* length of page title *) WINDOWSIZE = 63; (* Number of numbers less 1 that fit in 1 block *) MAXLISTSIZE = 31; (* Max number of blocks that can be kept in mem *) DIRNAME = 'FREEFORM.DIR'; THEVERSION = 'V4'; (* Validation string stored in directory *) VERSIONDATE = 'Sep 24, 1983'; TYPE TXTFILE = TEXT; NUMBERTYPE = REAL; (* Changed these to Reals SDA 3/25/80 *) BIGNUMTYPE = REAL; DIRRECORD = PACKED RECORD FORM_NAME: STRING[L_NAME]; FORM_ID: STRING[L_ID]; FORM_DATE: STRING[L_DATE]; (* Date of creation *) FORM_DESC: STRING[L_DESC]; VERSION: PACKED ARRAY[1..02] OF CHAR; FILLER: PACKED ARRAY[1..52] OF CHAR; (* Space holder *) FORMAT: (FROW,FCOL); (* Row or Col formatted *) AUTO_SWITCH: (NOAUTO,AROW,ACOL); (* Automatic headings? *) START_MONTH: 0..12; THEMAXROW: INTEGER; THEMAXCOL: INTEGER; NO_CONSTS: INTEGER; NO_PAGES: INTEGER; NO_ROWS: INTEGER; NO_COLS: INTEGER; END; TYPE_CTL = (DATA,INITIALC,HEADING,FINALC); CTLRECORD = PACKED RECORD CTL_DESC: STRING[L_CDESC]; CTL_FORMAT: STRING[L_CFORMAT]; FILLER: PACKED ARRAY[1..2] OF CHAR; (* for expansion *) CTL_CALC: STRING[L_CALC]; FILLER2: PACKED ARRAY[1..2] OF CHAR; CTL_TYPE: TYPE_CTL; CTL_CROSS: BOOLEAN; END; CFILE = FILE OF CTLRECORD; TITLETYPE = STRING[L_TITLE]; TFILE = FILE OF TITLETYPE; ACTIONTYPE = ( NOTHING, ANDGET, ANDPUT ); LISTRANGE = 0..MAXLISTSIZE; WINDOWTYPE = PACKED ARRAY[0..WINDOWSIZE] OF NUMBERTYPE; AFILE = FILE; FILEDESC = PACKED RECORD BLKSPERPAGE: INTEGER; LIST: PACKED ARRAY[LISTRANGE] OF PACKED RECORD DPAGE: INTEGER; DBLOCK: INTEGER; START: INTEGER; WINDOW: ^WINDOWTYPE; BEFORE: LISTRANGE; AFTER: LISTRANGE; CHANGED: BOOLEAN END; LISTHEAD, LISTTAIL, FREEHEAD: LISTRANGE; USEDHEAP: BOOLEAN END; VAR DIGITS: SET OF CHAR; MAX, FAKE, ZERO, EMPTY, OVERFLOW: NUMBERTYPE; PRINTER_ON, FILEOPEN, CTL_OPEN, DAT_OPEN, TIT_OPEN, CON_OPEN, QUIT, NO_PROMPT: BOOLEAN; IS: STRING; PAPER_LENGTH, CHARS_PER_LINE, S_HEIGHT, S_WIDTH, MSG_LINE, I: INTEGER; {HOME, CURSOR_UP, CURSOR_DOWN, CURSOR_LEFT, CURSOR_RIGHT,} ESCAPE, TAB, {CLEAR, ERASELINE,} SPACE, ENTER, {INSKEY, DELKEY,} THEBELL,{ ERASEFIELD,} ERASEINPUT, ABACKSPACE, CRT_CURSOR_LEFT: CHAR;{ not all of these are used } DIRECTORY: FILE OF DIRRECORD; FORM_TIT_FILE: TFILE; FORM_CTL_FILE: CFILE; FORM_DAT_FILE: AFILE; FORM_DAT_DESC: FILEDESC; FORM_CON_FILE: FILE OF NUMBERTYPE; PRINTER: TEXT; OPTION, RECNUMBER: INTEGER; DISKDRIVE: STRING[3]; REQUESTED_FORM: STRING[L_NAME]; DASHES: STRING[60]; TEMP_FILE_NAME: STRING[7]; DEBUGMODE, FIRSTTIMESEEN: BOOLEAN; (* SDA 11/14/80 *) PROCEDURE NUMBER( VAR DAT_FILE: AFILE; VAR DAT_DESC: FILEDESC; PAGE, ROW, COL: INTEGER; VAR NUM: NUMBERTYPE; WHAT: ACTIONTYPE; VAR ERR: BOOLEAN ); FORWARD; PROCEDURE VALUE( RETURNINTEGER: BOOLEAN; INSTRING: STRING; VAR REALANS: NUMBERTYPE; VAR INTANS: INTEGER ); FORWARD; PROCEDURE PROMPT( MSG: STRING; Y: INTEGER); FORWARD; PROCEDURE ONEMOMENT ( REASON: STRING ); FORWARD; PROCEDURE PRESSRETURN( MSG: STRING; Y: INTEGER); FORWARD; PROCEDURE GETRESPONSE( ANY: BOOLEAN; LMSG, DEFAULT, RMSG: STRING; LEN: INTEGER; VAR RESPONSE: STRING); FORWARD; PROCEDURE ERASE ( LINE: INTEGER ); FORWARD; FUNCTION YESNO( MSG, DEFAULT: STRING ): BOOLEAN; FORWARD; PROCEDURE LCTOUC( VAR INSTRING: STRING); FORWARD; PROCEDURE OPENDIR; FORWARD; PROCEDURE FREEMEM( VAR DAT_DESC: FILEDESC ); FORWARD; FUNCTION OPEN_DAT ( REQUESTED_FORM: STRING; VAR DAT_FILE: AFILE; VAR DAT_DESC: FILEDESC; ISEGS: STRING; MAX: BOOLEAN ): BOOLEAN; FORWARD; PROCEDURE CLOSE_DAT ( VAR DAT_FILE: AFILE; VAR DAT_DESC: FILEDESC; VAR ERR: BOOLEAN ); FORWARD; FUNCTION OPEN_CON ( RGQUESTED_FORM: STRING ): BOOLEAN; FORWARD; FUNCTION OPEN_CTL ( REQUESTED_FORM: STRING ): BOOLEAN; FORWARD; FUNCTION OPEN_TIT ( REQUESTED_FORM: STRING ): BOOLEAN; FORWARD; PROCEDURE SEEKDIR ( REC: INTEGER; WHAT: ACTIONTYPE ); FORWARD; PROCEDURE SEEKCON ( REC: INTEGER; WHAT: ACTIONTYPE ); FORWARD; PROCEDURE SEEKCTL ( VAR CTL_FILE: CFILE; COL: BOOLEAN; REC: INTEGER; WHAT: ACTIONTYPE ); FORWARD; PROCEDURE SEEKTIT ( VAR TIT_FILE: TFILE; REC: INTEGER; WHAT: ACTIONTYPE ); FORWARD; PROCEDURE FINISH_UP; FORWARD; PROCEDURE ERROR( INDEX: INTEGER ); FORWARD; FUNCTION SEARCH( VAR LOC: INTEGER; NAME: STRING ): BOOLEAN; FORWARD; PROCEDURE GETNUM(MIN,THEMAX,DEFAULT: INTEGER; WHAT: STRING; VAR ANS: INTEGER); FORWARD; PROCEDURE ENCODE( NUM: INTEGER; VAR ANS: STRING ); FORWARD; PROCEDURE MEMORY; FORWARD; SEGMENT PROCEDURE INITIALIZE; FORWARD; SEGMENT PROCEDURE HELP; FORWARD; SEGMENT PROCEDURE DEL; FORWARD; SEGMENT PROCEDURE MISC; FORWARD; SEGMENT PROCEDURE DATAIN; FORWARD; SEGMENT PROCEDURE FORMS; FORWARD; SEGMENT PROCEDURE COPYFORM; FORWARD; SEGMENT PROCEDURE SETPREFIX; FORWARD; SEGMENT PROCEDURE PRINTMENU; FORWARD; SEGMENT PROCEDURE CHOOSEOPTION; FORWARD; SEGMENT PROCEDURE NUMTOSTR(VAR ANS: STRING; NUM: NUMBERTYPE; BEFORE, AFTER: INTEGER ); FORWARD; SEGMENT FUNCTION FIGURE( VAR Z: NUMBERTYPE; X, Y: NUMBERTYPE; OP: CHAR ): BOOLEAN; FORWARD; SEGMENT PROCEDURE MOVEFORMDATA ( AROW: BOOLEAN; PAGE, SOURCE, DEST: INTEGER ); FORWARD; SEGMENT PROCEDURE SETPRINTER; FORWARD; SEGMENT FUNCTION DISK_DIR: BOOLEAN; FORWARD; SEGMENT FUNCTION NAME_FORM( VAR REQUESTED_FORM: STRING; VAR RECNUMBER: INTEGER): BOOLEAN; FORWARD; SEGMENT FUNCTION GET_FORM_NAME( VAR REQUESTED_FORM: STRING; VAR RECNUMBER: INTEGER): BOOLEAN; FORWARD; SEGMENT PROCEDURE ACCEPTNUM( ARROW: BOOLEAN; MAX_LENGTH: INTEGER; VAR IS: STRING; VAR CH: CHAR; var which_key : sc_key_command ); FORWARD; SEGMENT PROCEDURE ACCEPTSTR( ANY: BOOLEAN; MAX_LENGTH, X, Y: INTEGER; DEFAULT: STRING; VAR IS: STRING ); FORWARD; (*$I FF.MISC1.TEXT *) (*$I FF.MISC2.TEXT *) (*$I FF.DATA1.TEXT *) (*$I FF.DATA2.TEXT *) (*$I FF.DATA3.TEXT *) (*$I FF.DATA4.TEXT *) (*$I FF.DATA5.TEXT *) (*$I FF.FORMS1.TEXT *) (*$I FF.FORMS2.TEXT *) (*$I FF.FORMS3.TEXT *) (*$I FF.FORMS4.TEXT *) (*$I FF.FORMS5.TEXT *) (*$I FF.COPY1.TEXT *) (*$I FF.COPY2.TEXT *) (*$I FF.BASICS1.TEXT *) (*$I FF.BASICS2.TEXT *) (*$I FF.BASICS3.TEXT *) BEGIN (* FREEFORM *) INITIALIZE; REPEAT PRINT_MENU; CHOOSE_OPTION; CASE OPTION OF 0: DATAIN; 1: FORMS; 2: FORMS; 3: FORMS; 4: FORMS; 5: MISC; 6: MISC; 7: COPYFORM; 8: DEL; 9: HELP; 10: DEBUGMODE := NOT DEBUGMODE; 11: SETPREFIX END UNTIL FALSE; END. ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.misc1.text ======================================================================================== SEGMENT PROCEDURE INITIALIZE; VAR TRIX: RECORD CASE BOOLEAN OF TRUE: (A: CHAR); FALSE:(B: 0..255) END; I: INTEGER; backspace : char; THISID, SSN, PID: STRING; t_info : sc_info_type; PROCEDURE ALARM; CONST WAITTIME = 75; FILLCH = 25; VAR DELAY: INTEGER; LINE: PACKED ARRAY[0..255] OF CHAR; STATUS_REC: ARRAY[0..29] OF INTEGER; BEGIN { WRITE(OUTPUT,CLEAR,CHR(150)); (* erase screen then turn it off *) IF S_WIDTH > 255 THEN S_WIDTH := 255; FILLCHAR(LINE,S_WIDTH,CHR(FILLCH)); FOR I := 1 TO S_HEIGHT DO (* fill screen with Fillch *) BEGIN GOTOXY(0,I-1); UNITWRITE(2,LINE,S_WIDTH) END; } sc_clr_screen; GOTOXY((S_WIDTH - LENGTH(IS)) DIV 2,(S_HEIGHT DIV 2) - 1); WRITE(OUTPUT,IS); (* write msg in center of screen *) { I := 0; (* when I = 0 the screen is off *) REPEAT WRITE(OUTPUT,THEBELL,CHR(150)); I := 1 - I; FOR DELAY := 1 TO WAITTIME DO; UNITSTATUS( 2,STATUS_REC,1 ) UNTIL STATUS_REC[0] > 0; UNITREAD( 2, LINE, STATUS_REC[0], , 1 ); IF I = 0 THEN WRITE(OUTPUT,CHR(150)); } EXIT( PROGRAM ) END; (* of alarm *) BEGIN (* INITIALIZE *) {WITH SYSCOM^ DO BEGIN WITH EXPANINFO DO (* Addition SDA 9/22/81 *) BEGIN INSKEY := INSCHAR; DELKEY := DELCHAR; END; WITH CRTINFO DO BEGIN CURSOR_UP := UP; CURSOR_DOWN := DOWN; CURSOR_LEFT := LEFT; CURSOR_RIGHT := RIGHT; ABACKSPACE := BACKSPACE; ESCAPE := ALTMODE; ENTER := ETX; ERASEINPUT := LINEDEL; S_HEIGHT := HEIGHT; S_WIDTH := WIDTH END; WITH CRTCTRL DO BEGIN CRT_CURSOR_LEFT := BACKSPACE; CLEAR := CLEARSCREEN; ERASELINE := ERASEEOL END END; HOME := CHR(130); SPACE := CHR(32); TAB := CHR(9); THEBELL := CHR(7); ERASEFIELD := CHR(128); } backspace := chr ( 8 ); space := chr ( 32 ); tab := chr ( 9 ); thebell := chr ( 7 ); crt_cursor_left := backspace; abackspace := backspace; sc_use_info ( sc_get, t_info ); s_height := t_info.misc_info.height; s_width := t_info.misc_info.width; (*$R- *) DASHES[0] := CHR(60); FILLCHAR(DASHES[1],60,CHR(95{+128})); (* a low intensity underline *) (** not on my terminal!!! gws *) (*$R^ *) MSG_LINE := S_HEIGHT - 3; DISKDRIVE := ''; (* use prefixed drive until told otherwise *) TEMP_FILE_NAME := 'FFTEMP'; (* Set the temp file name to FFTEMP then *) FOR I := 1 TO 6 DO (* turn it into low intensity so there's no *) BEGIN (* chance of writing over an existing file *) TRIX.A := TEMP_FILE_NAME[I]; TRIX.B := TRIX.B + 128; {this puts the temp file in the directory with the high order bit set. If you bomb the program with this file created, you will have to use the Filer wildcard options to delete it. - gws } TEMP_FILE_NAME[I] := TRIX.A END; REQUESTED_FORM := ''; RECNUMBER := 0; DIGITS := ['0'..'9']; FILEOPEN := FALSE; (* Directory file status flag *) CTL_OPEN := FALSE; (* Control file status flag *) DAT_OPEN := FALSE; (* Data file status flag *) TIT_OPEN := FALSE; (* Title file status flag *) PRINTER_ON := FALSE; (* Printer status flag *) ZERO := 0.0; MAX := PWROFTEN( MAXWHOLE ); OVERFLOW := MAX + 1; (* Special code to represent an overflow *) EMPTY := MAX + 2; (* Special code to represent an empty number *) CHARS_PER_LINE := 132; PAPER_LENGTH := 66; FIRSTTIMESEEN := TRUE; (* If FIRSTTIMESEEN is true show copyright *) DEBUGMODE := FALSE; END; (* of initialize *) SEGMENT PROCEDURE HELP; PROCEDURE OUT(MSG, WHERE: STRING); BEGIN WRITELN(OUTPUT,' ',MSG,' - Sec. ',WHERE); END; BEGIN {WRITELN(OUTPUT,CLEAR);} sc_clr_screen; WRITELN(OUTPUT,'F R E E F O R M H E L P'); WRITELN(OUTPUT); WRITELN(OUTPUT); WRITELN(OUTPUT,'For Help with:'); WRITELN(OUTPUT); (*$B 40COL- *) OUT('What Freeform is and what it can do','8.1'); OUT('Defining a Form','8.2'); OUT('Using a Form - Data entry procedures','8.3'); OUT('Listing Form controls and the Freeform Directory','8.4'); OUT('Modifying Forms','8.5'); OUT('Delete, Roll and Copy Utilities','8.6'); OUT('Consolidation Utility','8.7'); (*$E 40COL *) (*$B 40COL+ *) OUT('What Freeform is','8.1'); OUT('Defining a Form','8.2'); OUT('Using a Form - Data entry','8.3'); OUT('Listing Form controls','8.4'); OUT('Listing Freeform Directory','8.4'); OUT('Modifying Forms','8.5'); OUT('Delete Utility','8.6'); OUT('Roll Utility','8.6'); OUT('Copy Utility','8.6'); OUT('Consolidation Utility','8.7'); (*$E 40COL *) WRITELN(OUTPUT); (*$B 40COL- *) WRITELN(OUTPUT,'Note: Above references are to the PCIF Users Manual'); (*$E 40COL *) (*$B 40COL+ *) WRITELN(OUTPUT,'Note: Above refs. are to the PCIF Manual'); (*$E 40COL *) MEMORY; PRESSRETURN('To continue,',MSG_LINE); END; (* of help *) SEGMENT PROCEDURE DEL; (* Deletes the RECNUMBER entry in Freeform directory *) VAR SWAPREC: INTEGER; BEGIN {WRITELN(OUTPUT,CLEAR);} sc_clr_screen; WRITELN(OUTPUT,'F R E E F O R M D E L E T E'); WRITELN(OUTPUT,'Delete an existing Form'); MEMORY; IF NOT DISKDIR THEN EXIT(DEL); IF NOT NAME_FORM(REQUESTED_FORM,RECNUMBER) THEN EXIT(DEL); (*$B 40COL- *) IF YESNO(CONCAT('Are you sure you want to Delete ',REQUESTED_FORM),'N') THEN (*$E 40COL *) (*$B 40COL+ *) IF YESNO(CONCAT('Delete ',REQUESTED_FORM),'N') THEN (*$E 40COL *) BEGIN (* delete the title, dat and ctl files *) ONEMOMENT('Removing Control, Title and Data files'); RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT')); CLOSE(FORM_DAT_FILE,PURGE); DAT_OPEN := FALSE; IF OPEN_CON(REQUESTED_FORM) THEN; CLOSE(FORM_CON_FILE,PURGE); CON_OPEN := FALSE; IF OPEN_CTL(REQUESTED_FORM) THEN; CLOSE(FORM_CTL_FILE,PURGE); CTL_OPEN := FALSE; IF OPEN_TIT(REQUESTED_FORM) THEN; CLOSE(FORM_TIT_FILE,PURGE); TIT_OPEN := FALSE; (* zap directory entry and shift the rest of the entries *) IF SEARCH(SWAPREC,'') THEN; (* Set swaprec one past last entry *) SWAPREC := SWAPREC - 1; (* now it points at the last entry *) (* take the last entry *) SEEKDIR(SWAPREC,ANDGET); (* and put it in the spot that contains the entry to delete *) SEEKDIR(RECNUMBER,ANDPUT); (* blank out the spot that the moved entry was in *) FILLCHAR(DIRECTORY^,SIZEOF(DIRRECORD),0); (* Use Fillchar now SDA 3/19 *) SEEKDIR(SWAPREC,ANDPUT); REQUESTED_FORM := '' (* Addition SDA 5/19/81 *) END; FINISHUP END; (* of del *) SEGMENT PROCEDURE MISC; VAR TEMP_DAT_FILE: AFILE; TEMP_DAT_DESC: FILEDESC; SEGMENT FUNCTION OPEN_DAT_TEMP( VAR NAME: STRING ): BOOLEAN; FORWARD; SEGMENT PROCEDURE ROLL; FORWARD; SEGMENT PROCEDURE CONSOLIDATE; FORWARD; SEGMENT FUNCTION OPEN_DAT_TEMP{( VAR NAME: STRING ): BOOLEAN }; VAR AWINDOW: WINDOWTYPE; I: INTEGER; BEGIN OPEN_DAT_TEMP := FALSE; NAME := CONCAT(DISKDRIVE,':',TEMP_FILE_NAME,'.DAT'); REWRITE(TEMP_DAT_FILE,NAME); IF IORESULT <> 0 THEN ERROR(11) ELSE BEGIN FOR I := 0 TO WINDOWSIZE DO AWINDOW[I] := EMPTY; WITH DIRECTORY^, TEMP_DAT_DESC DO BEGIN BLKSPERPAGE := ( (THEMAXROW*THEMAXCOL) + WINDOWSIZE ) DIV ( WINDOWSIZE + 1 ); USEDHEAP := FALSE; FOR I := 1 TO BLKSPERPAGE DO IF BLOCKWRITE(TEMP_DAT_FILE,AWINDOW,1) <> 1 THEN BEGIN CLOSE(TEMP_DAT_FILE,PURGE); ERROR(11); EXIT(OPEN_DAT_TEMP) END END; OPEN_DAT_TEMP := TRUE; (* file created successfully *) CLOSE(TEMP_DAT_FILE,LOCK) END END; (* of open_temp_file *) SEGMENT PROCEDURE ROLL; VAR WHAT: STRING[6]; DIR: STRING[5]; CNT, MAX: INTEGER; LEFT, DOROWS: BOOLEAN; TEMP_CTL_FILE: CFILE; DAT_TEMP, CTL_TEMP: STRING[17]; SEGMENT FUNCTION OPEN_CTL_TEMP( VAR NAME: STRING ): BOOLEAN; (* This Function returns true if it was able to open a temporary Control file and initialize it with the contents of FORM_CTL_FILE *) VAR I: INTEGER; BEGIN OPEN_CTL_TEMP := FALSE; NAME := CONCAT(DISKDRIVE,':',TEMP_FILE_NAME,'.CTL'); REWRITE(TEMP_CTL_FILE,NAME); IF IORESULT <> 0 THEN ERROR(11) ELSE BEGIN WITH DIRECTORY^ DO BEGIN FOR I := 0 TO THEMAXROW+THEMAXCOL DO BEGIN PUT(TEMP_CTL_FILE); IF IORESULT <> 0 THEN BEGIN CLOSE(TEMP_CTL_FILE,PURGE); ERROR(11); EXIT(OPEN_CTL_TEMP) END; GET(FORM_CTL_FILE); TEMP_CTL_FILE^ := FORM_CTL_FILE^ END END; OPEN_CTL_TEMP := TRUE; (* file created successfully *) CLOSE(TEMP_CTL_FILE,LOCK) END END; PROCEDURE GATHERCONTROLS; PROCEDURE LEAVE; (* Added SDA 6/26/81 *) BEGIN CNT := 0; EXIT(GATHERCONTROLS) END; BEGIN REPEAT GETRESPONSE(TRUE,'Roll Row or Columns ? (R/C) ','C','',1,IS); LCTOUC(IS); UNTIL (IS = 'R') OR (IS = 'C') OR (IS = 'ESCAPE'); IF IS = 'ESCAPE' THEN LEAVE; (* Change SDA 6/26/81 *) DOROWS := IS = 'R'; IF DOROWS THEN BEGIN MAX := DIRECTORY^.NO_ROWS-1; WHAT := 'Row' END ELSE BEGIN MAX := DIRECTORY^.NO_COLS-1; WHAT := 'Column' END; IF MAX = 0 THEN (* Change SDA 6/26/81 *) BEGIN PRESSRETURN(CONCAT('Only one ',WHAT,' to Roll'),MSG_LINE); LEAVE END; IF DOROWS THEN REPEAT GETRESPONSE(TRUE,'Roll Rows Down or Up ? (D/U) ','D','',1,IS); LCTOUC(IS); UNTIL (IS = 'D') OR (IS = 'ESCAPE') OR (IS = 'U') ELSE REPEAT GETRESPONSE(TRUE,'Roll Columns Left or Right ? (L/R) ','L','',1,IS); LCTOUC(IS); UNTIL (IS = 'L') OR (IS = 'ESCAPE') OR (IS = 'R'); IF IS = 'ESCAPE' THEN LEAVE; (* Change SDA 6/26/81 *) LEFT := (IS = 'L') OR (IS = 'U'); IF LEFT THEN IF DOROWS THEN DIR := 'Up' ELSE DIR := 'Left' ELSE IF DOROWS THEN DIR := 'Down' ELSE DIR := 'Right'; REPEAT (*$B 40COL- *) GETNUM(0,MAX,-1,CONCAT('Enter # of ',WHAT,'s to roll ',DIR),CNT); (*$E 40COL *) (*$B 40COL+ *) GETNUM(0,MAX,-1,CONCAT('# ',WHAT,'s to roll ',DIR),CNT); (*$E 40COL *) UNTIL YESNO(CONCAT('Is ',IS,' correct'),'Y'); END; (* of gathercontrols *) PROCEDURE ROLLIT; VAR I, J, PTR, PAGES: INTEGER; ERR, NOCALCS: BOOLEAN; NUM: NUMBERTYPE; PROCEDURE ADJUST(VAR C_STRING: STRING; MODNUM: INTEGER); VAR I, ANS: INTEGER; TEMP: STRING[L_CALC]; FUNCTION ENDOFNUM(START: INTEGER): INTEGER; BEGIN WHILE (START < LENGTH(TEMP)) AND (TEMP[START] IN DIGITS) DO START := START + 1; ENDOFNUM := START - 1; END; BEGIN LCTOUC(C_STRING); (* Convert C_STRING to caps *) TEMP := CONCAT(C_STRING,'#'); C_STRING := ''; REPEAT IF TEMP[1] = 'C' THEN I := ENDOFNUM(2) ELSE IF TEMP[1] IN DIGITS THEN BEGIN I := ENDOFNUM(1); VALUE(TRUE,COPY(TEMP,1,I),FAKE,ANS); ANS := ( ( ANS + MODNUM - CNT - 1 ) MOD MODNUM ) + 1; END ELSE BEGIN I := 1; WHILE (I < LENGTH(TEMP)) AND NOT (TEMP[I] IN DIGITS) AND (TEMP[I] <> 'C') DO I := I + 1; I := I - 1 END; IF TEMP[1] IN DIGITS THEN ENCODE(ANS,IS) ELSE IS := COPY(TEMP,1,I); C_STRING := CONCAT(C_STRING,IS); DELETE(TEMP,1,I) UNTIL LENGTH(TEMP) = 1; END; (* of adjust *) PROCEDURE MOVEROWNUMS; BEGIN WITH DIRECTORY^ DO FOR I := 1 TO NO_ROWS DO (* move rows *) BEGIN PTR := ( (I + CNT - 1) MOD NO_ROWS ) + 1; FOR J := 1 TO NO_COLS DO BEGIN NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1, PTR,J,NUM,ANDGET,ERR); NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGES,I, J,NUM,ANDPUT,ERR) END END END; (* of moverownums *) PROCEDURE MOVECOLNUMS; BEGIN WITH DIRECTORY^ DO FOR I := 1 TO NO_COLS DO (* move columns *) BEGIN PTR := ( (I + CNT - 1) MOD NO_COLS ) + 1; FOR J := 1 TO NO_ROWS DO BEGIN NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1, J,PTR,NUM,ANDGET,ERR); NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGES,J,I, NUM,ANDPUT,ERR) END END END; (* of movecolnums *) PROCEDURE MOVEROWCTLS; BEGIN WITH FORM_CTL_FILE^, DIRECTORY^ DO FOR I := 1 TO NO_ROWS DO BEGIN SEEKCTL(TEMP_CTL_FILE,FALSE,( ( I+CNT-1 ) MOD NO_ROWS ) + 1,ANDGET); FORM_CTL_FILE^ := TEMP_CTL_FILE^; IF LENGTH(CTL_CALC) > 0 THEN ADJUST(CTL_CALC,NO_ROWS); SEEKCTL(FORM_CTL_FILE,FALSE,I,ANDPUT) END END; (* of moverowctls *) PROCEDURE MOVECOLCTLS; BEGIN WITH FORM_CTL_FILE^, DIRECTORY^ DO FOR I := 1 TO NO_COLS DO BEGIN SEEKCTL(TEMP_CTL_FILE,TRUE,( ( I+CNT-1 ) MOD NO_COLS ) + 1,ANDGET); FORM_CTL_FILE^ := TEMP_CTL_FILE^; IF LENGTH(CTL_CALC) > 0 THEN ADJUST(CTL_CALC,NO_COLS); SEEKCTL(FORM_CTL_FILE,TRUE,I,ANDPUT) END END; (* of movecolctls *) BEGIN (* ROLLIT *) MEMORY; WITH DIRECTORY^ DO BEGIN IF NOT LEFT THEN (* moving right, change CNT *) IF DOROWS THEN CNT := NO_ROWS - CNT ELSE CNT := NO_COLS - CNT; (* Move Data now *) IF OPEN_DAT(REQUESTED_FORM,FORM_DAT_FILE,FORM_DAT_DESC,'ROLL',FALSE) THEN; IF OPEN_DAT(TEMP_FILE_NAME,TEMP_DAT_FILE,TEMP_DAT_DESC,'ROLL',TRUE) THEN; FOR PAGES := 1 TO NO_PAGES DO BEGIN ENCODE(PAGES,IS); (* Change Pages into a string *) ONEMOMENT(CONCAT('Rolling Page # ',IS,' now')); (* Set Temp file equal to file to be rolled *) FOR I := 1 TO NO_ROWS DO FOR J := 1 TO NO_COLS DO BEGIN NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,PAGES,I,J,NUM,ANDGET,ERR); NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1, I,J,NUM,ANDPUT,ERR) END; IF DOROWS THEN MOVEROWNUMS ELSE MOVECOLNUMS END; ONEMOMENT('Closing Data File'); FREEMEM(TEMP_DAT_DESC); CLOSE(TEMP_DAT_FILE); CLOSE_DAT(FORM_DAT_FILE,FORM_DAT_DESC,ERR); (* Move Controls now *) ONEMOMENT(CONCAT('Rolling ',WHAT,' descriptions now')); IF OPEN_CTL(REQUESTED_FORM) THEN; (* re-open CTL files *) RESET(TEMP_CTL_FILE,CTL_TEMP); MEMORY; IF DOROWS THEN MOVEROWCTLS ELSE MOVECOLCTLS; CLOSE(TEMP_CTL_FILE) END END; (* of rollit *) BEGIN (* ROLL *) {WRITELN(OUTPUT,CLEAR);} sc_clr_screen; WRITELN(OUTPUT,'F R E E F O R M R O L L'); WRITELN(OUTPUT,'Roll an existing Form'); MEMORY; IF DISKDIR THEN IF NAME_FORM(REQUESTED_FORM,RECNUMBER) THEN BEGIN ONEMOMENT('Searching for Control and Data files'); IF NOT OPEN_CTL(REQUESTED_FORM) THEN ERROR(4) ELSE BEGIN RESET(FORM_DAT_FILE,CONCAT(DISKDRIVE,':',REQUESTED_FORM,'.DAT')); IF IORESULT <> 0 THEN ERROR(5) ELSE BEGIN CLOSE(FORM_DAT_FILE); (* Leave CTL file open though *) ONEMOMENT('Opening Temp Files'); IF OPEN_DAT_TEMP( DAT_TEMP ) THEN BEGIN IF OPEN_CTL_TEMP( CTL_TEMP ) THEN BEGIN CLOSE(FORM_CTL_FILE); CTL_OPEN := FALSE; GATHERCONTROLS; IF CNT > 0 THEN ROLLIT; RESET(TEMP_CTL_FILE, CTL_TEMP); CLOSE(TEMP_CTL_FILE, PURGE); END; RESET(TEMP_DAT_FILE, DAT_TEMP); CLOSE(TEMP_DAT_FILE, PURGE) END END END END; FINISHUP END; (* of roll *) ======================================================================================== DOCUMENT :usus Folder:VOL27:ff.misc2.text ======================================================================================== SEGMENT PROCEDURE CONSOLIDATE; VAR CALC: STRING[L_CALC]; CONSPAGE: INTEGER; OPERATORS: SET OF CHAR; DAT_TEMP: STRING[17]; VOL: STRING[7]; FNAME: STRING[10]; PROCEDURE EVALUATE; VAR CH: CHAR; PT: INTEGER; FUNCTION VALID_CALC: BOOLEAN; PROCEDURE ERR(WHAT: INTEGER); VAR MSG: STRING[17]; I: INTEGER; BEGIN CASE WHAT OF 1: MSG := 'Invalid Page'; 2: MSG := 'Bad character'; 3: MSG := 'Unexpected end'; 4: MSG := 'Invalid Constant' END; GOTOXY(1,MSG_LINE); FOR I := 1 TO PT-1 DO WRITE(OUTPUT,CALC[I]); WRITE(OUTPUT,' <-> '); DELETE(CALC,LENGTH(CALC),1); (* remove EOF character *) FOR I := PT TO LENGTH(CALC) DO WRITE(OUTPUT,CALC[I]); PRESSRETURN(MSG,MSG_LINE+1); ERASE(MSG_LINE+1); EXIT(VALID_CALC) END; PROCEDURE SCANNER; (* This procedure sets the variable PT that is the index into CALC, sets CH to the character just scanned, and calls ERR if something is wrong. *) VAR NUM, ENDOFNUM: INTEGER; FUNCTION SETNUM: BOOLEAN; BEGIN IF CH IN DIGITS THEN (* set NUM *) BEGIN ENDOFNUM := PT + 1; WHILE CALC[ ENDOFNUM ] IN DIGITS DO ENDOFNUM := ENDOFNUM + 1; VALUE(TRUE, COPY(CALC,PT,ENDOFNUM-PT), FAKE, NUM); PT := ENDOFNUM; SETNUM := TRUE END ELSE SETNUM := FALSE END; BEGIN (* SCANNER *) IF CALC[PT] = SPACE THEN REPEAT PT := PT + 1 UNTIL CALC[ PT ] <> SPACE; (* get non-blank *) CH := CALC[ PT ]; IF SETNUM THEN IF (NUM < 1) OR (NUM > DIRECTORY^.NO_PAGES) THEN ERR(1) ELSE (* Have a valid Page reference *) ELSE IF CH IN OPERATORS THEN PT := PT + 1 ELSE IF CH = 'C' THEN (* at a possible constant *) BEGIN PT := PT + 1; CH := CALC[ PT ]; IF SETNUM THEN IF (NUM < 1) OR (NUM > DIRECTORY^.NO_CONSTS) THEN ERR(4) ELSE (* have a valid Constant reference *) ELSE ERR(2) END ELSE ERR(2); IF CH = '#' THEN PT := PT - 1 END; (* of scanner *) BEGIN (* VALID_CALC *) VALID_CALC := FALSE; SCANNER; (* get first thing to consolidate *) IF CH = '#' THEN ERR(3); (* if nothing there then error *) IF NOT (CH IN DIGITS) THEN ERR(2); SCANNER; (* get first operator *) WHILE (CH IN OPERATORS) AND (CH <> '#') DO BEGIN SCANNER; (* skip operator *) IF NOT (CH IN DIGITS) THEN (* have a number ? *) IF CH = '#' THEN ERR(3) ELSE ERR(2); (* No ! *) SCANNER; (* skip number *) END; IF CH <> '#' THEN ERR(3); (* make sure no more string is left *) VALID_CALC := TRUE END; (* of valid_calc *) BEGIN (* EVALUATE *) REPEAT PROMPT('Enter Consolidation Control',MSG_LINE-1); PROMPT('=',MSG_LINE); ACCEPTSTR(TRUE,L_CALC-1,1,MSG_LINE,CALC,CALC); IF CALC = 'ESCAPE' THEN BEGIN FREEMEM(TEMP_DAT_DESC); CLOSE(TEMP_DAT_FILE,PURGE); FINISHUP; EXIT(CONSOLIDATE) END; LCTOUC(CALC); PT := 1; CALC := CONCAT(CALC,'#'); UNTIL VALID_CALC; PROMPT('Consolidation -> ',MSG_LINE-1); DELETE(CALC,LENGTH(CALC),1); WRITE(OUTPUT,CONSPAGE,'=',CALC); END; PROCEDURE MATH; VAR NUM, PT, ROW, COL, I, J: INTEGER; NUMBER1, NUMBER2: NUMBERTYPE; ERR, ACONST: BOOLEAN; CH, OP: CHAR; PROCEDURE SCANNER( VAR ACONST: BOOLEAN ); (* This procedure sets the variable PT that is the index into CALC, sets CH to the character just scanned, sets PAGE to a page number if it was legal. *) VAR ENDOFNUM: INTEGER; PROCEDURE SETNUM; BEGIN ENDOFNUM := PT + 1; WHILE CALC[ ENDOFNUM ] IN DIGITS DO ENDOFNUM := ENDOFNUM + 1; VALUE(TRUE, COPY(CALC,PT,ENDOFNUM-PT), FAKE, NUM); PT := ENDOFNUM END; BEGIN (* SCANNER *) ACONST := FALSE; IF CALC[PT] = SPACE THEN REPEAT PT := PT + 1 UNTIL CALC[ PT ] <> SPACE; (* get non-blank *) CH := CALC[ PT ]; IF CH IN DIGITS THEN SETNUM (* set Page number *) ELSE IF CH = 'C' THEN BEGIN ACONST := TRUE; PT := PT + 1; SETNUM END (* set Const number *) ELSE IF CH IN OPERATORS THEN PT := PT + 1; IF CH = '#' THEN PT := PT - 1 END; (* of scanner *) PROCEDURE GETVALUE( VAR ACONST: BOOLEAN ); BEGIN SCANNER( ACONST ); IF ACONST THEN (* Thing was a constant, init NUMBER1 to it *) BEGIN SEEKCON(NUM,ANDGET); NUMBER1 := FORM_CON_FILE^ END; END; BEGIN (* MATH *) ONEMOMENT('Consolidation in Progress'); MEMORY; PT := 1; CALC := CONCAT(CALC,'#'); GETVALUE( ACONST ); WITH DIRECTORY^ DO BEGIN FOR I := 1 TO NO_ROWS DO (* initialize temp page *) FOR J := 1 TO NO_COLS DO BEGIN IF NOT ACONST THEN (* set THENUMBER *) NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,NUM,I,J,NUMBER1,ANDGET,ERR); NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,I,J,NUMBER1,ANDPUT,ERR) END; SCANNER( ACONST ); (* get operator *) WHILE (CH IN OPERATORS) AND (CH <> '#') DO BEGIN OP := CH; (* Save operator *) GETVALUE( ACONST ); FOR I := 1 TO NO_ROWS DO (* do math *) FOR J := 1 TO NO_COLS DO BEGIN IF NOT ACONST THEN (* set NUMBER1 *) NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,NUM,I,J,NUMBER1,ANDGET,ERR); NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,I,J,NUMBER2,ANDGET,ERR); IF FIGURE(NUMBER2,NUMBER2,NUMBER1,OP) THEN; NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,I,J,NUMBER2,ANDPUT,ERR); END; SCANNER( ACONST ) END; ONEMOMENT('Saving Consolidated Page'); FOR I := 1 TO NO_ROWS DO FOR J := 1 TO NO_COLS DO BEGIN NUMBER(TEMP_DAT_FILE,TEMP_DAT_DESC,1,I,J,NUMBER1,ANDGET,ERR); NUMBER(FORM_DAT_FILE,FORM_DAT_DESC,CONSPAGE,I,J,NUMBER1,ANDPUT,ERR) END END; DELETE(CALC,LENGTH(CALC),1) (* Delete the EOF character *) END; (* of math *) PROCEDURE DOCONSOL; PROCEDURE OPENOUTPUTFILE( OLD: BOOLEAN ); BEGIN REPEAT GETRESPONSE(TRUE, 'Volume Name: ',VOL, ':', 7, VOL); IF VOL = 'ESCAPE' THEN EXIT(DOCONSOL); GETRESPONSE(TRUE, 'File Name: ', FNAME, '.TEXT', 10, FNAME); IF FNAME = 'ESCAPE' THEN EXIT(DOCONSOL); IF OLD THEN RESET(PRINTER, CONCAT(VOL,':',FNAME,'.TEXT')) ELSE REWRITE(PRINTER, CONCAT(VOL,':',FNAME,'.TEXT')); PRINTER_ON := IORESULT = 0; IF NOT PRINTER_ON THEN PRESSRETURN(CONCAT('Unable to open ',VOL,':',FNAME,'.TEXT'),MSG_LINE) UNTIL PRINTER_ON END; (* of open output file *) PROCEDURE CLOSEFILE; BEGIN CLOSE(PRINTER, LOCK); PRINTER_ON := FALSE END; (* of close file *) BEGIN (* DOCONSOL *) IF YESNO('Is there a Control file to use','N') THEN BEGIN OPENOUTPUTFILE(TRUE); READLN(PRINTER,CONSPAGE); READLN(PRINTER,CALC); CLOSEFILE END; (*$B 40COL- *) GETNUM(1,DIRECTORY^.NO_PAGES,CONSPAGE,'Enter Consolidation Page #',CONSPAGE); (*$E 40COL *) (*$B 40COL+ *) GETNUM(1,DIRECTORY^.NO_PAGES,CONSPAGE,'Consol Page #',CONSPAGE); (*$E 40COL *) EVALUATE; IF YESNO('Perform Consolidation','Y') THEN MATH; ERASE(MSG_LINE-1); (*$B 40COL- *) IF YESNO('Save this information in a Control file','N') THEN (*$E 40COL *) (*$B 40COL+ *) IF YESNO('Save info in Control file','N') THEN (*$E 40COL *) BEGIN OPENOUTPUTFILE(FALSE); WRITELN(PRINTER,CONSPAGE); WRITELN(PRINTER,CALC); CLOSEFILE END END; (* of do consols *) BEGIN (* CONSOLIDATE *) OPERATORS := ['+','-','*','/','^','#']; {WRITELN(OUTPUT,CLEAR);} sc_clr_screen; (*$B 40COL- *) WRITELN(OUTPUT,'F R E E F O R M C O N S O L I D A T I O N'); (*$E 40COL *) (*$B 40COL+ *) WRITELN(OUTPUT,'F R E E F O R M CONSOLIDATION'); (*$E 40COL *) MEMORY; IF DISK_DIR THEN IF NAME_FORM(REQUESTED_FORM, RECNUMBER) THEN BEGIN ONEMOMENT('Opening Constant, Data and Temp files'); IF NOT OPEN_CON(REQUESTED_FORM) THEN ERROR(12) ELSE IF NOT OPEN_DAT(REQUESTED_FORM,FORM_DAT_FILE,FORM_DAT_DESC, 'CONSOLIDATE,FIGURE',FALSE) THEN ERROR(5) ELSE IF OPEN_DAT_TEMP( DAT_TEMP ) THEN BEGIN IF OPEN_DAT(TEMP_FILE_NAME,TEMP_DAT_FILE,TEMP_DAT_DESC, 'CONSOLIDATE,FIGURE',TRUE) THEN; MEMORY; VOL := DISKDRIVE; FNAME := ''; CALC := ''; CONSPAGE := -1; REPEAT DOCONSOL UNTIL NOT YESNO(CONCAT('More to Consolidate in ', REQUESTED_FORM),'N'); FREEMEM(TEMP_DAT_DESC); CLOSE(TEMP_DAT_FILE,PURGE) END END; FINISHUP END; (* of consolidate *) BEGIN (* MISC *) CASE OPTION OF 5: CONSOLIDATE; 6: ROLL END END; (* of misc *) ======================================================================================== DOCUMENT :usus Folder:VOL27:readme.1st.text ======================================================================================== FreeForm is a 3-D spreadsheet. It is very useful in certain types of problems and useless in others. FreeForm assumes that calculations are done on entire rows or columns at a time and the results are deposited in other entire rows or columns. It therefore is well suited to ledger sheets sort of applications. The 3-D nature becomes apparent when you realize that you can set up a sheet, for example, for each month's activity of a business. Each month's sheet can be stacked behind the next month's sheet and year end consolidations can be done on all twelve sheets to end up with grand totals. Up to 100 sheets (all must be of identical format) can be stacked. FreeForm does not allow calculations of individual cells so that it is nearly useless in an application such as a tax calculator. You pays your money and takes your chances. FreeForm uses real numbers for all of it calculations so that 4 word reals are necessary to obtain any kind of precision. A 2 word real version is provided for those that don't have 4 word reals on their iron, but its use is strictly limited as dollar figures can only be represented to $9,999.99 before you start losing track of the odd cents. Also, if you build data files with two word reals, and then switch to 4 word reals, THE DATA WILL NOT BE COMPATIBLE!!! The screen control features of FreeForm have been modified extensively by the reviewer (yours truly, gws) to allow the software to be transported to different types of terminals. The author used the screen control values found in KERNEL to obtain the values of the arrow keys and such. However, he did not allow for terminals with two-character sequences (such as an H-19). The use of KERNEL also made the program un-compilable on most hardware without extended memory as the compilation of KERNEL uses up most of memory for mere mortal iron. The program has been modified to eliminate the dependance on KERNEL. It now uses SCREENOPS instead. In this way it becomes terminal independant. However, since SCREENOPS does not support HOME, KEY_TO_INSERT_CHARACTER, or KEY_TO_DELETE_CHARACTER, these features are no longer available. The modifications have been done in a haphazard style (typical of this particular reviewer) so that some of the old code has been commented out and some of it has been entirely removed. It will now compile on most IV.x p-systems. If you are using a p-system older than IV.1 then you must comment out the selective uses list for SCREENOPS (found in FF.FREEFRM). regards - gws ======================================================================================== DOCUMENT :usus Folder:VOL27:vol27.doc.text ======================================================================================== USUS Library Volume 27 FreeForm (a 3-D spreadsheet) Sources Documentation and code files on Volume 28 --> IV.x ONLY <-- 4 word reals recommended FF.FREEFRM.TEXT 22 The main program of FreeForm FF.COPY2.TEXT 18 an include file FF.DATA1.TEXT 20 an include file FF.FORMS3.TEXT 22 an include file FF.DATA3.TEXT 20 an include file FF.DATA2.TEXT 20 an include file FF.DATA5.TEXT 22 an include file FF.FORMS5.TEXT 26 an include file FF.FORMS1.TEXT 24 an include file FF.FORMS2.TEXT 14 an include file FF.FORMS4.TEXT 16 an include file FF.MISC2.TEXT 20 an include file FF.BASICS1.TEXT 30 an include file FF.COPY1.TEXT 26 an include file FF.BASICS3.TEXT 24 an include file FF.BASICS2.TEXT 24 an include file FF.MISC1.TEXT 32 an include file FF.DATA4.TEXT 32 an include file README.1ST.TEXT 8 Read this FIRST! VOL27.DOC.TEXT 6 You're reading it ----------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 27 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.2word.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.4word.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.a.text ======================================================================================== Freeform [F.4] Introduction and Overview 8/82 1. FREEFORM 1.1 FREEFORM INTRODUCTION AND OVERVIEW Freeform is a math package which allows a user to define a form under UCSD p-SYSTEMTM. The form consists of pages of rows and columns of numbers. Algebra ic calculations, specified by the user, can then be performs on the data. Operation Upon initiating the Freeform program, the user will be prompted with a main menu describing Freeform's options and capabilities. Typically, a user would begin by selecting the form definition option which prompts the user for the dimensions of the form, the headings for the rows, columns, and pages and the calculations to be performed. Once the form is defined, the user may proceed to the data entry mode and enter data, have the math performed, alter data, or list desired data to a printer. Other options in the main menu prompt the user through the other features decribed in this document. The following is an example of a simple table (Form) representing the distribution of inventory for three part types in five locations. A total of each part type at each location is also computed. Form Example - Distribution of Inventory by Location loc 1 loc 2 loc 3 loc 4 loc 5 Total part 1 100 200 300 - 50 650 part 2 10 50 80 30 - 170 part 3 200 - - 120 90 410 Total 310 250 380 150 140 1230 1.1.1 The Freeform Form Many numerical problems, particularly those in business applications, can be represented as tables or matrices. In general terms, a matrix is a set of related data in which each element of the set is ordered by qualifiers called coordinates, the bounds of which form the dimensions of the matrix. Any element in the set may be referenced by specifying the values of each coordinate. A FREEFORM matrix has three dimensions and is referred to throughout this documentation as a Form. Each Form will be assigned a unique name by the user in addition to the specification of the three dimensions of the Page, Row, and Column. A Form is defined by its dimensions and 'attributes ' which describe the row and column names, types, calculations, and editing formats. A visual model of how the inventory example on the previous page would be represented by a FREEFORM matrix or Form is shown on the next page. Note, an additional page has been provided for a second month's data. .___.___.___.___.___.___.___.___.___.___.___.___. / / / / / / / month 2 / / / / / / / Pages .___.___.___.___.___.___.___.___.___.___.___.___. . _. month 1 / / / / / / / / / loc 1 / loc 2 / loc 3 / loc 4 / loc 5 / Total / / .___.___.___.___.___.___.___.___.___.___.___.___. . +-> Columns ./ 100 200 300 - 50 650 / . . v part 1 __________________________________________ Rows ./ . 10 50 80 30 - 170 / . part 2 __________________________________________ ./ 200 - - 120 90 410 / . part 3 __________________________________________ ./ 310 250 380 150 140 1230 / Total __________________________________________ Version F.4 of FREEFORM is limited to a maximum Form size of 100 pages. Each page has the same number of rows and columns with the constraints of having no more than 32,704 numbers in a page with no more than 101 columns. up to 18 forms may be stored on one disk. Details of this process and further definition of terms are found in section 1.2. At this point, a brief word about disk files and the structure of FREEFORM is appropriate. 1.1.2 System Environment The FREEFORM program is named FF/VER4.CODE. FREEFORM uses one file to keep reference information about Forms which are stored on the disk. This 'directory' file is not to be confused with the disk directory. It is just another file on the disk and is named FREEFORM.DIR. For each Form defined, FREEFORM creates a Control, Constants, Titles, and Data file. The Control, Constants, Titles, and Data files' file names are made up of the Form name concatenated with the suffix '.CTL', '.CON', '.TIT', and '.DAT' respectively. The Control file contains the information which describes the Form, and the Data file contains the values input by the user and/or which are computed by FREEFORM under the user's direction. To run FREEFORM eXecute the file FF/VER4.CODE. The FREEFORM main function menu is then displayed in the following format. ********************************************************************* F R E E F O R M The Electronic Worksheet [F.4] ========================================== June 24, 1981 0. Data Entry Procedure 1. Define new FORM controls 2. Modify FORM controls 3. Display or List directory 4. Display or List FORM controls 5. Consolidate Procedure 6. Roll a FORM 7. Copy a FORM 8. Delete a FORM 9. Help and User's Guide Enter desired option # _ Press ESC to leave ********************************************************************* The cursor will stop on the function selection prompt. Select the appropriate function by typing its respective number. Terminate FREEFORM by pressing the key. If a FREEFORM function is selected, there will be a pause while the appropriate program is loaded and the system responds with its next prompt. Most inputs to FREEFORM prompts have been designed to be brief yet self-explanatory and allow for error corrections. 1.1.3 Standard Keyboard Procedures Each program requests input from the user via "prompts". These indicate what information is being requested. To enter a response, type as though using a standard typewriter keyboard. Each character entered will appear on the video screen. Pressing the key terminates the input and sends the response to the program. Prior to pressing , one may backspace one character at a time by pressing the or the key. A number of other keys to perform special functions when entering a string response (as opposed to a numerical response) exist. The key, for example, deletes the character at the current cursor position. The key erases all the characters from the current cursor position to the end of the field. The key redisplays the field with its original value. The key allows characters to be inserted into the middle of a response. After pressing the key, simply enter the characters to be added. To get out of the insert mode, press a different function key. These functions allow the user to correct input prior to sending it to the program. All prompts are pre-programmed to expect a certain range or type of response to which the program can properly react. If a user attempts to enter invalid data, the cursor will neither move nor print the character which is being entered. To speed the process of using FREEFORM, many prompts are preset to specific defaults which they will assume if is pressed. These are typically one-character responses to multiple choice prompts. Throughout this documentation, prompts will be highlighted by three leading asterisks (***) to prevent confusing them with the surrounding explanatory text. These leading asterisks will not appear on the video display during actual program execution. A FREEFORM prompt takes the general form *** {Prompt text}? (valid responses) default [optional comment] Example: *** Select another Form? (Y/N) Y Most FREEFORM program modules will begin with the prompt *** Form Name (8 alpha max.) __________ Press ESC to leave A valid Form name consists of 1 to 8 alphanumeric characters. The special characters " # $ % & ' ( ) * : = - { } [ ] ^ ~ + ; ` @ | _ < > , . ? / and embedded blanks are not allowed. ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.b.text ======================================================================================== Form Definition Procedures 1.2 FORM DEFINITION PROCEDURES 1.2.1 How to Define a Form Defining a Form involves specifying to FREEFORM the dimensions and the data to be represented. As pointed out in section 1.1, the dimensions of the Forms are Page, Row, and Column. FREEFORM creates a computerized representation of the sheets of paper on which numerical problems are solved. A Form definition consists of: (1) giving the Form a unique name, (2) specifying the dimensions and parameters of the Form pages, rows, and columns, and (3) describing the calculations, if any, to be performed. These steps are only necessary the first time a Form is to be used. All parameters which describe a Form and its contents are stored in disk files. The Form definition program does the following: (1) creates an entry the directory file describing the dimensions and other attributes of the Form, (2) creates and loads the control file per its specifications, detailing the row and column parameters and calculations to be performed, (3) creates and initializes a file to hold any constants that may be defined in the Form, (4) creates and initializes a file to hold all the page titles, and (5) initializes a data file of the proper size to hold the prescribed information. * To avoid confusion, review the Standard Keyboard Procedures (1.1.3). To envoke the new Form definition procedure select menu option number 1. ********************************************************************* F R E E F O R M The Electronic Worksheet [F.4] ========================================== June 24, 1981 0. 1. Define new FORM controls <===== Form definition 2. 3. 4. 5. 6. 7. 8. 9. Enter desired option # _ Press ESC to leave ********************************************************************* When the program has been loaded, the screen will clear, and a new title will be displayed. F R E E F O R M F O R M S C O N T R O L S New Forms Definition If FREEFORM does not find a 'directory' file it will display an error message stating there is no directory. If this happens, FREEFORM will ask if another disk should be looked at. If so, press otherwise type . If was pressed the program will prompt for the disk drive number to search in for a directory file. After receiving a valid disk drive number, the program will instruct the user to insert a disk into that drive and press . If no FREEFORM directory exists then one needs to be created. FREEFORM should be instructed to look on the disk that is to have a directory for a FREEFORM form. An error message should appear stating that a directory was not found and then FREEFORM will ask if another disk should be checked. One should respond by typing . FREEFORM will ask if a new directory should be created. Press or . FREEFORM will create a directory on the last disk searched which is the reason for searching for a directory on one that does not have one. FREEFORM will display: *** Creating FREEFORM directory ... one moment, please Simply wait until this message disappears (several seconds). * The term 'directory' should not be confused with the system directory. The program then checks to verify there is available space on the diskette to add a new Form. If there is not enough space, the message *** FREEFORM directory is full ... press RETURN will appear and FREEFORM automatically returns to the main menu. The options of initializing a new diskette or deleting one or more Forms from the current diskette are then available. (For instructions on deleting Forms, see 1.5 Form Controls Modification Procedures.) *** Form name (8 alpha max.)__________ Press ESC to leave * This prompt will only accept letters of the alphabet and the numbers zero through nine. Respond by typing the name to be assigned to the new Form and pressing . If alone is pressed, control returns to the main menu. If a valid Form name request is entered, the program then checks the directory to ensure against duplication of Form names. If an existing Form is found with the input name, the option to replace the existing definition and data is given. Replace the form by responding with a to the prompt *** Replace existing FORM? (Y/N) N To avoid replacing a Form, simply press . The program will then prompt for a new name. * Use with care as the replaced Form can not be recovered! The program will then ask if checkpoint prompts are desired. These prompts give the user a chance to review progress at various intervals during Form definition. Until experienced with the sequence of events and comfortable with the various prompts, users should respond to this option. * Input will be displayed on the screen for visual verification. If errors are produced during definition, they can be corrected. The Form definition program next prompts for descriptive information about the Form being defined. Optional identifiers such as user initials, descriptive comment, and definition date are provided to help the user keep track of the location of Forms. FREEFORM will function satisfactorily without this information. If space is available, the program then asks for the number of pages desired, displaying the maximum number allowed. The program will not allow the user to exceed the maximum. *** How many Pages? __ (max. available is 100) Next, the format of the Form is selected. There are two choices: Row or Column formatting. Formatting indicates whether data is homogenous by row or column and the order in which calculations are performed. Calculated rows are done before calculated columns in row-formatted forms and vice versa in column formatted forms. *** Format Rows or Columns? (R/C) R Examples: Row Formatted | Column Formatted Col 1 Col 2 Col 3 Total | Col 1 Col 2 Col 3 | Row 1 10.0 215.2 65.8 291.0 | Row 1 10.0 20 0.500 | Row 2 20 460 135 615 | Row 2 215.2 460 0.468 | Row 3 0.500 0.468 0.489 1.457 | Row 3 65.8 135 0.489 | | Total 291.0 615 1.457 ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.c.text ======================================================================================== *** Do you want automatic month descriptions? (Y/N) N allows the program to assign the standard month abbreviations either for rows or columns in the Form. If this option is selected, additional prompts will ask if the headings are for rows or for columns and for the starting month number. *** How many Calculation constants? __ (max. 200) allows the user to preset the constants which will be required in the calculations. Input the number of constants required; the program then asks for the values to be assigned. *** CHECKPOINT *** At this point, the user may elect to make corrections or change any or all of the previous control data, terminate definition of this Form, or continue. First the user is prompted *** Anything to change? (Y/N) N If the response is the program returns to the number of pages prompt. If the response is , the program continues gathering form parameters. It then asks *** How many columns might ever be in the FORM ? __ (max. 101) *** How many rows might ever be in the FORM ? __ (max. XXXX) The response to these prompts are critical to the definition of the FORM. These responses set limits to the size that the FORM will ever be able to obtain. The FORM may be altered later to contain fewer columns or rows but no more. It is suggested to select maximums that are equal to the final number desired currently plus enough for any additions to the FORM. There is one way to expand a FORM beyond these maximums and that is by using the Copy command (see 1.6.3) * A FORM may contain no more than 32,704 numbers per page, therefore the maximum number of rows allowed will be a function of the maximum number of columns. After the maximums have been set, the number of rows and columns that are actually going to be in the FORM at the present time are gathered. The maximum responses allowed here are determined by the answers just gathered. *** How many rows? __ (max. XXXX) *** How many columns? __ (max. XXX) These prompts accept only numeric values >=1 and <=max. specified. *** Are the dimensions ok as specified? (Y/N) Y If the response is N, the maximum number of rows and columns and the actual number of rows and columns prompts are repeated. The program will then update the FREEFORM directory file on the user diskette and create the necessary control files. *** Enter Title for Page (60 char. max.)_______________ Each page of the Form may have its own unique title which will be displayed when viewing and printed when listing. This title may be up to 60 characters max. and consist of most alphanumeric characters. Invalid characters will not be accepted from the keyboard. *** CHECKPOINT *** ***Is Title Correct? (Y/N) Y allows repeat of title entry until correct. 1.2.2 Row and Column Parameter Definition There are three parameters which must be defined for both rows and columns of a Form: description, type and cross calculation. The description is a user-defined label which will be displayed and printed when using FREEFORM. Type refers to one of the following valid types: D-data, I-initial calculations, F-final calculations, and H-heading. Data type indicates the values assigned to a row or column will be input by the user and are variable. Calculated types indicate the values will be computed based on instructions input by the user. The precedence of calculations will vary according to one of several cases which is determined by the mix of operations to be performed. Initial calculations will be done before Final calculations. For example, in a Form formatted by rows, calculations will proceed as follows: Initial calculated rows, Initial calculated columns, Final calculated rows, and Final calculated columns. In a Form formatted by columns calculations will be performed in the following order: Initial calculated columns, Initial calculated rows, Final calculated columns and Final calculated rows. Heading type is only a valid option for a row. A row that is of Heading type will not contain any data. The third parameter refers to whether or not a cross-calculation can be done. When defining a row, the question "O.K. to set values from Column Calculations?" will be asked. Type if none of the data items in the row being defined are allowed to be the direct result of a column calculation, otherwise press . When defining a column, the question "O.K. to set values from Row calculations?" will be asked. Type if none of the data items in the column being defined are allowed to be the direct result of a row calculation, otherwise press . A fourth parameter, Calculate string, will be prompted if the type of a row, or column, is specified as I or F. Simple arithmetic relationships may be expressed using the algebraic operators, + - / * ^ (^ is exponentiation), row or column numbers, parenthesis to force the precedence of operators and any constants if needed as explained earlier. The exponentiation operator has the highest precedence, then multiplication and division and then addition and subtraction. Sequences of operators of the same precedence are executed from left to right. Calculate examples: 1. Row 3 is to be the sum of rows 1 and 2. Row 3 is declared to be type I and the calculate string is entered as simply 1 + 2. 2. Column 1 is to be divided by column 8 and added to column 5 giving column 12. Column 12 must be declared as type I (or type F) and the calculate string is 1 / 8 + 5. Other possibilities that will give the same results are ( 1 / 8 ) + 5 and 5 + 1 / 8. 3. Row 4 is the product of row 1 and row 2 divided by 1000 and minus row 3. A constant must have been pre-defined as 1000. Assume it is the only constant for this Form, therefore it is constant (1). Row 4 is declared type I and the calculate string ((1 * 2) / C1) - 3. * If automatic month headings for either rows or columns are specified, the parameters are preset, and all prompts are skipped. * If checkpoint prompts are suppressed, the user is not given the opportunity to change any of the row or column parameters during Form definition. Upon completion of the row and column parameter definition sequences, the program will update the Form control file and create a data file initialized with no values. A fifth parameter, Editing Format, must be specified for either rows or columns in accordance with the formatting option chosen earlier in the Form definition process. One may specify the print format to be used to display or print Form data. Each numeric field will hold thirteen characters and no more than eleven may be to the right of the decimal point. Example: 1234.567 Editing Format Result ### *** #### 1235 ####.# 1234.6 ####.### 1234.567 * If a number will not fit in its specified field, asterisks will be displayed. * Rounding is done only on the display of the number and not on the number's internal representation. If formatting is specified by rows, no prompts for editing columns will appear, and the reverse is true if formatting is specified by columns. The Form is now stored and ready for use, and the user is returned to the main menu. ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.d.text ======================================================================================== Data Entry Procedures 1.3 DATA ENTRY PROCEDURES 1.3.1 How to Update Form Data FREEFORM's data entry procedure allows a user to change values stored in a Form, compute those rows or columns which have prescribed calculations, prepare printed copies of the Form for presentation, and store the results for future reference. To envoke the Form DATA ENTRY procedure, select menu option number 0. ********************************************************************* F R E E F O R M The Electronic Worksheet [F.4] ========================================== June 24, 1981 0. Data Entry Procedure <===== Form update procedure 1. 2. 3. 4. 5. 6. 7. 8. 9. Enter desired option # _ Press ESC to leave ********************************************************************* Once the program has loaded, the screen will clear and a new title will be displayed. F R E E F O R M D A T A E N T R Y * If FREEFORM does not find a 'directory' file on its first try (FREEFORM searches on the prefix disk unless another drive was previously specified), it displays an error message stating there is no directory. If this happens, FREEFORM will ask if it should try another disk. If so, press otherwise type . If was pressed, the program will prompt for the disk drive number to search in for a directory file. After receiving a valid disk drive number, the program will instruct the user to insert a disk into that drive and press . * To avoid confusion, review the Standard Keyboard Procedures (1.1.3). The program then displays the prompt *** Form Name (8 alpha max.) __________ Press ESC to leave There are three possible responses to this command. Press to return to the FREEFORM main menu, supply a Form name, or press . Each time is pressed FREEFORM looks at the Freeform directory and displays a possible Form name. If a selected Form name is not found on the user diskette, the prompt *** Form named not found... *** Try another Form name? (Y/N) Y will appear. The user may now try another Form name, by supplying the desired Form name in the manner previously described. If a user chooses not to select another Form name by typing , control will return to the FREEFORM main menu. If the Form name selected is valid, however, the program will continue its normal progress and inform the user that the Form controls are being loaded. Data in a Form may be accessed on any plane: row-column, page-column, or row-page. Data may be listed and entered on any plane. A work file may be used, and Math can be done, only when data is accessed on the row-column plane. To access data on the row-column plane press in response to the following prompt: *** Access Data by Pages ? (Y/N) N If or is pressed, FREEFORM will ask if the data is to be accessed by Columns (the row-page plane) and then by Rows (the page-column plane). If data is accessed by Pages then the program will prompt: *** Use a Work File ? (Y/N) Y If a work file is used, the program will always copy the data in the page being worked on into a separate file. This protects the original information in a page from any changes made. The contents of the work file may, or may not, be saved. If a work file is not used, the original data is used and modified when changes are made to the pages. It may be impossible to use a work file if there is not enough room on the data disk. If this is the case Freeform will display an error message. If there is more than one page (or column or row depending upon the plane of access chosen) in the selected Form, then the program will ask for the page (or column or row) to read in. For example, if access is by Pages then FREEFORM will prompt: *** Enter Page # 1 (max. XX) XX is the number of pages defined for the selected Form. If this is a "Map page" to be used with the Planline to Freeform Interface Program (PuFF) then end the page number entered with the letter M. The program will now display the selected plane of the Form on the screen. The title of the page (or column or row description depending on the access plane) will appear on the first line of the screen. The column descriptions (or page numbers if access is by Columns) will appear on the third line. The row descriptions (or page numbers if access is by Rows) will be displayed along the left-hand side of the screen and if data has never been stored in the Form, dashes (a dash means no value or null) will appear at each data element position. The position at the intersection of the left most column and uppermost row is known as the Anchor position. Finally, the command line *** Enter Command => A,U,M,Z,N,L,S, (H for Help) will appear below the form. Each of the letters and the key represent a data entry command. When one of the letters is pressed the appropriate command will be executed. A description of each of the commands follows. 1.3.2 A - Anchor As many rows and columns of data as the screen size allows will be displayed. In order to move beyond this physical screen size limit, a concept called the 'anchor' provides the bridge between the Form and the screen. By changing the value of the anchor, it is possible to access, display, and update any portion of a Form. The anchor command calls in a routine which allows the user to change the current value of the anchor. The anchor is specified by giving a page number, row number and column number. Two levels of modifying the anchor exist: one from the command line, and one as described below in the update mode. The command mode allows the changing of pages, whereas the update mode keeps the same page and only resets row and column. Upon pressing A in response to the command prompt, the current anchor coordinates will be displayed. To change a value, simply type over the current coordinates with the new values. 1.3.3 U - Update When the is typed, the cursor will immediately move to the first data element position. The user is now ready to enter data into that portion of the Form appearing on the screen. Do not enter commas, when entering numbers. When data has been entered, press , , , , , , , , or . If the Form is formatted by row, the cursor will move to the right one data element position in the same row when or are pressed. When the last data element position in a row is reached, the cursor moves to the leftmost data element position in the next data row. Similarly, if the Form is formatted by column, the cursor moves to the next element of the same data column when or are pressed. When the last data element position has been entered the cursor will again move to the very first data element position of the next data column. ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.e.text ======================================================================================== 1.3.4 The Keyboard The use of the keyboard is restricted during the update mode. There are only a few special keys, other than the numbers, that can be utilized during up date. Move directly to a data element on the screen by using one of the following combination of keys. moves the cursor left one element position. If the cursor is in the leftmost element position of a row, it will move to the rightmost element position of the next row. moves the cursor down one data element position. If the cursor is in the bottom element position of a column, it will move to the top element position of the next column. moves the cursor up one data element position. If the cursor is in the top element position of a column, it will move to the bottom element position of the next column. moves the cursor right one element position. If the cursor is in the rightmost element position of a row, it will move to the leftmost element position of the next row. exits update mode and returns to the command line. moves the cursor to the top, leftmost element position on the screen. automatically resets the anchor position to the coordinates specified by the cursor position. The screen will clear and the Form will be redisplayed at the new anchor. * The , , , , , , , , and keys terminate a numeric field for transmittal to the data entry program. * the program prevents the user from moving the cursor to an element that is in a row of type heading. * The commands U and A, described above, only affect that portion of the Form which is currently displayed on the screen. The following commands affect the currently anchored page. 1.3.5 M - Math From the command line, press and the computer performs all the prescribed calculations which have been defined for the rows and/or columns of the page. The number and complexity of stored calculations, and the number of rows and columns defined in the Form will effect the speed at which the calculations are performed. In any case, it is many times faster than manually keying the data into a calculator. 1.3.6 S - Save The Save command only works if a workfile is being used. To save the current page, type from the command line and the information in the workfile will be transferred to the Form data file. Upon completion, the command line will be redisplayed and the user may continue. 1.3.7 Z - Zero This command sets specified elements of the current plane to zero. The specific data items to set to zero are determined by first giving a sequence or sequences of rows (or pages) to zero and then a sequence or sequences of columns (or pages) to zero. If access is by Pages, or Columns, Freeform will first prompt *** Enter sequences of Rows (XX-XX,YY-YY) to Zero below (there are XX) *** ____________________________________ The number shown in 'there are XX' tells how many rows the Form contains. For example to set all of row two to zeros enter 2 and press . Next, Freeform prompts for sequences of columns, or pages to Zero. Enter 1| followed by a dash followed by the number of columns, or pages, in the Form, then press . 1.3.8 N - Nullify This command sets specified elements of the current plane to null. The specific data items to be nullified are denoted in the same manner as in the Zero command (see 1.3.7). 1.3.9 L - List The listing command allows for the printing of reports for use in presentations. The response to the L command by FREEFORM is: *** Is there a Control file to use ? (Y/N) N FREEFORM allows the listing controls (page, row and column specifications, titles, and footing gathered at List time) to be saved in a text file which is referred to as a Control file. To use a Control file, type . FREEFORM will prompt for the file name of the Control file. If is pressed the Data Entry command line is redisplayed. If the file name entered is not available, the program will prompt for the file name again. When a Control file is used FREEFORM will use the values read as default values when the listing controls are gathered. *** Enter sequences of Rows (XX-XX,YY-YY) to List below (there are XX) *** ____________________________________ For example, to list rows one through ten, row thirteen, and rows 25 through 20 enter 1-10, 13, 25-20 Next a prompt to obtain sequences of columns will appear. An error message will be displayed if an invalid page, row or column is selected, more than the maximum number of pages, rows or columns in a Form are selected to be listed, or more columns of data are selected than will fit in the specified line size. If access is by Pages, the rows and columns to list will be gathered, otherwise if access is by Columns, the rows and pages to list will be gathered, or if access is by Rows, the pages and columns to list will be gathered. The user is then prompted for three title lines and a footing. The three additional title lines are provided in addition to the stored page title and column headings. If entered, all titles will be automatically centered above the body of the Form. The page footing will be flush left at the bottom of the page. The page footing feature is optional and must be entered each time the report is to be printed. FREEFORM then prompts *** Save this information in a Control file (Y/N) N To save the listing controls specified, type , otherwise press . The following prompt then appears *** List to the printer ? (Y/N) Y If is pressed then the user is asked how many characters will fit on one line and how many lines will fit per page and is then advised to set the printer alignment and press . After printing, the page will eject and control will return to the command line. If is pressed, FREEFORM assumes that the user wishes to send the output to a disk file. A file title consisting of a Volume name and a File name (a type of TEXT is used automatically) are prompted for until FREEFORM can 'open up' the file specified for output or is pressed. If a file is 'opened' successfully, the user is asked if the output is to be for Word Processing. The user should type since the Word Processor package is not available at this time. When the Listing is complete FREEFORM will redisplay the Data Entry command line. 1.3.10 H - Help This command will display a brief explanation of valid FREEFORM data entry commands, one line at a time. 1.3.11 - Escape The command line services the key in the usual manner. When pressed, FREEFORM will return to the main menu. ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.f.text ======================================================================================== Directory and Control Files 1.4 DIRECTORY AND CONTROL FILES 1.4.1 How to List the Freeform Directory By selecting function #3 (Display or List Directory) from the main menu, the user can get a display or printed listing of the currently stored Forms on the FREEFORM disk. This is useful for keeping track of which diskette has which Forms stored on it. If FREEFORM does not find a FREEFORM directory on the first disk it searches, the program will advise and allow the user to specify a disk drive to look in and to insert another disk or opt to abort. If a valid directory file is found, the user is allowed to select display or hardcopy listing. It is a good idea to periodically print directory listings of all FREEFORM diskettes to maintain a current catalogue of all the files on the disks. 1.4.2 How to List or Display Controls Function selection #4 (Display or List Form controls) gives either a printout or display of the controls for a Form stored on the currently logged user disk. The prompts for doing so are straightforward. As in most FREEFORM programs the user is prompted to supply the Form name. After being entered the prompt below appears. *** Listing on Printer? (Y/N) N To display the controls on the console, press . After each screen is displayed the user is prompted to press . This allows plenty of time to study each screen. To get a printout of the Form controls, press a . The user may then set the printer alignment and press when ready. The controls will be read from the control file for the requested Form and printed in a readable format. It is suggested that files of such listings be maintained for each Form used. This will save time in the event it is necessary to redefine or modify a Form. When the requested Form controls have been displayed or printed, control will pass to the FREEFORM main menu. ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.g.text ======================================================================================== Controls Modification Procedures 1.5 CONTROLS MODIFICATION PROCEDURES 1.5.1 How to Modify a Form Modifying a Form involves changing the dimensions of existing Forms are stored in the Form control files. * Review the procedures described in the Form Definition Procedures section (1.2) as use of the modification program requires that the user be completely familiar with it. The Form modification program allows the user to: change the dimensions and other attributes of a Form, change the row and column descriptions and calculations to be performed and load the control file accordingly. The formatting of a Form cannot be changed. 1.5.2 Calling the Modify Procedure To envoke the Form modification procedure select menu option number ******************************************************************** F R E E F O R M The Electronic Worksheet [F.4] ========================================== June 24, 1981 0. 1. 2. Modify FORM controls <===== Form modification 3. 4. 5. 6. 7. 8. 9. Enter desired option # _ Press ESC to leave ******************************************************************** When the program has loaded, the screen will clear and a new title will be displayed. F R E E F O R M F O R M S C O N T R O L S Forms Modification * If FREEFORM does not find a 'directory' file on its first try (FREEFORM searches on the prefix disk unless another drive was previously specified), it displays an error message stating there is no directory. If this happens, FREEFORM will ask if you wish to try another disk. If so, press otherwise type . If was pressed, the program will prompt for the disk drive number to search in for a directory file. After receiving a valid disk drive number, the program will instruct the user to insert a disk in to that drive and press . * A review of the Standard Keyboard Procedures (1.1.3) is recommended. The program then displays the prompt: *** Form Name (8 alpha max.)__________ Press ESC to leave There are three possible responses to this command. Press to return to the FREEFORM main menu, supply a Form name, or press . Each time is pressed FREEFORM looks at the FreeForm directory and displays a possible Form name. If a selected Form name is not found on the user diskette, the prompt *** Form named not found... *** Try another Form name? (Y/N) Y will appear. The user may now try another Form name by supplying the desired Form name in the manner previously described. If a user chooses not to select another Form name by typing , control will return to the FREEFORM main menu. When a valid Form name is selected FREEFORM will continue its normal progress and inform the user that the Form controls are being loaded. 1.5.3 Modifying a Form The modification portion of the FREEFORM program is now entered. The program then asks whether or not it is desired to change certain controls. The change prompts are of the form: *** Change ? (Y/N) N where is the control in question. If a control is to be changed respond with a , else press . Once a response is given, the control may be changed in the same way as in the Form definition program. The user is allowed to do such things as inserting and/or deleting rows and columns from a form, adding pages, changing various descriptions, etc. EXAMPLE: Change Row Controls? Y Enter row # to be modified? 23 (max. XX) The controls for row 23 will be displayed and the user may then elect to change the fields of description, type, editing format, and calculation string as necessary. The parameters are the same as those detailed in How to Define a Form (1.2.1). 1.5.4 Special Hints on Modify It is not possible to change the format of a Form once it has been created. No rows or columns may be added to a Form once the maximum values set for them, at Form definition time, have been reached. It is possible to use the Copy utility (see 1.6.3) to create a new Form, just like the old one but, with larger maximums for either the number of rows, or columns, or both. It will then be possible to add rows, or columns, to the new Form. To add pages to a Form there has to be fewer than 100 pages in it already and there must be empty space on the data disk immediately below the data file that is to be extended. To create empty space below the data file use the Extended List Directory command and note the block number just below the data file. Then use the Krunch command and Krunch, not the whole disk but, from the block number noted. 1.5.5 Exiting the Modify Program After modifications for a Form have been completed, the program will return to the FREEFORM main menu. ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.h.text ======================================================================================== Roll, Copy and Delete Utilities 1.6 ROLL, COPY AND DELETE UTILITIES 1.6.1 How to Use the Roll, Copy and Delete Utilities The purpose of the roll utility is to allow the user to change, to some degree, the order in which rows and/or columns appear in a form. The copy utility offers the user the capability of setting up duplicate Forms under different Form names without having to repeat Form definition. Using Copy is also a way of expanding the limits set on the numbers of rows and columns of a Form which are set at Form definition time. The delete utility will delete a Form from the 'directory' file and erase the control and data files associated with that Form. * To avoid confusion review Standard Keyboard Procedures (1.1.3). To envoke the ROLL, COPY or DELETE procedures, select the proper menu option number. ******************************************************************** F R E E F O R M The Electronic Worksheet [F.4] ========================================== June 24, 1981 0. 1. 2. 3. 4. 5. 6. Roll a FORM <===== ROLL procedure 7. Copy a FORM <===== COPY procedure 8. Delete a FORM <===== DELETE procedure 9. Enter desired option # _ Press ESC to leave ******************************************************************** When the program has loaded, the screen will clear and a new title will be displayed. * If FREEFORM does not find a 'directory' file on its first try (FREEFORM searches on the prefix disk unless another drive was previously specified), it displays an error message stating there is no directory. If this happens, FREEFORM will ask if you wish to try another disk. If so, press otherwise type . If is pressed the program will prompt for the disk drive number to search for a directory file. After receiving a valid disk drive number, the program will instruct the user to insert a disk into that drive and press . 1.6.2 Roll * This option best applies to Forms used in trending information. As stated at the beginning of this module, the roll allows the user change, to some degree, the order in which rows and columns appear in a Form. An easy way of seeing this is by example. If a Form has the following column headings JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC By using the roll option one may change this to APR MAY JUN JUL AUG SEP OCT NOV DEC JAN FEB MAR by 'rolling' 3 columns to the left. Of course, whenever a heading is moved, the data associated with that heading is moved as well. * Calculation strings are adjusted when they are moved. The program will respond to the user's request for a roll with the prompt: *** Form name (8 alpha max.) __________ Press ESC to leave If the requested Form is not found on the current diskette, a standard error message will be displayed. The user may try a different Form name, use the '?' option, or elect to return to the main menu. If the Form is found, the process continues. *** Roll rows or columns? (R/C) C To roll rows, type . If column rolls are desired, press only. This prompt appears if the roll column option has been selected. *** Roll columns left or right? (L/R) L The columns will move in the specified direction. The program will then ask how many columns are to be rolled. For example, if prior to the roll the headings are: JAN FEB MAR APR MAY JUN JUL AUG SEP OCT NOV DEC and the response to the above prompts is as follows: *** Roll rows or columns? (R/C) C *** Roll columns left or right? (L/R) L *** Roll 03 columns left....(enter number) The result will be: APR MAY JUN JUL AUG SEP OCT NOV DEC JAN FEB MAR Row rolls are like column rolls, except that the user is asked to specify how many rows are to be rolled and whether they are to be rolled up or down. When the roll has been completed, control will be returned to the FREEFORM main menu. 1.6.3 Copy The Copy command is very powerful, and if the instructions provided by FREEFORM are followed, it is very simple to use. Forms, pages of Forms, portions of Forms, and portions of pages of Forms, may be copied to Forms that already exist or used to create new Forms. Form controls do not have to match to do these copies and Forms may be copied onto different disks. After the Copy command is given, the prompt: *** Copy from one disk to another ? (Y/N) N will be displayed. Type if information is going to be transferred from one disk to another, otherwise press . If was pressed, then the program will prompt to find out which drive the source and destination disks will be placed in. * The user should not do any disk swapping until instructed by FREEFORM to do so. When swapping is done, it should be done very carefully so as not to confuse the source with the destination disks. The program will prompt: *** Copy a Form or just Pages ? (F/P) F If only the pages from an existing Form are to be copied to another existing Form on the same or different disk type

, otherwise press to create a new Form from an old one. Then FREEFORM prompts: *** Copy a Complete page or Portions of a page ? (C/P) C A subset of one Form may be used to create a new Form or a subset of each page of an existing form may be copied into an existing Form. To copy portions of pages type

, otherwise press and whole page(s) will be copied. If information is being copied from one disk to another, the program will at this time instruct the user to insert the destination disk into the drive that was specified previously. FREEFORM now prompts: *** Destination Form name *** Form name (8 alpha max.) __________ Press ESC to leave This Form is referred to as the Destination Form. The name of an existing Form must be given if only a single page is being copied. Note that a question mark may be typed and FREEFORM will supply a name of an existing Form on the destination disk. If a new Form is being created, the question mark option does not work because FREEFORM expects to be given the name of a Form that does not exist. If the Destination Form name already exists on the current diskette, an error message will appear. If information is being copied from one disk to another, the program will at this time instruct the user to insert the source disk into the drive that was specified previously. Then FREEFORM prompts: *** Source Form name *** Form name (8 alpha max.) __________ Press ESC to leave Respond with a valid, existing Form name (the question mark option may be used to find the proper Form name). This Form is referred to as the Source Form. If the requested Form is not found on the current diskette, a standard error message will be displayed. The user may try a different Form name or elect to return to the main menu. If the Form is found, the process continues with the prompt: *** Searching for Source FORM files, one moment please... If the contents of one Form are being copied to another Form (the Just Pages option) then Freeform will prompt for starting locations to put the copied pages, rows, and columns. For example to copy pages one through four of the source Form into pages two through five of the destination Form the answer to the place to start putting the pages would be two. Later specify that pages one through four are to be copied. The sequences of pages, rows, and columns of the source form to copy will be gathered as is done with the List command (1.3.9) during Data Entry. *** Enter sequences of Pages (XX-XX,YY-YY) to copy below (there are XX) *** _____________________________________ *** Enter sequences of Rows (XX-XX,YY-YY) to copy below (there are XX) ***_____________________________________ *** Enter sequences of Columns (XX-XX,YY-YY) to copy below (there are XX) ***_____________________________________ For example to copy pages one through four, rows one through ten, row thirteen, and row 25, and columns seven through one enter 1-4 in response to the Pages prompt, and 1-10, 13, 25 in response to the Rows prompt, and 7-1 in response to the Columns prompt. If a new Form is being created, the program will now copy the Control files. The Page(s) are copied now by the program, but before doing so, the user is prompted: *** Copy or Empty data fields? (C/E) _ The C response will cause the data in the old Form to be duplicated in the new Form. The E response will initialize all the data in the new Form to null. When the Copy has been completed, the user is instructed to return all disks to their original drives, i.e., all disks should be back where they where before the Copy command was entered. Then, the program returns to the FREEFORM main menu. 1.6.4 Delete When the Delete command is entered, the user is prompted for a Form name. When an existing Form has been specified the prompt *** Delete ? (Y/N) N will be displayed on the console screen. If the Form is not to be deleted, simply press . However, if the Form is to be deleted, respond with a . At this point, the program will display an update message, the file will be removed from the directory, and the associated control and data files will be erased. * Once a form has been deleted, it can not be restored. ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.i.text ======================================================================================== Form Consolidation 1.7 FORM CONSOLIDATION FREEFORM provides a facility for numerical consolidation of multi-page Forms. Consolidation sequencing is not preset and may be changed at will. Typical applications for consolidation would be instances where the same data is prepared for multiple entities and the summation to one or more overall entity levels is desired. Prior to Form definition of a multi-page Form, consider the extra pages needed to serve as 'scratch pads' for what-if consolidations and add these to the total number of pages required during a Form definition. To envoke the Form CONSOLIDATE procedure select menu option number 5. ********************************************************************* F R E E F O R M The Electronic Worksheet [F.4] ========================================== June 24, 1981 0. 1. 2. 3. 4. 5. Consolidation Utility <======== CONSOLIDATE routine 6. 7. 8. 9. Enter desired option # _ Press ESC to leave ********************************************************************* Once the program has loaded, the screen will clear and a new title will be displayed. F R E E F O R M C O N S O L I D A T I O N * If FREEFORM does not find a 'directory' file on its first try (FREEFORM searches on the prefix disk unless another drive was previously specified), it displays an error message stating there is no directory. If this happens, FREEFORM will ask if you wish to try another disk. If so press ; otherwise type . If was pressed, the program will prompt for the disk drive number to search in for a directory file. After receiving a valid disk drive number, the program will instruct the user to insert a disk into that drive and press . * To avoid confusion, review the Standard Keyboard Procedures (1.1.3). The program then displays the prompt... *** Form Name (8 alpha max.) __________ Press ESC to leave There are three possible responses to this command. Press to return to the FREEFORM main menu, supply a Form name, or press . Each time is pressed FREEFORM looks at the FreeForm directory and displays a possible Form name. If a selected Form name is not found on the user diskette, the prompt *** Form named not found... *** Try another Form name? (Y/N) Y will appear. The user may now try another Form name by supplying the desired Form name in the manner previously described. If a user chooses not to select another Form name, by typing control will return to the FREEFORM main menu. If the Form name selected is valid, the program will operate normally and inform the user that the Form controls are being loaded. Freeform then asks if there is a control file to use. Consolidation control files contain the destination page number as well as the consolidation expression to use. To use an existing control file the Volume name of the disk it is on and its name must be specified. When this has been accomplished the program will prompt: *** Enter Consolidation Page # __ (max. is XX) Enter the page number into which the results of the consolidation are to be stored. This should be done carefully to avoid unintentionally writing over other pages. *** Enter Consolidation Control ***=_________________________________ A prompt is given for a calculation string which will govern the consolidation process. The syntax and capabilities of this calculate string are similar to those used in defining row and column calculations. Constants may be specified, however, parenthesis are not permitted. All operators are of equal precedence and are therefore executed in left-to-right order. Examples: (1) Pages 1, 2, and 3 represent three department profit and loss statements. A division total profit and loss statement is requested for the three pages. In FORMDEF, 4 pages are allocated; 1 for each department, and 1 for a division total. The consolidation page for this problem is 4. The calculation string which defines the consolidation control is 1 + 2 + 3. (2) If, on the other hand, the division total and department 1 and 2 data is known, the objective would be to compute or 'squeeze' department 3 data. The consolidation page for this would be 3, and the appropriate calculation string would be 4 - 1 - 2. (3) A different Form may contain inventory in Dollar amounts on page one. To get the amounts in British pounds on page two, a constant would have to exist containing the exchange rate for Dollars and Pounds. Suppose C1 equals 2.1900. The appropriate calculation string would be 2 / C1 with the consolidation page set to two. (4) The inventory of 12 items in seven warehouses exists. Three of the warehouses are in Texas, two are in Oklahoma, and two are in Louisiana. A record of beginning inventory, issues, receipts, and computed ending inventory by item in each warehouse, a total of all items in each state, and a grand total of all warehouses has been requested. The Form to define would consist of 11 pages; one for each warehouse, one for each state total, and one for a total of all warehouses. Each page would have 12 data rows to represent each of the 12 inventory items and one calculated row to total the 12 items, plus three data columns in which the quantities would be entered and one column for computing the ending inventories. The user would probably want to sequence the pages so the display would be most meaningful. Any sequence will work. Some examples are: Sequence #1 Sequence #2 Sequence #3 pg 1 Tex. WH 1 Tex. WH 1 Grand Tot. pg 2 Tex. WH 2 Tex. WH 2 Tex. SUB pg 3 Tex. WH 3 Tex. WH 3 Okl. SUB pg 4 Okl. WH 1 Tex. SUB La. SUB pg 5 Okl. WH 2 Okl. WH 1 Tex. WH 1 pg 6 La. WH 1 Okl. WH 2 Tex. WH 2 pg 7 La. WH 2 Okl. SUB Tex. WH 3 pg 8 Tex. SUB La. WH 1 Okl. WH 1 pg 9 Okl. SUB La. WH 2 Okl. WH 2 pg10 La. SUB La. SUB La . WH 1 pg11 Grand Tot. Grand Tot. La . WH 2 The consolidation controls and sequence for these cases: 8 = 1 + 2 + 3 4 = 1 + 2 + 3 2 = 5 + 6 + 7 9 = 4 + 5 7 = 5 + 6 3 = 8 + 9 10 = 6 + 7 10 = 8 + 9 4 = 10 + 11 11 = 8 + 9 + 10 11 = 4 + 7 + 10 1 = 2 + 3 + 4 * The user may want to define an extra page to be used as a scratchpad for hypothetical cases; for example, in the inventory example above, Tex. WH 1 and La. WH 2 are both within 100 miles of a customer. What is the total supply of item 6 available in these locations? After the consolidation string is entered, the program will perform the prescribed consolidation math and rewrite the consolidation page to the Form data file. When this process has completed (time required will vary with the number of pages in the consolidation and the number of calculated rows and columns in the Form), FREEFORM will ask if the consolidation controls used should be saved. It will then ask if there are more consolidations to be done with the current Form. When there are no more consolidations to be done with the current Form, FREEFORM will return to the main menu. ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.j.text ======================================================================================== Form Creation Example 1.8 FORM CREATION EXAMPLE The following instructions will create a Form which could be used in doing a financial Forecast. Step one is to set the Prefix to whichever Volume FREEFORM is to put the 'directory' file on or to the disk which already contains a FREEFORM directory. This can be done by typing /SP (Set Prefix) while at Freeform's main menu or while in the Filer program using the P)refix command. Step two is to execute FREEFORM. This is done by eXecuting the code file FF/VER4. The following exchange will then take place: FREEFORM: Puts up FREEFORM main menu. User Enters: 1 Explanation: Selected Define new FORM controls option. FREEFORM: Enters Forms Control mode, creates FREEFORM directory if one was not found on the prefixed disk, and prompts for a Form name. Form Name (8 alpha max.)________ User Enters: FORECAST Explanation: User named Form FORECAST. FREEFORM: Are checkpoint prompts desired? N User Enters: Y Explanation: This turns on the Checkpoint option. With the Checkpoint option on, FREEFORM will give the option of re-entering a bad input. An experienced user will normally press so this option will not be turned on. FREEFORM: Enter user initials User Enters: DA Explanation: This is optional. It is O.K. to just press . FREEFORM: Enter optional descriptive comment -> User Enters: Forecast Form Explanation: This comment is displayed when the FREEFORM directory is listed. This helps one recognize what a Form contains, and is therefore recommended for use, although it is optional. FREEFORM: Enter today's date (MMDDYY) -> User Enters: 080680 Explanation: This is displayed as the date of creation when the Form controls are listed. It is optional also. FREEFORM: How many pages? User Enters: 1 Explanation: Only one page is wanted in this Form. If more are wanted later, it is possible to add them. FREEFORM: Format Rows or Columns? R User Enters: Explanation: Form will be formatted by Row because R is the default. Row formatting lets the user define the decimal point position for an entire row, one row at a time. This means that the number of digits to the left and the right of the decimal point will not vary across a row but may vary down a column. With column formatting, the number of digits to the left and the right of the decimal point is fixed for each column but may vary across a row. In either case all numbers will line up when the form and its data are printed. FREEFORM: Do you want automatic month descriptions? N User Enters: Y Explanation: This is a forecast and will contain monthly information as well as a year and quarterly totals. The columns containing the totals will be added to the Form after the initial definition is complete. For now only the columns with month names for headings will be put into the Form. FREEFORM: Month descriptions for rows or columns? C User Enters: Explanation: Descriptions will be for the columns because C is the default. FREEFORM: Enter starting month # 1 User Enters: Explanation: The first column will be labeled Jan, one was the default, and the last will be labeled Dec. It is possible to start with any month by picking a different number in the range one through twelve. FREEFORM: How many Calculation Constants? User Enters: 1 Explanation: One constant wanted. FREEFORM: CONSTANT(1) = - User Enters: .95 Explanation: FREEFORM will set C1 equal to 0.9500. FREEFORM: Anything to change? N User Enters: Explanation: Default is N. If something had been entered wrong so far should be typed. If is pressed FREEFORM will repeat all questions asked so far again. This question would not have been asked if the Checkpoint option had not been turned on. FREEFORM: How many columns might ever be in the FORM? User Enters: 20 Explanation: In this Form a total of 17 columns will be used. By responding with 20 there will be a little room for expansion later. FREEFORM: How many rows might ever be in the FORM? User Enters: 40 Explanation: A total of nine rows will be used in this Form now. By telling Freeform 40 there will be plenty of room for expansion. FREEFORM: How many columns? User Enters: 12 Explanation: Twelve columns are desired in this Form, one for each month. Quarterly totals will be added later. FREEFORM: How many rows? User Enters: 9 Explanation: Nine rows are desired in this Form. FREEFORM: Are the dimensions o.k. as specified? Y User Enters: Explanation: To change the number of rows or columns just specified type . FREEFORM: Updating directory ...one moment, please Creating Control and Data files ...one moment, please User: Explanation: These are displayed while FREEFORM writes the information just given it into the FREEFORM directory. FREEFORM then creates new Control and Data files. FREEFORM: Enter Title for Page 1 ______________________________________ User Enters: PCIF FORECAST Explanation: Enter the title on the dashed line below the prompt. The title entered will always appear whenever page one of this Form is listed. FREEFORM: Is Title correct? Y User Enters: Explanation: Yes is the default. If the Title was entered incorrectly typing would allow you to re-enter the Title. FREEFORM: This title will be written to the disk. FREEFORM then prompts Enter Description for Row 1 _______________ User Enters: EX PEOPLE Explanation: FREEFORM: Enter 1 Type (D/I/F/H) D User Enters: Explanation: This is where the option of defining a Row as Data, Initial calculation, Final calculation or Heading is given. Data is the default and was chosen. FREEFORM: O.K. to set values from Column calculations? Y User Enters: N Explanation: This will not be a calculated row. Therefore it is not okay to set values from column calculations in this row. This will be more evident when the Form is finished and being used. FREEFORM: Enter Row 1 Editing Format ####.##__ User Enters: ## Explanation: Just defined the field to be two digits wide. This row will be able to store integers in the range -99 through 99. A user must define the field to have at least one digit to the left of the decimal point and at most four digits to the right of the decimal point. FREEFORM: Are Controls for Row 1 o.k.? Y User Enters: Explanation: Type if an error was made while defining the controls for Row one and all questions asked to describe it will be repeated. FREEFORM: Enter Description for Row 2 _______________ User Enters: NON-EX PEOPLE Explanation: This is the description for Row two. Answer all the rest of the questions about Row two in the same way as for Row one. FREEFORM: Enter Description for Row 3 _______________ User Enters: Explanation: You want to have a blank line before Row four. The Row type will be the heading. FREEFORM: Enter 3 Type (D/I/F/H) D User Enters: H Explanation: Row type of heading was chosen. FREEFORM: Are Controls for Row 3 o.k.? Y User Enters: Explanation: Type if an error was made while defining the controls for Row three, and all questions asked to describe it will be repeated. FREEFORM: Enter Description for Row 4 _______________ User Enters: TOTAL PEOPLE Explanation: FREEFORM: Enter 4 Type (D/I/F/H) D User Enters: I Explanation: This is to be a Initial calculation row. FREEFORM: =___________________________ User Enters: 1 + 2 Explanation: This tells FREEFORM that Row four is the sum of Row one and Row two. FREEFORM: O.K. to set values from Column calculations? Y User Enters: N Explanation: FREEFORM: Enter Row 4 Editing Format ##_______ User Enters: Explanation: This defines the field to be two digits wide as the default was ##. FREEFORM: Are Controls for Row 4 o.k.? Y User Enters: Explanation: Type if an error was made while defining the controls for Row four, and all questions asked to describe it will be repeated. FREEFORM: Enter Description for Row 5 _______________ User Enters: Explanation: You want to have a blank line before Row six just like the one before Row four. FREEFORM: Enter 5 Type (D/I/F/H) D User Enters: H Explanation: FREEFORM: Are Controls for Row 5 o.k.? Y User Enters: Explanation: Type if an error was made while defining the controls for Row five, and all questions asked to describe it will be repeated. FREEFORM: Enter Description for Row 6 _______________ User Enters: LABOR Explanation: FREEFORM: Enter 6 Type (D/I/F/H) D User Enters: Explanation: This is to be a Data row (Data is the default). FREEFORM: O.K. to set values from Column calculations? Y User Enters: Explanation: FREEFORM: Enter Row 6 Editing Format ##_______ User Enters: ####.## Explanation: You want the field to have up to four digits before the decimal point and two after it. FREEFORM: Are Controls for Row 6 o.k.? Y User Enters: Explanation: Type if an error was made while defining the controls for Row six, and all questions asked to describe it will be repeated. FREEFORM: Enter Description for Row 7 _______________ User Enters: LESS BILLINGS Explanation: FREEFORM: Enter 7 Type (D/I/F/H) D User Enters: Explanation: This is to be a Data row (Data is the default). FREEFORM: O.K. to set values from Column calculations? Y User Enters: Explanation: FREEFORM: Enter Row 7 Editing Format ####.##__ User Enters: Explanation: Just defined the field to have up to four digits before the decimal point and two after it. FREEFORM: Are Controls for Row 7 o.k.? Y User Enters: Explanation: Type if an error was made while defining the controls for Row seven, and all questions asked to describe it will be repeated. FREEFORM: Enter Description for Row 8 _______________ User Enters: Explanation: Want to have a blank line before Row nine just like the one before Row four. FREEFORM: Enter 8 Type (D/I/F/H) D User Enters: H Explanation: FREEFORM: Are Controls for Row 8 o.k.? Y User Enters: Explanation: Type if an error was made while defining the controls for Row eight, and all questions asked to describe it will be repeated. ======================================================================================== DOCUMENT :usus Folder:VOL28:ff.k.text ======================================================================================== FREEFORM: Enter Description for Row 9 _______________ User Enters: NET PROJECT EXP Explanation: FREEFORM: Enter 9 Type (D/I/F/H) D User Enters: I Explanation: This is to be a Calculated row. FREEFORM: =___________________________ User Enters: (6 - 7) * C1 Explanation: This tells FREEFORM that Row nine is the Row six minus Row seven, all multiplied by C1 which is 0.95. FREEFORM: O.K. to set values from Column calculations? Y User Enters: Explanation: FREEFORM: Enter Row 9 Editing Format ####.##__ User Enters: Explanation: Just defined the field to have up to four digits before the decimal point and two after it. FREEFORM: Are Controls for Row 9 o.k.? Y User Enters: Explanation: Type if an error was made while defining the controls for Row nine, and all questions asked to describe it will be repeated. FREEFORM: (Will ask if the controls for each column are ok, one at a time.) User Enters: (12 times) Explanation: FREEFORM will not let the user change column descriptions here because automatic month descriptions were asked for. Modify may be used later to change this information. FREEFORM: FREEFORM definition process completed for FORECAST. FREEFORM redisplays the main menu and continues. User Enters: Explanation: The definition of the form is finished. The form FORECAST, however, will not be complete until Quarter totals have been inserted. FREEFORM: Enter desired option # User Enters: 2 Explanation: Picked Modify procedure. FREEFORM: Form Name (8 alpha max.) User Enters: FORECAST Explanation: It is necessary to modify the definition of the Form named FORECAST. Columns are to be inserted in the current Form to provide totals for each of the quarters and for the year's total. Quarter totals are to be inserted in reverse order. This makes entering calculation strings simpler as the postions of the columns that are being summed have not been moved due to insertions. FREEFORM: Opening Control and Data files ... one moment, please When the files are opened, FREEFORM will prompt Change User ID? N User Enters: Explanation: FREEFORM first tries to open the Control and Data files associated with the Form name specified once the Form name is found in the 'directory' file. Then all the 'Change' prompts appear. All 'Change' prompts default to No, so whenever it is desirable to leave a value alone, press . FREEFORM: Change Form description? N User Enters: Explanation: Do not change it. FREEFORM: Change Form creation date? N User Enters: Explanation: Do not change it. FREEFORM: Change number of Pages? N User Enters: Explanation: Do not change it. FREEFORM: Change number of Constants? N User Enters: Explanation: Do not change it. FREEFORM: Change Value of a Constant? N User Enters: Explanation: Do not change any. FREEFORM: Change Number of Rows? N User Enters: Explanation: Do not change it. FREEFORM: Change Number of Columns? N User Enters: Y Explanation: Add a Column. FREEFORM: Insert a Column? N User Enters: Y Explanation: Insert a Total column. FREEFORM: Enter Column # to Insert After User Enters: 12 Explanation: Insert the 4th quarter total. FREEFORM: Insert how many columns ? 1 User Enters: Explanation: Just want to insert one column immediately after column twelve. FREEFORM: Enter Description for Column 13 User Enters: 4th QTR Explanation: FREEFORM: Enter 13 Type (D/I/F/H) D User Enters: I Explanation: An Initial calculation column. FREEFORM: =___________________________ User Enters: 10+11+12 Explanation: October, November and December. FREEFORM: O.K. to set values from Row calculations? Y User Enters: Explanation: "Yes" is the default. FREEFORM: Delete a Column? N User Enters: Explanation: "No" is the default. FREEFORM: Change Number of Columns? N User Enters: Y Explanation: Add a Column. FREEFORM: Insert a Column? N User Enters: Y Explanation: Insert a Total column. FREEFORM: Enter Column # to Insert After User Enters: 9 Explanation: Insert the 3rd quarter total. FREEFORM: Insert how many columns ? 1 User Enters: Explanation: Just want to insert one column immediately after column nine. FREEFORM: Enter Description for Column 10 User Enters: 3rd QTR Explanation: FREEFORM: Enter 12 Type (D/I/F/H) D User Enters: I Explanation: An Initial calculation column. FREEFORM: =___________________________ User Enters: 7+8+9 Explanation: July, August and September. FREEFORM: O.K. to set values from Row calculations? Y User Enters: Explanation: "Yes" is the default. FREEFORM: Delete a Column? N User Enters: Explanation: "No" is the default. FREEFORM: Change Number of Columns? N User Enters: Y Explanation: Add a Column. FREEFORM: Insert a Column? N User Enters: Y Explanation: Insert a Total column. FREEFORM: Enter Column # to Insert After User Enters: 6 Explanation: Insert the 2nd quarter total. FREEFORM: Insert how many columns ? 1 User Enters: Explanation: Just want to insert one column immediately after column six. FREEFORM: Enter Description for Column 7 User Enters: 2nd QTR Explanation: FREEFORM: Enter 7 Type (D/I/F/H) D User Enters: I Explanation: An Initial calculation column. FREEFORM: =___________________________ User Enters: 4+5+6 Explanation: April, May and June. FREEFORM: O.K. to set values from Row calculations? Y User Enters: Explanation: "Yes" is the default. FREEFORM: Delete a Column? N User Enters: Explanation: "No" is the default. FREEFORM: Change Number of Columns? N User Enters: Y Explanation: Add a Column. FREEFORM: Insert a Column? N User Enters: Y Explanation: Insert a Total column. FREEFORM: Enter Column # to Insert After User Enters: 3 Explanation: Insert the 1st quarter total. FREEFORM: Insert how many columns ? 1 User Enters: Explanation: Just want to insert one column immediately after column three. FREEFORM: Enter Description for Column 4 User Enters: 1st QTR Explanation: FREEFORM: Enter 4 Type (D/I/F/H) D User Enters: I Explanation: An Initial calculation column. FREEFORM: =___________________________ User Enters: 1+2+3 Explanation: January, February and March. FREEFORM: O.K. to set values from Row calculations? Y User Enters: Explanation: "Yes" is the default. FREEFORM: Delete a Column? N User Enters: Explanation: "No" is the default. FREEFORM: Change Number of Columns? N User Enters: Y Explanation: Add a Column. FREEFORM: Insert a Column? N User Enters: Y Explanation: Insert a Total column. FREEFORM: Enter Column # to Insert After User Enters: 16 Explanation: Insert the Year total. FREEFORM: Insert how many columns ? 1 User Enters: Explanation: Just want to insert one column immediately after column sixteen. FREEFORM: Enter Description for Column 17 User Enters: YEAR 1980 Explanation: FREEFORM: Enter 17 Type (D/I/F/H) D User Enters: I Explanation: An Initial calculation column. FREEFORM: =___________________________ User Enters: 4+8+12+16 Explanation: 1st, 2nd, 3rd and 4th QTR's. FREEFORM: O.K. to set values from Row calculations? Y User Enters: Explanation: "Yes" is the default. FREEFORM: Delete a Column? N User Enters: Explanation: "No" is the default. FREEFORM: Change Number of Columns? N User Enters: Explanation: Do not add any more. FREEFORM: Are these new specifications ok? Y User Enters: Explanation: If a mistake has been made type . FREEFORM: Change Page Titles? N User Enters: Explanation: Do not change any. FREEFORM: Change Row controls? N User Enters: Explanation: Do not change any. FREEFORM: Change Column controls? N User Enters: Explanation: Do not change any. FREEFORM: Are these new specifications ok? Y User Enters: Explanation: If a mistake has been made type . FREEFORM: Updating Directory, Control and Data files, one moment please... User Enters: Explanation: The program is now updating all the mentioned files. FREEFORM will return to the main menu, and the Form named FORECAST is complete. At this point, the user can run the data entry portion of FREEFORM and enter data into the form named FORECAST. For instructions on the Data Entry procedure see Section 1.3. ======================================================================================== DOCUMENT :usus Folder:VOL28:readme.1st.text ======================================================================================== FreeForm is a 3-D spreadsheet. It is very useful in certain types of problems and useless in others. FreeForm assumes that calculations are done on entire rows or columns at a time and the results are deposited in other entire rows or columns. It therefore is well suited to ledger sheets sort of applications. The 3-D nature becomes apparent when you realize that you can set up a sheet, for example, for each month's activity of a business. Each month's sheet can be stacked behind the next month's sheet and year end consolidations can be done on all twelve sheets to end up with grand totals. Up to 100 sheets (all must be of identical format) can be stacked. FreeForm does not allow calculations of individual cells so that it is nearly useless in an application such as a tax calculator. You pays your money and takes your chances. FreeForm uses real numbers for all of it calculations so that 4 word reals are necessary to obtain any kind of precision. A 2 word real version is provided for those that don't have 4 word reals on their iron, but its use is strictly limited as dollar figures can only be represented to $9,999.99 before you start losing track of the odd cents. Also, if you build data files with two word reals, and then switch to 4 word reals, THE DATA WILL NOT BE COMPATIBLE!!! The screen control features of FreeForm have been modified extensively by the reviewer (yours truly, gws) to allow the software to be transported to different types of terminals. The author used the screen control values found in KERNEL to obtain the values of the arrow keys and such. However, he did not allow for terminals with two-character sequences (such as an H-19). The use of KERNEL also made the program un-compilable on most hardware without extended memory as the compilation of KERNEL uses up most of memory for mere mortal iron. The program has been modified to eliminate the dependance on KERNEL. It now uses SCREENOPS instead. In this way it becomes terminal independant. However, since SCREENOPS does not support HOME, KEY_TO_INSERT_CHARACTER, or KEY_TO_DELETE_CHARACTER, these features are no longer available. The modifications have been done in a haphazard style (typical of this particular reviewer) so that some of the old code has been commented out and some of it has been entirely removed. It will now compile on most IV.x p-systems. If you are using a p-system older than IV.1 then you must comment out the selective uses list for SCREENOPS (found in FF.FREEFRM). regards - gws ======================================================================================== DOCUMENT :usus Folder:VOL28:vol28.doc.text ======================================================================================== USUS Library Volume 28 FreeForm (a 3-D spreadsheet) Documentation and Run Modules (Sources on Volume 27) --> Version IV.x ONLY <-- 4 word reals recommended FF.A.TEXT 20 FreeForm Documentation FF.B.TEXT 16 ditto FF.C.TEXT 18 ditto FF.D.TEXT 18 ditto FF.E.TEXT 18 ditto FF.F.TEXT 8 ditto FF.G.TEXT 14 ditto FF.H.TEXT 22 ditto FF.I.TEXT 18 ditto FF.J.TEXT 26 ditto FF.K.TEXT 20 ditto FF.4WORD.CODE 125 FreeForm for 4 word reals IV.x only FF.2WORD.CODE 124 FreeForm for 2 word reals IV.x only README.1ST.TEXT 8 Read this first! VOL28.DOC.TEXT 6 You're reading it ----------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 28 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOL29:convdoc.text ======================================================================================== 1 1 84/04/16 Program CONVERS - Users Manual John W. Dykstra April 14, 1984 CONVERS handles communication between two computers over a character-oriented full-duplex link, such as serial modems connected by a dial-up telephone line. Usually, the computer running CONVERS (referred to in this document as the workstation) is micro- or mini-sized, and a mainframe machine (called the host) is on the other end of the link. CONVERS interacts with the host via standard host commands. No special programming or modification of the host system is necessary, because CONVERS appears to the host as a human user. CONVERS can be used with virtually any host system hardware, operating system or applications programs, because all interactions are controlled by easily-written scripts. The commands contained in these scripts actually form a simple programming language, which is interpretively executed by CONVERS. CONVERS has been implemented in Pascal on a system running the UCSD P-system. The design and implementation have been oriented to making transportation of the program to other hardware and software systems as easy as possible. This document specifically describes Revision C of CONVERS, but most of the material presented applies to earlier (and probably later) versions of the program. 1 1-1 84/04/16 --------------------------------------------------------------- 1.0 CONVERS CONCEPTS AND DEFINITIONS --------------------------------------------------------------- 1.0 CONVERS CONCEPTS AND DEFINITIONS + ________________________________ 1.1 PRINCIPLES OF CONVERS OPERATION + _______________________________ CONVERS is controlled by text files called scripts, each of which contains a sequence of commands. When CONVERS is started by the user or from another workstation program, it is passed a parameter string containing the name of the first script to interpret, possibly accompanied by parameter definitions for that script. The initial script may pass control to other scripts through operations similar to subroutine calls and/or program branches. Control is finally passed to the workstation operating system or another user program, under control of script commands. The language used in writting scripts is similar to many block-oriented programming languages. The usual data types are available, as are variables, constants and expressions. Language statements are used to communicate with the host, manipulate variables, and control script execution. 1.2 DATA TYPES + __________ CONVERS supports data types of string, integer, name, and boolean. 1.2.1 STRINGS A string contains zero or more characters from the full 7-bit ASCII set ( including control characters ). The maximum permissible length of a string is determined at CONVERS compile time, and is currently set at 80 characters. 1.2.2 INTEGERS The range of values that an integer may take is implementation dependent, but is guaranteed to be at least 0...32767. CONVERS does not support negative integer values. 1.2.3 NAMES Names are used to denote CONVERS variables and files on the local processor (workstation). Variables of type name are often used in communication with the host system. Names may be from 1 to 32 characters in length, with each character selected from the alphabetic and digit characters, and the special characters period (.), underscore (_), asterisk (*), currency sign ($), and colon (:). The first 1 1-2 84/04/16 --------------------------------------------------------------- 1.0 CONVERS CONCEPTS AND DEFINITIONS 1.2.3 NAMES --------------------------------------------------------------- character of a name must not be a digit. All names used by CONVERS are case-insensitive, and may be written in any combination of upper and lower-case characters. CONVERS translates user- provided names into upper-case, and returns them in this form if a name assigned to a variable. Names used to identify workstation files must follow both the above rules, and any additional rules required by the workstation operating system. 1.3 STRING, INTEGER AND BOOLEAN CONSTANTS + _____________________________________ String constants are defined with ASCII characters contained within single quote marks. Any graphic character may be included in a string defined in this way except the single quote. If it is necessary to use a single quote or ASCII control character in a string constant, the constant may be built using the concatenation operator and the $CHR function (see below). An integer constant is expressed in decimal modulus, with no embedded commas or trailing periods. Boolean constants are represented by the reserved words TRUE, YES, FALSE and NO. 1.4 VARIABLES + _________ Variables may be assigned values and used (with the $VALUE function) in any expression. There are no variable declarations. The type of a variable is determined by the type of the value assigned to it. Variables may be redefined, and the type of the new value may be different from the type of the old value. There is no way to "undefine" a variable. The number of variables that can be defined is a compile-time contant, currently set to thirty. Variable names follow the standard rules for name formation. Several variable names are reserved. Assignment of a value to one of these variables changes the way that CONVERS behaves. These variables, and their effect, are: DISPLAY_COMMANDS This variable is a boolean. If it is set to TRUE, CONVERS displays each script command line as it is executed. DISPLAY_LINK This variable is also a boolean. If it is set to TRUE, the text arriving from the 1 1-3 84/04/16 --------------------------------------------------------------- 1.0 CONVERS CONCEPTS AND DEFINITIONS 1.4 VARIABLES --------------------------------------------------------------- host during MATCH commands is displayed. The value of reserved variables can be changed at any time. Reserved variable names can be used as parameters to $VALUE only if they have been previously defined by a script. The distinction between variable names and variable values may be difficult to understand. A variable name used alone denotes only that name. The $VALUE function (see below) must be used to obtain the value of that variable. 1.5 STRING OPERATORS + ________________ Terms of type string may be concatenated with the binary operator //. 1.6 BOOLEAN OPERATORS + _________________ Terms of type boolean may be prefixed with the unary operator NOT to negate their value. 1.7 FUNCTIONS + _________ CONVERS includes a number of built-in functions that may be used in expressions. All function names begin with a dollar sign, and are case insensitive. The parameters of the function follow the name, enclosed in parentheses. 1.7.1 THE $CHR FUNCTION This function has a single integer parameter, which must be in the range 0..127. The value of the function is the one-character string formed by interpreting the value of the parameter as an ASCII character. 1.7.2 THE $VALUE FUNCTION This function has a single name parameter, which must be the name of a previously-defined variable. The value of that variable is returned as the value of the function. If the $VALUE function is applied to a variable name that has not been explicitly defined, an error message will be issued. 1.7.3 THE $DEF FUNCTION The single parameter of this function is a name. If a variable of that name has been defined, the function return a boolean value of TRUE. Otherwise, it returns a value of FALSE. 1 1-4 84/04/16 --------------------------------------------------------------- 1.0 CONVERS CONCEPTS AND DEFINITIONS 1.7.4 THE $READ FUNCTION --------------------------------------------------------------- 1.7.4 THE $READ FUNCTION The parameter of this function is the name of a file on the workstation. This file is opened, if it is not already, and then the next line in the file is read and returned in string form as the value of the function. Successive calls to $READ with the same file name will result in successive lines being transfered from the file. The number of files that can be open simultaneously is a compile-time constant, currently set at five. (See the LINE parameter of the TRANSFER command.) 1.7.5 THE $EOF FUNCTION The parameter of this function is the name of a file on the workstation. This file is opened, if it is not already, and then the status of that file is checked. If the file is positioned at end-of-file, then this function returns a boolean value of TRUE; otherwise, a value of FALSE is returned. The limitation on simultaneously-open files described above applies. 1.7.6 THE $EQ FUNCTION The two parameters of this function are expressions of any matching type. The boolean value of the function is TRUE if the values of the expressions are identical; otherwise, the value of the function is FALSE. 1.7.7 THE $STR FUNCTION The single parameter of this function is a name. The characters making up this name are converted into a string, and the string is returned as the value of the function. 1.7.8 THE $NAME FUNCTION The single parameter of this function is a string. A name is formed from the string, and returned as the value of the function. 1.8 SCRIPT COMMANDS + _______________ Each script command occupies one line. Blank lines, and lines whose first non-blank character is an asterisk (comment lines), are ignored. Blank characters at the beginning of each command, and between parts of each command, are ignored. Script lines can be up to 80 characters long. Command lines must begin with a command name, which follows 1 1-5 84/04/16 --------------------------------------------------------------- 1.0 CONVERS CONCEPTS AND DEFINITIONS 1.8 SCRIPT COMMANDS --------------------------------------------------------------- the usual rules for name formation. The remainder of the line specifies parameters (if any) for the command. Each parameter is either positional, or specified by a name. Named parameters cannot be specified positionally, nor can positional parameters be specified with a name. The first parameter in a command is usually positional, and subsequent parameters are identified by names. Named parameters that do not require values are called keywords. If a value is required, it follows an equal sign ( "=" ). Commands cannot be continued from one line to the next. 1.9 ERRORS DURING COMMAND EXECUTION + _______________________________ Various abnormal situations may cause a command to abort during execution. CONVERS needs a general control structure to intercept these aborts, and attempt a retry of the failing script sequence. However, no workable structure has yet been devised. Anyone with ideas should contact the author. At present, CONVERS ends execution with an appropriate error message if any command aborts. 1 2-1 84/04/16 --------------------------------------------------------------- 2.0 SCRIPT COMMANDS --------------------------------------------------------------- 2.0 SCRIPT COMMANDS + _______________ 2.1 THE SEND COMMAND + ________________ This command sends a text line to the host system. The first (positional) parameter is the string to be transmitted over the link. This is followed by a carriage return character, unless the NOCC parameter has been specified (see below). If the string parameter is omitted or a null string, only a carriage return will be transmitted. The only possible Parameter is: NOCR If this keyword is specified, the string is not followed by a carriage return character. If this parameter is omitted, the carriage return is transmitted. This command aborts if the link carrier drops during command execution. 2.2 THE MATCH COMMAND + _________________ This command suspends execution of the current script until a given string is received from the host system. The first (positional) parameter is the string or name to be matched against. Optional parameters may follow, separated from the match string by a comma. Allowable name parameters are: ENDING If this keyword is coded, the matched string must be the last non- blank, non-control character received from the host for at least 1/2 second. ANYWHERE If this keyword is coded, the matched string will be recognized anywhere in the character stream received from the host. This is the default if ENDING is not specified. PERIOD If this parameter is coded, CONVERS will abort if the matching conditions are not satisfied within the specified period. This period is expressed as an integer number of tenths of seconds. If this parameter is not specified, CONVERS will wait 30 seconds before aborting. This command aborts if the link carrier drops, or if the match is not made within the specified time period. 1 2-2 84/04/16 --------------------------------------------------------------- 2.0 SCRIPT COMMANDS 2.3 THE TRANSFER COMMAND --------------------------------------------------------------- 2.3 THE TRANSFER COMMAND + ____________________ This command transfers data to/from a workstation file. The first (positional) parameter of this command is the name of the workstation file to be transfered. The remainder of the parameters are specified with named parameters: UPLOAD This keyword specifies that the direction of the transfer is from the workstation to the host system. DOWNLOAD This keyword specifies that the direction of the transfer is from the host system to the workstation. It is assumed if UPLOAD is not specified. TERM This parameter specifies the character string from the host that terminates a DOWNLOAD operation. All text received from the host is compared against the contents of this string. When a match occurs, the destination file is closed, and execution proceeds to the next command. The line in which the termination string was detected is not included in the file. This parameter must be supplied for a DOWNLOAD, and has no meaning for an UPLOAD. USECC This keyword specifies that the host file includes FORTRAN-style carriage control characters. If the transfer direction is DOWNLOAD, '1' carriage controls are converted to ASCII form-feeds, and all other carriage controls are ignored (deleted). If the transfer direction is UPLOAD, lines containing form-feeds are prefixed with '1', and all other lines are prefixed with ' '. Additionally, a line containing only a '1' carriage control is uploaded before the first line of the file. The default if the USECC keyword is not specified is to transmit each text line unchanged. LINE This keyword specifies that only one line is to be transfered. The specified file remains open, so that additional lines can be transfered by subsequent commands. The number of files that can be left open is a compile-time constant, currently set to five. PROMPT This parameter specifies a string that must be received from the host system before each line is transfered on an UPLOAD. The prompt is not required before the first line of the transfer, or after the last line. 1 2-3 84/04/16 --------------------------------------------------------------- 2.0 SCRIPT COMMANDS 2.3 THE TRANSFER COMMAND --------------------------------------------------------------- PERIOD If this parameter is coded, CONVERS will abort if the string specified by the PROMPT parameter is not detected within the specified period. This period is expressed as an integer numbers of tenths of a second. If this parameter is not specified, CONVERS will wait 30 seconds for each prompt. During uploads, each line is transmitted followed by a carriage return character. During downloads, the carriage return character is interpreted as end-of-line, and all other ASCII control characters are ignored. This command aborts if the link carrier drops, or if a prompt string is not detected within the specifed period. 2.4 THE WAIT COMMAND + ________________ This command suspends execution of the script until a carrier is detected on the link. This command aborts if the carrier is not detected within 30 seconds. 2.5 THE PAUSE COMMAND + _________________ This command suspends execution of the script for one second. 2.6 THE DEFINE COMMAND + __________________ This command is used to define one or more variables. The remainder of the command line contains symbol definitions, of the form: variable_name = expression Each definition is separated from the next by a comma. The number of variables that may be defined is a CONVERS compile-time parameter, currently set at 30. The definition of a variable cannot be deleted. 2.7 THE EXECUTE COMMAND + ___________________ This command saves the current state of CONVERS, and begins execution of a specified program. The first (positional) parameter specifies the program name. The remainder of the command line is passed to the called program as a parameter string. 1 2-4 84/04/16 --------------------------------------------------------------- 2.0 SCRIPT COMMANDS 2.8 THE CALL COMMAND --------------------------------------------------------------- 2.8 THE CALL COMMAND + ________________ This command passes control to another script. The action is quite similar to a subroutine call, in that when the called script executes a RETURN command, the calling script will resume execution with the command immediately following the CALL. The first (positional) parameter is the name of the called script. Variable definitions may follow, separated from the script name by a comma. These definitions are performed before execution of the called script begins, and may be used as parameters to the called script. All variable definitions remain valid across CALL's and RETURN's; i.e., variables are declared globally. Scripts may be called recursively. The maximum depth of script nesting is a compile-time parameter, currently set at five. 2.9 THE RETURN COMMAND + __________________ This command returns control to the script that called the current one. If the current script was called by the CONVERS parameter string, execution of the program ends normally. 2.10 THE QUIT COMMAND + ________________ This command immediately terminates execution of CONVERS. If the current script is not the top level, a trace-back of script CALL's will be displayed. 2.11 THE IF COMMAND + ______________ This command marks the beginning of a sequence of commands that are conditionally executed. The sole parameter of the command is a boolean expression. If the expression is true, commands between this IF and a matching IFEND or ELSE will be executed. If the value of the expression is false, the following commands will be skipped. IF, ELSE and WHILE ranges may be nested to a maximum depth that is a compile- time constant (currently set to five). 2.12 THE ELSE COMMAND + ________________ This command reverses the effect of the most recent outstanding IF command. If the expression in the IF command was true, commands following the ELSE will be skipped. If the IF expression was false, commands following the ELSE will be executed. The ELSE command is illegal outside of 1 2-5 84/04/16 --------------------------------------------------------------- 2.0 SCRIPT COMMANDS 2.12 THE ELSE COMMAND --------------------------------------------------------------- the range of an IF command. 2.13 THE IFEND COMMAND + _________________ This command marks the end of the range of a matching IF command. 2.14 THE WHILE COMMAND + _________________ This command marks the beginning of a sequence of commands (terminated by a WHILEND command) that will be executed repeatedly. The boolean expression that is the only parameter of the WHILE command controls the repetition. If this expression is false the first time the WHILE is executed, the commands within the range of the WHILE are skipped. 2.15 THE WHILEND COMMAND + ___________________ This command marks the end of the range of a matching WHILE command. 2.16 THE DIAL COMMAND + ________________ This command executes an autodial operation on equipment with that feature. The single positional parameter is a string specifying the number to be dialed. The ':' character is used to indicate where the modem should wait for a new dial tone before proceeding. This command aborts if the equipment does not support autodialing, or if the communications software detects an error. 2.17 THE HANGUP COMMAND + __________________ This command terminates the communication link on equipment with this feature. This command is usually used with the DIAL command. 1 3-1 84/04/16 --------------------------------------------------------------- 3.0 EXECUTION OF CONVERS --------------------------------------------------------------- 3.0 EXECUTION OF CONVERS + ____________________ Each CONVERS script exists as a separate text file on the workstation. The file name is the name of the script. When CONVERS is started by the workstation operating system, it looks for a workstation file called CMDLINE. If the file exists, the first line is used as CONVERS' command string. If the file does not exist, CONVERS gets a parameter string from the user via the keyboard. (Hitting the escape key results in immediate exit from CONVERS.) The first expression in the parameter string is the name of the first script to be executed. The remainder of the line is interpreted as a series of variable definitions. The variables DISPLAY_COMMANDS and DISPLAY_LINK control the display of debugging information (see the previous section on variables). When either of these variables is true, the information requested is shown in a "window" on the display screen. During script debugging, these variables can be set to TRUE in the parameter string. (See the section on variables for more information.) (Note: The link display advances to the first position of a new line upon receipt of an ASCII line-feed character. The carriage return character is ignored.) The escape key on the workstation keyboard may be used to abort CONVERS execution at any time. This is especially useful during script debugging, when CONVERS cannot find a string that it is trying to MATCH. The UCSD operating system currently does not provide a means to pass a parameter string to an executing program. Therefore, the program first looks for a parameter string on a file called CMDLINE.TEXT on the system device. If that file does not exist or is empty, the user is prompted for the parameter string after program execution begins. If the EXECUTE command includes a parameter string to be passed to the called program, that string is written as a one-line file called CMDLINE.TEXT on the system device. 1 4-1 84/04/16 --------------------------------------------------------------- 4.0 SAMPLE SCRIPTS --------------------------------------------------------------- 4.0 SAMPLE SCRIPTS + ______________ Script ON_CIS: * * this script logs onto the CompuServ network. * Display, 'Waiting for carrier...' Wait Display, 'Logging onto system...' Pause Send Match, 'NAME:' Send, 'CIS' Match, 'ID:', ANYWHERE * * Substitute your own user id in the following command. * Send, 'userid' Match, 'WORD:', ANYWHERE * * Substitute your own password in the following command. * Send, 'password' Display, 'Waiting for prompt from MUSUS...' Match, 'FUNCTION:', ANYWHERE Send, 'op;br;t' Match, 'Function:', ANYWHERE Display, 'Logged onto MUSUS' Return 1 4-2 84/04/16 --------------------------------------------------------------- 4.0 SAMPLE SCRIPTS --------------------------------------------------------------- Script GET_LATEST: * * this script gets the latest mail summary from MUSUS, * and puts it into file MUSUS_SUM.TEXT. * Display, 'Logging onto CompuServ...' Call, on_cis Display, 'Downloading message summary...' Send, 'qs;n' Transfer,musus_sum, term='Function:' Display, 'Logging off CompuServ...' Send, 'off' Match, 'CONNECT', ANYWHERE Display, 'Executing summary review program...' Execute, look_sum * * Program look_sum displays each summary line, * and asks whether I want to see the full message. * If I do, the program writes the message number * into file MUSUS_NUM. At the end of the * summary, CONVERS is called with script GET_MSGS. * Script GET_MSGS: * * This script downloads selected messages from * MUSUS to the workstation. The message numbers * are specified, one per line, on file musus_num. * Display, 'Logging onto CompuServ...' Call, on_cis Define, cret_prompt = 'T)', to_end_prompt = 'END):' While, NOT $EOF ( musus_num ) Define, line = $READ ( musus_num ) Display, 'Downloading message ' // $VALUE( line ) Send, 'ri;' // $VALUE ( line ) Transfer, log, DOWNLOAD, TERM = $VALUE ( cret_prompt ) Send, 'rr' Transfer, log, DOWNLOAD, TERM = $VALUE ( cret_prompt ) Send, 'ns' Transfer, log, DOWNLOAD, TERM = $VALUE (to_end_prompt ) Send, 't' Whilend Display, 'Logging off CompuServ...' Send, 'off' Match, 'CONNECT', ANYWHERE Return 1 4-3 84/04/16 --------------------------------------------------------------- 4.0 SAMPLE SCRIPTS --------------------------------------------------------------- Script PRINT: * Script PRINT * * Version C5 * * This script prints a file (with added * carriage controls) on a system running * the Control Data NOS/VE operating system. * * Parameters: FILE - name of the file on local * processor (defaults to * *LISTING ); * TITLE - banner page heading for * listing (defaults to name * specified for parameter FILE) * * If, NOT $DEF( file ) Define, file = *LISTING Ifend * If, NOT $DEF( title ) Define, title = $VALUE( file ) Ifend * Define, ctl_t = $CHR( 20 ), quote = $CHR ( 39 ) Display, 'Configuring host for file transfer...' Send, 'collect_text, $LOCAL.listing' Match, '?' Display, 'Uploading file ' // $STR( $VALUE( file )) Transfer, $VALUE(file), UPLOAD, ADDCC, prompt='?' Send, '**' Match, '/' Display, 'Executing host print command...' Send, 'prif $LOCAL.listing,title='//$STR($VALUE(title)) Match, '/' Display, 'Printing competed' Return 1 1 84/04/16 Table of Contents 1.0 CONVERS CONCEPTS AND DEFINITIONS . . . . . . . . 1-1 1.1 PRINCIPLES OF CONVERS OPERATION . . . . . . . . . 1-1 1.2 DATA TYPES . . . . . . . . . . . . . . . . . . . 1-1 1.2.1 STRINGS . . . . . . . . . . . . . . . . . . . 1-1 1.2.2 INTEGERS . . . . . . . . . . . . . . . . . . 1-1 1.2.3 NAMES . . . . . . . . . . . . . . . . . . . . 1-1 1.3 STRING, INTEGER AND BOOLEAN CONSTANTS . . . . . . 1-2 1.4 VARIABLES . . . . . . . . . . . . . . . . . . . . 1-2 1.5 STRING OPERATORS . . . . . . . . . . . . . . . . 1-3 1.6 BOOLEAN OPERATORS . . . . . . . . . . . . . . . . 1-3 1.7 FUNCTIONS . . . . . . . . . . . . . . . . . . . . 1-3 1.7.1 THE $CHR FUNCTION . . . . . . . . . . . . . . 1-3 1.7.2 THE $VALUE FUNCTION . . . . . . . . . . . . . 1-3 1.7.3 THE $DEF FUNCTION . . . . . . . . . . . . . . 1-3 1.7.4 THE $READ FUNCTION . . . . . . . . . . . . . 1-4 1.7.5 THE $EOF FUNCTION . . . . . . . . . . . . . . 1-4 1.7.6 THE $EQ FUNCTION . . . . . . . . . . . . . . 1-4 1.7.7 THE $STR FUNCTION . . . . . . . . . . . . . . 1-4 1.7.8 THE $NAME FUNCTION . . . . . . . . . . . . . 1-4 1.8 SCRIPT COMMANDS . . . . . . . . . . . . . . . . . 1-4 1.9 ERRORS DURING COMMAND EXECUTION . . . . . . . . . 1-5 2.0 SCRIPT COMMANDS . . . . . . . . . . . . . . . . . 2-1 2.1 THE SEND COMMAND . . . . . . . . . . . . . . . . 2-1 2.2 THE MATCH COMMAND . . . . . . . . . . . . . . . . 2-1 2.3 THE TRANSFER COMMAND . . . . . . . . . . . . . . 2-2 2.4 THE WAIT COMMAND . . . . . . . . . . . . . . . . 2-3 2.5 THE PAUSE COMMAND . . . . . . . . . . . . . . . . 2-3 2.6 THE DEFINE COMMAND . . . . . . . . . . . . . . . 2-3 2.7 THE EXECUTE COMMAND . . . . . . . . . . . . . . . 2-3 2.8 THE CALL COMMAND . . . . . . . . . . . . . . . . 2-4 2.9 THE RETURN COMMAND . . . . . . . . . . . . . . . 2-4 2.10 THE QUIT COMMAND . . . . . . . . . . . . . . . . 2-4 2.11 THE IF COMMAND . . . . . . . . . . . . . . . . . 2-4 2.12 THE ELSE COMMAND . . . . . . . . . . . . . . . . 2-4 2.13 THE IFEND COMMAND . . . . . . . . . . . . . . . 2-5 2.14 THE WHILE COMMAND . . . . . . . . . . . . . . . 2-5 2.15 THE WHILEND COMMAND . . . . . . . . . . . . . . 2-5 2.16 THE DIAL COMMAND . . . . . . . . . . . . . . . . 2-5 2.17 THE HANGUP COMMAND . . . . . . . . . . . . . . . 2-5 3.0 EXECUTION OF CONVERS . . . . . . . . . . . . . . 3-1 4.0 SAMPLE SCRIPTS . . . . . . . . . . . . . . . . . 4-1 1 --EOR-- ======================================================================================== DOCUMENT :usus Folder:VOL29:convers.text ======================================================================================== {$S++} PROGRAM convers; {$C Copyright 1981, 1982, 1983, 1984 by John Dykstra. All rights reserved. } { CONVERS - Release 1 - 7/3/82 } { Release 2 - 1/10/83 } { Release 3 - 1/01/84 } USES screenops, (*$U remunit.code*) remunit, (*$U textio.code*) textio, (*$U osmisc.code*) osmisc; {$P} CONST { Constants that define the characteristics of the serial link. } default_baud = 0; { Default baud rate used - zero means search } use_par = TRUE; { Use parity checking } even_par = TRUE; { Even parity } char_size = 7; { Link character size, in bits } stop_bits = 1; { Number of stop bits for link } { Miscellaneous program constants which may be changed in the future. } version = 'C9'; { Program version } copyr_msg= 'Copyright 1981, 1982, 1983, 1984 by John Dykstra. All rights reserved.'; max_open_files = 5; { Number of transfer files open at once } sym_tbl_size = 30; { size of the symbol table } max_nest_level = 5; { max levels of script nesting } max_cnd_level = 5; { max levels of conditional nesting } max_name_size = 32; { Max size of names } max_cmd_size = 8; { max chars in a command name } max_script_line = 80; { Max length of line in script } { Program constants that will probably never change. } ch_lf = 10; { ASCII line feed character } ch_cr = 13; { ASCII carriage return character } ch_ff = 12; { ASCII form feed character } ch_esc = 27; { ASCII } console = 1; { unit number of CONSOLE: } { Screen format addresses } header_x = 31; header_y = 0; { Program identification header } status_x = 0; status_y = 5; { Start of status box } cmd_x = 0; cmd_y = 7 ; { Start of command box } link_x = 0; link_y = 11; { Start of text display field } {$P} TYPE script_line = STRING [ max_script_line ]; command_name = STRING [ max_cmd_size ]; long_string = STRING [ 255 ]; script_index = 1 .. max_script_line; name_type = STRING [ max_name_size ]; string_type = STRING [ max_script_line ]; { The script status types } script_status = ARRAY [ 1..max_nest_level ] OF RECORD script_name: STRING; line_number: INTEGER; END; { RECEND } { Conditional status types } cnd_kinds = ( if_cnd, el_cnd, wh_cnd ); cnd_status = ARRAY [ 1..max_cnd_level ] OF RECORD skip_flag: BOOLEAN; CASE cnd_kind: cnd_kinds OF wh_cnd: ( line_num: INTEGER ); if_cnd: ( ); el_cnd: ( ); END; { RECEND } { Lexical tokens definitions } token_kinds = ( nam_tok, str_tok, int_tok, equ_tok, com_tok, eol_tok, con_tok, fun_tok, lpn_tok, rpn_tok, log_tok, not_tok, bad_tok, no_tok ); set_of_token_kinds = SET OF token_kinds; token_type = RECORD CASE tok_kind: token_kinds OF int_tok: ( int_val: INTEGER ); str_tok: ( str_val: string_type ); nam_tok: ( nam_val: name_type ); fun_tok: ( fun_val: name_type ); log_tok: ( log_val: BOOLEAN ); END; { RECEND } { function definitions } fun_kinds = ( chr_fun, val_fun, read_fun, eof_fun, eq_fun, str_fun, nam_fun, def_fun, bad_fun ); { error message severity levels } error_level = ( warning, fatal, catastrophic ); time_period = INTEGER; { Command definitions } cmd_kinds = ( cal_cmd, com_cmd, def_cmd, dis_cmd, exe_cmd, mat_cmd, qui_cmd, ret_cmd, sen_cmd, pau_cmd, tra_cmd, wai_cmd, if_cmd, els_cmd, ife_cmd, whi_cmd, whe_cmd, dia_cmd, han_cmd, bad_cmd ); { reserved variable names } res_kinds = ( res_command, res_line, res_unknown ); { Symbol table types } symtbl_entry = RECORD name: name_type; value: token_type; END; { RECEND } sym_tbl_index = 1..sym_tbl_size; { Transfer file table entry } tran_entry = RECORD name: name_type; now_open: BOOLEAN; direction: io_direction; file_blk: io_file; END; tran_range = 1..max_open_files; { The translate table is used to translate ASCII characters into upper-case { or printable (non-control) characters only. } xlate_entry = RECORD upper: CHAR; no_ctl: CHAR; END; {$P} VAR cur_script_line: script_line; { current script line } exit_requested: BOOLEAN; { user hit ESC on keyboard } command: token_type; { current command name } delim_tok: token_type; { delimiter of command name } alpha_chars: SET OF CHAR; { All alphabetic characters } visible_chars: SET OF CHAR; { All printables (not space) } script_file: io_file; { The script input file } script_name: STRING; { the script file title } exit_condition: BOOLEAN; { Some reason found to exit prog } successful: BOOLEAN; { Command processor was successful } sym_table: ARRAY [ sym_tbl_index ] OF symtbl_entry; { The symbol table } highest_entry_index: 0..sym_tbl_size;{ Index of top entry in symbol table } nest_stack: script_status; { Keeps track of script nesting } script_level: 1..max_nest_level; { current script nesting level } cnd_stack: cnd_status; { keeps track of condition nesting } cnd_level: 0..max_cnd_level; { current conditional nesting level } tok_table: ARRAY [ token_kinds ] OF STRING [ 7 ]; { Names of tokens for error messages } tran_tbl: ARRAY [ tran_range ] OF tran_entry; { Table of open transfer files } fun_names: ARRAY [ fun_kinds ] OF STRING [ 7 ]; { Names of functions } cmd_names: ARRAY [ cmd_kinds ] OF command_name; { Names of all commands } var_names: ARRAY [ res_kinds ] OF name_type; { Names of reserved variables } cmd_index: cmd_kinds; { Index of current command } skipping: BOOLEAN; { Currently skipping command } cnd_cmds: SET OF cmd_kinds; { Conditional commands } xlate_tbl: ARRAY [ CHAR ] OF xlate_entry; { Translates characters } link_dis_line: INTEGER; { Where we're displaying text } cmd_display: BOOLEAN; { Display all commands } link_display: BOOLEAN; { Display downline text } max_screen_y: INTEGER; { Maximum y for GOTOXY } {$P} { Forward procedure declarations } PROCEDURE get_token ( VAR line: script_line; expected: set_of_token_kinds; VAR token: token_type ); FORWARD; PROCEDURE eval_expr ( VAR line: script_line; exp_type: set_of_token_kinds; exp_delim: set_of_token_kinds; VAR value: token_type; VAR delim: token_type ); FORWARD; PROCEDURE error ( level: error_level; message: STRING ); FORWARD; PROCEDURE make_upper ( VAR symbol: STRING ); FORWARD; PROCEDURE get_tran_file ( file_name: script_line; direction: io_direction; VAR tbl_index: tran_range ); FORWARD; PROCEDURE close_all_files; FORWARD; PROCEDURE close_tran_file ( tbl_index: tran_range ); FORWARD; PROCEDURE match ( text_line: string_type; quiet_ending: BOOLEAN; period: time_period; VAR complete_match: BOOLEAN ); FORWARD; PROCEDURE do_define ( line: script_line ); FORWARD; PROCEDURE check_kb ( VAR exit_seen: BOOLEAN); FORWARD; {$P} SEGMENT PROCEDURE initialize; TYPE baud_rates = ( baud_9600, baud_1200, baud_300, baud_110, all_tried ); VAR rem_exists, dialer_exists: BOOLEAN; bauds: ARRAY [ baud_rates ] OF INTEGER; attempted_baud_rate: baud_rates; table_index: 1..max_open_files; result: cr_baud_result; index: CHAR; PROCEDURE init_screen; VAR info: sc_info_type; box_line: STRING [ 80 ]; BEGIN { PROCEDURE init_screen } { Get the screen height from SCREENOPS. This is used to decide how far { we can write while displaying downlink data. } sc_use_info ( sc_get, info ); max_screen_y := info.misc_info.height; sc_clr_screen; GOTOXY ( header_x, header_y ); WRITE ( 'CONVERS Version ', version ); GOTOXY ( header_x - 26, header_y + 2 ); WRITE ( copyr_msg ); { Put the status box onto the screen, with an initializing message. { This message will be overlaid with the first message from the script. } box_line := '----------------------------------------'; box_line := CONCAT ( box_line, box_line ); GOTOXY ( status_x, status_y ); WRITE ( box_line ); GOTOXY ( status_x, status_y + 1 ); WRITE ( '| Status: Initializing' ); GOTOXY ( 79, status_y + 1 ); WRITE ( '|' ); GOTOXY ( status_x, status_y + 2 ); WRITE ( box_line ); END; { PROCEDURE init_screen } PROCEDURE init_tables; BEGIN { Initialize the token table, used for error messages by get_token. } tok_table [ nam_tok ] := 'name'; tok_table [ str_tok ] := 'string'; tok_table [ int_tok ] := 'integer'; tok_table [ equ_tok ] := '"="'; tok_table [ com_tok ] := '","'; tok_table [ eol_tok ] := ''; tok_table [ con_tok ] := '"//"'; tok_table [ fun_tok ] := 'functn'; tok_table [ lpn_tok ] := '"("'; tok_table [ rpn_tok ] := '")"'; tok_table [ log_tok ] := 'bool'; tok_table [ not_tok ] := '"NOT"'; tok_table [ bad_tok ] := 'int err'; tok_table [ no_tok ] := 'int err'; { Initialize the command name table. } cmd_names [ cal_cmd ] := 'CALL'; cmd_names [ com_cmd ] := '*'; cmd_names [ def_cmd ] := 'DEFINE'; cmd_names [ dis_cmd ] := 'DISPLAY'; cmd_names [ els_cmd ] := 'ELSE'; cmd_names [ if_cmd ] := 'IF'; cmd_names [ ife_cmd ] := 'IFEND'; cmd_names [ exe_cmd ] := 'EXECUTE'; cmd_names [ mat_cmd ] := 'MATCH'; cmd_names [ pau_cmd ] := 'PAUSE'; cmd_names [ qui_cmd ] := 'QUIT'; cmd_names [ ret_cmd ] := 'RETURN'; cmd_names [ sen_cmd ] := 'SEND'; cmd_names [ tra_cmd ] := 'TRANSFER'; cmd_names [ wai_cmd ] := 'WAIT'; cmd_names [ whe_cmd ] := 'WHILEND'; cmd_names [ whi_cmd ] := 'WHILE'; cmd_names [ dia_cmd ] := 'DIAL'; cmd_names [ han_cmd ] := 'HANGUP'; cmd_names [ bad_cmd ] := ''; { Initialize the function name table } fun_names [ chr_fun ] := '$CHR'; fun_names [ val_fun ] := '$VALUE'; fun_names [ read_fun ] := '$READ'; fun_names [ eof_fun ] := '$EOF'; fun_names [ eq_fun ] := '$EQ'; fun_names [ nam_fun ] := '$NAME'; fun_names [ str_fun ] := '$STR'; fun_names [ def_fun ] := '$DEF'; { Initialize the reserved variable table } var_names [ res_command ] := 'DISPLAY_COMMANDS'; var_names [ res_line ] := 'DISPLAY_LINK'; var_names [ res_unknown ] := ''; END; { PROCEDURE init_tables } PROCEDURE process_parameters; VAR param_line: script_line; { Program parameter line } script: token_type; delim: token_type; successful: BOOLEAN; BEGIN { PROCEDURE process_parameters } os_get_param_line ( param_line ); { The following IF/EXIT is present to kludge around a IV bug that { prevents EXIT from UNITs. } IF LENGTH ( param_line ) = 0 THEN EXIT ( PROGRAM ); eval_expr ( param_line, [ nam_tok ], [ eol_tok, com_tok ], command, delim_tok ); nest_stack [ 1 ] . script_name := command.nam_val; io_open_file ( script_file, nest_stack [ 1 ].script_name, io_input, successful ); IF NOT successful THEN error ( fatal, CONCAT ( 'Cannot find script ', command.nam_val ) ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while opening script file' ); do_define ( param_line ); END; { PROCEDURE process_parameters } BEGIN { SEGMENT PROCEDURE initialize } { Preset the display screen. } init_screen; { Initialize the serial interface link } bauds [ baud_9600 ] := 9600; bauds [ baud_1200 ] := 1200; bauds [ baud_300 ] := 300; bauds [ baud_110 ] := 110; cr_comminit ( cr_orig, CHR ( ch_esc ), rem_exists, dialer_exists ); IF NOT rem_exists THEN error ( catastrophic, 'Remote interface cannot be initialized' ); { If no default baud rate has been specified by a compilation constant { (the usual case), try each baud rate in turn until REMUNIT accepts one. { If a default baud rate has been specified, just try that one. } IF default_baud = 0 THEN BEGIN attempted_baud_rate := baud_9600; REPEAT cr_setcommunications ( use_par, even_par, bauds [ attempted_baud_rate ], char_size, stop_bits, cr_orig, '', result ); attempted_baud_rate := SUCC ( attempted_baud_rate ); UNTIL ( result = cr_rate_set_ok ) OR ( result = cr_select_not_supported ) OR ( attempted_baud_rate = all_tried ); END ELSE cr_setcommunications ( TRUE, TRUE, default_baud, char_size, stop_bits, cr_orig, '', result ); IF ( result <> cr_rate_set_ok ) AND (result <> cr_select_not_supported ) THEN error ( catastrophic, 'Cannot set link baud rate' ); alpha_chars := [ 'A'..'Z', 'a'..'z' ]; visible_chars := [ '!' .. CHR ( 127 ) ]; script_level := 1; highest_entry_index := 0; skipping := FALSE; cnd_cmds := [ if_cmd, ife_cmd, els_cmd, whi_cmd, whe_cmd ]; { Initialize the transfer file table. } FOR table_index := 1 TO max_open_files DO tran_tbl [ table_index ] . now_open := FALSE; { Initialize the Pascal variables that implement the reserved variables. } cmd_display := FALSE; link_display := FALSE; { Initialize the condition stack. } cnd_level := 0; { Initialize xlate_tbl. This table is used to translate names (and other { character strings) to all-upper-case, or non-control characters. } FOR index := CHR ( 0 ) TO CHR ( 127 ) DO BEGIN IF index IN [ 'a'..'z' ] THEN xlate_tbl [ index ].upper := CHR ( ORD ( index ) - 32 ) ELSE xlate_tbl [ index ] . upper := index; IF index <= ' ' THEN xlate_tbl [ index ] . no_ctl := ' ' ELSE xlate_tbl [ index ] . no_ctl := index; END; { FOREND } { Initialize other "constant" tables. This is done in a separate procedure { due to a UCSD II.0 limitation on the size of a procedure. } init_tables; { Process the program parameters. } process_parameters; END; { SEGMENT PROCEDURE initialize } {$P} SEGMENT PROCEDURE transfer_command ( line: script_line; VAR successful: BOOLEAN ); CONST ch_cr = 13; { ASCII carriage return } TYPE trans_direction = ( download, upload ); VAR direction: trans_direction; usecc_mode: BOOLEAN; line_mode: BOOLEAN; term_string: name_type; prompt_string: script_line; file_name: name_type; period: time_period; PROCEDURE scan_command ( line: script_line; VAR file_name: name_type; VAR direction: trans_direction; VAR usecc_mode: BOOLEAN; VAR term_string: name_type; VAR period: time_period ); VAR value: token_type; token: token_type; keyword: token_type; BEGIN { PROCEDURE scan_command } { Get the filename ( first symbol in the command ). } eval_expr ( line, [ nam_tok ], [ com_tok, eol_tok ], value, token ); file_name := value.nam_val; { Set the defaults if the appropriate keywords are not encountered. } direction := download; usecc_mode := FALSE; line_mode := FALSE; term_string := ''; prompt_string := ''; period := 300; { Scan the command line for keywords. } WHILE token.tok_kind <> eol_tok DO BEGIN eval_expr ( line, [ nam_tok ], [ com_tok, eol_tok, equ_tok ], keyword, token ); IF keyword.nam_val = 'UPLOAD' THEN direction := upload; IF keyword.nam_val = 'DOWNLOAD' THEN direction := download; IF keyword.nam_val = 'ADDCC' THEN usecc_mode := TRUE; IF keyword.nam_val = 'USECC' THEN usecc_mode := TRUE; IF keyword.nam_val = 'LINE' THEN line_mode := TRUE; IF keyword.nam_val = 'TERM' THEN BEGIN eval_expr ( line, [ str_tok ], [ com_tok, eol_tok ], value, token ); term_string := value.str_val; make_upper ( term_string ); END; IF keyword.nam_val = 'PROMPT' THEN BEGIN eval_expr ( line, [ str_tok ], [ com_tok, eol_tok ], value, token ); prompt_string := value.str_val; make_upper ( prompt_string ); END; IF keyword.nam_val = 'PERIOD' THEN BEGIN eval_expr ( line, [ int_tok ], [ com_tok, eol_tok], value, token ); period := value.int_val; END; END; { WHILEND } END; { PROCEDURE scan_command } PROCEDURE do_upload ( file_name: name_type; usecc_mode: BOOLEAN; line_mode: BOOLEAN; prompt_string: script_line; period: time_period ); CONST ch_ff = 12; { ASCII form feed character } VAR buffer: STRING [ 255 ]; index: 0..255; successful: BOOLEAN; tbl_index: tran_range; BEGIN { PROCEDURE do_upload } { Open the transfer file. If we are in ADDCC mode, write { a first line containing only a carriage control of "1". } get_tran_file ( file_name, io_input, tbl_index ); IF usecc_mode THEN BEGIN cr_putrem ( '1' ); cr_putrem ( CHR ( ch_cr ) ); END; { IFEND } IF NOT io_end_of_file ( tran_tbl [ tbl_index ] . file_blk ) THEN BEGIN REPEAT io_read_line ( tran_tbl [ tbl_index ] . file_blk, buffer ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while transfering file' ); IF usecc_mode AND ( LENGTH ( buffer ) > 0 ) THEN BEGIN { Add carriage control character } index := SCAN( LENGTH ( buffer ), = CHR ( ch_ff ), buffer [ 1 ] ) + 1; IF ( index < LENGTH ( buffer ) ) THEN BEGIN DELETE ( buffer, index, 1 ); cr_putrem ( '1' ); END ELSE cr_putrem ( ' ' ); END; { IFEND Add carriage control } FOR index := 1 to LENGTH ( buffer ) DO BEGIN IF NOT cr_carrier THEN error ( fatal, 'Lost carrier during upload' ); cr_putrem ( buffer [ index ] ); END; { FOREND } cr_putrem ( CHR ( ch_cr ) ); IF ( LENGTH ( prompt_string ) > 0 ) AND NOT io_end_of_file ( tran_tbl [ tbl_index ] . file_blk ) THEN BEGIN match ( prompt_string, FALSE, period, successful ); IF NOT successful THEN error ( fatal, 'Did not see prompt within specified period' ); END; check_kb ( exit_requested ); UNTIL io_end_of_file ( tran_tbl [ tbl_index ] . file_blk ) OR exit_requested OR line_mode; END; { IFEND } IF io_end_of_file ( tran_tbl [ tbl_index ] . file_blk ) THEN close_tran_file ( tbl_index ); END; { PROCEDURE do_upload } PROCEDURE do_download ( file_name: name_type; term_string: name_type; usecc_mode: BOOLEAN ); VAR buffer: long_string; buffer_index: 1..255; ch: CHAR; term_index: script_index; terminated: BOOLEAN; tbl_index: tran_range; BEGIN { PROCEDURE do_download } get_tran_file ( file_name, io_output, tbl_index ); {$R-} { Disable range checking for speed in these loops. } REPEAT { for each line } buffer [ 0 ] := CHR ( 255 ); buffer_index := 1; term_index := 1; terminated := FALSE; REPEAT { for each character } REPEAT check_kb ( exit_requested ); UNTIL cr_remstat OR exit_requested; IF NOT exit_requested THEN BEGIN ch := cr_getrem; IF ch >= ' ' THEN BEGIN buffer [ buffer_index ] := ch; buffer_index := buffer_index + 1; END; { IFEND } IF xlate_tbl [ ch ] . upper = term_string [ term_index ] THEN BEGIN IF term_index < LENGTH ( term_string ) THEN term_index := term_index + 1 ELSE terminated := TRUE; END ELSE term_index := 1; END; UNTIL terminated OR ( ch = CHR ( ch_cr ) ) OR exit_requested OR NOT cr_carrier; buffer [ 0 ] := CHR ( buffer_index - 1 ); { If processing carriage controls and the first character in the { line is a "1", write an ASCII FF character as the first character { in the line. Delete any other value of carriage control character. } IF usecc_mode THEN IF LENGTH ( buffer ) > 0 THEN IF buffer [ 1 ] = '1' THEN buffer [ 1 ] := CHR ( ch_ff ) ELSE DELETE ( buffer, 1, 1 ); IF NOT terminated THEN BEGIN io_write_line ( tran_tbl [ tbl_index ] . file_blk, buffer ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while writing transfer file' ); END; UNTIL terminated OR exit_requested OR NOT cr_carrier ; {$R+} { Reenable range checking. } IF NOT cr_carrier THEN error ( fatal, 'Carrier lost during download' ); close_tran_file ( tbl_index ); END; { PROCEDURE do_download } BEGIN { PROCEDURE transfer_command } successful := FALSE; { in case a called procedure exits } scan_command ( line, file_name, direction, usecc_mode, term_string, period ); CASE direction OF download: BEGIN IF LENGTH ( term_string ) = 0 THEN error ( fatal, 'Termination string must be specifed for download.'); do_download ( file_name, term_string, usecc_mode ); END; { CASE ITEM } upload: do_upload ( file_name, usecc_mode, line_mode, prompt_string, period ); END; { CASEND } successful := TRUE; END; { SEGMENT PROCEDURE transfer_command } {$P} PROCEDURE setup_display; VAR box_line: STRING [ 80 ]; BEGIN { PROCEDURE setup_display } box_line := '----------------------------------------'; box_line := CONCAT ( box_line, box_line ); sc_eras_eos ( cmd_x, cmd_y+1 ); IF cmd_display THEN BEGIN GOTOXY ( cmd_x, cmd_y ); WRITE ( box_line ); GOTOXY ( cmd_x, cmd_y + 1 ); WRITE ( '| Command:' ); GOTOXY ( 79, cmd_y + 1 ); WRITE ( '|' ); GOTOXY ( cmd_x, cmd_y + 2 ); WRITE ( box_line ); END; { IFEND } IF link_display THEN BEGIN GOTOXY ( link_x, link_y ); WRITE ( 'Downlink text: ' ); GOTOXY ( link_x, link_y + 2 ); END; { IFEND } { Note that we always initialize link_dis_line, even if we are not { displaying link text, because this is where we always put the { cursor when we're not writing something to the screen. } link_dis_line := link_y + 2; END; { PROCEDURE setup_display } {$P} PROCEDURE check_kb { ( VAR exit_seen: BOOLEAN ) }; CONST ch_esc = 27; { ASCII ESC character } BEGIN { PROCEDURE check_kb } { If the user hits ESC on the keyboard, return with exit_seen TRUE. { Otherwise, don't change it. } IF cr_kbstat THEN IF cr_getkb = CHR ( ch_esc ) THEN exit_seen := TRUE; END; { PROCEDURE check_kb } {$P} PROCEDURE display_status ( message: STRING ); BEGIN { PROCEDURE display_status } GOTOXY ( status_x + 11, status_y + 1 ); WRITE ( message: 64 ); GOTOXY ( 0, link_dis_line ); END; { PROCEDURE display_status } {$P} PROCEDURE error { ( level: error_level; message: STRING ) }; VAR prefix: STRING [ 25 ]; BEGIN { PROCEDURE error } CASE level OF warning: prefix := 'Warning - ' ; fatal: prefix := 'Fatal error - ' ; catastrophic: prefix := 'Catastrophic error - ' ; END; { CASEND } display_status ( CONCAT ( prefix, message )); IF level > warning THEN BEGIN close_all_files; os_clear_commands; EXIT ( PROGRAM ); END; END; { PROCEDURE error } {$P} PROCEDURE get_tran_file { ( file_name: script_line; direction: io_direction; VAR tbl_index: tran_range ) }; VAR open_successful: BOOLEAN; BEGIN { PROCEDURE get_tran_file } { First, check to see if the file is already open. } tbl_index := 1; WHILE ( ( tran_tbl [ tbl_index ] . name <> file_name ) OR ( tran_tbl [ tbl_index ] . direction <> direction ) OR ( NOT tran_tbl [ tbl_index ] . now_open ) ) AND ( tbl_index < max_open_files ) DO tbl_index := tbl_index + 1; IF ( tran_tbl [ tbl_index ] . name <> file_name ) OR NOT tran_tbl [ tbl_index ] . now_open OR ( tran_tbl [ tbl_index ] . direction <> direction ) THEN BEGIN { File not already open, so search for vacant table entry. } tbl_index := 1; WHILE tran_tbl [ tbl_index ].now_open AND ( tbl_index < max_open_files ) DO tbl_index := tbl_index + 1; IF tran_tbl [ tbl_index ] . now_open THEN error ( fatal, 'Maximum number of files already open' ); tran_tbl [ tbl_index ] . name := file_name; tran_tbl [ tbl_index ] . direction := direction; tran_tbl [ tbl_index ] . now_open := TRUE; io_open_file ( tran_tbl [ tbl_index ] . file_blk, file_name, direction, open_successful ); IF NOT open_successful THEN error ( fatal, CONCAT ( 'Cannot open transfer file ', file_name ) ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while opening transfer file' ); END; { IFEND } END; { PROCEDURE get_tran_file } {$P} PROCEDURE close_tran_file { tbl_index: tran_range }; BEGIN io_close_file ( tran_tbl [ tbl_index ] . file_blk ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while closing transfer file' ); tran_tbl [ tbl_index ] . now_open := FALSE; END; { PROCEDURE close_tran_file } {$P} PROCEDURE close_all_files; VAR tbl_index: 1..max_open_files; BEGIN { PROCEDURE close_all_files } FOR tbl_index := 1 TO max_open_files DO IF tran_tbl [ tbl_index ] . now_open THEN close_tran_file ( tbl_index ); END; { PROCEDURE close_all_files } {$P} PROCEDURE make_upper { ( VAR symbol: STRING ) }; VAR index: 1..255; BEGIN { PROCEDURE make_upper } FOR index := 1 TO LENGTH ( symbol ) DO symbol [ index ] := xlate_tbl [ symbol [ index ] ] . upper; END; { PROCEDURE make_upper } {$P} PROCEDURE get_token { ( VAR line: script_line; expected: set_of_token_kinds; VAR token: token_type ) }; VAR index: script_index; saved_line: script_line; token_index: token_kinds; msg_text: STRING [ 255 ]; PROCEDURE get_symbol; VAR symbol_length: 0..max_name_size; symbol_done: BOOLEAN; BEGIN { PROCEDURE get_symbol } symbol_length := 0; REPEAT symbol_length := symbol_length + 1; IF index + symbol_length <= LENGTH ( line ) THEN symbol_done := NOT ( line [ index + symbol_length ] IN [ 'a'..'z', 'A'..'Z', '0'..'9','_', '$', '.', '*', ':' ] ) ELSE symbol_done := TRUE; UNTIL symbol_done; token.tok_kind := nam_tok; token.nam_val := COPY ( line, index, symbol_length ); make_upper ( token.nam_val ); IF ( token.nam_val = 'TRUE' ) OR ( token.nam_val = 'YES' ) THEN BEGIN token.tok_kind := log_tok; token.log_val := TRUE; END ELSE IF (token.nam_val = 'FALSE' ) OR ( token.nam_val = 'NO' ) THEN BEGIN token.tok_kind := log_tok; token.log_val := FALSE; END ELSE IF token.nam_val = 'NOT' THEN token.tok_kind := not_tok; index := index + symbol_length; END; { PROCEDURE get_symbol } PROCEDURE get_number; VAR more_to_go: BOOLEAN; BEGIN { PROCEDURE get_number } token.int_val := 0; REPEAT BEGIN token.int_val := ORD ( line [ index ] ) - 48 + ( token.int_val * 10 ); index := index + 1; IF index <= LENGTH ( line ) THEN more_to_go := line [ index ] IN [ '0'..'9' ] ELSE more_to_go := FALSE; END; { WHILEND } UNTIL NOT more_to_go; END; { PROCEDURE get_number } PROCEDURE get_string; VAR string_length: 0..max_script_line; string_done: BOOLEAN; BEGIN { PROCEDURE get_string } string_length := 0; index := index + 1; REPEAT IF ( index + string_length <= LENGTH ( line ) ) AND ( string_length < max_script_line ) THEN string_done := line [ index + string_length ] = '''' ELSE string_done := TRUE; IF NOT string_done THEN string_length := string_length + 1; UNTIL string_done; token.str_val := COPY ( line, index, string_length ); index := index + string_length + 1; END; { PROCEDURE get_string } BEGIN { PROCEDURE get_token } saved_line := line; token.tok_kind := no_tok; IF LENGTH ( line ) > 0 THEN BEGIN index := 1; REPEAT CASE line [ index ] OF ' ': index := index + 1; ',': BEGIN token.tok_kind := com_tok; index := index + 1; END; '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','.','_','*',':': BEGIN get_symbol; END; '$': BEGIN get_symbol; token.tok_kind := fun_tok; END; '0','1','2','3','4','5','6','7','8','9': BEGIN token.tok_kind := int_tok; get_number; END; '(': BEGIN token.tok_kind := lpn_tok; index := index + 1; END; ')': BEGIN token.tok_kind := rpn_tok; index := index + 1; END; '=': BEGIN token.tok_kind := equ_tok; index := index + 1; END; '/': BEGIN IF index < LENGTH ( line ) THEN IF line [ index + 1 ] = '/' THEN BEGIN token.tok_kind := con_tok; index := index + 2; END; IF token.tok_kind <> con_tok THEN BEGIN token.tok_kind := bad_tok; index := index + 1; END; END; { CASE ITEM } '''': BEGIN token.tok_kind := str_tok; get_string; END; '!','"','#','%','&','+','-',';','<','>', '?','@','[','\',']','^','`','{','|','}','~': BEGIN token.tok_kind := bad_tok; index := index + 1; END; END; { CASEND } UNTIL ( token.tok_kind <> no_tok ) OR ( index > LENGTH ( line ) ); DELETE ( line, 1, index - 1 ); END; { IFEND } IF ( token.tok_kind = no_tok ) AND ( LENGTH ( line ) = 0 ) THEN token.tok_kind := eol_tok; IF NOT ( token.tok_kind IN expected ) THEN BEGIN { report error } msg_text := 'Command syntax error - Expected '; FOR token_index := nam_tok TO no_tok DO IF token_index IN expected THEN msg_text := CONCAT ( msg_text, tok_table [ token_index ], ', ' ); error ( fatal, COPY ( msg_text, 1, LENGTH ( msg_text ) - 2 ) ); END; { IFEND report error } END; { PROCEDURE get_token } {$P} PROCEDURE lookup_variable ( VAR name: token_type; VAR found: BOOLEAN ); VAR table_index: sym_tbl_index; BEGIN { PROCEDURE lookup_variable } { Search the variable table for a match with the variable name. } found := TRUE; IF highest_entry_index > 0 THEN FOR table_index := 1 TO highest_entry_index DO IF sym_table [ table_index ] . name = name.nam_val THEN BEGIN { match found } name := sym_table [ table_index ] . value; EXIT ( lookup_variable ); END; { IFEND } { No match was found. } found := FALSE; END; { PROCEDURE lookup_variable } {$P} PROCEDURE eval_func ( VAR line: script_line; exp_type: set_of_token_kinds; VAR value: token_type ); VAR temp_token: token_type; temp2_token: token_type; delim_token: token_type; fun_index: fun_kinds; tbl_index: tran_range; variable_found: BOOLEAN; BEGIN { PROCEDURE eval_func } make_upper ( value.fun_val ); fun_index := chr_fun; WHILE ( value.fun_val <> fun_names [ fun_index ] ) AND ( fun_index < bad_fun ) DO fun_index := SUCC ( fun_index ); CASE fun_index OF chr_fun: BEGIN get_token ( line, [ lpn_tok ], delim_token ); get_token ( line, [ int_tok ], temp_token ); IF (temp_token.int_val < 0 ) OR ( temp_token.int_val > 127 ) THEN error ( fatal, '$CHR parameter not 0..127' ); value.tok_kind := str_tok; value.str_val := 'x'; value.str_val [ 1 ] := CHR ( temp_token.int_val ); get_token ( line, [ rpn_tok ], delim_token ); END; { CASE ITEM } val_fun: BEGIN get_token ( line, [ lpn_tok ], delim_token ); eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token, delim_token ); lookup_variable ( temp_token, variable_found ); IF NOT variable_found THEN error ( fatal, CONCAT ( 'Variable ', temp_token.nam_val, ' has not been defined' )); value := temp_token; END; { CASE ITEM } read_fun: BEGIN get_token ( line, [ lpn_tok ], delim_token ); eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token, delim_token ); get_tran_file ( temp_token.nam_val, io_input, tbl_index ); value.tok_kind := str_tok; io_read_line ( tran_tbl [ tbl_index ] . file_blk, value.str_val ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while reading file' ); END; { CASE ITEM } eof_fun: BEGIN get_token ( line, [ lpn_tok ], delim_token ); eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token, delim_token ); get_tran_file ( temp_token.nam_val, io_input, tbl_index ); value.tok_kind := log_tok; value.log_val := io_end_of_file ( tran_tbl [ tbl_index ] . file_blk ); END; { CASE ITEM } eq_fun: BEGIN get_token ( line, [ lpn_tok ], delim_token ); eval_expr ( line, [ nam_tok, str_tok, int_tok, log_tok ], [ com_tok ], temp_token, delim_token ); eval_expr ( line, [ temp_token.tok_kind ], [ rpn_tok ], temp2_token, delim_token ); value.tok_kind := log_tok; CASE temp_token.tok_kind OF nam_tok: value.log_val:=temp_token.nam_val=temp2_token.nam_val; str_tok: value.log_val:=temp_token.str_val=temp2_token.str_val; int_tok: value.log_val:=temp_token.int_val=temp2_token.int_val; log_tok: value.log_val:=temp_token.log_val=temp2_token.log_val; END; { CASEND } END; { CASE ITEM } str_fun: BEGIN get_token ( line, [ lpn_tok ], delim_token ); eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token, delim_token ); value.tok_kind := str_tok; value.str_val := temp_token.nam_val; END; { CASE ITEM } nam_fun: BEGIN get_token ( line, [ lpn_tok ], delim_token ); eval_expr ( line, [ str_tok ], [ rpn_tok ], temp_token, delim_token ); value.tok_kind := nam_tok; value.nam_val := temp_token.str_val; END; { CASE ITEM } def_fun: BEGIN get_token ( line, [ lpn_tok ], delim_token ); eval_expr ( line, [ nam_tok ], [ rpn_tok ], temp_token, delim_token ); lookup_variable ( temp_token, variable_found ); value.tok_kind := log_tok; value.log_val := variable_found; END; { CASE ITEM } bad_fun: error ( fatal, 'Unknown function name' ); END; { CASEND } IF NOT ( value.tok_kind IN exp_type ) THEN error ( fatal, 'Function is not of expected type' ); END; { PROCEDURE eval_func } {$P} PROCEDURE eval_expr { ( VAR line: script_line; exp_type: set_of_token_kinds; exp_delim: set_of_token_kinds; VAR value: token_type; VAR delim: token_type ) }; VAR exp_operators: set_of_token_kinds; exp_term: set_of_token_kinds; term_value: token_type; PROCEDURE get_term ( VAR line: script_line; exp_type: set_of_token_kinds; VAR value: token_type ); VAR unary_not: BOOLEAN; unary_ops: set_of_token_kinds; BEGIN { PROCEDURE get_term } IF log_tok IN exp_type THEN unary_ops := [ not_tok ] ELSE unary_ops := []; unary_not := FALSE; REPEAT get_token ( line, exp_type + unary_ops + [ fun_tok ], value ); IF value.tok_kind = fun_tok THEN eval_func ( line, exp_type, value ) ELSE IF value.tok_kind = not_tok THEN unary_not := NOT unary_not; UNTIL NOT ( value.tok_kind IN unary_ops ); IF unary_not THEN value.log_val := NOT value.log_val; END; { PROCEDURE get_term } BEGIN { PROCEDURE eval_expr } get_term ( line, exp_type, value ); { Now that we know the base type of the expression, figure out which { operators are acceptable. } IF value.tok_kind = str_tok THEN exp_operators := [ con_tok ] ELSE exp_operators := [ ]; get_token ( line, exp_operators + exp_delim, delim ); WHILE delim.tok_kind IN exp_operators DO BEGIN get_term ( line, exp_type, term_value ); IF delim.tok_kind = con_tok THEN value.str_val := CONCAT ( value.str_val, term_value.str_val ); get_token ( line, exp_operators + exp_delim, delim ); END; { WHILEND } END; { PROCEDURE eval_expr } {$P} PROCEDURE do_define { ( line: script_line ) }; VAR var_name: name_type; var_value: token_type; res_index: res_kinds; token: token_type; table_index: sym_tbl_index; BEGIN { PROCEDURE do_define } REPEAT BEGIN { repeat for each defnition } get_token ( line, [ nam_tok, eol_tok ], token ); IF token.tok_kind <> eol_tok THEN BEGIN { more defnitions on line } var_name := token.nam_val; make_upper ( var_name ); get_token ( line, [ equ_tok ], token ); eval_expr ( line, [ nam_tok, int_tok, str_tok, log_tok ], [ com_tok, eol_tok ], var_value, token ); { Search the reserved variable table, and change the value of the { relevant Pascal variable if found. Note that we also put an { entry into the Symbol table, so that the user can refer to { this variable later. } res_index := res_command; WHILE ( res_index < res_unknown ) AND ( var_name <> var_names [ res_index ] ) DO res_index := SUCC ( res_index ); IF res_index <> res_unknown THEN BEGIN IF ( res_index IN [ res_command, res_line ] ) AND ( var_value.tok_kind <> log_tok ) THEN error ( fatal, CONCAT ( var_name, ' can only be TRUE or FALSE' )); IF res_index = res_command THEN cmd_display := var_value.log_val; IF res_index = res_line THEN link_display := var_value.log_val; END; { IFEND } { Find a table entry in which to put this symbol. } table_index := 1; IF highest_entry_index > 0 THEN BEGIN WHILE ( sym_table [ table_index ] . name <> var_name ) AND ( table_index < highest_entry_index ) DO table_index := table_index + 1; END; { IFEND } IF ( highest_entry_index = 0 ) OR ( sym_table [ table_index ] . name <> var_name ) THEN BEGIN { new table entry needed } IF highest_entry_index < sym_tbl_size THEN BEGIN { make new table entry } highest_entry_index := highest_entry_index + 1; table_index := highest_entry_index; END { IFEND } ELSE error ( fatal, 'Variable table is full' ); END; { IFEND make new table entry } { Put new data into the variable table entry. } sym_table [ table_index ] . name := var_name; sym_table [ table_index ] . value := var_value; END; { IFEND more definitions on line } END; { REPEATEND for all defnitions } UNTIL token.tok_kind = eol_tok; END; { PROCEDURE do_define } {$P} FUNCTION get_char: CHAR; VAR ch: CHAR; translated: xlate_entry; BEGIN { FUNCTION get_char } {$R- Turn off range checking to speed up execution } ch := cr_getrem; translated := xlate_tbl [ ch ]; IF link_display THEN IF ch = CHR ( ch_lf ) THEN BEGIN IF link_dis_line < max_screen_y THEN link_dis_line := link_dis_line + 1 ELSE link_dis_line := link_y + 2; GOTOXY ( link_x, link_dis_line ); sc_clr_cur_line; END ELSE UNITWRITE ( console, translated.no_ctl, 1,, 4+8 ); get_char := ch; {$R+ Turn range checking on again } END; { FUNCTION get_char } {$P} PROCEDURE match { ( text_line: string_type; quiet_ending: BOOLEAN; period: time_period; VAR complete_match: BOOLEAN ) }; VAR delim: token_type; { delimiter of the pattern } char_index: script_index; { current character being matched } text_match: BOOLEAN; { all the text has matched } input_char: CHAR; { character read from serial interface } total_time: os_timer; { time we've been trying to match } ending_time: os_timer; { wait for quiet after text match} visible_seen: BOOLEAN; { a visible char has been received } exit_condition: BOOLEAN; ms_period: INTEGER; BEGIN { PROCEDURE match } {$R- Disable range checking to make this run faster. } ms_period := period * 100; complete_match := FALSE; exit_condition := FALSE; os_start_timer ( total_time ); WHILE cr_carrier AND NOT complete_match AND ( LENGTH ( text_line ) > 0 ) AND ( os_elapsed_time ( total_time ) < ms_period ) AND NOT exit_condition DO BEGIN text_match := FALSE; char_index := 1; REPEAT BEGIN { text match } REPEAT check_kb ( exit_requested ); exit_condition := exit_requested OR NOT cr_carrier OR ( os_elapsed_time ( total_time ) >= ms_period ); UNTIL exit_condition OR cr_remstat; IF NOT exit_condition THEN BEGIN input_char := get_char; IF input_char = text_line [ char_index ] THEN IF char_index < LENGTH ( text_line ) THEN char_index := char_index + 1 ELSE text_match := TRUE ELSE char_index := 1; END; END; { REPEATEND text match } UNTIL text_match OR exit_condition; IF text_match THEN BEGIN visible_seen := FALSE; IF quiet_ending THEN BEGIN { check for quiet ending } os_start_timer ( ending_time ); WHILE cr_carrier AND NOT visible_seen AND ( os_elapsed_time(ending_time) < 500 ) AND NOT exit_condition DO BEGIN IF cr_remstat THEN visible_seen := get_char IN visible_chars; check_kb ( exit_requested ); exit_condition := exit_requested; END; { WHILEND } END; { IFEND } complete_match := NOT visible_seen AND cr_carrier; END; { ifend } END; { WHILEND complete match } {$R+ Reenable range checking. } END; { PROCEDURE match } {$P} PROCEDURE if_command ( line: script_line ); VAR value: token_type; delim: token_type; BEGIN { PROCEDURE if_command } IF cnd_level = max_cnd_level THEN error ( fatal, 'Maximum conditional nesting level exceeded' ); cnd_level := cnd_level + 1; cnd_stack [ cnd_level ] . cnd_kind := if_cnd; eval_expr ( line, [ log_tok ], [ eol_tok ], value, delim ); skipping := NOT value.log_val OR skipping; cnd_stack [ cnd_level ] . skip_flag := skipping; END; { PROCEDURE if_command } {$P} PROCEDURE ifend_command; BEGIN { PROCEDURE ifend_command } IF ( cnd_level = 0 ) OR NOT ( cnd_stack [ cnd_level ] . cnd_kind IN [ if_cnd, el_cnd ] ) THEN error ( fatal, 'IFEND not expected here.' ); cnd_level := cnd_level - 1; IF cnd_level > 0 THEN skipping := cnd_stack [ cnd_level ] . skip_flag ELSE skipping := FALSE; END; { PROCEDURE ifend_command } {$P} PROCEDURE else_command; BEGIN { PROCEDURE else_command } IF ( cnd_level = 0 ) OR ( cnd_stack [ cnd_level ] . cnd_kind <> if_cnd ) THEN error ( fatal, 'ELSE not expected here' ); IF cnd_level = 1 THEN skipping := NOT skipping ELSE IF cnd_stack [ cnd_level - 1 ] . skip_flag <> TRUE THEN skipping := NOT skipping; cnd_stack [ cnd_level ] . skip_flag := skipping; END; { PROCEDURE else_command } {$P} PROCEDURE while_command ( line: script_line ); VAR value: token_type; delim: token_type; BEGIN { PROCEDURE while_command } IF cnd_level = max_cnd_level THEN error ( fatal, 'Maximum conditional nesting level exceeded' ); cnd_level := cnd_level + 1; cnd_stack [ cnd_level ] . cnd_kind := wh_cnd; cnd_stack [ cnd_level ] . line_num := nest_stack [ script_level ] . line_number - 1; eval_expr ( line, [ log_tok ], [ eol_tok ], value, delim ); skipping := NOT value.log_val OR skipping; cnd_stack [ cnd_level ] . skip_flag := skipping; END; { PROCEDURE while_command } {$P} PROCEDURE whilend_command; BEGIN { PROCEDURE whilend_command } IF ( cnd_level = 0 ) OR ( cnd_stack [ cnd_level ] . cnd_kind <> wh_cnd ) THEN error ( fatal, 'WHILEND not expected here.' ); IF NOT skipping THEN BEGIN { jump to the top of the loop } io_seek_line ( script_file, cnd_stack [ cnd_level ] . line_num ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while reading script file' ); nest_stack [ script_level ] . line_number := cnd_stack [ cnd_level ] . line_num; cnd_level := cnd_level - 1; END { go to top of loop } ELSE BEGIN { finished skipping over loop } cnd_level := cnd_level - 1; IF cnd_level > 0 THEN skipping := cnd_stack [ cnd_level ] . skip_flag ELSE skipping := FALSE; END; { ELSEND finished skipping over loop } END; { PROCEDURE whilend_command } {$P} PROCEDURE return_command ( VAR exit_condition: BOOLEAN ); VAR file_exists: BOOLEAN; BEGIN { PROCEDURE return_command } IF script_level = 1 THEN exit_condition := TRUE ELSE BEGIN exit_condition := FALSE; io_close_file ( script_file ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while closing script file' ); script_level := script_level - 1; io_open_file ( script_file, nest_stack [ script_level ] . script_name, io_input, file_exists ); IF NOT file_exists THEN error ( catastrophic, 'Cannot open script file during RETURN' ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while opening script file' ); io_seek_line ( script_file, nest_stack [ script_level ] . line_number ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while reading script file' ); END; { ELSEND } END; { PROCEDURE return_command } {$P} PROCEDURE define_command ( line: script_line ); BEGIN { PROCEDURE define_command } do_define ( line ); END; { PROCEDURE define_command } {$P} PROCEDURE display_command ( line: script_line ); VAR message: token_type; delim: token_type; BEGIN { PROCEDURE display_command } eval_expr ( line, [ str_tok ], [ eol_tok ], message, delim ); display_status ( message.str_val ); END; { PROCEDURE display_command } {$P} PROCEDURE match_command ( text_line: script_line; VAR complete_match: BOOLEAN ); VAR anywhere_mode: boolean; pattern: token_type; delim: token_type; keyword: token_type; value: token_type; period: time_period; BEGIN { PROCEDURE match_command } eval_expr ( text_line, [ str_tok ], [eol_tok, com_tok ], pattern, delim ); anywhere_mode := TRUE; period := 300; WHILE delim.tok_kind = com_tok DO BEGIN eval_expr(text_line, [nam_tok],[eol_tok,com_tok,equ_tok ], keyword, delim ); IF keyword.nam_val = 'ENDING' THEN anywhere_mode := FALSE; IF keyword.nam_val = 'PERIOD' THEN BEGIN eval_expr ( text_line, [ int_tok ], [ eol_tok, com_tok ], value, delim ); period := value.int_val; END; END; { IFEND } match ( pattern.str_val, NOT anywhere_mode, period, complete_match ); IF NOT complete_match AND NOT exit_requested THEN error ( fatal, CONCAT ( 'Could not match ''', pattern.str_val, ''' within specified period' )); END; { PROCEDURE match_command } {$P} PROCEDURE send_command ( text_line: script_line ); VAR char_index: script_index; echoed_char: CHAR; text_data: token_type; delim: token_type; param: token_type; no_cr: BOOLEAN; BEGIN { PROCEDURE send_command } IF LENGTH ( text_line ) > 0 THEN BEGIN eval_expr(text_line, [ str_tok ], [ com_tok,eol_tok ], text_data, delim ); no_cr := FALSE; WHILE delim.tok_kind = com_tok DO BEGIN eval_expr(text_line, [nam_tok], [ com_tok,eol_tok ], param, delim ); IF param.nam_val = 'NOCR' THEN no_cr := TRUE; END; { WHILEND } FOR char_index := 1 TO LENGTH ( text_data.str_val ) DO IF cr_carrier THEN BEGIN cr_putrem ( text_data.str_val [ char_index ] ); IF cr_remstat THEN echoed_char := get_char; END; { IFEND } END; { IFEND } IF cr_carrier AND NOT no_cr THEN cr_putrem ( CHR ( ch_cr ) ); IF cr_remstat THEN echoed_char := get_char; END; { PROCEDURE send_command } {$P} PROCEDURE pause_command ( text_line: script_line ); VAR pause_time: os_timer; display_char: CHAR; BEGIN { PROCEDURE pause_command } os_start_timer ( pause_time ); WHILE os_elapsed_time ( pause_time ) < 1000 DO IF cr_carrier THEN IF cr_remstat THEN display_char := get_char; END; { PROCEDURE pause_command } {$P} PROCEDURE call_command ( line: script_line ); VAR name: token_type; delim: token_type; file_exists: BOOLEAN; BEGIN { PROCEDURE call_command } IF script_level = max_nest_level THEN error ( fatal, 'Maximum script nesting level exceeded' ) ELSE BEGIN io_close_file ( script_file ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while closing script file' ); script_level := script_level + 1; eval_expr ( line, [ nam_tok ], [ com_tok, eol_tok ], name, delim ); nest_stack [ script_level ] . script_name := name.nam_val; nest_stack [ script_level ] . line_number := 1; io_open_file ( script_file, name.nam_val, io_input, file_exists ); IF NOT file_exists THEN error ( fatal, CONCAT ( 'Called script ', name.nam_val, ' does not exist' ) ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while opening script file' ); END; { ELSEND } IF delim.tok_kind = com_tok THEN do_define ( line ); END; { PROCEDURE call_command } {$P} PROCEDURE execute_command ( text_line: script_line ); VAR prog_name: token_type; prog_param: os_prog_param; delim: token_type; BEGIN { PROCEDURE execute_command } IF LENGTH ( text_line ) = 0 THEN error ( fatal, '? No codefile title specified in eXecute command.' ); eval_expr ( text_line, [ nam_tok ], [ eol_tok, com_tok ], prog_name, delim ); IF LENGTH ( text_line ) > 0 THEN prog_param := text_line ELSE prog_param := ''; os_store_command ( prog_name.nam_val, prog_param ); close_all_files; os_exit_to_next; { The following EXIT is present to kludge around a bug in IV.03. Delete { it when no longer needed. } EXIT ( PROGRAM ); END; { PROCEDURE execute_command } {$P} PROCEDURE dial_command ( text_line: script_line ); VAR result: cr_dialresult; BEGIN { PROCEDURE dial_command } { Take the line off-hook. } cr_hook ( FALSE ); { Dial the number, and check the response we get. } cr_dial ( text_line, ':', result ); CASE result OF cr_noautodial: error ( fatal, 'Dialing not supported by REMUNIT software' ); cr_dialerror: error ( fatal, 'Error detected by REMUNIT during dialing' ); cr_offhook: BEGIN END; END; { CASEND } END; { PROCEDURE dial_command } {$P} PROCEDURE hangup_command; BEGIN { PROCEDURE hangup_command } cr_hook ( TRUE ); END; { PROCEDURE hangup_command } {$P} PROCEDURE wait_command ( VAR carrier_found: BOOLEAN ); VAR start_time: os_timer; BEGIN { PROCEDURE wait_command } os_start_timer ( start_time ); REPEAT check_kb ( exit_requested ); UNTIL cr_carrier OR exit_requested OR ( os_elapsed_time ( start_time ) > 30000 ); IF cr_carrier THEN cr_answer ELSE IF NOT exit_requested THEN error ( fatal, 'Did not detect carrier within 30 seconds' ); carrier_found := TRUE; END; { PROCEDURE wait_command } {$P} BEGIN { PROGRAM convers } initialize; setup_display; nest_stack [ 1 ] . line_number := 1; exit_condition := FALSE; exit_requested := FALSE; display_status ( CONCAT ( 'Beginning execution of script ', nest_stack [ 1 ].script_name )); WHILE NOT exit_condition DO BEGIN successful := TRUE; io_read_line ( script_file, cur_script_line ); IF IORESULT <> 0 THEN error ( fatal, 'I/O device error while reading script file' ); nest_stack [ script_level ] . line_number := nest_stack [ script_level ] . line_number + 1; IF cmd_display THEN BEGIN GOTOXY ( cmd_x + 13, cmd_y + 1 ); WRITE ( cur_script_line: 60 ); GOTOXY ( 0, link_dis_line ); END; { IFEND } eval_expr ( cur_script_line, [ nam_tok ], [ nam_tok..bad_tok ], command, delim_tok ); make_upper ( command.nam_val ); cmd_index := cal_cmd; WHILE ( command.nam_val <> cmd_names [ cmd_index ] ) AND ( cmd_index < bad_cmd ) DO cmd_index := SUCC ( cmd_index ); IF cmd_index <> bad_cmd THEN BEGIN { valid command } IF ( NOT skipping ) OR ( cmd_index IN cnd_cmds ) THEN CASE cmd_index OF cal_cmd: call_command ( cur_script_line ); com_cmd: BEGIN END; def_cmd: define_command ( cur_script_line ); dis_cmd: display_command ( cur_script_line ); dia_cmd: dial_command ( cur_script_line ); els_cmd: else_command; exe_cmd: execute_command ( cur_script_line ); han_cmd: hangup_command; if_cmd: if_command ( cur_script_line ); ife_cmd: ifend_command; mat_cmd: match_command ( cur_script_line, successful ); pau_cmd: pause_command ( cur_script_line ); qui_cmd: exit_condition := TRUE; ret_cmd: return_command ( exit_condition ); sen_cmd: send_command ( cur_script_line ); tra_cmd: transfer_command ( cur_script_line, successful ); wai_cmd: wait_command ( successful ); whe_cmd: whilend_command; whi_cmd: while_command ( cur_script_line ); END { CASEND } END { IFEND valid command } ELSE error ( fatal, CONCAT ( 'Unrecognized command ', command.nam_val, ' found.' ) ); IF NOT exit_requested THEN check_kb ( exit_requested ); exit_condition := NOT successful OR exit_condition OR exit_requested; END; { WHILEND } IF exit_requested THEN error ( warning, 'Execution ended in response to ESC key' ); close_all_files; cr_commquit; END. ======================================================================================== DOCUMENT :usus Folder:VOL29:conv_test.text ======================================================================================== * SCRIPT CONV_TEST * * This script provides a primitive test that CONVERS is installed * and executing properly. Execute the script by starting CONVERS, * and entering: * * CONV_TEST, DISPLAY_COMMANDS=YES, DISPLAY_LINK=YES * * to the prompt. * * The comments below tell what to expect as CONVERS executes. * * The following Pause commands should each execute in approximately * one second. pause * Pause * PAUSE * * The following statements define some variables, and then execute * a WHILE loop three times. Among other things, this tests that the * seek_line function of TEXTIO is working. * define, switch1=true, switch2=true while, $VALUE ( switch1 ) define, switch1 = $VALUE ( switch2 ) define, switch2 = false whilend * * The following command should wait for a carrier to be detected. If * no carrier is provided in approximately 30 seconds, it should abort. * wait * * The following commands send some junk over the link, and then wait * for a (highly improbable) reply. This may catch some drastic errors * in the installation. For a more effective test, write your own scripts * based on the system with which you are communicating. * send, 'Transmitted test text' Match, 'Say what?', ANYWHERE return ======================================================================================== DOCUMENT :usus Folder:VOL29:draw4a.1.text ======================================================================================== PROCEDURE SETUP; {Reads all color and weave} VAR COUNT : INTEGER; {setup parameters and sends to screen} BEGIN CLEARSCREEN; WRITELN; WRITELN(' ----- DRAWDOWN FOR 4 HARNESS LOOMS -----'); WRITELN(' ',REM); WRITELN(' SETUP IS FOR ',HORIZLEN,' WARP THREADS'); WRITELN; WRITELN(' "A" TABBY IS TREADLE ',TABBYA); WRITELN(' "B" TABBY IS TREADLE ',TABBYB); WRITELN; COUNT := 0; WRITELN(' THREADING SEQUENCE IS --->'); WRITELN; FOR I := 1 TO HORIZLEN DO BEGIN WRITE (THREAD[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN(' WARP COLOR SEQUENCE IS --->'); WRITELN; COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(COLOR1[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN CLEARSCREEN; WRITELN; WRITELN(' TREADLE TIEUP IS--->'); WRITELN; FOR I := 1 TO 6 DO BEGIN WRITE('TREADLE ',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2); WRITELN(' -',TIE3[I]:2); END; WRITELN; COUNT := 0; WRITELN(' TREADLING SEQUENCE IS---> '); WRITELN; FOR I := 1 TO VERTLEN DO BEGIN WRITE(TREADL[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN(' WEFT COLOR SEQUENCE IS --->'); WRITELN; COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(COLOR2[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(SETUP) END; PROCEDURE PSETUP; {Reads all plain drawdown setup} VAR COUNT : INTEGER; {parameters and sends to screen} BEGIN CLEARSCREEN; WRITELN; WRITELN(' ----- DRAWDOWN FOR 4 HARNESS LOOMS -----'); WRITELN(' ',REM); WRITELN(' SETUP IS FOR ',HORIZLEN,' WARP THREADS'); WRITELN; WRITELN(' "A" TABBY IS TREADLE ',TABBYA); WRITELN(' "B" TABBY IS TREADLE ',TABBYB); WRITELN; COUNT := 0; WRITELN(' THREADING SEQUENCE IS --->'); FOR I := 1 TO HORIZLEN DO BEGIN WRITE (THREAD[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN(' TREADLE TIEUP IS--->'); FOR I := 1 TO 6 DO BEGIN WRITE('TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2); WRITELN(' -',TIE3[I]:2); END; WRITELN; COUNT := 0; WRITELN(' TREADLING SEQUENCE IS---> '); FOR I := 1 TO VERTLEN DO BEGIN WRITE(TREADL[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(PSETUP) END; PROCEDURE SETUP1; {Reads all color and weave setup} VAR COUNT : INTEGER; {parameters and outputs to printer} BEGIN COUNT := 0; WRITELN(FT,'DRAWDOWN FOR 4 HARNESS LOOMS (color and weave)'); WRITELN(FT,REM); WRITELN(FT,'SETUP IS FOR ',HORIZLEN,' THREADS.'); WRITELN(FT); WRITELN(FT,'THREADING SEQUENCE IS --->'); FOR I := 1 TO HORIZLEN DO BEGIN WRITE (FT,THREAD[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); WRITELN(FT,'WARP COLOR SEQUENCE IS --->'); COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(FT,COLOR1[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); WRITELN(FT,'"A" TABBY IS TREADLE',TABBYA:2); WRITELN(FT,'"B" TABBY IS TREADLE',TABBYB:2); WRITELN(FT); WRITELN(FT,'TREADLE TIEUP IS--->'); FOR I := 1 TO 6 DO BEGIN WRITE(FT,'TREADLE',I:2,' TO HARNESS NUMBERS ',TIE1[I]:2,' -',TIE2[I]:2); WRITELN(FT,' -',TIE3[I]:2); END; WRITELN(FT); COUNT := 0; WRITELN(FT,'TREADLING SEQUENCE IS --->'); FOR I := 1 TO VERTLEN DO BEGIN WRITE(FT,TREADL[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); WRITELN(FT,'WEFT COLOR SEQUENCE IS --->'); COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(FT,COLOR2[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); END; PROCEDURE PSETUP1; {Reads all plain drawdown setup} VAR COUNT : INTEGER; {parameters and outputs to printer} BEGIN COUNT := 0; WRITELN(FT); WRITELN(FT,'DRAWDOWN FOR 4 HARNESS LOOMS'); WRITELN(FT,REM); WRITELN(FT,'SETUP IS FOR ',HORIZLEN,' THREADS.'); WRITELN(FT); WRITELN(FT,'THREADING SEQUENCE IS --->'); FOR I := 1 TO HORIZLEN DO BEGIN WRITE (FT,THREAD[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); WRITELN(FT,'"A" TABBY IS TREADLE',TABBYA:2); WRITELN(FT,'"B" TABBY IS TREADLE',TABBYB:2); WRITELN(FT); WRITELN(FT,'TREADLE TIEUP IS--->'); FOR I := 1 TO 6 DO BEGIN WRITE(FT,'TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2); WRITELN(FT,' -',TIE3[I]:2); END; WRITELN(FT); COUNT := 0; WRITELN(FT,'TREADLING SEQUENCE IS --->'); FOR I := 1 TO VERTLEN DO BEGIN WRITE(FT,TREADL[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); END; PROCEDURE CRTOUT; {Outputs color and weave pattern to screen} BEGIN CLEARSCREEN; SETUP; WRITELN; WRITELN; WRITELN; BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['D','d']) THEN WRITE(SHOWARPD) ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['L','l']) THEN WRITE(SHOWARPL) ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['D','d']) THEN WRITE(SHOWARPD) ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['L','l']) THEN WRITE(SHOWARPL) END; WRITELN; END; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(CRTOUT) END; PROCEDURE PCRTOUT; {Outputs plain drawdown pattern to screen} BEGIN CLEARSCREEN; PSETUP; WRITELN; WRITELN; BEGIN BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) THEN WRITE(SHOWARPD) ELSE WRITE(SHOWARPL); END; WRITELN; END; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(PCRTOUT) END; END; PROCEDURE HARDCOPY; {Outputs color and weave pattern to printer} BEGIN CLEARSCREEN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN(' SETUP FOR PRINTER-->'); WRITELN(' 10 Characters per INCH'); WRITELN(' 8 Lines per INCH'); WRITELN; WRITELN(' *** NOTE---USE ASCII 96 PRINT WHEEL ON QUME ***'); WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN BEGIN REWRITE(FT,'PRINTER:'); SETUP1; WRITELN(FT,CHR(12)); WRITELN(FT); BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['D','d']) THEN WRITE(FT,SHOWARPD) ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['L','l']) THEN WRITE(FT,SHOWARPL) ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['D','d']) THEN WRITE(FT,SHOWARPD) ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['L','l']) THEN WRITE(FT,SHOWARPL) END; WRITELN(FT); END; END; END; WRITELN(FT,CHR(12)); CLOSE(FT); END; PROCEDURE PHARDCOPY; {Outputs plain drawdown pattern to printer} BEGIN CLEARSCREEN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN(' SETUP FOR PRINTER-->'); WRITELN(' 10 Characters per INCH'); WRITELN(' 8 Lines per INCH'); WRITELN; WRITELN(' *** NOTE---USE ASCII 96 PRINT WHEEL ON QUME ***'); WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN BEGIN REWRITE(FT,'PRINTER:'); WRITELN(FT); WRITELN(FT); PSETUP1; WRITELN(FT,CHR(12)); WRITELN(FT); WRITELN(FT); BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) THEN WRITE(FT,SHOWARPD) ELSE WRITE(FT,SHOWARPL); END; WRITELN(FT); END; END; END; WRITELN(FT,CHR(12)); CLOSE(FT); END; PROCEDURE GRAFOUT; {Outputs color and weave pattern} {to IDS-460 graphics printer} BEGIN CLEARSCREEN; WRITELN; WRITELN; WRITELN; WRITELN(' SETUP FOR IDS-460 PRINTER-->'); WRITELN(' 10 Characters per INCH'); WRITELN(' 8 Lines per INCH'); WRITELN(' ENABLE EXPANDED FUNCTION-- SWITCH NO. 7 ON ..'); WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN BEGIN REWRITE(FT,'PRINTER:'); SETUP1; WRITELN(FT); WRITELN(FT); WRITE(FT,CHR(3)); {Puts IDS-460 into graphics mode} BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['D','d']) THEN DPIXEL ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K])) AND (COLOR1[J] IN ['L','l']) THEN LPIXEL ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['D','d']) THEN DPIXEL ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K])) AND (COLOR2[I] IN ['L','l']) THEN LPIXEL END; WRITE(FT,CHR(3),CHR(14)); {Graphics CR & LF} END; END; END; WRITELN(FT,CHR(3),CHR(2)); {Disabels graphics mode} WRITELN(FT,CHR(12)); {FF} CLOSE(FT); END; PROCEDURE PGRAFOUT; {Outputs plain drawdown pattern} {to IDS-460 graphics printer} BEGIN CLEARSCREEN; WRITELN; WRITELN; WRITELN; WRITELN(' SETUP FOR IDS-460 PRINTER-->'); WRITELN(' 10 Characters per INCH'); WRITELN(' 8 Lines per INCH'); WRITELN(' ENABLE EXPANDED FUNCTION-- SWITCH NO. 7 ON ..'); WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN BEGIN REWRITE(FT,'PRINTER:'); WRITELN(FT); WRITELN(FT); PSETUP1; WRITELN(FT); WRITELN(FT); WRITE(FT,CHR(3)); {Puts IDS-460 into graphics mode} BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) THEN DPIXEL ELSE LPIXEL END; WRITE(FT,CHR(3),CHR(14)); {Graphics CR & LF} END; END; END; WRITE(FT,CHR(3),CHR(2)); {Disable graphics mode} WRITELN(FT,CHR(12)); CLOSE(FT); END; PROCEDURE PRINT; {Secondary menu for output selection} VAR CH : CHAR; OKSET : SETOFCHAR; BEGIN CLEARSCREEN; OKSET := ['S','s','P','p','G','g','Q','q']; WRITELN(' Do you want output to go to the------>'); WRITELN; WRITELN; WRITE(' ---> S)creen, P)rinter normal, G)raphics IDS-460, Q)UIT ? '); CH := GETCHAR(OKSET); CASE CH OF 'S','s' : CRTOUT; 'P','p' : HARDCOPY; 'G','g' : GRAFOUT; 'Q','q' : BEGIN CLEARSCREEN; EXIT(PRINT); END; END; END; PROCEDURE PPRINT; {Secondary menu for output selection} VAR CH : CHAR; OKSET : SETOFCHAR; BEGIN CLEARSCREEN; OKSET := ['S','s','P','p','G','g','Q','q']; WRITELN(' Do you want output to go to the------>'); WRITELN; WRITELN; WRITE(' ---> S)creen, P)rinter normal, G)raphics IDS-460, Q)UIT ? '); CH := GETCHAR(OKSET); CASE CH OF 'S','s' : PCRTOUT; 'P','p' : PHARDCOPY; 'G','g' : PGRAFOUT; 'Q','q' : BEGIN CLEARSCREEN; EXIT(PPRINT); END; END; END; PROCEDURE TITLE; {Title block for program} BEGIN OKSET := [CHR(13)]; CLEARSCREEN; GOTOXY(0,2); WRITELN(' ***** PROGRAM DRAW4C *****'); GOTOXY(0,6); WRITELN(' This program is for four harness looms and the output'); WRITELN; WRITELN(' is a Drawdown to a printer or the terminal. The program'); WRITELN; WRITELN(' was inspired by the book "COLOR AND WEAVE" by Margaret and'); WRITELN; WRITELN(' Thomas Windeknecht. It is written in UCSD Pascal version'); WRITELN; WRITELN(' IV.1 for the Sage II computer and output on a standard'); WRITELN; WRITELN(' printer or graphics output on the IDS-460 printer.'); WRITELN; WRITELN(' by GEORGE. H. DODGE December 1983'); WRITELN; WRITELN; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(TITLE); END; PROCEDURE CMENU; {Color and weave menu} VAR OKSET : SETOFCHAR; BEGIN OKSET := ['A','a','B','b','C','c','D','d','P','p','Q','q']; REPEAT CLEARSCREEN; WRITE('> Draw4C: A)Threading B)Tieup C)Treadling '); WRITE('D)DrawnIn P)rint Q)uit---> '); CH := GETCHAR(OKSET); CASE CH OF 'A','a' : THREADING; 'B','b' : TYEUP; 'C','c' : TREADLING; 'D','d' : COPYTHRD; 'P','p' : PRINT; 'Q','q' : BEGIN CLEARSCREEN; MENU; END; END; UNTIL FALSE END; PROCEDURE PMENU; {Plain drawdown menu} VAR OKSET : SETOFCHAR; BEGIN OKSET := ['A','a','B','b','C','c','D','d','P','p','Q','q']; REPEAT CLEARSCREEN; WRITE('> Draw4: A)Threading B)Tieup C)Treadling '); WRITE('D)DrawnIn P)rint Q)uit---> '); CH := GETCHAR(OKSET); CASE CH OF 'A','a' : PTHREADING; 'B','b' : TYEUP; 'C','c' : PTREADLING; 'D','d' : COPYTHRD; 'P','p' : PPRINT; 'Q','q' : BEGIN CLEARSCREEN; MENU; END; END; UNTIL FALSE END; PROCEDURE MENU; {Main program menu} VAR OKSET : SETOFCHAR; BEGIN OKSET := ['P','p','C','c','Q','q']; REPEAT CLEARSCREEN; WRITE('> DrawDown 4 : P)lain drawdown C)olor & weave Q)uit---> '); CH := GETCHAR(OKSET); CASE CH OF 'P','p' : PMENU; 'C','c' : CMENU; 'Q','q' : BEGIN CLEARSCREEN; EXIT(PROGRAM); END; END; UNTIL FALSE END; BEGIN {Main program} TITLE; MENU; END. ======================================================================================== DOCUMENT :usus Folder:VOL29:draw4a.text ======================================================================================== PROGRAM DRAW4; uses screenops; CONST SHOWARPD = '#'; SHOWARPL = ' '; TYPE SETOFCHAR = SET OF CHAR; VAR THREAD : ARRAY[1..80] OF INTEGER; {For threading info} TREADL : ARRAY[1..80] OF INTEGER; {For treadling info} TIE1, TIE2, TIE3 : ARRAY[1..10] OF INTEGER; {For tieup info} COLOR1, COLOR2 : ARRAY[1..80] OF CHAR; {For color info} I, J, K, MAXSIZE, HORIZLEN, VERTLEN, TABBYA, TABBYB : INTEGER; REM : STRING[40]; OKSET : SETOFCHAR; GOOD : BOOLEAN; CH, BS, CR, BELL : CHAR; FT : TEXT; PROCEDURE MENU; FORWARD; PROCEDURE CLEARSCREEN; BEGIN sc_clr_screen; END; PROCEDURE DPIXEL; {Dark pixel for IDS-460 graphics} BEGIN WRITE(FT,CHR(85),CHR(42),CHR(85),CHR(42),CHR(85),CHR(42),CHR(85)); END; PROCEDURE LPIXEL; {Light pixel for IDS-460 graphics} BEGIN WRITE(FT,CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0)); END; FUNCTION GETCHAR(OKSET : SETOFCHAR) : CHAR; VAR CH : CHAR; GOOD : BOOLEAN; BEGIN CR := CHR(13); BELL := CHR(7); REPEAT READ(KEYBOARD,CH); IF EOLN(KEYBOARD) THEN CH := CR; GOOD := CH IN OKSET; IF NOT GOOD THEN WRITE(BELL) ELSE IF CH IN [' '..CHR(125)] THEN WRITE(CH) UNTIL GOOD; GETCHAR := CH; END; { Used by GETINTEGER for bomb proof numerical data entry } FUNCTION GETNUM(MAXVAL,MINVAL : REAL; PTOK : BOOLEAN):REAL; TYPE SETOFCHAR = SET OF CHAR; VAR FIRSTCHAR, LASTCHAR : BOOLEAN; NUMSET, GETSET, OKSET : SETOFCHAR; NUMSTRTEMP : STRING[10]; S1 : STRING[1]; LEN, MAXLEN : INTEGER; NUM : REAL; CR, BS, BELL : CHAR; FUNCTION FPNUM(FPSTR : STRING) : REAL; VAR POWER, SIGN, I : INTEGER; NUM : REAL; BEGIN IF FPSTR[1] = '-' THEN BEGIN SIGN := -1; DELETE(FPSTR,1,1); END ELSE SIGN := 1; POWER := POS('.',FPSTR); IF POWER <> 0 THEN BEGIN DELETE(FPSTR,POWER,1); POWER := LENGTH(FPSTR)- POWER +1; END; NUM := 0; FOR I := 1 TO LENGTH(FPSTR) DO NUM := 10 * NUM + (ORD(FPSTR[I]) - ORD('0')); FPNUM := SIGN * NUM/PWROFTEN(POWER); END; BEGIN CR := CHR(13); BS := CHR(8); BELL := CHR(7); NUMSET := ['0'..'9']; IF MINVAL < 0 THEN OKSET := NUMSET + ['-'] ELSE OKSET := NUMSET; IF PTOK THEN MAXLEN := 8 ELSE MAXLEN := 7; S1 := ' '; NUMSTRTEMP := ''; REPEAT LEN := LENGTH(NUMSTRTEMP); FIRSTCHAR := (LEN=0); LASTCHAR := (LEN=MAXLEN); IF PTOK THEN OKSET := OKSET + ['.'] ELSE OKSET := OKSET - ['.']; IF FIRSTCHAR THEN GETSET := OKSET ELSE IF LASTCHAR THEN GETSET := [CR,BS] ELSE GETSET := OKSET + [CR,BS] - ['-']; S1[1] := GETCHAR(GETSET); IF S1 = '.' THEN PTOK := FALSE; IF S1[1] IN OKSET THEN BEGIN NUMSTRTEMP := CONCAT(NUMSTRTEMP,S1); IF S1[1] IN NUMSET THEN BEGIN NUM := FPNUM(NUMSTRTEMP); IF (NUM > MAXVAL) OR (NUM < MINVAL) THEN BEGIN WRITE(CHR(7)); WRITE(BS,' ',BS); DELETE(NUMSTRTEMP,LEN+1,1); END; END; END ELSE IF S1[1] = BS THEN BEGIN IF POS('.',NUMSTRTEMP) = LEN THEN PTOK := TRUE; WRITE(BS,' ',BS); DELETE(NUMSTRTEMP,LEN,1); END; UNTIL S1[1] = CR; WRITELN; GETNUM := FPNUM(NUMSTRTEMP); END; FUNCTION GETINTEGER(PROMPT : STRING; MAXVAL, MINVAL : INTEGER) : INTEGER; VAR POINTOK : BOOLEAN; {For bomb proof entry of numerical data} EOL : STRING[2]; BEGIN WRITE(PROMPT,CHR(27),CHR(116)); {Erase to end of line for TV-925 Term.} POINTOK := FALSE; GETINTEGER := TRUNC(GETNUM(MAXVAL,MINVAL,FALSE)); END; PROCEDURE THREADING; {Color and weave threading entry routine} VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER; {RPTFAC = Repeat factor, RPTSEQ = Repeat sequence} TEMP : ARRAY [1..80] OF INTEGER; {Temp array for repeat sequence} TEMPC : ARRAY [1..80] OF CHAR; {Temp array for color repeat sequence} OKSET : SETOFCHAR; BEGIN CLEARSCREEN; REM := ''; WRITELN; WRITELN('ENTER ANY COMMENTS YOU MAY WANT UP TO 40 CHARACTERS--IF YOU'); WRITELN('DON''T WANT ANY COMMENTS ---- PRESS '); WRITELN; WRITELN(' >----------------------------------------<'); WRITE('ENTER COMMENTS --> '); READLN(REM); WRITELN; WRITELN('ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR DRAWDOWN'); WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80'); WRITELN; MAXSIZE := GETINTEGER('HOW MANY WARP THREADS ?---> ',80,1); WRITELN; RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1); RPTFAC := MAXSIZE DIV RPTSEQ; HORIZLEN := RPTSEQ * RPTFAC; WRITELN; WRITELN; WRITELN; WRITELN(' ENTER YOUR THREADING REPEAT SEQUENCE'); WRITELN(' FOR ',RPTSEQ:3,' THREADS AND'); WRITELN(' 4 HARNESSES'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('NO. ',I:2,' THREAD '); TEMP[I] := GETINTEGER(' TO HARNESS NO.---> ',4,1); END; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN THREAD[J] := TEMP[K]; J := J + 1 END; END; CLEARSCREEN; WRITELN; WRITELN('THREADING SEQUENCE IS----->'); WRITELN; COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(THREAD[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN CLEARSCREEN; WRITELN; WRITELN; WRITELN('ENTER YOUR WARP THREAD COLOR REPEAT SEQUENCE WITH EITHER '); WRITELN('"D" OR "L" FOR EACH THREAD FOR ',RPTSEQ,' THREADS'); WRITELN; OKSET := ['D','d','L','l']; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('NO. ',I:2,' THREAD COLOR --> '); TEMPC[I] := GETCHAR(OKSET); WRITELN; END; WRITELN; WRITELN; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN COLOR1[J] := TEMPC[K]; J := J + 1 END; END; CLEARSCREEN; WRITELN('WARP THREAD COLOR SEQUENCE IS --->'); WRITELN; COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(COLOR1[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(THREADING); END; PROCEDURE PTHREADING; {Plain drawdown threading entry routine} VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER; TEMP : ARRAY[1..80] OF INTEGER; TEMPC : ARRAY[1..80] OF CHAR; OKSET : SETOFCHAR; BEGIN CLEARSCREEN; REM := ''; WRITELN('ENTER ANY COMMENTS YOU MAY HAVE UP TO 40 CHARACTERS--IF YOU'); WRITELN('DON''T WANT ANY COMMENTS -------- PRESS '); WRITELN; WRITELN(' >---------------------------------------<'); WRITE('ENTER COMMENTS --> '); READLN(REM); WRITELN; WRITELN('ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR DRAWDOWN'); WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80'); WRITELN; MAXSIZE := GETINTEGER('HOW MANY WARP THREADS DO YOU WANT ??---> ',80,1); WRITELN; RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1); RPTFAC := MAXSIZE DIV RPTSEQ; HORIZLEN := RPTSEQ * RPTFAC; WRITELN; WRITELN; WRITELN; WRITELN(' ENTER YOUR THREADING REPEAT SEQUENCE'); WRITELN(' FOR ',RPTSEQ:3,' THREADS AND'); WRITELN(' 4 HARNESSES'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('NO. ',I:2,' THREAD '); TEMP[I] := GETINTEGER(' TO HARNESS NO.---> ',4,1); END; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN THREAD[J] := TEMP[K]; J := J + 1 END; END; WRITELN; WRITELN('THREADING SEQUENCE IS----->'); WRITELN; COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(THREAD[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(PTHREADING); END; PROCEDURE TYEUP; {Treadle tieup entry routine} BEGIN CLEARSCREEN; WRITE('WHAT TREADLE DO YOU WANT'); TABBYA := GETINTEGER(' FOR TABBY "A" ? --> ',6,1); WRITELN; WRITE('WHAT TREADLE DO YOU WANT'); TABBYB := GETINTEGER(' FOR TABBY "B" ? --> ',6,1); WRITELN; WRITELN(' --> ENTER THE TREADLE TIEUP TO THE HARNESSES <--'); WRITELN; WRITELN(' IF YOU WANT A TREADLE TIED TO ONLY ONE HARNESS'); WRITELN(' THEN ENTER THE SAME HARNESS NO. THREE TIMES OR'); WRITELN(' IF YOU WANT A TREADLE TIED TO TWO HARNESSES THEN'); WRITELN(' REPEAT EITHER OF THE HARNESSES ONCE OR IF YOU WANT'); WRITELN(' A TREADLE TIED TO THREE DIFFERENT HARNESSES THEN'); WRITELN(' ENTER THE HARNESS NUMBERS....'); WRITELN; FOR I := 1 TO 6 DO BEGIN WRITE('TREADLE ',I:2); TIE1[I] := GETINTEGER(' TO ---> ',4,1); TIE2[I] := GETINTEGER(' AND ---> ',4,1); TIE3[I] := GETINTEGER(' AND ---> ',4,1); WRITELN; END; WRITELN; WRITELN('YOUR "A" TABBY IS TREADLE ',TABBYA); WRITELN('YOUR "B" TABBY IS TREADLE ',TABBYB); WRITELN; WRITELN('YOUR TIEUP IS -------->'); WRITELN; FOR I := 1 TO 6 DO BEGIN WRITE('TREADLE',I:2, ' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2); WRITELN(' -',TIE3[I]:2); END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(TYEUP); END; PROCEDURE TREADLING; {Color and weave treadling sequence entry routine} VAR COUNT, RPTSEQ, RPTFAC, I, J, K : INTEGER; TEMP : ARRAY[1..80] OF INTEGER; TEMPC : ARRAY[1..80] OF CHAR; OKSET : SETOFCHAR; BEGIN CLEARSCREEN; RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1); RPTFAC := MAXSIZE DIV RPTSEQ; VERTLEN := RPTSEQ * RPTFAC; WRITELN; WRITELN; WRITELN; WRITELN(' ENTER YOUR TREADLEING REPEAT SEQUENCE'); WRITELN(' FOR ',RPTSEQ:3,' TREADLINGS AND'); WRITELN(' 4 HARNESSES'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('FOR WARP THREAD ',I:2); TEMP[I] := GETINTEGER(' TREADLE NO.---> ',6,1); END; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN TREADL[J] := TEMP[K]; J := J + 1 END; END; WRITELN('TREDLING SEQUENCE IS------>'); WRITELN; COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(TREADL[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN CLEARSCREEN; OKSET := ['D','d','L','l']; WRITELN; WRITELN; WRITELN('ENTER YOUR WEFT COLOR SEQUENCE EITHER "D" OR "L"'); WRITELN('FOR EACH PICK FOR ',RPTSEQ:3,' PICKS'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('NO. ',I:2,' THREAD COLOR --> '); TEMPC[I] := GETCHAR(OKSET); WRITELN; END; WRITELN; WRITELN; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN COLOR2[J] := TEMPC[K]; J := J + 1 END; END; WRITELN; WRITELN; WRITELN('PICK COLOR SEQUENCE IS --->'); WRITELN; COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(COLOR2[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(TREADLING); END; PROCEDURE PTREADLING; {Plain drawdown treadling sequence entry routine} VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER; TEMP : ARRAY[1..80] OF INTEGER; OKSET : SETOFCHAR; BEGIN CLEARSCREEN; RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1); RPTFAC := MAXSIZE DIV RPTSEQ; VERTLEN := RPTFAC * RPTSEQ; WRITELN; WRITELN; WRITELN; WRITELN(' ENTER YOUR TREADLEING REPEAT SEQUENCE'); WRITELN(' FOR ',RPTSEQ:3,' TREADLINGS AND'); WRITELN(' 4 HARNESSES'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('FOR WARP THREAD ',I:2); TEMP[I] := GETINTEGER(' TREADLE NO.---> ',6,1); END; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN TREADL[J] := TEMP[K]; J := J + 1 END; END; WRITELN; WRITELN; WRITELN('TREDLING SEQUENCE IS------>'); WRITELN; COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(TREADL[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(PTREADLING); END; PROCEDURE COPYTHRD; VAR COUNT, I : INTEGER; BEGIN CLEARSCREEN; WRITELN(' **** AS DRAWN IN ****'); WRITELN; WRITELN(' THIS PROCEDURE WILL MAKE YOUR TREADLING SEQUENCE THE SAME AS'); WRITELN(' YOUR THREADING SEQUENCE---IF YOUR TABBY TIEUP IS TO 5 OR 6'); WRITELN(' AND YOU USE ANY TABBY TREADLING THIS PROCEDURE WILL NOT WORK'); WRITELN; WRITE(' DO YOU WANT TO PROCEED ? Y OR N :--> '); READ(KEYBOARD,CH); IF CH IN ['Y','y'] THEN BEGIN VERTLEN := HORIZLEN; WRITELN; WRITELN; WRITELN(' COPYING THREADING SEQUENCE TO TREADLING SEQUENCE --->'); FOR I := 1 TO HORIZLEN DO BEGIN TREADL[I] := THREAD[I]; WRITE('.'); END; WRITELN; WRITELN; WRITELN; WRITELN('YOUR TREADLING SEQUENCE IS ---> '); WRITELN; COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(TREADL[I]:3); COUNT := COUNT + 1; IF COUNT MOD 25 = 0 THEN WRITELN; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(COPYTHRD); END ELSE EXIT(COPYTHRD); END; (*$I DRAW4A.1.TEXT *) ======================================================================================== DOCUMENT :usus Folder:VOL29:draw8a.1.text ======================================================================================== {INCLUDE FILE FOR WEAVE:DRAW8A.TEXT} PROCEDURE SETUP; {Reads all color and weave} VAR COUNT : INTEGER; {setup parameters and sends to screen} BEGIN CLEARSCREEN; WRITELN; WRITELN(' ----- DRAWDOWN FOR 8 HARNESS LOOMS -----'); WRITELN(' ',REM); WRITELN(' SETUP IS FOR ',HORIZLEN,' WARP THREADS'); WRITELN; WRITELN(' "A" TABBY IS TREADLE ',TABBYA); WRITELN(' "B" TABBY IS TREADLE ',TABBYB); WRITELN; COUNT := 0; WRITELN(' THREADING SEQUENCE IS --->'); WRITELN; FOR I := 1 TO HORIZLEN DO BEGIN WRITE (THREAD[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN(' WARP COLOR SEQUENCE IS --->'); WRITELN; COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(COLOR1[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN CLEARSCREEN; WRITELN; WRITELN(' YOUR TREADLE TIEUP IS--->'); WRITELN; FOR I := 1 TO 10 DO BEGIN WRITE('TREADLE ',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2); WRITE(' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -'); WRITELN(TIE6[I]:2); END; WRITELN; COUNT := 0; WRITELN(' TREADLING SEQUENCE IS---> '); WRITELN; FOR I := 1 TO VERTLEN DO BEGIN WRITE(TREADL[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN(' WEFT COLOR SEQUENCE IS --->'); WRITELN; COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(COLOR2[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(SETUP) END; PROCEDURE PSETUP; {Reads all plain drawdown setup} VAR COUNT : INTEGER; {parameters and sends to screen} BEGIN CLEARSCREEN; WRITELN; WRITELN(' ----- DRAWDOWN FOR 8 HARNESS LOOMS -----'); WRITELN(' ',REM); WRITELN(' SETUP IS FOR ',HORIZLEN,' WARP THREADS'); WRITELN; WRITELN(' "A" TABBY IS TREADEL ',TABBYA); WRITELN(' "B" TABBY IS TREADEL ',TABBYB); WRITELN; COUNT := 0; WRITELN(' THREADING SEQUENCE IS --->'); FOR I := 1 TO HORIZLEN DO BEGIN WRITE (THREAD[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN(' TREADLE TIEUP IS--->'); FOR I := 1 TO 10 DO BEGIN WRITE('TREADLE ',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2); WRITE(' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -'); WRITELN(TIE6[I]:2); END; WRITELN; COUNT := 0; WRITELN(' TREADLING SEQUENCE IS---> '); FOR I := 1 TO VERTLEN DO BEGIN WRITE(TREADL[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(PSETUP) END; PROCEDURE SETUP1; {Reads all color and weave setup} VAR COUNT : INTEGER; {parameters and outputs to printer} BEGIN COUNT := 0; WRITELN(FT,'DRAWDOWN FOR 8 HARNESS LOOMS (color and weave)'); WRITELN(FT,REM); WRITELN(FT,'SETUP IS FOR ',HORIZLEN,' THREADS.'); WRITELN(FT); WRITELN(FT,'THREADING SEQUENCE IS --->'); FOR I := 1 TO HORIZLEN DO BEGIN WRITE (FT,THREAD[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); WRITELN(FT,'WARP COLOR SEQUENCE IS --->'); COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(FT,COLOR1[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); WRITELN(FT,'"A" TABBY IS TREADLE ',TABBYA:2); WRITELN(FT,'"B" TABBY IS TREADLE ',TABBYB:2); WRITELN(FT); WRITELN(FT,'TREADLE TIEUP IS--->'); FOR I := 1 TO 10 DO BEGIN WRITE(FT,'TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2); WRITE(FT,' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -'); WRITELN(FT,TIE6[I]:2); END; WRITELN(FT); COUNT := 0; WRITELN(FT,'TREADLING SEQUENCE IS --->'); FOR I := 1 TO VERTLEN DO BEGIN WRITE(FT,TREADL[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); WRITELN(FT,'WEFT COLOR SEQUENCE IS --->'); COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(FT,COLOR2[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); END; PROCEDURE PSETUP1; {Reads all plain drawdown setup} VAR COUNT : INTEGER; {parameters and outputs to printer} BEGIN COUNT := 0; WRITELN(FT); WRITELN(FT,'DRAWDOWN FOR 8 HARNESS LOOMS'); WRITELN(FT,REM); WRITELN(FT,'SETUP IS FOR ',HORIZLEN,' THREADS.'); WRITELN(FT); WRITELN(FT,'THREADING SEQUENCE IS --->'); FOR I := 1 TO HORIZLEN DO BEGIN WRITE (FT,THREAD[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); WRITELN(FT,'"A" TABBY IS TREADLE ',TABBYA:2); WRITELN(FT,'"B" TABBY IS TREADLE ',TABBYB:2); WRITELN(FT); WRITELN(FT,'TREADLE TIEUP IS--->'); FOR I := 1 TO 10 DO BEGIN WRITE(FT,'TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2); WRITE(FT,' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -'); WRITELN(FT,TIE6[I]:2); END; WRITELN(FT); COUNT := 0; WRITELN(FT,'TREADLING SEQUENCE IS --->'); FOR I := 1 TO VERTLEN DO BEGIN WRITE(FT,TREADL[I]:2); COUNT := COUNT + 1; IF COUNT MOD 30 = 0 THEN WRITELN(FT); END; WRITELN(FT); WRITELN(FT); END; PROCEDURE CRTOUT; {Outputs color and weave pattern to screen} BEGIN CLEARSCREEN; SETUP; WRITELN; WRITELN; WRITELN; BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])) AND (COLOR1[J] IN ['D','d']) THEN WRITE(SHOWARPD) ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])) AND (COLOR1[J] IN ['L','l']) THEN WRITE(SHOWARPL) ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) AND (COLOR2[I] IN ['D','d']) THEN WRITE(SHOWARPD) ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) AND (COLOR2[I] IN ['L','l']) THEN WRITE(SHOWARPL) END; WRITELN; END; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(CRTOUT) END; PROCEDURE PCRTOUT; {Outputs plain drawdown pattern to screen} BEGIN CLEARSCREEN; PSETUP; WRITELN; WRITELN; BEGIN BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K]) THEN WRITE(SHOWARPD) ELSE WRITE(SHOWARPL); END; WRITELN; END; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(PCRTOUT) END; END; PROCEDURE HARDCOPY; {Outputs color and weave pattern to printer} BEGIN CLEARSCREEN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN(' SETUP FOR PRINTER-->'); WRITELN(' 10 Characters per INCH'); WRITELN(' 8 Lines per INCH'); WRITELN; WRITELN(' *** NOTE---USE ASCII 96 PRINT WHEEL ON QUME ***'); WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN BEGIN REWRITE(FT,'PRINTER:'); SETUP1; WRITELN(FT); BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])) AND (COLOR1[J] IN ['D','d']) THEN WRITE(FT,SHOWARPD) ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])) AND (COLOR1[J] IN ['L','l']) THEN WRITE(FT,SHOWARPL) ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) AND (COLOR2[I] IN ['D','d']) THEN WRITE(FT,SHOWARPD) ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) AND (COLOR2[I] IN ['L','l']) THEN WRITE(FT,SHOWARPL) END; WRITELN(FT); END; END; END; WRITELN(FT,CHR(12)); CLOSE(FT); END; PROCEDURE PHARDCOPY; {Outputs plain drawdown pattern to printer} BEGIN CLEARSCREEN; WRITELN; WRITELN; WRITELN; WRITELN; WRITELN(' SETUP FOR PRINTER-->'); WRITELN(' 10 Characters per INCH'); WRITELN(' 8 Lines per INCH'); WRITELN; WRITELN(' *** NOTE---USE ASCII 96 PRINT WHEEL ON QUME ***'); WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN BEGIN REWRITE(FT,'PRINTER:'); WRITELN(FT); WRITELN(FT); PSETUP1; WRITELN(FT); WRITELN(FT); BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K]) THEN WRITE(FT,SHOWARPD) ELSE WRITE(FT,SHOWARPL); END; WRITELN(FT); END; END; END; WRITELN(FT,CHR(12)); CLOSE(FT); END; PROCEDURE GRAFOUT; {Outputs color and weave pattern} {to IDS-460 graphics printer} BEGIN CLEARSCREEN; WRITELN; WRITELN; WRITELN; WRITELN(' SETUP FOR IDS-460 PRINTER-->'); WRITELN(' 10 Characters per INCH'); WRITELN(' 8 Lines per INCH'); WRITELN(' ENABLE EXPANDED FUNCTION-- SWITCH NO. 7 ON ..'); WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN BEGIN REWRITE(FT,'PRINTER:'); SETUP1; WRITELN(FT); WRITELN(FT); WRITE(FT,CHR(3)); {Puts printer in graphics mode} BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])) AND (COLOR1[J] IN ['D','d']) THEN DPIXEL ELSE IF ((THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K])) AND (COLOR1[J] IN ['L','l']) THEN LPIXEL ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) AND (COLOR2[I] IN ['D','d']) THEN DPIXEL ELSE IF ((THREAD[J] <> TIE1[K]) OR (THREAD[J] <> TIE2[K]) OR (THREAD[J] <> TIE3[K]) OR (THREAD[J] <> TIE4[K]) OR (THREAD[J] <> TIE5[K]) OR (THREAD[J] <> TIE6[K])) AND (COLOR2[I] IN ['L','l']) THEN LPIXEL END; WRITE(FT,CHR(3),CHR(14)); {Graphics CR & LF} END; END; END; WRITELN(FT,CHR(3),CHR(2)); {Leave graphics mode} WRITELN(FT,CHR(12)); {FF} CLOSE(FT); END; PROCEDURE PGRAFOUT; {Outputs plain drawdown pattern} {to IDS-460 graphics printer} BEGIN CLEARSCREEN; WRITELN; WRITELN; WRITELN; WRITELN(' SETUP FOR IDS-460 PRINTER-->'); WRITELN(' 10 Characters per INCH'); WRITELN(' 8 Lines per INCH'); WRITELN(' ENABLE EXPANDED FUNCTION-- SWITCH NO. 7 ON ..'); WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN BEGIN REWRITE(FT,'PRINTER:'); WRITELN(FT); WRITELN(FT); PSETUP1; WRITELN(FT); WRITELN(FT); WRITE(FT,CHR(3)); {Puts printer into graphics mode} BEGIN FOR I := 1 TO VERTLEN DO BEGIN FOR J := 1 TO HORIZLEN DO BEGIN K := TREADL[I]; IF (THREAD[J] = TIE1[K]) OR (THREAD[J] = TIE2[K]) OR (THREAD[J] = TIE3[K]) OR (THREAD[J] = TIE4[K]) OR (THREAD[J] = TIE5[K]) OR (THREAD[J] = TIE6[K]) THEN DPIXEL ELSE LPIXEL END; WRITE(FT,CHR(3),CHR(14)); {Graphics CR & LF} END; END; END; WRITE(FT,CHR(3),CHR(2)); {Leave graphics mode} WRITELN(FT,CHR(12)); {FF} CLOSE(FT); END; PROCEDURE PRINT; {Secondary menu for color and weave output selection} VAR CH : CHAR; OKSET : SETOFCHAR; BEGIN OKSET := ['S','s','P','p','G','g','Q','q']; CLEARSCREEN; WRITELN(' Do you want output to go to the------>'); WRITELN; WRITELN; WRITE(' ---> S)creen, P)rinter normal, G)raphics IDS-460, Q)UIT ? '); CH := GETCHAR(OKSET); CASE CH OF 'S','s' : CRTOUT; 'P','p' : HARDCOPY; 'G','g' : GRAFOUT; 'Q','q' : BEGIN CLEARSCREEN; EXIT(PRINT); END; END; END; PROCEDURE PPRINT; {Secondary menu for normal drawdown output selection} VAR CH : CHAR; OKSET : SETOFCHAR; BEGIN OKSET := ['S','s','P','p','G','g','Q','q']; CLEARSCREEN; WRITELN(' Do you want output to go to the------>'); WRITELN; WRITELN; WRITE(' ---> S)creen, P)rinter normal, G)raphics IDS-460, Q)UIT ? '); CH := GETCHAR(OKSET); CASE CH OF 'S','s' : PCRTOUT; 'P','p' : PHARDCOPY; 'G','g' : PGRAFOUT; 'Q','q' : BEGIN CLEARSCREEN; EXIT(PPRINT); END; END; END; PROCEDURE TITLE; {Title block for program} BEGIN OKSET := [CHR(13)]; CLEARSCREEN; GOTOXY(0,2); WRITELN(' ***** PROGRAM DRAW8C *****'); GOTOXY(0,6); WRITELN(' This program is for eight harness looms and the output'); WRITELN; WRITELN(' is a Drawdown to a printer or the terminal. The program'); WRITELN; WRITELN(' was inspired by the book "COLOR AND WEAVE" by Margaret and'); WRITELN; WRITELN(' Thomas Windeknecht. It is written in UCSD Pascal version'); WRITELN; WRITELN(' IV.1 for the Sage II computer and output on a standard'); WRITELN; WRITELN(' printer or graphics output on the IDS-460 printer.'); WRITELN; WRITELN(' by GEORGE. H. DODGE December 1983'); WRITELN; WRITELN; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(TITLE); END; PROCEDURE CMENU; {Color and weave menu} VAR OKSET : SETOFCHAR; BEGIN OKSET := ['A','a','B','b','C','c','D','d','P','p','Q','q']; REPEAT CLEARSCREEN; WRITE('> Draw 8-c: A)Threading B)Tieup C)Treadling '); WRITE('D)DrawnIn P)rint Q)uit--> '); CH := GETCHAR(OKSET); CASE CH OF 'A','a' : THREADING; 'B','b' : TYEUP; 'C','c' : TREADLING; 'D','d' : COPYTHRD; 'P','p' : PRINT; 'Q','q' : BEGIN CLEARSCREEN; MENU; END; END; UNTIL FALSE END; PROCEDURE PMENU; {Plain drawdown menu} VAR OKSET : SETOFCHAR; BEGIN OKSET := ['A','a','B','b','C','c','D','d','P','p','Q','q']; REPEAT CLEARSCREEN; WRITE('> Draw 8: A)Threading B)Tieup C)Treadling '); WRITE('D)DrawnIn P)rint Q)uit --> '); CH := GETCHAR(OKSET); CASE CH OF 'A','a' : PTHREADING; 'B','b' : TYEUP; 'C','c' : PTREADLING; 'D','d' : COPYTHRD; 'P','p' : PPRINT; 'Q','q' : BEGIN CLEARSCREEN; MENU; END; END; UNTIL FALSE END; PROCEDURE MENU; {Main program menu} VAR OKSET : SETOFCHAR; BEGIN OKSET := ['C','c','P','p','Q','q']; REPEAT CLEARSCREEN; WRITE('> DrawDown 8 : P)lain drawdown C)olor & weave Q)uit---> '); CH := GETCHAR(OKSET); CASE CH OF 'P','p' : PMENU; 'C','c' : CMENU; 'Q','q' : BEGIN CLEARSCREEN; EXIT(PROGRAM); END; END; UNTIL FALSE END; BEGIN {Main program} TITLE; MENU; END. ======================================================================================== DOCUMENT :usus Folder:VOL29:draw8a.text ======================================================================================== PROGRAM DRAW8; uses screenops; CONST SHOWARPD = '#'; SHOWARPL = ' '; TYPE SETOFCHAR = SET OF CHAR; VAR THREAD : ARRAY[1..80] OF INTEGER; {For threading info} TREADL : ARRAY[1..80] OF INTEGER; {For treadling info} TIE1, TIE2, TIE3, TIE4, TIE5, TIE6 : ARRAY[1..10] OF INTEGER; {For tieup info} COLOR1, COLOR2 : ARRAY[1..80] OF CHAR; {For color info} I, J, K, MAXSIZE, HORIZLEN, VERTLEN, TABBYA, TABBYB : INTEGER; OKSET : SETOFCHAR; GOOD : BOOLEAN; REM : STRING[40]; CH, BS, CR, BELL : CHAR; FT : TEXT; PROCEDURE MENU; FORWARD; PROCEDURE CLEARSCREEN; BEGIN sc_clr_screen; END; PROCEDURE DPIXEL; {Dark pixel for IDS-460 graphics} BEGIN WRITE(FT,CHR(85),CHR(42),CHR(85),CHR(42),CHR(85),CHR(42),CHR(85)); END; PROCEDURE LPIXEL; {Light pixel for IDS-460 graphics} BEGIN WRITE(FT,CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0),CHR(0)); END; FUNCTION GETCHAR(OKSET : SETOFCHAR) : CHAR; VAR CH : CHAR; GOOD : BOOLEAN; BEGIN CR := CHR(13); BELL := CHR(7); REPEAT READ(KEYBOARD,CH); IF EOLN(KEYBOARD) THEN CH := CR; GOOD := CH IN OKSET; IF NOT GOOD THEN WRITE(BELL) ELSE IF CH IN [' '..CHR(125)] THEN WRITE(CH) UNTIL GOOD; GETCHAR := CH; END; { Used by GETINTEGER for bomb proof numerical data entry } FUNCTION GETNUM(MAXVAL,MINVAL : REAL; PTOK : BOOLEAN):REAL; TYPE SETOFCHAR = SET OF CHAR; VAR FIRSTCHAR, LASTCHAR : BOOLEAN; NUMSET, GETSET, OKSET : SETOFCHAR; NUMSTRTEMP : STRING[10]; S1 : STRING[1]; LEN, MAXLEN : INTEGER; NUM : REAL; CR, BS, BELL : CHAR; FUNCTION FPNUM(FPSTR : STRING) : REAL; VAR POWER, SIGN, I : INTEGER; NUM : REAL; BEGIN IF FPSTR[1] = '-' THEN BEGIN SIGN := -1; DELETE(FPSTR,1,1); END ELSE SIGN := 1; POWER := POS('.',FPSTR); IF POWER <> 0 THEN BEGIN DELETE(FPSTR,POWER,1); POWER := LENGTH(FPSTR)- POWER +1; END; NUM := 0; FOR I := 1 TO LENGTH(FPSTR) DO NUM := 10 * NUM + (ORD(FPSTR[I]) - ORD('0')); FPNUM := SIGN * NUM/PWROFTEN(POWER); END; BEGIN CR := CHR(13); BS := CHR(8); BELL := CHR(7); NUMSET := ['0'..'9']; IF MINVAL < 0 THEN OKSET := NUMSET + ['-'] ELSE OKSET := NUMSET; IF PTOK THEN MAXLEN := 8 ELSE MAXLEN := 7; S1 := ' '; NUMSTRTEMP := ''; REPEAT LEN := LENGTH(NUMSTRTEMP); FIRSTCHAR := (LEN=0); LASTCHAR := (LEN=MAXLEN); IF PTOK THEN OKSET := OKSET + ['.'] ELSE OKSET := OKSET - ['.']; IF FIRSTCHAR THEN GETSET := OKSET ELSE IF LASTCHAR THEN GETSET := [CR,BS] ELSE GETSET := OKSET + [CR,BS] - ['-']; S1[1] := GETCHAR(GETSET); IF S1 = '.' THEN PTOK := FALSE; IF S1[1] IN OKSET THEN BEGIN NUMSTRTEMP := CONCAT(NUMSTRTEMP,S1); IF S1[1] IN NUMSET THEN BEGIN NUM := FPNUM(NUMSTRTEMP); IF (NUM > MAXVAL) OR (NUM < MINVAL) THEN BEGIN WRITE(BELL); WRITE(BS,' ',BS); DELETE(NUMSTRTEMP,LEN+1,1); END; END; END ELSE IF S1[1] = BS THEN BEGIN IF POS('.',NUMSTRTEMP) = LEN THEN PTOK := TRUE; WRITE(BS,' ',BS); DELETE(NUMSTRTEMP,LEN,1); END; UNTIL S1[1] = CR; WRITELN; GETNUM := FPNUM(NUMSTRTEMP); END; FUNCTION GETINTEGER(PROMPT : STRING; MAXVAL, MINVAL : INTEGER) : INTEGER; VAR POINTOK : BOOLEAN; {For bomb proof entry of numerical data} EOL : STRING[2]; BEGIN WRITE(PROMPT,CHR(27),CHR(116)); {Erase to end of line for TV-925 Term.} POINTOK := FALSE; GETINTEGER := TRUNC(GETNUM(MAXVAL,MINVAL,FALSE)); END; PROCEDURE THREADING; {Color and weave threading entry routine} VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER; TEMP : ARRAY [1..80] OF INTEGER; TEMPC : ARRAY [1..80] OF CHAR; OKSET : SETOFCHAR; BEGIN CLEARSCREEN; REM := ''; WRITELN; WRITELN('ENTER ANY COMMENTS YOU MAY HAVE UP TO 40 CHARACTERS. IF YOU'); WRITELN('DONT''T WANT ANY COMMENTS PRESS '); WRITELN(' >---------------------------------------<'); WRITE('ENTER COMMENTS --> '); READLN(REM); WRITELN; WRITELN('ENTER THE MAXIMUM NUMBER OF WARP THREADS YOU WANT IN YOUR DRAWDOWN'); WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80'); WRITELN; MAXSIZE := GETINTEGER('HOW MANY WARP THREADS ?---> ',80,1); WRITELN; RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1); RPTFAC := MAXSIZE DIV RPTSEQ; HORIZLEN := RPTSEQ * RPTFAC; WRITELN; WRITELN; WRITELN; WRITELN(' ENTER YOUR THREADING REPEAT SEQUENCE'); WRITELN(' FOR',RPTSEQ:2,' THREADS AND'); WRITELN(' 8 HARNESSES'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('NO.',I:2,' THREAD '); TEMP[I] := GETINTEGER('TO HARNESS NO.---> ',8,1); END; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN THREAD[J] := TEMP[K]; J := J + 1 END; END; CLEARSCREEN; WRITELN; WRITELN('THREADING SEQUENCE IS----->'); WRITELN; COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(THREAD[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN CLEARSCREEN; WRITELN; WRITELN; WRITELN('ENTER YOUR WARP THREAD COLOR REPEAT SEQUENCE WITH EITHER '); WRITELN('"D" OR "L" FOR EACH THREAD FOR ',RPTSEQ,' THREADS'); WRITELN; OKSET := ['D','d','L','l']; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('NO. ',I:2,' THREAD COLOR --> '); TEMPC[I] := GETCHAR(OKSET); WRITELN; END; WRITELN; WRITELN; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN COLOR1[J] := TEMPC[K]; J := J + 1 END; END; CLEARSCREEN; WRITELN('THREAD COLOR SEQUENCE IS --->'); WRITELN; COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(COLOR1[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(THREADING); END; PROCEDURE PTHREADING; {Plain drawdown threading entry routine} VAR COUNT, RPTSEQ, RPTFAC : INTEGER; TEMP : ARRAY[1..80] OF INTEGER; OKSET : SETOFCHAR; BEGIN CLEARSCREEN; REM := ''; WRITELN('ENTER ANY COMMENTS YOU MAY HAVE UP TO 40 CHARACTERS. IF YOU'); WRITELN('DON''T WANT ANY COMMENTS PRESS '); WRITELN; WRITELN(' >---------------------------------------<'); WRITE('ENTER COMMENTS --> '); READLN(REM); WRITELN; WRITELN('ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR DRAWDOWN'); WRITELN('THE MINIMUM SHOULD BE ONE REPEAT LENGTH AND THE MAXIMUM IS 80'); WRITELN; MAXSIZE := GETINTEGER('HOW MANY WARP THREADS ?--> ',80,1); WRITELN; RPTSEQ := GETINTEGER('HOW MANY THREADS IN A REPEAT ?--->',80,1); RPTFAC := MAXSIZE DIV RPTSEQ; HORIZLEN := RPTSEQ * RPTFAC; WRITELN; WRITELN; WRITELN; WRITELN(' ENTER YOUR THREADING REPEAT SEQUENCE'); WRITELN(' FOR ',RPTSEQ:3,' THREADS AND'); WRITELN(' 8 HARNESSES'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('NO. ',I:2,' THREAD '); TEMP[I] := GETINTEGER(' TO HARNESS NO.---> ',8,1); END; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN THREAD[J] := TEMP[K]; J := J + 1 END; END; CLEARSCREEN; WRITELN; WRITELN('THREADING SEQUENCE IS----->'); WRITELN; COUNT := 0; FOR I := 1 TO HORIZLEN DO BEGIN WRITE(THREAD[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(PTHREADING); END; PROCEDURE TYEUP; {Treadle tieup entry routine} BEGIN CLEARSCREEN; WRITE('WHAT TREADLE DO YOU WANT'); TABBYA := GETINTEGER(' FOR TABBY "A" ? --> ',10,1); WRITELN; WRITE('WHAT TREADLE DO YOU WANT'); TABBYB := GETINTEGER(' FOR TABBY "B" ? --> ',10,1); WRITELN; WRITELN(' --> ENTER THE TREADLE TIEUP TO THE HARNESSES <--'); WRITELN; WRITELN(' IF YOU WANT A TREADLE TIED TO ONLY ONE HARNESS'); WRITELN(' THEN ENTER THE SAME HARNESS NO. SIX TIMES OR'); WRITELN(' IF YOU WANT A TREADLE TIED TO TWO HARNESSES THEN'); WRITELN(' REPEAT EITHER OF THE HARNESSES OR IF YOU WANT'); WRITELN(' A TREADLE TIED TO THREE DIFFERENT HARNESSES THEN'); WRITELN(' ENTER THE HARNESS NUMBERS....etc.'); WRITELN; FOR I := 1 TO 10 DO BEGIN WRITE('TREADLE ',I:2); TIE1[I] := GETINTEGER(' TO ---> ',8,1); TIE2[I] := GETINTEGER(' AND ---> ',8,1); TIE3[I] := GETINTEGER(' AND ---> ',8,1); TIE4[I] := GETINTEGER(' AND ---> ',8,1); TIE5[I] := GETINTEGER(' AND ---> ',8,1); TIE6[I] := GETINTEGER(' AND ---> ',8,1); WRITELN; END; WRITELN; WRITELN('"A" TABBY IS TREADLE ',TABBYA); WRITELN('"B" TABBY IS TREADLE ',TABBYB); WRITELN; WRITELN('TIEUP IS -------->'); WRITELN; FOR I := 1 TO 10 DO BEGIN WRITE('TREADLE',I:2,' TO HARNESS NUMBERS',TIE1[I]:2,' -',TIE2[I]:2); WRITE(' -',TIE3[I]:2,' -',TIE4[I]:2,' -',TIE5[I]:2,' -'); WRITELN(TIE6[I]:2); END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(TYEUP); END; PROCEDURE TREADLING; {Color and weave treadling sequence entry routine} VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER; {RPTFAC = Repeat factor, RPTSEQ = Repeat sequence} TEMP : ARRAY[1..80] OF INTEGER; {Temp array to hold repeat sequence} TEMPC : ARRAY[1..80] OF CHAR; {Temp array to hold color repeat sequence} OKSET : SETOFCHAR; BEGIN CLEARSCREEN; RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1); RPTFAC := MAXSIZE DIV RPTSEQ; VERTLEN := RPTSEQ * RPTFAC; WRITELN; WRITELN; WRITELN; WRITELN(' ENTER YOUR TREADLEING REPEAT SEQUENCE'); WRITELN(' FOR ',RPTSEQ:3,' TREADLINGS AND'); WRITELN(' 8 HARNESSES'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('FOR WARP THREAD ',I:2); TEMP[I] := GETINTEGER(' TREADLE NO.---> ',10,1); END; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN TREADL[J] := TEMP[K]; J := J + 1 END; END; WRITELN('TREDLING SEQUENCE IS------>'); WRITELN; COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(TREADL[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN CLEARSCREEN; OKSET := ['D','d','L','l']; WRITELN; WRITELN; WRITELN('ENTER YOUR WEFT COLOR SEQUENCE EITHER "D" OR "L"'); WRITELN('FOR EACH PICK FOR ',RPTSEQ:3,' PICKS'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('NO. ',I:2,' THREAD COLOR --> '); TEMPC[I] := GETCHAR(OKSET); WRITELN; END; WRITELN; WRITELN; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN COLOR2[J] := TEMPC[K]; J := J + 1 END; END; WRITELN; WRITELN; WRITELN('PICK COLOR SEQUENCE IS --->'); WRITELN; COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(COLOR2[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(TREADLING); END; PROCEDURE PTREADLING; {Plain weave treadling sequence entry routine} VAR COUNT, RPTFAC, RPTSEQ, I, J, K : INTEGER; TEMP : ARRAY[1..80] OF INTEGER; OKSET : SETOFCHAR; BEGIN CLEARSCREEN; RPTSEQ := GETINTEGER('HOW MANY TREADLINGS IN A REPEAT ?--->',80,1); RPTFAC := MAXSIZE DIV RPTSEQ; VERTLEN := RPTSEQ * RPTFAC; WRITELN; WRITELN; WRITELN; WRITELN(' ENTER YOUR TREADLEING REPEAT SEQUENCE'); WRITELN(' FOR ',RPTSEQ:3,' TREADLINGS AND'); WRITELN(' 8 HARNESSES'); WRITELN; FOR I := 1 TO RPTSEQ DO BEGIN WRITE('FOR WARP THREAD ',I:2); TEMP[I] := GETINTEGER(' TREADLE NO.---> ',10,1); END; J := 1; FOR I := 1 TO RPTFAC DO BEGIN FOR K := 1 TO RPTSEQ DO BEGIN TREADL[J] := TEMP[K]; J := J + 1 END; END; WRITELN('TREDLING SEQUENCE IS------>'); WRITELN; COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(TREADL[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITE(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(PTREADLING); END; PROCEDURE COPYTHRD; VAR COUNT, I : INTEGER; BEGIN CLEARSCREEN; WRITELN(' **** AS DRAWN IN ****'); WRITELN; WRITELN(' THIS PROCEDURE WILL MAKE YOUR TREADLING SEQUENCE THE SAME AS'); WRITELN(' YOUR THREADING SEQUENCE---IF YOUR TABBY''S ARE ON 9 AND 10'); WRITELN(' AND YOU USE ANY TABBY TREADLING THIS PROCEDURE WILL NOT WORK'); WRITELN; WRITE(' DO YOU WANT TO PROCEED ? Y OR N :--> '); READ(KEYBOARD,CH); IF CH IN ['Y','y'] THEN BEGIN VERTLEN := HORIZLEN; WRITELN; WRITELN; WRITELN(' COPYING THREADING SEQUENCE TO TREADLING SEQUENCE --->'); FOR I := 1 TO VERTLEN DO BEGIN TREADL[I] := THREAD[I]; WRITE('.'); END; WRITELN; WRITELN; WRITELN; WRITELN('TREADLING SEQUENCE IS ---> '); WRITELN; COUNT := 0; FOR I := 1 TO VERTLEN DO BEGIN WRITE(TREADL[I]:2); COUNT := COUNT + 1; IF COUNT MOD 40 = 0 THEN WRITELN; END; WRITELN; WRITELN; OKSET := [CHR(13)]; WRITELN(' PRESS TO CONTINUE'); CH := GETCHAR(OKSET); IF CH = CHR(13) THEN EXIT(COPYTHRD); END ELSE EXIT(COPYTHRD); END; {$I DRAW8A.1.TEXT} ======================================================================================== DOCUMENT :usus Folder:VOL29:drawdn.doc.text ======================================================================================== DOCUMENTATION FOR DRAWDOWN USERS A computer using the UCSD p-System IV.1 is required and a printer with a graphics capability will make a draw-down almost identical with one done by hand on graph paper. A draw-down using a regular printer gives a fairly good draw- down, however it is an elongated version and presents a distorted idea in comparison with a hand draw-down. The time saved in this process can be understood when using a straight draw twill threading with a standard tie-up by the timing of the running of the program. To key in all the original information (including the color and weave sequences) took a total time of 3 minutes. Using the option to change the treadlings and color and weave sequences only, took 1-1/2 minutes. By using the "menu-driven" commands and following the directions on the screen, even a person with no computer experience can get draw-downs once the equipment is running (computer on - screen ready - program in place - and printer on and ready to print. The screen will display: >DrawDown 4: P)lain drawdown C)olor & Weave Q)uit There are 3 decisions to make: "P" to proceed with an ordinary drawdown, "C" to select a color and weave option, or "Q" to quit. In order to do this one merely preses one key, either P or C or Q. >DrawDown 4: Lets you know that you are in a 4 harness drawdown program. >Draw 4: A)Threading B)Tie-up C)Treadling D)Drawn-In P)Print Q)uit >Draw 4: Indicates that the plain portion of the program is running. >Draw 4C: Indicates that the color & weave portion of the program is running. A)Threading - refers to the original draft for threading a warp - One should be aware of the number of repeats of the pattern and when the the question comes up for how many warp threads, be prepared to answer how many (straight twill 1-2-3-4- x 10 repeats = 40) - in this case 40. The smallest number for one repeat is 2, the largest is 80. Eighty is chosen as the maximum number because of screen and printer limitations. Complex patterns must be built up - block by block. Once the number of threads are selected, the computer will adjust the maximum that is entered so that an even number of repeats will be shown. B)Tieup refers to any ordinary loom tie-up or in the case of table looms, the harness combinations. Special or trial tie-ups may be entered or changed without affecting either the threading or the treadling. How to do this will be explained later. Tabby sequences are possible by designating certain harnesses as such. C)Treadling refers to the treadling sequence in one repeat. The computer fills in any additional repeats as called for. Each treadling may be viewed or printed, and then if different one is desired it is possible. D)DrawnIn - will automatically enter a treadling sequence identical to the threading, commonly known as "TROMP-AS- WRIT" or "AS DRAWN IN". P)Print: This command also gives choices, such as for display on the screen only, to go to an ordinary printer or to go to the graphics printeri. Q)Quit is the command that stops the program. There is no capacity to save individual draw-downs at present, however it is possible if the need is greater than the need for storage disks. Considering the time involved in doing a draw-down it seems wiser at present to have all the information on a hard (paper) copy rather than fill disk after disk with drafts. As many copies as needed of a particular draft may be made before the "Q" command is called. In view of this, it seema that hard-copy files of all draw-downs be kept for future reference. The program was written for a rising shed loom. THE ABOVE IS A BRIEF EXPLANATION OF WHAT THE PROGRAM DOES, FROM THE HANDWEAVERS POINT OF VIEW. FOLLOWING IS THE HANDS ON PRESENTATION OR WHAT HAPPENS WHEN A WEAVER IS USING THE PROGRAM FOR THE FIRST TIME: USING THE SYSTEM DISK, (IN DISK DRIVE 4) BOOT UP THE SYSTEM, THEN WITH THE DISK "WEAVE" (IN DISK DRIVE 5) SELECT THE PROPER OPTION TO GET INTO THE PROGRAM. (WHAT APPEARS ACROSS THE TOP OF THE SCREEN IS THE MENU - WHAT FOLLOWS IT ARE THE OPTIONS OR ACTIVITIES AVAILABLE FOR CHOICE - ONLY ONE OPTION AT A TIME MAY BE SELECTED.) THE ")" CHARACTER INDICATES THAT ONLY THE FIRST LETTER NEED BE TYPED IN. Key --X-- when asked - Execute what file? - type in WEAVE:DRAW4 (or DRAW8) and the program will come up running. An explanation (Title block) of the program appears. Read and follow directions. The Menu shows three choices: DRAWDOWN 4 (or 8)(This tells which program was selected.) P)LAIN DRAWDOWN, C)OLOR AND WEAVE, Q)UIT. Keying P means that a plain drawdown was selected. Keying C means a Color and WEave drawdown was selected. Keying Q will terminate the program. note: A "C" option will be selected because it shows more options. Everything that appears in the Plain option also appears in the Color and Weave. Menu: DRAW 4C A)Threading B)Tieup C)Treadling D)DrawnIn P)rint Q)uit A)Threading NOTE: Always start with the "A" option as this option defines how large the drawdown pattern will be and it establishes this size for the other options to use. By keying the A the 1st thing to appear is COMMENT. Enter any comments you may want to make. This permits anything to be entered - perhaps an identifying name or number or source, but room has been reserved for only 40 spaces. If no such comment is desired, press [Return]. ENTER THE MAXIMUM NUMBER OF THREADS YOU WANT IN YOUR DRAWDOWN. THE MINIMUM NUMBER SHOULD BE ONE REPEAT AND THE MAXIMUM IS 80. HOW MANY WARP THREADS? Enter the number (for example) 10. HOW MANY THREADS IN A REPEAT? Enter the number (for example) 2. ENTER YOUR THREADING REPEAT SEQUENCE FOR (number) THREADS AND ( 4 ) HARNESSES. NO. 1 THREAD TO HARNESS NO. (number). NO. 2 THREAD TO HARNESS NO. (number). NO. 3 THREAD TO HARNESS NO. (number). NO. 4 THREAD TO HARNESS NO. (number). etc: A horizontal presentation of the sequence appears on the screen, follow directions, press [Return]. ENTER YOUR WARP THREAD COLOR REPEAT SEQUENCE WITH EITHER "D" OR "L" FOR EACH 2 THREADS. (More than 2 colors are not possible with the present programs). NO. 1 THREAD COLOR (when cursor remains in one place - key either) D or L. At the top of the screen WARP THREAD COLOR SEQUENCE IS __ (color sequence appears horizontally). Press [Return] to continue. The previous menu appears, this time press the B key which relates to the tie up. B)Tie up WHAT TREADLE DO YOU WANT FOR TABBY A? (Usually refers to a number other than any of the numbered harnesses for example answer) 5. [Return] WHAT TREADLE DO YOU WANT FOR TABBY B? (ans.) 6. [Return].i ENTER THE TREADLE TIE UP TO THE HARNESSES. If a treadle is tied to only one harness - then - enter that same harness number 3 times or if a treadle is tied to 2 harnesses - then - repeat either of the harnesses once or if a treadle is tied to 3 different harnesses - then - enter all three numbers. Draw 4 has reserved space for 3 different harnesses on each treadle, Draw 8 has reserved space for 6 different harnesses per treadle.....Each space must be filled (for the computer), but remember that you can in reality only tie harness 2 to treadle 1 one time, no matter how many times it is repeated for the computer. Repetition of the numbers of harnesses permit greater flexibility in tie ups. TREADLE 1 TO (Enter the harness to which treadle is tied) for example...) 1 and 2 and 2. Key [Return] after each entry. TREADLE 2 TO (Enter...) 2 and 3 and 3. TREADLE 3 TO (Enter...) 3 and 4 and 4. TREADLE 4 TO (Enter...) 4 and 1 and 1 etc: A summary of the tie up appears for double checking [Return]. Note: Space is left on the hard-copy print to paste on a graph paper copy of the draft and tie up to the left of the printer-copy. C)treadling HOW MANY TREADLINGS IN A REPEAT (for example) 4. ENTER YOUR TREADLING REPEAT SEQUENCE FOR 4 TREADLINGS AND 4 HARNESSES. FOR WARP THREAD 1 - TREADLE NO _____ (complete). [Return] after each entry. FOR WARP THREAD 2 - TREADLE NO _____ [Return]. FOR WARP THREAD 3 - TREADLE NO _____ [Return]. FOR WARP THREAD 4 - TREADLE NO _____ [Return]. etc: ENTER YOUR WEFT COLOR SEQUENCE (either D or L for each pick of the repeat). NO 1 THREAD COLOR ____ (no return is needed here) NO 2 THREAD COLOR ____ NO 3 THREAD COLOR ____ NO 4 THREAD COLOR ____ etc: Again there will be a horizontal sequence of colors displayed. The draft has been entered, now the computer really goes to work. P)rint By keying P for print, another set of choices appears on the screen. S)creen P)rinter G)raphics Q)uit S. shows a screen draw down which gives a fair representation of graph paper version. P. gives the typewriter or printer version of what appeared on the screen. It is a distorted and much elongated representation of the draw down. G. produces the same draw down, but it most nearly approximates the graph paper version because the design is made up of adjoining squares. Before each step of the print out continues the program is stopped to let you check the printer settings. Remember each time you change settings on a printer, turn the printer off to be sure it has your new instructions in the memory. There is only one more item on the menu -- that is Q)UIT. Q. will bring up the previous menu....If you want to experiment with other tie-ups the "A" or "B" or "C" keys may be changed - one at a time. In other words, by changing the "C" or treadling, an entire new treadling sequence may be tried without changing either the threading or the tie up, or another tie up may be chosen without changing the threading or the treadling. When making these choices, the original threading sequence and the repeats should either be put in first and remain, or if it is changed, treadling should be re entered. Use of a color printer is possible, howeve, the program would have to be adjusted and we preferred to work only in black and white. If you make a mistake in one of your entries, continue to enter any data untill that option is completed then when the menu appears again, select the same option and re-enter that option and the mistake will be corrected. You are finished and want to stop entirely. Key "Q" and the original menu appears. There is still the choice to go to either a simpler or more complex version. You may elect to do the draw-down as a plain version or in color and weave, if really quitting is desired, keying the "Q" again terminates the program. If you want to do an 8 harness you will have to eX)ecute the DRAW8 program as at the start. ======================================================================================== DOCUMENT :usus Folder:VOL29:install.text ======================================================================================== 1 Program CONVERS - Installation Notes John Dykstra April 14, 1984 This document is an attempt to describe everything needed to install CONVERS on a personal computer running the p-System. Most of the material concerns the external compilation UNIT's that are used to interface CONVERS to the hardware and software of the system. There is also some discussion of the system features useful or necessary when running CONVERS, and some miscellaneous notes. The final section describes TERMINAL, which provides "dumb terminal" emulation, with the added capability of easily calling CONVERS. John Dykstra 4788 Anderson Lane Shoreview, MN 55112 (612) 483-4286 (612) 482-3874 1 1-1 84/04/16 --------------------------------------------------------------- 1.0 SEPARATE COMPILATION UNITS --------------------------------------------------------------- 1.0 SEPARATE COMPILATION UNITS + __________________________ CONVERS uses separate compilation units to handle machine and implementation dependent matters. 1.1 SCREENOPS + _________ Softech provides SCREENOPS as a standard part of the Version IV p-System. II.0 systems can use the SCREENOPS provided with CONVERS. Since this UNIT obtains character definitions from the p-system, this code should work for all II.0 systems. II.1 users may have to modify it to get it to work with their systems. To compile SCREENOPS on either II.0 or II.1, you will need a copy of the GLOBALS definitions for your system. These files have been distributed through USUS. 1.2 REMUNIT + _______ CONVERS uses the USUS standard remote compilation unit REMUNIT to interface to the link. See USUS Newsletter 4 for a description of this UNIT. REMUNIT's for several popular personal computers have been distributed through the USUS library. 1.3 TEXTIO + ______ TEXTIO handles reading and writing text lines from disk files. It has two advantages: It allows ARRAY's of FILES, and on II.0 systems it is much faster than Pascal READ and WRITE statements. I have included sources of TEXTIO for II.0 and IV systems. Both should run without modification on all systems of the proper version. If you have II.1, you may have to modify the II.0 source to get it to compile. The source for IV includes explicit p-codes, and may therefore have to be modified due to future changes in the p-System. It has been tested thru Version IV.03. If it stops working when you upgrade to a later system, try using DECODE to look at the p-codes generated by READ and WRITE statements. 1 1-2 84/04/16 --------------------------------------------------------------- 1.0 SEPARATE COMPILATION UNITS 1.4 OSMISC --------------------------------------------------------------- 1.4 OSMISC + ______ This unit provides miscellaneous services, including a way to pass parameters and commands between various programs, and a real-time timer. The UCSD operating system currently does not provide a standard way to pass a parameter string to an executing program. OSMISC implements my own scheme. The unit first looks for a parameter string on a file called CMDLINE.TEXT on the system device. If that file does not exist or is empty, a command string is requested from the keyboard. The EXECUTE command calls OSMISC to pass a parameter string to the called program. That string is written to CMDLINE.TEXT on the system device. OSMISC also implements the real-time timers that CONVERS uses to keep track of how long it waits for prompts. Time periods are expressed in tenths of a second. The distributed versions of these UNIT's approximate the operation of the timers by delay loops. If these UNIT's are used, the time periods specified in scripts will be only approximate. If your system has a real-time clock, you may want to modify OSMISC to use it. There are two versions of OSMISC provided. The II.0 version uses a separate unit called CHAIN from Volume 8 of the USUS library. The IV version uses interfaces from the Softech standard unit COMMANDIO. Both of these versions follow their own conventions for keyboard control, which may or may not match the conventions of your system. The backspace key is used to delete one character, and ASCII code CAN (control-X) is used to delete the entire typein. If desired, these can be changed by editing and compiling the source for the unit. 1 2-1 84/04/16 --------------------------------------------------------------- 2.0 OTHER SYSTEM REQUIREMENTS AND INTERFACES --------------------------------------------------------------- 2.0 OTHER SYSTEM REQUIREMENTS AND INTERFACES + ________________________________________ 2.1 DISPLAY + _______ CONVERS uses the SC_USE_INFO procedure in SCREENOPS to find out the height of the display screen. (It assumes that the screen is at least 80 characters wide.) Separate compilation unit OSMISC assumes that the ASCII character BS (backspace) moves the cursor back one space when written to the display. This can be changed, if necessary, by editing and re-compiling OSMISC. 2.2 LINK + ____ CONVERS uses the USUS standard remote compilation unit REMUNIT to interface to the link. Normally, the physical implementation of the link is an asynchronous RS-232 line, possibly including modems and dial-up connections. When CONVERS begins operation, it "searches" for the highest baud rate accepted by REMUNIT. The following rates are tried, in the order given: 9600, 1200, 300 and 110 baud. If none of these baud rates is accepted and the remote unit does not supply its own default (indicated by a result of CR_SELECT_NOT_SUPPORTED), a message is displayed, and CONVERS aborts. If this procedure will not work with your REMUNIT, set the constant DEFAULT_BAUD at the beginning of CONVERS to the baud rate desired, and all of this searching will be bypassed. CONVERS calls CR_SETCOMMUNICATIONS with parameters specifying even parity, a character size of 7 bits, and 1 stop bit. If necessary, these defaults can be changed via the constant declarations at the beginning of the CONVERS source code. To reduce the possiblility of losing incoming serial characters during workstation disk I/O operations, the link hardware should be interrupt-driven, and provide buffering capacity. The exact amount of buffering necessary is dependent upon the link data rate and workstation hardware characteristics. CONVERS has been successfully run at 300 baud with 16 characters of buffer space, and at 1200 baud with 64 characters of space. If the host system recognizes flow-control characters such as DC1 and DC3 (sometimes referred to as XON and XOFF), the 1 2-2 84/04/16 --------------------------------------------------------------- 2.0 OTHER SYSTEM REQUIREMENTS AND INTERFACES 2.2 LINK --------------------------------------------------------------- interrupt driver for the link can use this flow control to prevent overflow of its buffers. This effectively eliminates any chance of losing characters. If possible, interaction with the host should be in full-duplex mode. This eliminates the possibility of an echoed character appearing in the middle of a host string that is being searched for by CONVERS, and falsely preventing recognition of the match. The UPLOAD option of TRANSFER attempts to read and discard any echos it receives, but CONVERS has not been extensively tested in this mode. The CONVERS commands DIAL and HANGUP have not been tested, due to the lack of an auto-dial modem. 1 3-1 84/04/16 --------------------------------------------------------------- 3.0 MISCELLANEOUS NOTES --------------------------------------------------------------- 3.0 MISCELLANEOUS NOTES + ___________________ The UCSD P-system permits file names to begin with a digit character. These file names cannot be used by CONVERS, due to a syntatic conflict between names and integer constants. 1 4-1 84/04/16 --------------------------------------------------------------- 4.0 PROGRAM TERMINAL --------------------------------------------------------------- 4.0 PROGRAM TERMINAL + ________________ This program provides "dumb terminal" emulation, with the added capability of easily calling CONVERS. The baud rate, parity, character size and stop bit options used by terminal are determined by compile-time constants. The code uses separate compilation units REMUNIT, SCREENOPS, and OSMISC. When TERMINAL is executed, it immediately goes into terminal mode. Every key hit will be transmitted to the host, and each character received from the host is displayed. Hitting Control-E will exit the program. Hitting Control-C will result in a prompt for a CONVERS parameter string. The user should enter a command string for CONVERS, in the usual form. When carriage-return is hit, TERMINAL ends execution, and CONVERS begins. If carriage-return is hit without a parameter line, TERMINAL continues execution. 1 84/04/16 Table of Contents 1.0 SEPARATE COMPILATION UNITS . . . . . . . . . . . 1-1 1.1 SCREENOPS . . . . . . . . . . . . . . . . . . . . 1-1 1.2 REMUNIT . . . . . . . . . . . . . . . . . . . . . 1-1 1.3 TEXTIO . . . . . . . . . . . . . . . . . . . . . 1-1 1.4 OSMISC . . . . . . . . . . . . . . . . . . . . . 1-2 2.0 OTHER SYSTEM REQUIREMENTS AND INTERFACES . . . . 2-1 2.1 DISPLAY . . . . . . . . . . . . . . . . . . . . . 2-1 2.2 LINK . . . . . . . . . . . . . . . . . . . . . . 2-1 3.0 MISCELLANEOUS NOTES . . . . . . . . . . . . . . . 3-1 4.0 PROGRAM TERMINAL . . . . . . . . . . . . . . . . 4-1 ======================================================================================== DOCUMENT :usus Folder:VOL29:osmisc_ii0.text ======================================================================================== UNIT osmisc; { UNIT OSMISC - II.0 Version { This unit provides various utility functions that may be system dependent. } { {$C Copyright 1981, 1982, 1983, 1984 by John Dykstra. All rights reserved. } INTERFACE TYPE os_timer = RECORD hitime: INTEGER; lotime: INTEGER; END; os_prog_name = STRING [ 25 ]; os_prog_param = STRING [ 255 ]; PROCEDURE os_start_timer ( VAR user_timer: os_timer ); FUNCTION os_elapsed_time ( VAR user_timer: os_timer ): INTEGER; PROCEDURE os_get_param_string ( VAR param_string: os_prog_param ); PROCEDURE os_store_command ( prog_name: os_prog_name; param_string: os_prog_param ); PROCEDURE os_clear_commands; PROCEDURE os_exit_to_next; PROCEDURE os_chain_to_program ( prog_name: os_prog_name ); IMPLEMENTATION CONST { The following constants define special control characters for { keyboard input within OS_GET_PARAM_STRING. } ch_bs = 8; { character to delete one character } ch_can = 24; { character to delete entire field } { The following constant is used in OS_ELAPSED_TIME to approximate the { operation of a real-time clock. The value supplied is more or less { right for a 4Mhz Z80 running II.0 or IV.03. } kludge_constant = 2; { Other miscellaneous constant definitions. } cmd_file_name = '*CMDLINE.TEXT'; codefile_suffix = '.CODE'; VAR saved_name: os_prog_name; PROCEDURE chain ( codefile: STRING ); EXTERNAL; PROCEDURE os_start_timer; BEGIN user_timer.hitime := 0; END; FUNCTION os_elapsed_time; BEGIN user_timer.hitime := user_timer.hitime + kludge_constant; os_elapsed_time := user_timer.hitime; END; PROCEDURE os_get_param_string; CONST console = 2; ch_esc = 27; ch_cr = 13; VAR bs_string: STRING [ 3 ]; str: STRING [ 1 ]; cmd_file: TEXT; index: INTEGER; got_command: BOOLEAN; BEGIN { PROCEDURE os_get_param_string } bs_string := ' '; bs_string [ 1 ] := CHR ( ch_bs ); bs_string [ 2 ] := ' '; bs_string [ 3 ] := CHR ( ch_bs ); param_string := ''; got_command := FALSE; {$I- Disable implicit I/O checking } RESET ( cmd_file, cmd_file_name ); {$I+ Re-enable implicit I/O checking } IF IORESULT = 0 THEN IF NOT EOF ( cmd_file ) THEN BEGIN READLN ( cmd_file, param_string ); CLOSE ( cmd_file, PURGE ); got_command := LENGTH ( param_string ) > 0; END; { ifend } IF NOT got_command THEN BEGIN GOTOXY ( 0, 22 ); WRITE( 'What is the parameter line? ' ); str := 'x'; REPEAT BEGIN UNITREAD ( console, str [ 1 ], 1, , 4 + 2 ); IF str [ 1 ] >= ' ' THEN BEGIN param_string := CONCAT ( param_string, str ); UNITWRITE ( console, str [ 1 ], 1 ); END ELSE IF ( str [ 1 ] = CHR ( ch_bs ) ) AND ( LENGTH ( param_string ) > 0) THEN BEGIN DELETE ( param_string, LENGTH ( param_string ), 1 ); UNITWRITE ( console, bs_string [ 1 ], 3 ); END ELSE IF str [ 1 ] = CHR ( ch_can ) THEN WHILE LENGTH ( param_string ) > 0 DO BEGIN DELETE ( param_string, LENGTH ( param_string ), 1 ); UNITWRITE ( console, bs_string [ 1 ], 3 ); END; END; { REPEATEND } UNTIL ( str [ 1 ] = CHR ( ch_esc ) ) OR ( str [ 1 ] = CHR ( ch_cr ) ); IF str [ 1 ] = CHR ( ch_esc ) THEN EXIT ( PROGRAM ); END; { ifend } END; { PROCEDURE os_get_param_string } PROCEDURE os_store_command; VAR cmd_file: TEXT; BEGIN { PROCEDURE os_store_command } saved_name := prog_name; REWRITE ( cmd_file, cmd_file_name ); WRITELN ( cmd_file, param_string ); CLOSE ( cmd_file, LOCK ); END; { PROCEDURE os_store_command } PROCEDURE os_clear_commands; VAR cmd_file: TEXT; BEGIN { PROCEDURE os_clear_commands } {$I- Disable implicit I/O checking } RESET ( cmd_file, cmd_file_name ); {$I+ Re-enable implicit I/O checking } IF IORESULT = 0 THEN CLOSE ( cmd_file, PURGE ); END; { PROCEDURE os_clear_commands } PROCEDURE os_exit_to_next; BEGIN { PROCEDURE os_exit_to_next } IF LENGTH ( saved_name ) > 0 THEN chain ( CONCAT ( saved_name, codefile_suffix ) ); EXIT ( PROGRAM ); END; { PROCEDURE os_exit_to_next } PROCEDURE os_chain_to_program; BEGIN chain ( CONCAT ( prog_name, codefile_suffix ) ); EXIT ( PROGRAM ); END; END. ======================================================================================== DOCUMENT :usus Folder:VOL29:osmisc_iv.text ======================================================================================== PROGRAM aunit; {$S+} UNIT osmisc; { UNIT OSMISC } { P-System Version IV.03 } { This unit provides various utility functions that may be system-dependent. } {$C Copyright 1981, 1982, 1984 by John Dykstra. All rights reserved. } INTERFACE TYPE os_timer = RECORD hitime: INTEGER; lotime: INTEGER; END; os_prog_name = STRING [ 25 ]; os_prog_param = STRING [ 255 ]; PROCEDURE os_start_timer ( VAR user_timer: os_timer ); FUNCTION os_elapsed_time ( VAR user_timer: os_timer ): INTEGER; PROCEDURE os_get_param_string ( VAR param_string: os_prog_param ); PROCEDURE os_store_command ( prog_name: os_prog_name; param_string: os_prog_param ); PROCEDURE os_clear_commands; PROCEDURE os_exit_to_next; PROCEDURE os_chain_to_program ( prog_name: os_prog_name ); IMPLEMENTATION USES commandio; CONST { The following constants define special control characters for { keyboard input within GET_PARAM_STRING. } ch_bs = 8; { character to delete one character } ch_can = 24; { character to delete entire field } { The following constant is used in OS_ELAPSED_TIME to approximate the { operation of a real-time clock. The value supplied is more or less { right for a 4Mhz Z80 running II.0 or IV.03. } kludge_constant = 2; { Other miscellaneous constant definitions. } cmd_file_name = '*CMDLINE.TEXT'; codefile_suffix = '.CODE'; PROCEDURE os_start_timer; BEGIN user_timer.hitime := 0; END; FUNCTION os_elapsed_time; BEGIN user_timer.hitime := user_timer.hitime + kludge_constant; os_elapsed_time := user_timer.hitime; END; PROCEDURE os_get_param_string; CONST console = 2; ch_esc = 27; ch_cr = 13; VAR bs_string: STRING [ 3 ]; str: STRING [ 1 ]; cmd_file: TEXT; index: INTEGER; got_command: BOOLEAN; BEGIN { PROCEDURE os_get_param_string } bs_string := ' '; bs_string [ 1 ] := CHR ( ch_bs ); bs_string [ 2 ] := ' '; bs_string [ 3 ] := CHR ( ch_bs ); param_string := ''; got_command := FALSE; {$I- Disable implicit I/O checking } RESET ( cmd_file, cmd_file_name ); {$I+ Re-enable implicit I/O checking } IF IORESULT = 0 THEN IF NOT EOF ( cmd_file ) THEN BEGIN READLN ( cmd_file, param_string ); CLOSE ( cmd_file, PURGE ); got_command := LENGTH ( param_string ) > 0; END; { ifend } IF NOT got_command THEN BEGIN GOTOXY ( 0, 22 ); WRITE( 'What is the parameter line? ' ); str := 'x'; REPEAT BEGIN UNITREAD ( console, str [ 1 ], 1, , 4 + 2 ); IF str [ 1 ] >= ' ' THEN BEGIN param_string := CONCAT ( param_string, str ); UNITWRITE ( console, str [ 1 ], 1 ); END ELSE IF ( str [ 1 ] = CHR ( ch_bs ) ) AND ( LENGTH ( param_string ) > 0) THEN BEGIN DELETE ( param_string, LENGTH ( param_string ), 1 ); UNITWRITE ( console, bs_string [ 1 ], 3 ); END ELSE IF str [ 1 ] = CHR ( ch_can ) THEN WHILE LENGTH ( param_string ) > 0 DO BEGIN DELETE ( param_string, LENGTH ( param_string ), 1 ); UNITWRITE ( console, bs_string [ 1 ], 3 ); END; END; { REPEATEND } UNTIL ( str [ 1 ] = CHR ( ch_esc ) ) OR ( str [ 1 ] = CHR ( ch_cr ) ); IF str [ 1 ] = CHR ( ch_esc ) THEN { The following code is temporarily deleted due to a bug in IV.03's { implementation of the EXIT statement from UNIT's. It is up to the { caller to check for a null command. } (* EXIT ( PROGRAM ); *) param_string := ''; END; { ifend } END; { PROCEDURE os_get_param_string } {$P} PROCEDURE os_store_command; VAR cmd_file: TEXT; BEGIN { PROCEDURE os_store_command } CHAIN ( prog_name ); REWRITE ( cmd_file, cmd_file_name ); WRITELN ( cmd_file, param_string ); CLOSE ( cmd_file, LOCK ); END; { PROCEDURE os_store_command } PROCEDURE os_clear_commands; VAR cmd_file: TEXT; BEGIN { PROCEDURE os_clear_commands } CHAIN ( '' ); {$I- Disable implicit I/O checking } RESET ( cmd_file, cmd_file_name ); {$I+ Re-enable implicit I/O checking } IF IORESULT = 0 THEN CLOSE ( cmd_file, PURGE ); END; { PROCEDURE os_clear_commands } PROCEDURE os_exit_to_next; BEGIN { PROCEDURE os_exit_to_next } { The following code is temporarily deleted due to a bug in IV.03's { implementation of the EXIT statement from UNIT's. It is up to the { caller to exit after calling this noop procedure. } (* EXIT ( PROGRAM ); *) END; { PROCEDURE os_exit_to_next } PROCEDURE os_chain_to_program { ( prog_name: STRING ) }; BEGIN { PROCEDURE os_chain_to_program } chain ( prog_name ); END; { PROCEDURE os_chain_to_program } END. ======================================================================================== DOCUMENT :usus Folder:VOL29:scrnop_ii0.text ======================================================================================== {$S+} {$I *GLOBAL.II0 } { SCREENOPS { { Version C1 { { This unit implements a subset of the Softech definition of SCREENOPS for { version II.0 systems. { { WARNING - Not all SCREENOPS functions are currently implemented. { { The INTERFACE section of this code is copyrighted by Softech Microsystems. { } {$C (C) Copyright 1982, 1984 by John Dykstra. All rights reserved.} SEPARATE UNIT screenops; INTERFACE CONST sc_fill_len = 11; sc_eol = 13; TYPE sc_chset = SET OF CHAR; sc_misc_rec = PACKED RECORD height, width : 0..255; can_break, slow, xy_crt, lc_crt, can_upscroll, can_downscroll : BOOLEAN; END; sc_date_rec = PACKED RECORD month : 0..12; day : 0..31; year : 0..99; END; sc_info_type = PACKED RECORD sc_version : STRING; sc_date : sc_date_rec; spec_char : sc_chset; {Characters not to echo} misc_info : sc_misc_rec; END; sc_long_string = STRING[255]; sc_scrn_command = (sc_whome, sc_eras_s, sc_erase_eol, sc_clear_lne, sc_clear_scn, sc_up_cursor, sc_down_cursor, sc_left_cursor, sc_right_cursor); sc_key_command = (sc_backspace_key, sc_dc1_key, sc_eof_key, sc_etx_key, sc_escape_key, sc_del_key, sc_up_key, sc_down_key, sc_left_key, sc_right_key, sc_not_legal); sc_choice = (sc_get, sc_give); sc_window = PACKED ARRAY [0..0] OF CHAR; sc_tx_port = RECORD row, col, { screen relative} height, width, { size OF txport (zero based)} cur_x, cur_y : INTEGER; {cursor positions relative to the txport } END; PROCEDURE sc_use_info(do_what:sc_choice; VAR t_info:sc_info_type); PROCEDURE sc_use_port(do_what:sc_choice; VAR t_port:sc_tx_port); PROCEDURE sc_erase_to_eol(x,line:INTEGER); PROCEDURE sc_left; PROCEDURE sc_right; PROCEDURE sc_up; PROCEDURE sc_down; PROCEDURE sc_getc_ch(VAR ch:CHAR; return_on_match:sc_chset); PROCEDURE sc_clr_screen; PROCEDURE sc_clr_line (y:INTEGER); PROCEDURE sc_home; PROCEDURE sc_eras_eos (x,line:INTEGER); PROCEDURE sc_goto_xy(x, line:INTEGER); PROCEDURE sc_clr_cur_line; FUNCTION sc_find_x:INTEGER; FUNCTION sc_find_y:INTEGER; FUNCTION sc_scrn_has(what:sc_scrn_command):BOOLEAN; FUNCTION sc_has_key(what:sc_key_command):BOOLEAN; FUNCTION sc_map_crt_command(VAR k_ch:CHAR):sc_key_command; FUNCTION sc_prompt(line :sc_long_string; x_cursor,y_cursor,x_pos, where:INTEGER; return_on_match:sc_chset; no_char_back:BOOLEAN; break_char:CHAR):CHAR; FUNCTION sc_check_char(VAR buf:sc_window; VAR buf_index,bytes_left:INTEGER) :BOOLEAN; FUNCTION space_wait(flush:BOOLEAN):BOOLEAN; PROCEDURE sc_init; IMPLEMENTATION PROCEDURE sc_use_info { do_what:sc_choice; VAR t_info:sc_info_type }; BEGIN IF do_what = sc_get THEN BEGIN t_info.sc_version := 'II.0 emulation by John Dykstra'; t_info.sc_date := thedate; t_info.spec_char := []; t_info.misc_info.height := 23; t_info.misc_info.width := 79; t_info.misc_info.can_break := FALSE; { ? } t_info.misc_info.slow := FALSE; t_info.misc_info.xy_crt := TRUE; { ? } t_info.misc_info.lc_crt := FALSE; { ? } t_info.misc_info.can_upscroll := TRUE; t_info.misc_info.can_downscroll := TRUE; END; { IFEND } END; PROCEDURE sc_use_port { do_what:sc_choice; VAR t_port:sc_tx_port }; BEGIN END; PROCEDURE sc_erase_to_eol { x,line:INTEGER }; BEGIN GOTOXY ( x, line ); WRITE ( OUTPUT, syscom ^ .crtctrl. eraseeol ); END; PROCEDURE sc_left; BEGIN WRITE ( OUTPUT, syscom ^ . crtctrl . backspace ); END; PROCEDURE sc_right; BEGIN WRITE ( OUTPUT, syscom ^ . crtctrl . ndfs ); END; PROCEDURE sc_up; BEGIN WRITE ( OUTPUT, syscom ^ . crtctrl . rlf ); END; PROCEDURE sc_down; CONST ch_lf = 10; BEGIN WRITE ( OUTPUT, CHR ( ch_lf ) ); END; PROCEDURE sc_getc_ch { VAR ch:CHAR; return_on_match:sc_chset }; BEGIN END; PROCEDURE sc_clr_screen; BEGIN WRITE ( OUTPUT, syscom ^ .crtctrl.clearscreen ); END; PROCEDURE sc_clr_line { y:INTEGER }; BEGIN GOTOXY ( 0, y ); WRITE ( OUTPUT, syscom ^ . crtctrl . clearline ); END; PROCEDURE sc_home; BEGIN WRITE ( OUTPUT, syscom ^ . crtctrl . home ); END; PROCEDURE sc_eras_eos { x,line:INTEGER }; BEGIN GOTOXY ( x, line ); WRITE ( OUTPUT, syscom ^ . crtctrl . eraseeos ); END; PROCEDURE sc_goto_xy { x, line:INTEGER }; BEGIN GOTOXY ( x, line ); END; PROCEDURE sc_clr_cur_line; BEGIN WRITE ( OUTPUT, syscom ^ . crtctrl . clearline ); END; FUNCTION sc_find_x { :INTEGER }; BEGIN END; FUNCTION sc_find_y { :INTEGER }; BEGIN END; FUNCTION sc_scrn_has { what:sc_scrn_command } { :BOOLEAN }; BEGIN sc_scrn_has := TRUE; END; FUNCTION sc_has_key { what:sc_key_command } { :BOOLEAN }; BEGIN END; FUNCTION sc_map_crt_command { VAR k_ch:CHAR } { :sc_key_command }; BEGIN END; FUNCTION sc_prompt { line :sc_long_string; x_cursor,y_cursor,x_pos, where:INTEGER; return_on_match:sc_chset; no_char_back:BOOLEAN; break_char:CHAR } { :CHAR }; BEGIN END; FUNCTION sc_check_char { VAR buf:sc_window; VAR buf_index,bytes_left:INTEGER } { :BOOLEAN }; BEGIN END; FUNCTION space_wait { flush:BOOLEAN } {:BOOLEAN }; BEGIN END; PROCEDURE sc_init; BEGIN END; END; BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL29:terminal.text ======================================================================================== PROGRAM terminal; { 29 Apr 84 gws removed a unitwrite to suppress half duplex 29 Apr 84 gws added $U directives to unit list } USES screenops, (*$U remunit.code*) remunit, (*$U osmisc.code*) osmisc; CONST version = 'C1'; baud_rate = 300; convers_name = '*CONVERS'; exit_command = 5; { CTL-E } convers_command = 3; { CTL-C } ch_esc = 27; VAR c : CHAR ; exit_requested: BOOLEAN; to_convers: BOOLEAN; keyboard: INTERACTIVE; command_string: STRING [ 255 ]; PROCEDURE initialize ; VAR havedial : BOOLEAN ; haverem : BOOLEAN ; result : cr_baud_result ; BEGIN sc_clr_screen; GOTOXY ( 0, 0 ); WRITE ( 'TERMINAL Version ', version, '. Baud rate = ', baud_rate, '.' ); GOTOXY ( 0, 3 ); cr_comminit( cr_orig, CHR( 5 ), haverem, havedial ) ; IF NOT haverem THEN BEGIN WRITELN( ' REMOTE not supported in current environment.' ) ; WRITELN( ' Program is terminating.' ) ; EXIT( PROGRAM ) ; END ; cr_setcommunications( TRUE, TRUE, baud_rate, 7, 1, cr_orig, '', result ) ; WRITE ( 'Waiting for carrier...' ); cr_answer ; GOTOXY ( 0, 3 ); sc_clr_cur_line; END; { PROCEDURE initialize } BEGIN { PROGRAM terminal } initialize ; exit_requested := FALSE; to_convers := FALSE; REPEAT IF cr_remstat THEN BEGIN c := cr_getrem; if c <> chr ( 10 ) then unitwrite ( 1,c,1 ); (* lsi-11 can't suppress lf *) (** UNITWRITE(1,c,1,,4+8 );*)(* use this line instead for most p-systems *) END ELSE BEGIN IF cr_kbstat THEN BEGIN c := cr_getkb ; IF ( c = CHR ( exit_command ) ) OR ( c = CHR ( convers_command )) THEN CASE ORD ( c ) OF exit_command: exit_requested := TRUE; convers_command: BEGIN WRITE ( 'CONVERS command string: '); READLN ( INPUT, command_string ); IF LENGTH ( command_string ) > 0 THEN BEGIN os_store_command ( convers_name, command_string ); exit_requested := TRUE; to_convers := TRUE; END; { IFEND } END; { CASE ITEM } END { CASEND } ELSE BEGIN (**UNITWRITE(1,c,1,,4+8 ) ;*) (* don't want local echo - gws *) cr_putrem( c ) ; END ; END ; IF NOT cr_carrier THEN BEGIN WRITELN ; WRITELN('LOST CARRIER'); WRITELN ; cr_commquit; EXIT ( PROGRAM ) END; END; UNTIL exit_requested; sc_clr_screen; cr_commquit ; IF to_convers THEN os_exit_to_next; END. ======================================================================================== DOCUMENT :usus Folder:VOL29:textio_ii0.text ======================================================================================== {$S+} {$U-} { SEPARATE COMPILATION UNIT - TEXTIO { { Version for p-system II.0 { { This unit provides line-oriented text I/O to and from disk file. The { procedures in this file execute much faster than the corresponding { procedures built into the p-system. } { Some of the following type declarations describe segment 0 of the { p-system. They are copyrighted by the University of California and { Softech Microsystems. } { A note on error processing: All callers of these procedures should { check IORESULT after the call. A close look at the following code will { reveal that nothing much is done if an I/O error occurs. This is due { to some peculiarities in the way that p-system version II.0 handles { (or rather, does not handle) EXIT's within separate procedures. } {$C (C) Copyright 1981, 1982, 1983, 1984 by John Dykstra. All rights reserved} PROGRAM pascalsystem; TYPE window = PACKED ARRAY [ 1..1024 ] OF CHAR; windowp = ^ window; fib = ARRAY [ 1..290 ] OF INTEGER; fibp = ^ fib; closetype = ( cnormal, clock, cpurge, ccrunch ); PROCEDURE EXECERROR; FORWARD; PROCEDURE FINIT(VAR F: FIB; WINDOW: WINDOWP; RECWORDS: INTEGER); FORWARD; PROCEDURE FRESET(VAR F: FIB); FORWARD; PROCEDURE FOPEN(VAR F: FIB; VAR FTITLE: STRING; FOPENOLD: BOOLEAN; JUNK: FIBP); FORWARD; PROCEDURE FCLOSE(VAR F: FIB; FTYPE: CLOSETYPE); FORWARD; PROCEDURE FGET(VAR F: FIB); FORWARD; PROCEDURE FPUT(VAR F: FIB); FORWARD; PROCEDURE XSEEK; FORWARD; FUNCTION FEOF(VAR F: FIB): BOOLEAN; FORWARD; FUNCTION FEOLN(VAR F: FIB): BOOLEAN; FORWARD; PROCEDURE FREADINT(VAR F: FIB; VAR I: INTEGER); FORWARD; PROCEDURE FWRITEINT(VAR F: FIB; I,RLENG: INTEGER); FORWARD; PROCEDURE XREADREAL; FORWARD; PROCEDURE XWRITEREAL; FORWARD; PROCEDURE FREADCHAR(VAR F: FIB; VAR CH: CHAR); FORWARD; PROCEDURE FWRITECHAR(VAR F: FIB; CH: CHAR; RLENG: INTEGER); FORWARD; PROCEDURE FREADSTRING(VAR F: FIB; VAR S: STRING; SLENG: INTEGER); FORWARD; PROCEDURE FWRITESTRING(VAR F: FIB; VAR S: STRING; RLENG: INTEGER); FORWARD; PROCEDURE FWRITEBYTES(VAR F: FIB; VAR A: WINDOW; RLENG,ALENG: INTEGER); FORWARD; PROCEDURE FREADLN(VAR F: FIB); FORWARD; PROCEDURE FWRITELN(VAR F: FIB); FORWARD; PROCEDURE SCONCAT(VAR DEST,SRC: STRING; DESTLENG: INTEGER); FORWARD; PROCEDURE SINSERT(VAR SRC,DEST: STRING; DESTLENG,INSINX: INTEGER); FORWARD; PROCEDURE SCOPY(VAR SRC,DEST: STRING; SRCINX,COPYLENG: INTEGER); FORWARD; PROCEDURE SDELETE(VAR DEST: STRING; DELINX,DELLENG: INTEGER); FORWARD; FUNCTION SPOS(VAR TARGET,SRC: STRING): INTEGER; FORWARD; FUNCTION FBLOCKIO(VAR F: FIB; VAR A: WINDOW; I: INTEGER; NBLOCKS,RBLOCK: INTEGER; DOREAD: BOOLEAN): INTEGER; FORWARD; PROCEDURE FGOTOXY(X,Y: INTEGER); FORWARD; SEPARATE UNIT textio; INTERFACE TYPE io_fib = ARRAY [ 1..290 ] OF INTEGER; io_direction = ( io_input, io_output ); io_file = RECORD osfib: io_fib; direction: io_direction; eof_flag: BOOLEAN; buffer: PACKED ARRAY [ 1..1024 ] OF CHAR; next_free: 1..1024; END; { RECEND } io_string = STRING [ 255 ]; PROCEDURE io_open_file ( VAR file_blk: io_file; file_title: STRING; direction: io_direction; VAR successful: BOOLEAN ) ; PROCEDURE io_close_file ( VAR file_blk: io_file ); PROCEDURE io_write_line ( VAR file_blk: io_file; data_string: io_string ); PROCEDURE io_read_line ( VAR file_blk: io_file; VAR data_string: io_string ); PROCEDURE io_seek_line ( VAR file_blk: io_file; desired_line: INTEGER ); FUNCTION io_end_of_file ( VAR file_blk: io_file ): BOOLEAN; IMPLEMENTATION {$R+ Re-enable run-time checking (turned off by U- above) } PROCEDURE io_open_file { ( VAR file_blk: io_file; file_title: STRING; direction: io_direction; successful: BOOLEAN ) }; CONST blk_size = 512; ch_nul = 0; VAR complete_title: STRING; BEGIN { PROCEDURE io_open_file } finit ( file_blk.osfib, NIL, -1 ); complete_title := CONCAT ( file_title, '.TEXT' ); IF direction = io_output THEN BEGIN file_blk.direction := io_output; file_blk.eof_flag := TRUE; fopen ( file_blk.osfib, complete_title, FALSE, NIL ); successful := TRUE; FILLCHAR ( file_blk.buffer [ 1 ], 1025 , CHR ( ch_nul ) ); IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, FALSE ) <> 2 THEN BEGIN successful := FALSE; END; file_blk.next_free := 1; END ELSE BEGIN file_blk.direction := io_input; fopen ( file_blk.osfib, complete_title, TRUE, NIL ); IF IORESULT <> 0 THEN successful := FALSE ELSE BEGIN successful := TRUE; { Insert code here to handle case of open of an empty file. } file_blk.eof_flag := FALSE; IF ( fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, 2, TRUE ) <> 2 ) THEN BEGIN successful := FALSE; END; { IFEND } file_blk.next_free := 1; END; { ELSEND } END; END; { PROCEDURE io_open_file } PROCEDURE io_close_file { ( VAR file_blk: io_file ) }; CONST blk_size = 512; ch_nul = 0; BEGIN { PROCEDURE io_close_file } IF file_blk.direction = io_output THEN BEGIN FILLCHAR ( file_blk.buffer [ file_blk.next_free ], 1025 - file_blk.next_free, CHR ( ch_nul ) ); IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, FALSE ) <> 2 THEN BEGIN END; fclose ( file_blk.osfib, clock ); END ELSE BEGIN fclose ( file_blk.osfib, cnormal ); END; END; { PROCEDURE io_close_file } PROCEDURE io_write_line { ( VAR file_blk: io_file; data_string: io_string ) }; CONST blk_size = 512; ch_nul = 0; ch_cr = 13; VAR new_index: 1..1161; { 1..blksize*2+max_line_length+1 } BEGIN new_index := file_blk.next_free + LENGTH ( data_string ) + 1; { If the string would overflow the buffer, fill the remainder of the buffer with characters and write it out. } IF new_index >= 1025 THEN BEGIN FILLCHAR ( file_blk.buffer [ file_blk.next_free ], 1025 - file_blk.next_free, CHR ( ch_nul ) ); IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, FALSE ) = 2 THEN BEGIN file_blk.next_free := 1; new_index := LENGTH ( data_string ) + 2; END; END; { IFEND } { Put the string into the output buffer, followed by a } IF LENGTH ( data_string ) > 0 THEN MOVERIGHT ( data_string [ 1 ], file_blk.buffer [ file_blk.next_free ], LENGTH ( data_string ) ); file_blk.buffer [ new_index - 1 ] := CHR ( ch_cr ); file_blk.next_free := new_index END; { PROCEDURE io_write_line } PROCEDURE io_read_line { ( VAR file_blk: io_file; VAR data_string: io_string ) }; CONST blk_size = 512; ch_nul = 0; ch_dle = 16; ch_cr = 13; VAR search_length: 1..1024; count: 0..255; index: 1..255; BEGIN { PROCEDURE read_line } IF NOT file_blk.eof_flag THEN BEGIN IF file_blk.buffer [ file_blk.next_free ] = CHR ( ch_dle ) THEN BEGIN { get compressed blank count } count := ORD ( file_blk.buffer [ file_blk.next_free + 1 ] ) - 32; file_blk.next_free := file_blk.next_free + 2; END ELSE count := 0; search_length := 1025 - file_blk.next_free; {$R-} data_string [ 0 ] := CHR ( SCAN ( search_length, = CHR ( ch_cr ), file_blk.buffer [ file_blk.next_free ] ) + count ); { Check to see if we searched without finding a carriage return. This { can happen on the last page of a file created by the editor if no { carriage return was typed after the last line. } IF ( ORD ( data_string [ 0 ] ) - count ) = search_length THEN BEGIN data_string [ 0 ] := CHR ( SCAN ( search_length, = CHR ( ch_nul ), file_blk.buffer [ file_blk.next_free ] ) + count ); END; { IFEND } {$R+} IF ( LENGTH ( data_string ) - count ) > 0 THEN MOVERIGHT ( file_blk.buffer [ file_blk.next_free ], data_string [ 1 + count ], LENGTH ( data_string ) - count ); IF count > 0 THEN FILLCHAR ( data_string [ 1 ], count, ' ' ); file_blk.next_free := file_blk.next_free + LENGTH ( data_string ) - count + 1; IF file_blk.buffer [ file_blk.next_free ] = CHR ( ch_nul ) THEN BEGIN IF feof ( file_blk.osfib ) THEN file_blk.eof_flag := TRUE ELSE BEGIN IF ( fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, TRUE ) <> 2 ) THEN BEGIN END; file_blk.next_free := 1; END; { ELSEND } END; { IFEND } END; { IFEND - at end of file } END; { PROCEDURE io_read_line } {$P} PROCEDURE io_seek_line { ( VAR file_blk: io_file; desired_line: INTEGER ) }; CONST ch_cr = 13; ch_nul = 0; x_2_blk_size = 1024; VAR line_count: INTEGER; BEGIN { PROCEDURE io_seek_line } IF file_blk.direction <> io_input THEN BEGIN END; { IFEND } IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, 2, TRUE ) <> 2 THEN BEGIN END; file_blk.eof_flag := FALSE; file_blk.next_free := 1; line_count := 1; WHILE line_count < desired_line DO BEGIN file_blk.next_free := file_blk.next_free + SCAN ( x_2_blk_size, = CHR ( ch_cr ), file_blk.buffer [ file_blk.next_free ] ) + 1; IF file_blk.buffer [ file_blk.next_free ] = CHR ( ch_nul ) THEN BEGIN IF NOT feof ( file_blk.osfib ) THEN BEGIN IF fblockio ( file_blk.osfib, file_blk.buffer, 0, 2, -1, TRUE ) <> 2 THEN BEGIN END; { IFEND } file_blk.next_free := 1; END; { IFEND } END; { IFEND } line_count := line_count + 1; END; { WHILEND } END; { PROCEDURE io_seek_line } FUNCTION io_end_of_file { ( VAR file_blk: io_file ): BOOLEAN }; BEGIN { FUNCTION io_end_of_file } io_end_of_file := file_blk.eof_flag; END; { FUNCTION io_end_of_file } END; BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL29:textio_iv.text ======================================================================================== UNIT textio; {$C Copyright 1982, 1983 by John Dykstra. All rights reserved. } { This is an implementation of the TEXTIO unit for { P-System Version Iv.03. } INTERFACE TYPE io_direction = ( io_input, io_output ); io_window = ARRAY [ 0..1 ] OF CHAR; io_file = RECORD os_fib: RECORD fwindow: ^ io_window; feof,feoln: BOOLEAN; fstate: (fjandw,fneedchar,fgotchar); frecsize: INTEGER; f_lock : SEMAPHORE; fisopen: BOOLEAN; filler: PACKED ARRAY [ 1..570 ] OF 0..255; END; { RECEND } os_window: io_window; END; { RECEND } io_string = STRING [ 255 ]; PROCEDURE io_open_file ( VAR file_blk: io_file; file_title: STRING; direction: io_direction; VAR successful: BOOLEAN ) ; PROCEDURE io_close_file ( VAR file_blk: io_file ); PROCEDURE io_write_line ( VAR file_blk: io_file; data_string: io_string ); PROCEDURE io_read_line ( VAR file_blk: io_file; VAR data_string: io_string ); PROCEDURE io_seek_line ( VAR file_blk: io_file; desired_line: INTEGER ); FUNCTION io_end_of_file ( VAR file_blk: io_file ): BOOLEAN; IMPLEMENTATION {$R+} { The following procedure exists in the codefile only to force the compiler { to generate segment references to FILEOPS and PASCALIO. } PROCEDURE dummy; VAR dum_file: TEXT; name: STRING; BEGIN name := CONCAT ( '', '' ); REWRITE ( dum_file, name ); IF EOF ( OUTPUT ) THEN WRITELN; END; PROCEDURE io_open_file { ( VAR file_blk: io_file; file_title: STRING; direction: io_direction; successful: BOOLEAN ) }; VAR complete_title: STRING; BEGIN { PROCEDURE io_open_file } { Initialize the file block. This operation is normally done by code { emitted by the compiler at the start of the procedure in which the { file is declared, which calls routine finit in FILEIO. } { file_blk.os_fib.fwindow := ^ file_blk.os_window; } PMACHINE ( ^ file_blk.os_fib.fwindow, ^ file_blk.os_window, { STO } 196 ); file_blk.os_fib.fwindow ^ [ 1 ] := CHR ( 0 ); file_blk.os_fib.feof := TRUE; file_blk.os_fib.feoln := TRUE; file_blk.os_fib.fstate := fjandw; file_blk.os_fib.frecsize := 1; SEMINIT ( file_blk.os_fib.flock, 1 ); file_blk.os_fib.fisopen := FALSE; complete_title := CONCAT ( file_title, '.TEXT' ); IF direction = io_output THEN BEGIN { REWRITE ( file_blk.os_fib, complete_title ); } PMACHINE ( { LDL 130 } ^ file_blk.os_fib , { SLLA 1 } ^ complete_title, { LDCN } 152, { SLDC 0 } 0, { SLDC 0 } 0, { SCXG FILEOPS 2 } 114, 2 ); successful := TRUE; END ELSE BEGIN { RESET ( file_blk.os_fib, complete_title ); } PMACHINE ( { LDL 130 } ^ file_blk.os_fib, { SLLA 1 } ^ complete_title, { LDCN } 152, { SLDC 1 } 1, { SLDC 0 } 0, { SCXG FILEOPS 2 } 114, 2 ); IF IORESULT <> 0 THEN successful := FALSE ELSE BEGIN successful := TRUE; END; { ELSEND } END; END; { PROCEDURE io_open_file } PROCEDURE io_close_file { ( VAR file_blk: io_file ) }; BEGIN { PROCEDURE io_close_file } { CLOSE ( file_blk.os_fib, LOCK ); } PMACHINE ( { SLDL 1 } 32, { SLDC 1 } 1, { SCXG FILEOPS 3 } 114, 3 ); END; { PROCEDURE io_close_file } PROCEDURE io_write_line { ( VAR file_blk: io_file; data_string: io_string ) }; BEGIN { WRITELN ( file_blk.os_fib, data_string ); } PMACHINE ( { LDL 131 } 135, 128, 131, { SLLA 1 } 96, { LDCN } 152, { SLDC 0 } 0, { SCXG PASCALIO 11 } 116, 11, { LDL 131 } 135, 128, 131, { SCXG PASCALIO 14 } 116, 14 ); END; { PROCEDURE io_write_line } PROCEDURE io_read_line { ( VAR file_blk: io_file; VAR data_string: io_string ) }; BEGIN { PROCEDURE read_line } { READLN ( file_blk.os_fib, data_string ); } PMACHINE ( { SLDL 2 } 33, { SLDL 1 } 32, { LDCB 255 } 128, 255, { SCXG PASCALIO 10 } 116, 10, { SLDL 2 } 33, { SCXG PASCALIO 13 } 116, 13); END; { PROCEDURE io_read_line } {$P} PROCEDURE io_seek_line { ( VAR file_blk: io_file; desired_line: INTEGER ) }; VAR line_count: INTEGER; BEGIN { PROCEDURE io_seek_line } { RESET ( file_blk.os_fib ); } PMACHINE ( { SLDL 3 } ^ file_blk.os_fib, { SCXG FILEOPS 6 } 114, 6 ); line_count := 1; WHILE line_count < desired_line DO BEGIN { READLN ( file_blk.os_fib ); } PMACHINE ( { SLDL 3 } ^ file_blk.os_fib, { SCXG PASCALIO 13 } 116, 13); line_count := line_count + 1; END; { WHILEND } END; { PROCEDURE io_seek_line } FUNCTION io_end_of_file { ( VAR file_blk: io_file ): BOOLEAN }; BEGIN { FUNCTION io_end_of_file } { io_end_of_file := EOF ( file_blk.os_fib ); } PMACHINE ( { SLDC 0 } 00, { SLDL 1 } 32, { SCXG PASCALIO 5 } 116, 5, { SSTL 2 } 105 ); END; { FUNCTION io_end_of_file } END. ======================================================================================== DOCUMENT :usus Folder:VOL29:vol29.doc.text ======================================================================================== USUS VOLUME 29 CONVERS and WEAVE A script driven communications package and a weaver's helper (a USUS REMUNIT is needed for CONVERS, see volume #15) DRAW4A.TEXT 32 A simple pattern weave analyzer DRAW4A.1.TEXT 34 an include file DRAW8A.TEXT 32 A more complex pattern weave analyzer DRAW8A.1.TEXT 36 an include file DRAWDN.DOC.TEXT 26 Documentation for the weaver's design package OSMISC_II0.TEXT 12 Misc routines for CONVERS for version II.0 OSMISC_IV.TEXT 14 Same for IV.x TEXTIO_II0.TEXT 26 Text file routines for CONVERS for version II.0 TEXTIO_IV.TEXT 14 Same for IV.x SCRNOP_II0.TEXT 14 An ersatz SCREENOPS for II.0 CONV_TEST.TEXT 6 A test script CONVDOC.TEXT 70 Documentation for CONVERS INSTALL.TEXT 26 Installation notes for CONVERS CONVERS.TEXT 112 CONVERS itself TERMINAL.TEXT 8 A dumb terminal emulator which can stand alone VOL29.DOC.TEXT 6 You're reading it. ----------------------------------------------------------------------------- Please transfer the text below to a disk label if you copy this volume. USUS Volume 29 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by George Schreyer from material collected by the Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOL2A:512.doc.text ======================================================================================== DOCUMENTATION FOR THE 512-BYTE SECTOR SYSTEM This volume of two disks contains a sophisticated new BIOS (Basic Input- Output System) as well as other supporting programs to implement a noticable speedup of disk access and a 23% greater disk capacity by the use of single- density disks with 512-byte sectors accessed sequentially. The use of double- density and double-sided disks is also supported; these formats can be mixed among the disk drives of your system in a manner transparent to the UCSD operating system. I have been running under this system for several months now and am aware of no bugs in its operation. You MUST have the following equipment and facilities in order to implement the 512-byte package: 1) 8080, Z-80, or 8085 CPU. 2) Western Digital-based Disk Controller (i.e., containing a 1771, 1773, 1791, 1792, 1793, 1794, or 1795). Adaptations to the code must be made if you do not have one of the Tarbell boards or the Delta disk controller. 3) The source code to the 8080/Z-80 UCSD interpreter. 4) The UCSD 8080/Z-80 system assembler (though the interpreter could be transported to CP/M and assembled with a CP/M-based assembler). 5) Digital Research's MAC (Macroassembler) running under CP/M (though it is likely that a similar macroassembler, such as M-80 from Microsoft, would also work -- you'd have to check that the syntax for the macro package is compatible). DESCRIPTION OF THE 512-BYTE SYSTEM The disk format used by the "standard" UCSD system on 8-inch disks is a derivative of DEC's RT-11 format, and consists of 76 tracks (track 0 is reserved for the booter and is not really used by the UCSD system once it's going) of 26 128-byte sectors each. Every other sector is read from or written to, rather than sequential sectors being used, so that accessing a track requires two disk revolutions. The scheme is somewhat complicated in that the first sector accessed on a new track is offset six sectors from the first sector on the previous track, which allows a six-sector delay for head settling when moving from track to track. This arrangement speeds up disk access (you don't have to wait a full disk revolution when moving to a new track) and improves reliability. Thus, the sectors on the "standard" disk are read as follows: TRACK 1: 1,3,5,...,23,25,2,4,...,24,26 TRACK 2: 7,9,11,...,3,5,8,10,...,4,6 TRACK 3: 13,15,17,...,9,11,14,16,...10,12 and so on. Notice that the change from odd to even occurs when the logical first sector on the track is reached and differs from track to track, rather than occuring at a fixed point. Those of us who use LSI-based disk controllers (until recently, universally one of the Western Digital 1770 or 1790 series) realized that we were not entirely happy with this disk format. First, the UCSD operating system utilizes logical sectors ("blocks") that are 512 bytes long, something we could easily achieve physically on a floppy disk. Second, our controllers were quite capable of reading sequential sectors. Finally, there is no provision in the standard UCSD system for double-density 8-inch disks. So I have provided programs on these two disks that provide the user of the UCSD system who has specific hardware (you MUST have a Z-80, 8080, or 8085 CPU as well as a Western Digital-based disk controller) with a sophisticated UCSD-compatible BIOS that will utilize disks formatted with 128- or 512-byte sectors in single density or 512-byte sectors double density. This BIOS contains most of the disk-handling and character-handling routines from the CPMIO section of the UCSD interpreter, so that within the BIOS we have complete control over the disk formats we use. As a result, the BIOS on this disk allows operation of the UCSD system in a manner that is TRANSPARENT to the disk format currently in use, as well as allowing you to use disks of different formats simultaneously. The only gotchas in this system are two: 1) to change the density of the disks in a given disk drive requires rebooting the system, since the density code is read only at boot time (otherwise the drive will hang up), and 2) you can change the sector size of the single- density disks in a drive only if another drive is accessed immediately before the system tries to use the new disk you've just inserted. This is because the BIOS checks sector size (if the disk drive has been initialized as single- density) each time the system changes from one disk drive to another, and the system will hang up if it tries to read a 128-byte sector from a 512-byte disk or vice-versa without first checking sector size. The routines on these two disks include specific code for three S-100 disk controller boards: the Tarbell single- and double-density controllers and the Delta double-density controller. (All the Western Digital-based double density controllers of which I am aware allow software-controlled switching between single- and double-density disks.) The routines have already been altered by others for other Western-Digital-based controllers such as the S.D. Sales and the Cromemco; you must have an intimate familiarity with your disk controller and a reasonable facility with assembly language to be able to accomplish this conversion. All the programs that form this system are amply documented, but there is no discussion of alternate controllers. The programs that make up the 512-byte sector system include the following: VOLUME 2A (normally UCSD format): CPMIO.DOC.TEXT. This file contains a discussion of the changes you must make to CPMIO.TEXT (part of the UCSD Z-80/8080 interpreter) to move most of the hardware-specific code out of the interpreter to the PBIOS (Pascal Basic Input- Output System), as well as implementing a number of nifty extensions to the I/O Unit system, such as direct port I/O, a form of Peek and Poke, and a system clock. Deletions are fully described, and insertions are listed. For copyright reasons, we are NOT able to give you the full text of CPMIO. Note that CPMIO has changed very little since the first 8080/Z-80 release, so the changes described will work for releases 1.4 to 2.0. The new Adaptable System just released by SofTec is NOT supported by this CPMIO file, although you could probably adapt the files on the CP/M disk (Volume 2B) to work with that system, since the conversion routines required are a part of the Adaptable System. To implement the system, after making the necessary changes in CPMIO (and in the main INCLUDE file, as discussed in CPMIO.DOC), you must reassemble the entire interpreter and save it until the new PBIOS is ready. TIMING.DOC.TEXT contains a discussion of the timing considerations for the 512-byte system; you will find that when you run your disk system at its maximum speed, you will discover all the subtle timing constraints you didn't have to worry about when you were going slower. VOLUME 2B (normally CP/M format): DFOCO.ASM and DFOCO.DOC. FOCO stands for fast FOrmat and COpy routine, and it is the fastest such disk utility I have ever used, as well as being the most flexible. The D stands for the Double-density version. It is highly hardware specific, including all the disk-access routines within the program for improved speed. Conditional assemblies are available for the Delta and both Tarbell controller boards; adaptations for the Cromemco and other Western Digital-based controllers have not been terribly difficult but require careful attention to timing (best done by trying it out with your system). DFOCO has been around in various versions for two years; the present one has been adapted to be compatible with the majority of disk hardware (you will note long delays after a disk home, for instance, required by some systems). In its evolution, several routines that worked in the original version but turned out not to be useful now bomb if you try to use them, particularly the logical- to-physical mapping utility or the facility that allows custom logical-to- physical sector numbering. However, anything you really need (sector size control, single or double density formatting and reading, the option of SKEW within a track, or sector-numbering OFFSET between tracks) works well. Only one needed facility does not yet exist, which is the ability to copy one disk to another when the disks have 512-byte sectors. DFOCO is fairly well documented in DFOCO.DOC. One aspect may not be noted there: if you wish a track-to-track sector numbering offset, you must use the compliment of the desired offset in your command (based on the number of sectors per track). So, if you wish a one-sector offset between tracks, include the command "OFFSET 25" if a 26-sector track is used, or "OFFSET 7" if an 8-sector track is required. I have noted other assorted bugs in DFOCO which preclude its release as a proprietary program, but it is still head and shoulders above any other such program I have used. Mostly, the bugs do not affect operation. If you have trouble with DFOCO, particularly if you find and fix a bug, Sam Singer (it author) would like to hear from you. His address is in the listing. BOOTER.ASM. This file contains a combination of a custom PBIOS and the original UCSD PINIT file released with that system on the CP/M disk. It has been greatly expanded and revised. Sophisticated terminal-handling routines for an ADM-3A are provided, allowing you to use a "dumb terminal" with the fancy UCSD screen editor. Basically, the combination of BOOTER, DFOCO, and PGEN should provide a full and sophisticated I/O system for the majority of UCSD users running an 8080/Z-80 system. PGEN.ASM. This file contains the original PGEN released with the UCSD system (to read and write the Track 0 booter and PBIOS on UCSD system disks). In addition, it has the 1-sector booter already in the file and will read the format code of a newly formatted disk and preserve it correctly for use by the initialization section of BOOTER. See the documentation within the listings of both BOOTER and PGEN for a more detailed discussion of what a format code is and how it is used. MACRO.LIB. This file is a sophisticated macro library developed by Sam Singer and used in the majority of his software (though not required by BOOTER or PGEN). Specifically, it must be on the disk before you can assemble DFOCO or DUMP (a utility not related to the UCSD Pascal system). MACRO.LIB is relatively specific to the Digital Research macroassembler, though it should not be hard to adopt for Microsoft's macroassembler. SAMPLEIO.ASM. This file contains the I/O portions of my EPROM-based monitor, and has examples of sophisticated drivers for a keyboard queue and a memory- mapped video terminal. It is well documented within the listing. ======================================================================================== DOCUMENT :usus Folder:VOL2A:acoustic.text ======================================================================================== ; FOR MY ACOUSTIC COUPLER NO INITIALIZATION IS NECESSARY .PROC MODEMINIT,1 .PRIVATE RETADDR POP HL LD (RETADDR),HL POP HL ;POP ARGUMENT OFF STACK LD HL,(RETADDR) JP (HL) ; HANGUP FOR FOR AN ACOUSTIC COUPLER (WOULD YOU BELIEVE) .PROC HANGUP,0 .PRIVATE RETADDR POP HL LD (RETADDR),HL LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL2A:bootasm.text ======================================================================================== PROGRAM BOOTASM; { COPYRIGHT 1979 BY BARRY A. COLE THIS MAY BE FREELY DISTRIBUTED IF COPYRIGHT NOTICE RETAINED PURPOSE: LOAD ASSEMBLY MODULE TO LOW MEM AND XEQ INTENDED USE: GENERATE CODE, CALL CPMRAM, SWITCH TO CPM DISK, BOOT CPM, SAVE XX FILE } TYPE BUFFER=PACKED ARRAY[0..20000] OF CHAR; VAR I,BLOKNUM,BYTES,LOC: INTEGER; BUF: BUFFER; F:FILE; TITLE: STRING[13]; PROCEDURE MOVRAM(FROMAD:BUFFER; TOAD,NBYTES:INTEGER); EXTERNAL; BEGIN WRITE('FILE NAME? '); READLN(TITLE); TITLE:=CONCAT(TITLE,'.CODE'); RESET(F,TITLE); BYTES:=512*BLOCKREAD(F,BUF,20,1); WRITE('LOCATION? '); READLN(LOC); MOVRAM(BUF,LOC,BYTES); END. ======================================================================================== DOCUMENT :usus Folder:VOL2A:bootcpm.text ======================================================================================== .PROC BOOTCPM,0 ; COPYRIGHT 1979 BY BARRY A. COLE ; THIS MAY BE FREELY DISTRIBUTED IF COPYRIGHT NOTICE RETAINED ; PURPOSE: BOOT CPM FROM PASCAL BOOTLOC .EQU 80H TADDR .EQU 40H UNIT .EQU TADDR+2 SECTOR .EQU TADDR+3 TRACK .EQU TADDR+4 PROMPT LD DE,MSG $100 LD A,(DE) OR A JR Z,WAIT LD C,A LD L,0CH ;OFFSET OF CONOUT IN BIOS CALL BIOS INC DE JR $100 WAIT LD L,09H ;OFFSET OF CONIN IN BIOS CALL BIOS CP 0DH ;CR? JR NZ,PROMPT LD HL,BOOTLOC LD SP,HL LD (TADDR),HL LD A,0FEH ;UNIT LD (UNIT),A XOR A LD (TRACK),A INC A LD (SECTOR),A LD L,27H ;READ OFFSET INTO BIOS CALL BIOS JP BOOTLOC BIOS LD A,(2) LD H,A JP (HL) MSG .BYTE 0DH,0AH .ASCII "MOUNT CPM DISK IN A--THEN CR" .BYTE 0 .END ======================================================================================== DOCUMENT :usus Folder:VOL2A:catalog.2.text ======================================================================================== VOLUME 2A AND VOLUME 2B CATALOG, UCSD PASCAL USERS' GROUP LIBRARY Machine-dependent software, 512-byte sequential sectors, and other goodies.* Contents of Volume 2A: 512.DOC.TEXT.......Documentation for the 512-byte sectoring routines on 2A & 2B. ACOUSTIC.TEXT......Use an acoustic modem with the Pascal Transfer Program (PTP). BOOTASM.TEXT.......Assemble a file with the UCSD assembler and save it on CP/M. BOOTCPM.TEXT.......Start up under UCSD and then boot up CP/M. CPMIO.DOC.TEXT.....How to alter the CP/M interpreter for fancy disk action. DCHAYES.IO.TEXT....Use a D.C. Hayes modem w/ the Pascal Transfer Program (PTP). DELETE.LF.TEXT.....After transfering a textfile to UCSD, dummp ASCII linefeeds. DFOCO.DOC.TEXT.....Documentation for DFOCO.ASM on Volume 2B. H14.DRIVER.TEXT....Print out a text file on the Heath printer at full speed. H19.DOC.TEXT.......Notes on optimizing the Heath terminal for UCSD Pascal. H19.GOTOXY.........Textfile to compile your own GOTOXY for the Heath H19. H19.MISCINFO.......SYSTEM.MISCINFO for the Heath terminal. HAZEL.MISCINFO.....All ready SETUP for the Hazeltine terminal. HEXOUT.TEXT........Pascal routine to print out integers in hexadecimal. KBSTAT.TEXT........Yet another keyboard status routine, this time for PTP.TEXT. LINECOUNTR.TEXT....Count the lines of a textfile. MOVRAM.TEXT........Assembly-language routine for BOOTASM. NEW.GOTOXY.TEXT....Good idea: let GOTOXY handle your CRT screen, too. Sample. PE1100.GOTOXY......Textfile for GOTOXY for the Perkin-Elmer 1100 (Fox) terminal. PERUSE.PG.TEXT.....Look over a textfile on your CRT one page at a time. POLICY.DOC.TEXT....How the Users' Group Library runs. PRIME1.TEXT........Pascal routine to find prime numbers. PRIME2.TEXT........Another prime-number generator. PTP.DOC.TEXT.......Documentation for the Pascal Transfer Program. PTP.TEXT...........The Pascal Transfer Program. Requires L2 editor to edit. PUNCH.TAPE.TEXT....Send data from the UCSD system to the Heath paper punch. RANDOMBYTE.TEXT....Assembly-language routine to access Z-80's R register. READ.TAPE.TEXT.....Compliment of PUNCH.TAPE. SHELLMSORT.TEXT....Sort a disk-based ASCII list. SMARTREMOT.TEXT....Set up your machine as a smart remote terminal. TIMING.DOC.TEXT....Notes on tuning your disk drives for fast 512-byte sectors. TVI912C.GOTOXY.....Another GOTOXY text, this time for the TelVideo 912. UPDATE.DOC.TEXT....Latest news on the UCSD Pascal Users' Group Library. VOL.2B.DOC.TEXT....Documentation for the second disk of this volume. VOLUME.2.TEXT......Notes on all the programs in Volume 2. WRITER.DOC.TEXT....Documentation for WRITER. WRITER.TEXT........A quick but nifty text or source file printer. * Note: UCSD Pascal is a trademark of the Regents of the University of California. Please read the file POLICY.DOC.TEXT regarding the software on this disk. All files are further documented in VOLUME.2.TEXT. Volume 2B Contents: This disk is normally supplied in CP/M format, and includes my favorite CP/M utilities. For documentation see VOL.2B.DOC and DFOCO.DOC on Volume 2A. BOOTER.ASM.......Sophisticated PINIT and *fast* PBIOS for Z-80 systems (can modify easily for 8080) to run 128- & 512-byte sectored single density and 512-byte sectored double density disks transparently. Requires Z-80-compatible assembler (extended Intel memnomics), Western Digital-based floppy disk controller (eg, 1771, 179x series), and DFOCO-like disk formatter. May require attention to disk timing. CAT.COM..........Part of Ward Christenson's CP/M cataloging system. From the CP/M Users Group Volume 25. CLEAN.COM........Nifty PIP-like utility to back up disk files; easy to use. D.COM............Replacement for DIR that alphabetizes your directory & dis- plays it in one screenful, along with filesize & room on disk. DFOCO.ASM........Double/single density fast FOrmat and COpy, for disks of 128, 256, or 512-byte sectors, single/double sided. Requires Digital Research's MAC (or equivalent) and MACRO.LIB. All disk access is in the program for speed; Western Digital chip on your floppy disk controller is a must. DUMP.ASM.........Fancy file/track/sector hex & ASCII dumps and patches for 3740-type disks. Accesses CP/M's logical groups directly. FMAP.COM.........Makes a file of CP/M directory names. Part of Ward Christenson's disk cataloging system. MACRO.LIB........Fancy 8080 macro library for Digital Research's macroassem- bler. Used by DFOCO and DUMP. PGEN.ASM.........Rewrite of UCSD's distribution PGEN to include booter and support multiple disk formats. SAMPLEIO.ASM.....Sample UCSD-compatible I/O routines for console and memory- mapped terminal. VERY fancy. SPAT.ASM.........Extensive updating of CP/M Users Group SPAT (Vol. 1), for patching disks on systems with memory-mapped terminals. Nice. UCAT.COM.........Update the CATalog; part of CP/M disk cataloging system. UCSD2CPM.COM.....Object (Z-80 only) of program to transfer UCSD files to CP/M. Runs under CP/M. UCSD2CPM.MAC.....Source for program to transfer UCSD files to CP/M. Requires assembler that accepts Zilog memnomics (eg, Microsoft). ======================================================================================== DOCUMENT :usus Folder:VOL2A:cpmio.doc.text ======================================================================================== INSTRUCTIONS FOR CHANGING CPMIO.TEXT TO WORK WITH NEW PBIOS If copyright laws would allow, I would simply send you the new file. Alas, you'll have to do it yourself. CPMIO.TEXT has changed little since its first version with release 1.4. So the instructions to follow work with any version. I assume you have printed out CPMIO.TEXT for reference. Also, note that many of the following jump instructions are of the "JR" form, which produces Z-80 code. If you have an 8080, you'll have to change them all to "JP". 1) First, add the following to the main file to be assembled (variously known as INCLUDE.TEXT, NOINCLUDE.TEXT, CPMINC.TEXT, and similar names), which you can identify because it is short and contains mostly a list of secondary files to be .INCLUDE'd or not, as well as some global variables. Put it near the beginning: TIO .EQU 0040H ;or wherever in the first page you want to put it... ; This table is the primary means of communication ; between CPMIO and your BIOS, so make sure they both ; look for it in the same place. BIOS .EQU TIO ;holds pointer to PBIOS in memory 2) Next, edit the file CPMIO.TEXT to make the following changes: a) Change MAXU to equal 15, not 8. b) Add the following to the end of UNITBL: .WORD ALLBIT ; Unit 9: drive 2 .WORD DR2DRVR .WORD ALLBIT ; Unit 10: drive 3 .WORD DR3DRVR .WORD 0 ; Unit 11: RESERVED FOR ADDED DISK DRV .WORD 0 .WORD 0 ; Unit 12: REVERVED FOR ADDED DISK DRV .WORD 0 .WORD INBIT|OUTBIT ; Unit 13: PORT I/O .WORD PORTDRVR .WORD 0 ; Unit 14: RESERVED .WORD 0 .WORD INBIT|OUTBIT ; Unit 15: MEMORY I/O (PEEK AND POKE) .WORD MEMDRVR c) Change the statement "UPTR .EQU TIO" to "UPTR .EQU BIOS". Add after "URTN .EQU UASY+2": ERRFLG .EQU URTN+2 ;PBIOS IO error flag. d) Leave IOC and IOR unchanged. Add the following line to GETU just ahead of the third line, POP HL: LD (ERRFLG),A ;zero PBIOS error flag also. e) Leave BDIR, BLUN, and BOMIT unchanged. Substitite the following for the three lines at UBUSY: UBUSY POP HL ;POP OFF RETURN ADDR EX (SP),HL ;GET UNIT NO LD A,L CP 03H JR NC,$20 LD A,0CH ;BIOS OFFSET FOR CONSOLE READY CALL GOBIOS LD L,A ;TRUE OR FALSE TO L PUSH HL JR UOUT $20 LD HL,0 PUSH HL UOUT JP BACK1 e) The next part is unchanged through IOXIT. f) The rest of CPMIO.TEXT (the disk drivers, character drivers, BIOS calling routines, and IOINIT) is deleted. Save the disk drivers and character drivers, since you will have to insert them where called for in PBIOS, first translating to 8080 memnomics (although if you have the Microsoft assembler, you can switch to Zilog memnomics in midstream with the ".Z80" pseudoop). Replace the deleted text with the following: ;------------ Disk driver's --------------- DR0DRVR LD C,00H ;select drive JR DSK0 DR1DRVR LD C,01H JR DSK0 DR2DRVR LD C,02H JR DSK0 DR3DRVR LD C,03H DSK0 XOR A ;reg A=0 offset into bios CALL GOBIOS LD A,(ERRFLG) ;check for error's from pbios LD (IORSLT),A ;if no error then ERRFLG and IORSLT =0 XIT JP IOXIT ;done with disk IO ;---------- PORT I/O DRIVER -------------------- PORTDRVR LD A,(UBLK) ;LOW ORDER BYTE OF BLOCK NO IS THE PORT LD HL,(UBUF) ;POINTS TO MEMORY LD C,A ;MOVE PORT NO TO REG C LD A,(UREQ) ;INPUT OR OUTPUT ? CP INBIT JR NZ,$10 INI ;Z-80 I/0 IS SO NICE JR XIT ;BYE $10 OUTI ;DO OUTPUT JR XIT ;BYE ;---------- MEMORY I/O DRIVER ------------------ MEMDRVR LD HL,(UBLK) ;BLOCK NO IS MEMORY ADDR LD BC,(UBUF) ;POINTS TO MEMORY LD A,(UREQ) ;PEEK OR POKE ? CP INBIT JR NZ,$10 LD A,(HL) ;PEEK LD (BC),A JR XIT ;BYE $10 LD A,(BC) ;POKE LD (HL),A JR XIT ;BYE ;-------- BIOS linker --------- GOBIOS LD HL,(BIOS) LD D,0 LD E,A ADD HL,DE ;ADD OFFSET TO BIOS ADDR JP (HL) ; ;---------- Character driver's ----------------- REMIN LD A,6 JR CHARIO REMOUT LD A,9 JR CHARIO CHDRVR LD A,3 CHARIO CALL GOBIOS JP IOXIT ;----------------------------------------------- ; Booter stuff .ALIGN 2 ; must start on word boundary INTEND IOINIT LD HL,(BIOS) LD DE,-10 ADD HL,DE LD (MEMTOP),HL RET @ ======================================================================================== DOCUMENT :usus Folder:VOL2A:dchayes.io.text ======================================================================================== .FUNC SRECSTAT,0 .PRIVATE RETADDR STAT .EQU 81H RECRDY .EQU 1H POP HL LD (RETADDR),HL POP HL ;CORRECT STACK POP HL LD HL,1 ;TRUE PUSH HL IN A,(STAT) ;READ STATUS AND RECRDY ;CHECK SER READ STATUS JP NZ,DONE ;REC NOT RDY POP HL LD HL,0 ;FALSE PUSH HL DONE LD HL,(RETADDR) JP (HL) .FUNC SERREAD,0 .PRIVATE RETADDR STAT .EQU 81H ;STATUS PORT DATA .EQU 80H ;DATA PORT RECRDY .EQU 01H ;REC BUF FULL POP HL LD (RETADDR),HL ;SAVE RET ADDR POP HL ;CORRECT STACK POP HL ;CORRECT STACK WAIT: IN A,(STAT) ;READ STATUS WORD AND RECRDY ;IS REC FULL JP Z,WAIT IN A,(DATA) AND 07FH ;CLEAR PARITY BIT LD L,A ;STORE FOR RETURN PUSH HL ;RETURN VALUE ON STACK LD HL,(RETADDR) JP (HL) .PROC SERWRITE,1 .PRIVATE OUTC,RETADDR STAT .EQU 81H ;STATUS PORT DATA .EQU 80H ;DATA PORT TRE .EQU 02H ;XMIT REG EMPTY POP HL LD (RETADDR),HL POP HL LD (OUTC),HL WAIT: IN A,(STAT) ;GET STATUS AND TRE ;CK STATUS JP Z,WAIT ;XMIT BUSY LD A,(OUTC) OUT (DATA),A ;SEND DATA LD HL,(RETADDR) JP (HL) ; THIS IS A VERY CRUDE D C HAYES INITIALIZER FOR THE PURPOSE ;OF CHECKING OUT THE REST OF THE PROGRAM CERTAINLY MUCH MORE ;WORK WILL NEED TO BE DONE ON THIS ROUTINE .PROC MODEMINIT,1 .PRIVATE DIR,RETADDR ANSW300 .EQU 83H ;300 BAUD, ANSWER, OFFHOOK, XMITTER ON ORIG300 .EQU 87H ;300 BAUD, ORGINATE, OFFHOOK, XMITTER ON WORD .EQU 17H ;8 BITS, NO PARITY, 1 START RNGMASK .EQU 080H ;RING DETECT MASK STAT .EQU 081H ;STATUS PORT MODE .EQU 082H ;MODE PORT POP HL LD (RETADDR),HL POP HL LD (DIR),HL LD A,(DIR) AND 01H ;LOOK AT ANS BIT OR A JP Z,ORIG ;ANSWER MODE ;WAIT FOR PHONE TO RING RNGCK: IN A,(STAT) ;READ STATUS AND RNGMASK ;ISOLATE RING DETECT JP NZ,RNGCK ;WAIT FOR RING LOW ;SET ANSWER MODE AND ANSWER PHONE LD A,ANSW300 ;SET MODEM TO ANSWER 300 BAUD AND OFFHOOK OUT (MODE),A JP DONE ;ORIGINATE MODE ORIG LD A,ORIG300 ;SET MODEM TO ORIGNATE 300 BAUD OUT (MODE),A DONE LD A,WORD ;SET MODEM TO WORD FORMAT OUT (STAT),A LD HL,(RETADDR) JP (HL) ; HANGUP FOR D C HAYES .PROC HANGUP,0 .PRIVATE RETADDR MODE .EQU 82H ;MODE PORT ONHOOK .EQU 0H ;ON HOOK POP HL LD (RETADDR),HL LD A,ONHOOK OUT (MODE),A LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL2A:delete.lf.text ======================================================================================== (* Program Author: Frank Monaco 679 Lowell Drive Marietta, GA 30060 404-424-1460 Rewritten for blockread/write and improved filename i/o by: Jim Gagne Datamed Research 1433 Roscomare Road Los Angeles, CA 90024 *) program copyit; CONST MaxArraySizeLess1 = 4095; MaxBlocks = 8; {MaxArraySize DIV 512} Testing = false; TYPE ArrayPointer = 0..MaxArraySizeLess1; var InPointer, OutPointer, Insize, i, j: ArrayPointer; InfileName, OutfileName: string [30]; typed: string; Infile, Outfile: file; OutChararray: PACKED ARRAY [0..511] OF char; InChararray: PACKED ARRAY [ArrayPointer] OF char; PROCEDURE GetString (x,y, maxlength: integer); VAR j, k: integer; Gotstring: boolean; bell: char; BEGIN bell := CHR (7); Gotstring := false; REPEAT Gotoxy (x,y); FOR j := 1 TO maxlength DO write ('.'); Gotoxy (x,y); Readln (typed); k := length (typed); IF k > maxlength THEN BEGIN Gotoxy (x,y); Write (' ':k); Gotoxy (0,23); Write (bell, 'You have entered too many characters in this line. ', 'Please try again.') END ELSE Gotstring := true UNTIL Gotstring; Gotoxy ((x+k),y); Write (' ':(maxlength - k)); Gotoxy (2,22); Write (' ':70); Gotoxy (0,73); Write (' ':70) END (*GetString*); PROCEDURE GetFile; VAR gotfn: boolean; bell, response: char; BEGIN Bell := CHR (7); REPEAT Gotoxy (11,20); Write ('Please type the name of the desired input file.'); Gotoxy (15,21); Write ('--> '); Gotoxy (11,22); Write (' (Or just press the key if you wish to quit.)'); Typed := ''; GetString (20,21, 23); IF LENGTH (typed) = 0 THEN BEGIN Gotoxy (11,23); Write ('Would you prefer to quit this program (Y/N)? '); Read (Keyboard, response); Gotoxy (11,23); Write (' ':47); IF (Response = 'Y') OR (Response = 'y') THEN EXIT (Program) END ELSE BEGIN InfileName := Typed; (*$I-*) Reset (Infile, InfileName); IF IORESULT > 0 THEN Reset (Infile, CONCAT (InfileName, '.TEXT')); (*$I+*) Gotfn := IORESULT = 0; IF NOT Gotfn THEN BEGIN Gotoxy (0,23); Write (bell, '<<**** ERROR ****>> ', 'Wrong volume or file name. Type to continue.'); REPEAT Read (Keyboard, Response) UNTIL Response = ' '; Gotoxy (0,23); Write (' ':78) END END(*else*) UNTIL Gotfn; END (*GetFile*); begin writeln('This program copies a textfile and removes extraneous line feeds.'); GETFILE; Gotoxy (0,5); Write ('What is the name of the file to which you wish to send the copy?'); GETSTRING (0,6, 23); OutfileName := Typed; Rewrite (Outfile, OutfileName); OutPointer := 0; IF testing THEN Write ('Outfile opened. '); while not eof (Infile) do begin i := Blockread (Infile, InChararray, MaxBlocks); IF testing THEN Write ('Read ', i, ' blocks. '); IF i > 0 THEN BEGIN Insize := (i * 512) - 1; IF testing THEN Writeln ('Insize = ', Insize); FOR InPointer := 0 TO Insize DO IF OutPointer < 512 THEN BEGIN IF InChararray [InPointer] <> CHR (10) THEN BEGIN OutChararray [OutPointer] := InChararray [InPointer]; OutPointer := succ (OutPointer) END END ELSE BEGIN i := Blockwrite (Outfile, OutChararray, 1); IF testing THEN Write ('Wrote ', i, ' blocks'); IF InChararray [InPointer] <> CHR (10) THEN BEGIN OutChararray [0] := InChararray [InPointer]; OutPointer := 1; END ELSE OutPointer := 0 END; END; end; IF OutPointer > 0 {Write out the last block,...} THEN BEGIN {zeroing the unused bytes.} IF testing THEN Writeln ('Last OutPointer = ', OutPointer); IF OutPointer < 512 THEN FOR OutPointer := OutPointer TO 511 DO OutChararray [OutPointer] := CHR (0); i := Blockwrite (Outfile, OutChararray, 1); IF testing THEN Write ('Last block written = ', i) END; close(Outfile,lock); end. ======================================================================================== DOCUMENT :usus Folder:VOL2A:dfoco.doc.text ======================================================================================== DFOCO DOCUMENTATION COPYRIGHT 1979 BY S. J. SINGER DFOCO IS A FAST FORMAT AND COPY UTILITY FOR CP/M AND THE DELTA FLOPPY DISK CONTROLLER. IT PERMITS FORMATTING DISKS IN BOTH THE STANDARD IBM FORMAT AND A VARIETY OF NON STANDARD FORMATS AS WELL AS COPYING ENTIRE DISKS OR ONLY SPECIFIED TRACKS FROM ONE DISK TO ANOTHER. IN ADDITION DFOCO PERMITS RELATIVELY EFFICIENT SINGLE DISK DRIVE COPIES AND WILL COPY FORMATS AND DISPLAY THE FORMAT ON ANY SPECIFIED TRACK OF ANY DISK. DFOCO SUPPORTS THE USE OF 4 DISK DRIVES. DFOCO MAY BE USED BOTH SINGLE DENSITY (FM) AND DOUBLE DENSITY (MFM). THE OPERATIONS PERFORMED ARE IN GENERAL THE SAME BUT MAY BE SLIGHTLY MORE LIMITED IN THE CASE OF DOUBLE DENSITY. DFOCO WILL RUN ON ANY 8080 OR Z-80 BASED SYSTEM USING THE DELTA DISK CONTROLLER. THE PROGRAM USES CP/M FOR ALL CONSOLE INPUT-OUTPUT, HOWEVER ALL DISK OPERATIONS ARE DIRECTLY EXECUTED BY DFOCO. THIS IS NECESSARY BECAUSE DFOCO USES NON CP/M COMMANDS LIKE DISK TRACK READ, AND DFOCO KEEPS CONTROL OF ALL DISK ERRORS TO FACILITATE ACCOUNTING AND ERROR RECOVERY. IT SHOULD BE POSSIBLE HOWEVER, TO MODIFY DFOCO TO RUN WITH ANY WESTERN DIGITAL 1771 OR 1791 BASED DISK CONTROLER. THERE ARE TWO DIFFERENT VERSIONS OF DFOCO, ONE FOR STANDARD DISK DRIVES AND THE OTHER FOR FAST SEEK PERSCI DRIVES. THE SINGLE DENSITY OPERATIONS WILL BE DESCRIBED IN DETAIL FIRST. * * * * * * * SINGLE DENSITY OPERATIONS * * * * * * * VALIDATING DISKS IT IS OFTEN USEFUL TO BE ABLE TO TELL WHETHER OR NOT THE RECORDING SURFACE OF A DISK IS COMPLETELY INTACT BEFORE USING THE DISK. THIS IS ESPECIALLY TRUE SINCE WHILE CP/M ALWAYS CHECKS FOR READ ERRORS THERE IS NO CHECK DONE FOR WRITE ERRORS. YOU WILL NOT KNOW YOU HAVE A BAD COPY OF A FILE UNTIL THE FIRST TIME YOU TRY TO READ IT AGAIN WHICH MAY BE DAYS OR EVEN MONTHS LATER. VALIDATING A DISK CONSISTS SIMPLY OF READING EACH SECTOR ON THE DISK AND VERIFYING THAT THE CRC IS CORRECT. THIS SIMPLE PROCESS NOT ONLY DETECTS PHYSICAL DAMAGE TO THE MEDIA SUCH AS SCRATCHES BUT ALSO FORMATTING ERRORS SOMETIMES CAUSED BY NOISE TRANSIENTS, ERRORS WHICH WILL DISAPPEAR UPON REFORMATTING THE DISK. THE FOLLOWING ARE EXAMPLES OF VALIDATION COMMANDS. VALID (DEFAULT IS DRIVE A:) VALID C: VALID D: RETRY 20 THE PROGRAM WILL READ THE ENTIRE DISK AND REPORT ANY READ ERRORS. IF A CRC ERROR OCCURS THE SECTOR WILL BE REREAD A MAXIMUM OF EITHER THE NUMBER OF RETRYS SPECIFIED OR 10 TIMES IF NO RETRY COUNT IS ENTERED. BOTH THE TOTAL NUMBER OF PERMANENT OR HARD ERROR AND RETRYS ARE REPORTED AT THE END OF THE VALIDATION PROCESS. SUCCESSFUL VALIDATION DRIVE B: OR PERMANENT READ ERROR TRACK 17 SECTOR 5 DRIVE B PERMANENT READ ERROR TRACK 42 SECTOR 19 DRIVE B THERE WERE 27 RETRYS AND 2 HARD ERRORS COPYING DISKS ALL OR PART OF A DISK MAY BE COPIED BETWEEN ANY SPECIFIED DRIVES. THE FOLLOWING ARE EXAMPLES OF TYPICAL COPY COMMANDS: COPY (DEFAULT IS A: TO B:) COPY A: TO C: COPY D: TO B: RETRY 20 COPY A: TO C: TRACK 0-1 COPY B: TO D: TRACK 3 - 20 COPY A: TO A: (SINGLE DISK TRANSFER) DFOCO WILL RESPOND WITH AND ACKNOWLEDGMENT AND INSTRUCTIONS. FOR EXAMPLE: COPYING DISK A TO DISK B TYPE RETURN TO START THE PROGRAM WILL HALT AND WAIT FOR DISKS TO BE CHANGED ETC. AND WILL BEGIN THE ACTUAL COPY OPERATION AFTER RETURN IS TYPED. IF YOU HAVE MADE AN ERROR AND WISH TO REENTER THE COMMAND TYPE CONTROL C. THE COPY OPERATION IS OPTIMIZED FOR SPEED. THE PROGRAM WILL DETERMINE THE MAXIMUM AMOUNT OF MEMORY AVAILABLE AND READ WHOLE TRACKS FROM THE SOURCE DISK UNTIL THE MEMORY IS FILLED. THEN THE ENTIRE MEMORY BUFFER IS WRITTEN ONTO THE DESTINATION DISK. ALL TRANSFERS ARE VERIFIED. AS EACH TRACK IS WRITTEN ONTO THE DESTINATION DISK IT IS READ BACK AND COMPARED BYTE BY BYTE WITH THE CONTENTS OF THE MEMORY BUFFER. ANY ERRORS ARE REPORTED. IF THE SOURCE AND DESTINATION ARE THE SAME DFOCO WILL FIRST RESPOND WITH A REQUEST THAT YOU VERIFY THAT YOU REALLY WANT TO PERFORM A SINGLE DRIVE COPY. IF THE REQUEST IS ACKNOWLEDGED THE PROGRAM WILL INDICATE WHICH DISK TO MOUNT IN THE SPECIFIED DRIVE. AS WITH TWO DRIVE COPIES THE PROGRAM WILL FILL THE ENTIRE MEMORY BUFFER WITH DATA. THE PROGRAM WILL THEN HALT AND NOTIFY YOU TO CHANGE DISKS. THE NUMBER OF DISK CHANGES REQUIRED WILL OF COURSE DEPEND UPON THE AMOUNT OF MEMORY AVAILABLE. WITH A 48K SYSTEM 8 SWAPS ARE REQUIRED, WITH A 64K SYSTEM ONLY 6 ARE NEEDED. COPYING DISKS WITH DIFFERENT SIZE SECTORS DFOCO WILL COPY DISKS WITH SECTORS OF 128, 256 OR 512 BYTES. THE PRIMARY LIMITATION OF THE PROGRAM IS THAT BOTH DISKS MUST HAVE THE SAME SIZE SECTORS. THE SIZE SHOULD BE SPECIFIED IN THE COPY COMMAND. COPY A: TO C: SIZE 256 COPY B: TO A: SIZE 512 COPY C: TO D: SIZE 128 SPECIFYING A SECTOR SIZE OF OTHER THAN 128, 256 OR 512 BYTES WILL GENERATE AN ERROR MESSAGE. ERROR HANDLING DURING COPY OPERATIONS ERROR HANDLING AND RECOVERY IS AN EXTREMELY INPORTANT PART OF ANY DISK FILE MANAGEMENT SYSTEM. DFOCO IS DESIGNED TO PERMIT THE MAXIMUM RECOVERY OF DATA FROM DAMAGED OR "CRASHED" DISKS. TWO TYPES OF ERRORS OCCUR DURING COPY OPERATIONS, ERRORS IN READING FROM THE SOURCE DISK AND ERRORS WRITING TO THE DESTINATION DISK. READ ERRORS ARE BY FAR THE MOST COMMON. IF A READ ERROR OCCURS DFOCO WILL ATTEMPT TO REREAD THE SECTOR 10 (OR RETRY) TIMES. IF THE READ ERROR PERSISTS ONE OF TWO ACTIONS MAY BE CHOSEN. THE DEFAULT IS TO FILL THE SECTOR WITH E5H AND WRITE IT ON THE DESTINATION DISK. THE OTHER CHOICE IS SIMPLY TO ACCEPT THE DATA AS READ IN AND WRITE IT ON THE DESTINATION DISK. THIS IS THE NOFILL OPTION. NOFILL PERMITS THE MAXIMUM DATA RECOVERY BUT REQUIRES CAREFUL INSPECTION OF THE SECTOR CAUSING THE ERROR SINCE THE ERRORS MAY NOT BE OBVIOUS. WRITE ERRORS ARE HANDLED IN A SOMEWHAT DIFFERENT FASHION. SINCE THERE IS USUALLY NO VALUABLE DATA ON THE DESTINATION DISK, THE NORMAL CHOICE IS TO NOT PERMIT COPY OPERATIONS IF WRITE ERROR OCCUR. DFOCO WILL ATTEMPT TO WRITE A SECTOR 10 (OR RETRY) TIMES. IF THE ERROR PERSISTS, DFOCO WILL STOP THE COPY OPERATION AND VALIDATE THE DESTINATION DISK THUS REPORTING ALL BAD SECTORS. IT IS POSSIBLE TO COPY IN THE PRESENCE OF WRITE ERRORS BY TURNING OFF THE WRITE VERIFICATION, THE NOVERIFY OPTION. HOWEVER SINCE DISKS HAVE BECOME RELATIVELY INEXPENSIVE THIS OPTION IS PROBABLY UNWISE EXCEPT IN VERY SPECIAL CASES. SOME EXAMPLES ARE AS FOLLOWS: COPY B: TO C: NOFILL RETRY 25 COPY A: TO B: TRACK 0-5 NOVERIFY COPY D: TO A: NOVERIFY NOFILL DISK FORMATTING AND MAPPING THE STANDARD IBM FORMAT FOR 8 INCH FLOPPY DISKS IS GIVEN IN THE WESTERN DIGITAL DOCUMENTATION FOR THE 1791 DISK CONROLLER CHIP AND IN VARIOUS IBM DOCUMENTS. THE USUAL FORMAT IS "SOFT SECTORED". THIS MEANS ESSENTIALLY THAT THE TRACK AND SECTOR NUMBERS ARE ACTUALLY WRITTEN ON THE DISK AS DATA RATHER THAN BEING DETERMINED BY THE PRESENCE OF PHYSICAL INDICATORS SUCH AS HOLES IN THE DISK. FORMATTING A DISK CONSISTS OF WRITING BOTH THE TRACK AND SECTOR NUMBERS AS WELL AS CLOCKING INFORMATION FOR THE CONTROLER ON THE DISK. IT IS IMPORTANT TO REMEMBER THAT A "BLANK" DISK IS BY NO MEANS REALLY BLANK. RATHER IT CONTAINS A GREAT DEAL OF FORMATTING INFORMATION WITHOUT WHICH THE CONTROLER IS TOTALLY UNABLE TO READ IT. BECAUSE OF THIS "SOFT SECTORING" IT IS SOMETIMES POSSIBLE AND OFTEN USEFUL TO CHANGE THE FORMAT TO ALLOW INCREASED AMOUNTS OF DATA TO BE WRITTEN ON THE DISK OR HIGHER SPEED OF OPERATION. THERE ARE TWO POSSIBLE CHANGES THAT ARE USEFUL, CHANGING THE SIZE OF THE SECTORS OR CHANGING THEIR ORDERING. THIS VERSION OF DFOCO SUPPORTS THREE DIFFERENT SECTOR SIZES USING THE "IBM" SOFT SECTOR FORMAT. SECTORS MAY BE FORMATED WITH THE NORMAL 26 SECTORS OF 128 BYTES OR WITH 16 SECTORS OF 256 BYTES OR 8 SECTORS OF 512 BYTES EACH. USING 256 OR 512 BYTE SECTORS ALLOWS APPROXIMATELY 20% MORE DATA TO BE WRITTEN ON A SINGLE DISK, HOWEVER THERE ARE AT PRESENT FEW PROGRAMS WHICH WILL SUPPORT THE USE OF LARGER SECTORS. DFOCO ALSO SUPPORTS A WIDE VARIETY OF SECTOR ORDERINGS. THE DESIGN OF CP/M DATES FROM A TIME WHEN DISK CONTROLLERS WERE QUITE SLOW AND COMPUTER MEMORIES SMALL AND VERY COSTLY. SMALL MEMORIES DICTATED SMALL SECTOR SIZES ON DISKS SINCE THE LARGER THE SECTORS THE LARGER THE MEMORY BUFFERS REQUIRED. SLOW CONTROLERS MEANT THAT HAVING READ A SECTOR FROM THE DISK IT WAS NECESSARY TO WAIT BEFORE ANOTHER SECTOR COULD BE READ. DELAYS OF 5 SECTOR TIMES (ABOUT 25 MSEC) WERE COMMON. THUS CP/M IS SET UP TO READ EVERY 6TH SECTOR AROUND THE DISK. THIS STRATEGY UNFORTUNATELY IS FAR FROM OPTIMAL FOR PRESENT DAY CONTROLLERS WHICH CAN READ CONSECUTIVE SECTORS FROM A DISK WITH EASE. NOTE THAT DFOCO WHICH READS AN ENTIRE TRACK IN A SINGLE DISK REVOLUTION IS OVER 5 TIMES AS FAST AS PIP. UNFORTUNATELY CP/M STANDARD SYSTEM PROGRAMS SUCH AS PIP AND THE ASSEMBLER CAN ONLY BE SPEEDED UP A SMALL AMOUNT, ABOUT 20 PER CENT, BY CHANGING DISK FORMATS ALONE. HOWEVER, NEW PROGRAMS WRITTEN TO TAKE ADVANTAGE OF FASTER CONTROLERS CAN BE SPEEDED UP A GREAT DEAL MORE. MAPPING DISK FORMATS WHEN EXPERIMENTING WITH NONSTANDARD FORMATS IT IS OFTEN VERY USEFUL TO BE ABLE TO READ AND DISPLAY THE ACTUAL DISK FORMAT. YOU CAN'T NECECESSARILY TELL WHATS ON A DISK BY LOOKING AT THE LABEL. THE MAP COMMAND READS THE FORMAT FROM A SINGLE TRACK ON A SPECIFIED DISK AND DISPLAYS IT. THERE ARE 26 SECTORS PER TRACK IN THE STANDARD IBM FORMAT WHICH ARE NUMBERED IN SEQUENTIAL ORDER. TO DISPLAY THE SECTOR ORDERING TYPE: MAP (DEFAULT IS TRACK 0 DRIVE A:) MAP C: TRACK 76 THE PROGRAM WILL READ THE SPECIFIED TRACK AND DISPLAY THE PHYSICAL TO LOGICAL SECTOR MAPPING. THE PHYSICAL SECTORS STARTING FROM THE SINGLE INDEX HOLE IN THE DISK ARE SIMPLY NUMBERED 1 THRU 26. THE CORRESPONDING LOGICAL SECTORS ACTUALLY WRITTEN ON THE DISK ARE DISPLAYED BESIDE THE PHYSICAL SECTOR NUMBER. FOR DISKS FORMATTED WITH LESS THAN 26 SECTORS, THE UNUSED LOGICAL SECTOR NUMBERS DISPLAY AS A '-'. OCCASIONALLY DFOCO WILL DISPLAY OBVIOUSLY INCORRECT MAPPING DATA, FOR EXAMPLE TRACK 404 SECTOR NUMBER 201. THIS MEANS THE FORMAT ON THE DISK IS INCORRECT. THE DISK CONTROLLER WILL OFTEN READ THESE DISKS CORRECTLY BUT IT IS USUALLY A GOOD IDEA TO COPY THE DATA TO A CORRECTLY FORMATTED DISK. FORMATTING PROBLEMS OF THIS TYPE OFTEN SHOW UP WHEN YOU ATTEMPT TO READ DISKS PRODUCED ON ANOTHER COMPUTER SYSTEM. IF THE HEAD ALLIGNMENT IF ONLY SLIGHTLY DIFFERENT FROM YOURS YOU MAY GET MAPPING ERRORS EVEN THOUGH YOU ARE USUALLY ABLE TO READ THE DATA CORRECTLY. FORMATTING DISKS DFOCO PERMITS FORMATTING DISKS ON ANY DRIVE SUPPORTED BY CP/M. EITHER THE ENTIRE DISK OR SPECIFIED TRACKS MAY BE FORMATTED. IT IS EVEN POSSIBLE TO WRITE DIFFERENT FORMATS ON DIFFERENT TRACKS OF THE SAME DISK. STANDARD FORMAT TO WRITE THE STANDARD IBM FORMAT ON A DISK TYPE FORMAT (DEFAULT IS DRIVE A) FORMAT B: FORMAT C: TRACK 20-40 THE PROGRAM WILL HALT AND THEN RESPOND WITH: STANDARD IBM 3740 FORMAT INSERT DISK TO BE FORMATTED IN DRIVE A TYPE CARRIAGE RETURN NON STANDARD FORMATS MAY HAVE ALMOST ANY FORM YOU SPECIFY. THE FIRST VARIATION IS TO OFFSET THE SAME FORMAT FROM TRACK TO TRACK. THIS IS USEFUL TO COMPENSATE FOR THE TIME IT TAKES TO STEP THE HEAD FROM ONE TRACK TO ANOTHER AND IS ONE OF THE TECHNIQUES USED IN DFOCO TO INCREASE THE COPY SPEED. THE FOLLOWING IS AN EXAMPLE OF TRACK OFFSETTING: FORMAT B: OFFSET 5 THIS RESULTS IN THE FOLLOWING FORMAT ON THE DISK TRACK 0 TRACK 1 TRACK 2 ETC. SECTOR 1 6 11 SECTOR 2 7 12 SECTOR 3 8 13 SECTOR 4 9 14 A SECOND FORMATTING VARIATION IS TO SKEW THE SECTORS BY A CONSTANT AMOUNT. THIS CAN BE SPECIFIED AS FOLLOWS. FORMAT B: SKEW 3 THIS WILL RESULT IN A DISPLAY OF THE PHYSICAL TO LOGICAL SECTOR MAPPING AND PERMIT CHANGING THE SPECIFICATIONS BEFORE WRITING THE FORMAT ON THE DISK. PHYSICAL LOGICAL PHYSICAL LOGICAL SECTOR SECTOR SECTOR SECTOR 1 1 14 14 2 4 15 17 3 7 16 20 4 10 17 23 5 13 18 26 6 16 19 3 7 19 20 6 8 22 21 9 9 25 22 12 10 2 23 15 11 5 24 18 12 8 25 21 13 11 26 24 TYPE RETURN TO FORMAT, SECTOR NO TO CORRECT TYPING A SECTOR NUMBER ALLOWS THE LOGICAL SECTOR NUMBER TO BE CHANGED. BEFORE USING A SECTOR NUMBER IT MUST BE FIRST SET TO ZERO SINCE THE PROGRAM CHECKS AND DOES NOT PERMIT TWO SECTORS WITH THE SAME NUMBER. THE SECTOR MAPPING IS REDISPLAYED FOR VERIFICATION AFTER EACH CHANGE. THE FINAL FORMATTING OPTION IS SIMPLY TO TYPE IN THE PHYSICAL TO LOGICAL SECTOR MAPPING FOR EACH SECTOR. TO SELECT THIS OPTION TYPE: SPECIAL FORMAT A: THE PROGRAM WILL RESPOND BY DISPLAYING EACH PHYSICAL SECTOR NUMBER AND WAITING FOR THE CORRESPONDING LOGICAL SECTOR NUMBER TO BE ENTERED. AGAIN THE PROGRAM CHECKS THE SECTOR NUMBERS AS ENTERED AND WILL NOT ALLOW THE SAME SECTOR NUMBER TO BE USED TWICE. NOTE THAT THE VARIOUS OPTIONS MAY BE COMBINED IF DESIRED. SPECIAL FORMAT B: TRACK 0-1 FORMAT C: OFFSET 6 SKEW 3 TRACK 10-76 IT IS EVEN POSSIBLE TO COPY THE FORMAT FROM ONE DISK TO ANOTHER COPY FORMAT A: TO B: COPY FORMAT B: TO D: TRACK 10 FORMATTING WITH DIFFERENT SIZE SECTORS THE DEFAULT SECTOR SIZE GENERATED BY DFOCO IS 128 BYTES, HOWEVER THE PROGRAM WILL ALSO FORMAT TRACKS WITH 16 SECTORS OF 256 BYTES OR 8 SECTORS OF 512 BYTES. THE SECTOR SIZE IS SPECIFIED BY THE SIZE PARAMETER. FORMAT B: SIZE 512 SPECIAL FORMAT A: SIZE 256 FORMAT C: OFFSET 2 SIZE 512 CAUTION MUST BE USED WITH THE SPECIAL FORMAT OPTION SINCE DFOCO WILL ALLOW SECTOR NUMBERS GREATER THAN THE NUMBER OF SECTORS ON A TRACK. THE 1791 WILL ACTUALLY READ SECTORS NUMBERED IN THIS FASHION. FOR EXAMPLE A TRACK MAY BE FORMATTED WITH 8 512 BYTE SECTORS NUMBERED 11 THRU 18, HOWEVER DISKS WRITTEN IN THIS FASHION MAY NOT VALIDATE CORRECTLY. IT IS ALSO POSSIBLE TO FORMAT A DISK WITH DIFFERENT SIZE SECTORS ON DIFFERENT TRACKS. AGAIN, DISKS WRITTEN IN THIS FASHION MAY NOT VALIDATE CORRECTLY. REGARDLESS OF THE SECTOR SIZE AND MAPPING CHOSEN, TRACK 0 OF THE DISK IS ALWAYS WRITTEN IN THE STANDARD IBM 3740 FORMAT. THIS IS DONE TO FACILITATE IDENTIFICATION OF THE DISK FORMAT BY A PROGRAM. READ AND WRITE OPERATIONS TO A DISK MAY ACTUALLY BE IMPOSSIBLE AND "HANG" THE CONTROLLER IF THE PROGRAM EXPECTS A FORMAT THAT IS NOT PRESENT. THIS IS ESPECIALLY TRUE IF THE INCORRECT DENSITY IS SELECTED. PROGRAM TIMING THE FOLLOWING TIMING FIGURES ARE TYPICAL OF A 64K SYSTEM AND WILL BE SLIGHTLY HIGHER FOR SMALLER SYSTEMS. THE COPY TIMINGS VARY WITH DISK FORMATS. IF THE FORMAT IS NON STANDARD BUT THE SAME ON BOTH DISKS THE TIMES ARE THE SAME AS FOR STANDARD FORMATS BUT IF THE SECTOR FORMATS ARE DIFFERENT ON THE TWO DISKS THE COPY TIMES WILL BE INCREASED. THE FOLLOWING TIMINGS ARE FOR SINGLE DENSITY ONLY. VALIDATING 17 SEC FORMATTING 43 SEC (INCLUDES VALIDATION) COPY SAME FORMAT 46 SEC COPY DIFFERENT FORMAT 90 SEC AVERAGE 300 SEC WORST CASE IF THE FORMAT IS DIFFERENT ON DIFFERENT TRACKS OF A DISK IT MAY BE POSSIBLE TO INCREASE COPY SPEED WITH THE USING OPTION. SINCE A WRITE OPERATION TAKES TWICE AS LONG AS A READ OPERATION THE PROGRAM CAN OPTIMIZE THE COPY BY READING THE TRACK FORMAT FROM THE DESTINATION DISK AND USING IT TO CONTROL READING AND WRITING. A SAMPLE COPY WITH THIS OPTION IS COPY A: TO B: USING 3 THIS CAUSES TRACK 3 TO BE READ FROM THE DESTINATION DISK AND USED TO CONTROL THE COPY OPERATION. THIS CAN OFTEN DOUBLE THE COPY SPEED IF THE FORMATS ARE DIFFERENT ON THE TWO DISKS. * * * * * * * DOUBLE DENSITY OPERATIONS * * * * * * * WITH A FEW EXCEPTIONS THE SAME OPERATIONS ARE AVAILABLE DOUBLE DENSITY AS ARE AVAILABLE SINGLE DENSITY. DOUBLE DENSITY MAY BE SELECTED EITHER BY ADDING A D TO THE DESIRED COMMAND OR BY PLACING THE CODE DD ANYWHERE ON THE COMMAND LINE. SOME EXAMPLES: DVALID B: VALID A: SIZE 512 DD DCOPY A: TO B: SIZE 256 DCOPY COPY B: TO D: DD SIZE 512 DFORMAT DFORMAT B: SIZE 512 FORMAT C: SIZE 256 DD THE FOLLOWING EXCEPTIONS SHOULD BE NOTED. THE MAPPING FUNCTION IS NOT AVAILABLE DOUBLE DENSITY. IT IS DIFFICULT TO DO AN ACCURATE TRACK READ OF THE FORMAT ON A DOUBLE DENSITY DISK DUE TO THE FORMAT USED. EVEN WHERE NOT SPECIFICALLY PROHIBITED, IT IS RECOMMENDED THAT OPERATIONS REQUIRING TRACK READ SUCH AS COPY FORMAT OR COPY USING NOT BE ATTEMPED. PROBLEMS IN READING THE FORMAT FROM DISKS MAY CAUSE UNPREDICTABLE RESULTS. THE SPECIAL FORMAT FUNCTION IS NOT AVAILABLE DOUBLE DENSITY. THE STANDARD FORMATS PROVIDED BY THE PROGRAM DOUBLE DENSITY ARE AS FOLLOWS: 128 BYTE SECTORS - TRACK 0 STANDARD 3740 FORMAT SINGLE DENSITY. TRACKS 1-76 HAVE 51 SECTORS WRITTEN IN A 6 TO 1 INTERLACE PATTERN FOR USE WITH CP/M VERS 1.4. THE SECTOR ORDER IS AS FILLOWS: 1,18,35,10,27,44,2,19,36,11,28,45,3,20,37,12,29,46,4,21,38,13,30,47,5, 22,39,14,31,48,6,23,40,15,32,49,7,24,41,16,33,50,8,25,42,17,34,51,9,26,43 ONE ADDITIONAL FEATURE IS PROVIDED FOR USE WITH CP/M. THE LAST BYTE OF DATA ON TRACK ZERO SECTOR ONE IS WRITTEN WITH A SPECIAL FLAG BYTE TO INDICATE THE FORMAT OF THE REST OF THE DISK. THE CODES ARE E5 SINGLE DENSITY (E5 IS THE STANDARD FILL CHAR) DD DOUBLE DENSITY 51 SECTORS PER TRACK 4D "QUAD" DOUBLE DENSITY DOUBLE SIDED DISK TO INSERT THE "QUAD" CODE INTO SECTOR ONE OF A 128 BYTE SECTOR DISK THE FOLLOWING EXAMPLES MAY BE USED: DFORMAT C: QUAD DFORMAT A: QUAD 256 BYTE SECTORS - DOUBLE DENSITY DISKS FORMATTED WITH 256 BYTE SECTORS ARE IN STANDARD IBM FORMAT. 26 SECTORS OF 256 BYTES. TRACK ZERO IS SINGLE DENSITY 3740 FORMAT. THERE IS NO FLAG BYTE IN SECTOR 1 OF TRACK ZERO 512 BYTE SECTORS - DOUBLE DENSITY DISKS FORMATTED WITH 512 BYTE SECTORS HAVE 16 SECTORS PER TRACK. TRACK ZERO IS STANDARD 3740 FORMAT. NO FLAG BYTE ON TRACK ZERO THE OFFSET AND SKEW FUNCTIONS WORK AS BEFORE ALTHOUGH THE EFFECT OF FURTHER SKEWING THE ALREADY INTERLACED 128 BYTE PATTERN MAY BE CONFUSING. COPYING DISKS DOUBLE DENSITY IS ALMOST EXACTLY THE SAME AS COPYING THEM SINGLE DENSITY. TWO SIMPLE RULES MUST BE OBSERVED. 1. BOTH DISKS MUST BE OF THE SAME DENSITY. 2. BOTH DISKS MUST HAVE THE SAME SECTOR SIZE. A VIOLATION OF THES RULES MAY CAUSE THE CONTROLLER TO "HANG" REQUIRING THE COMPUTER TO BE RESET TO RECOVER. IT WILL BE NOTED THAT COPY OPERATIONS ON DOUBLE DENSITY DISKS HAVING 51 SECTORS IS MUCH SLOWER THAN OTHER COPY OPERATIONS. THIS IS BECAUSE THE SECTORS ON THESE DISKS ARE WRITTEN SO CLOSE TOGETHER THAT THE 1791 CONTROLLER DOES NOT HAVE TIME TO WRITE CONSECUTIVE SECTORS ALTHOUGH IT IS ABLE TO READ CONSECUTIVE SECTORS IN THIS FORMAT. COPY OPERATIONS ON DISKS IN THIS FORMAT READ AND WRITE EVERY OTHER SECTOR THUS REQUIRING TWICE AS MANY DISK REVOLUTIONS AND TWICE THE TIME. DOUBLE SIDED OR "QUAD" DISKS ARE NOT AUTOMATICALLY COPIED BY DFOCO IN A SINGLE OPERATION BUT REQUIRE TWO COPY OPERATIONS. TO COPY A "QUAD" DISK YOU MIGHT TYPE: DCOPY A: TO C: (COPY THE FRONT SIDE) DCOPY B: TO D: (COPY THE BACK SIDE) A SINGLE "QUAD" COPY OPERATION WILL BE ADDED TO DFOCO LATER. ======================================================================================== DOCUMENT :usus Folder:VOL2A:h14.driver.text ======================================================================================== (* Program Author: Frank Monaco 679 Lowell Drive Marietta, GA 30060 404-424-1460 *) PROGRAM H14PRINTERDRIVER( (* FROM *) INPUT (* TO PRINTER AND SCREEN *)); (* SENDS UCSD PASCAL DISK FILES TO THE HEATHKIT H14 LINE PRINTER WHILE INTERACTIVELY ALLOWING THE USER TO SPECIFY OPTIONS AT RUN TIME. PROMPTS FOR FILE(S) TO BE PRINTED, AND ALSO FOR USE OF FORTRAN/NOFORTRAN CARRIAGE CONTROL CONVENTIONS IN COLUMN ONE OF THE FILE TO BE PRINTED. IF NOFORTRAN IS SELECTED, PRODUCES PAGED AND TITLED OUTPUT (WITH USER NAMING OPTIONS) *) (* ******************************************************* * FORTRAN CARRIAGE CONNTROL * * 1....TOP OF FORM * * +....NO LINE FEED * * 0....DOUBLE SPACE * * -....TRIPLE SPACE * ******************************************************* *) CONST (*ASCII CONTROL CHARACTERS (DECIMAL) THAT H14 UNDERSTANDS TO CONTROL COLUMN AND VERTICAL SPACING AS WELL AS CHARACTER SIZE. SEE PAGE 13, HEATHKIT MANUAL FOR H14 (OPERATION). *) LF = 10; FF = 12; CR = 13; ESC = 27; LCU = 117; LCX = 120; LCY = 121; CTLA = 1; CTLD = 4; CTLH = 8; CTLP = 16; CTLT = 20; CTLX = 24; SP = 32; DOL = 36; LPAREN = 40; TYPE CONTROLCOLUMNWIDTH = PACKED ARRAY[0..2] OF CHAR; (* BUFFER FOR PRINTER OPTIONS *) VAR C8080, C8096, C80132, C9680,C9696,C96132, C13280,C13296,C132132 : CONTROLCOLUMNWIDTH; COLUMNOPTION, LINESPERINCH : INTEGER; CH, LASTCH : CHAR; FIRSTPART, FILENAME : STRING; F : TEXT; FIRSTPOS, BOLDFACE, FORTRANCONTROLS : BOOLEAN; I : INTEGER; PROCEDURE PUTP; EXTERNAL; (* ASSEMBLY ROUTINE THAT PUTS ONE CHARACTER INTO THE H14'S SERIAL BOARD AT 177514. ALSO CHECKS BIT 15 (RTS) OF 177510 TO VERIFY STATUS OF FIFO BUFFER *) PROCEDURE SENDARRAY(T : CONTROLCOLUMNWIDTH); (* SENDS A THREE CHARACTER COLUMN CONTROL SEQUENCE TO THE H14. SEE PAGE 13, H14 MANUAL FOR OPERATION *) VAR I : INTEGER; BEGIN FOR I := 0 TO 2 DO BEGIN CH := T[I]; PUTP END END; (* SENDARRAY *) PROCEDURE INITIALIZE; (* GIVES VALUES TO COLUMN OPTIONS AND SOLICITS INTERACTIVELY FROM THE USER WHETHER THE FILE SELECTED IS TO BE PRINTED USING FORTRAN CONTROLS OR WHETHER IT IS TO BE PAGED AND TITLED *) BEGIN (* DEFINE COLUMN CONTROL SEQUENCES FOR "SENDARRAY " *) C8080[0] := CHR (ESC); C8096[0] := CHR (ESC); C80132[0] := CHR (ESC); C9680[0] := CHR (ESC); C9696[0] := CHR (ESC); C96132[0] := CHR (ESC); C13280[0] := CHR (ESC); C13296[0] := CHR (ESC); C132132[0] := CHR (ESC); C8080[1] := CHR (LCU); C8096[1] := CHR (LCU); C80132[1] := CHR (LCU); C9680[1] := CHR (LCU); C9696[1] := CHR (LCU); C96132[1] := CHR (LCU); C13280[1] := CHR (LCU); C13296[1] := CHR (LCU); C132132[1] := CHR (LCU); C8080[2] := CHR (CTLA); C8096[2] := CHR (CTLD); C80132[2] := CHR (CTLH); C9680[2] := CHR (CTLP); C9696[2] := CHR (CTLT); C96132[2] := CHR (CTLX); C13280[2] := CHR (SP); C13296[2] := CHR (DOL); C132132[2] := CHR (LPAREN); WRITELN; (* SEE HEATHKIT MANUAL FOR H14 OPERATION, PAGE 13 *) WRITELN('Please select column control options', CHR(7)); WRITELN; WRITELN ('1) 80x80; 2) 80x96; 3) 80x132; 4) 96x80; 5) 96x96; '); WRITE ('6) 96x132; 7) 132x80; 8) 132x96; or 9) 132x132 - - > ', CHR(7)); READLN(KEYBOARD,COLUMNOPTION); CASE COLUMNOPTION OF 1 : SENDARRAY(C8080); 2 : SENDARRAY(C8096); 3 : SENDARRAY(C80132); 4 : SENDARRAY(C9680); 5 : SENDARRAY(C9696); 6 : SENDARRAY(C96132); 7 : SENDARRAY(C13280); 8 : SENDARRAY(C13296); 9 : SENDARRAY(C132132) END; (*CASE COLUMOPTION *) WRITELN; (* SEE HEATHKIT MANUAL FOR H14 OPERATION, PAGE 13 *) WRITELN('Please select number of lines per inch ', CHR(7)); WRITE(' 1) 6 lines per inch; 2) 8 lines per inch - - -> ', CHR(7)); READLN(KEYBOARD,LINESPERINCH); IF LINESPERINCH = 1 THEN BEGIN CH := CHR (ESC); PUTP; CH := CHR (LCX); PUTP END ELSE BEGIN CH := CHR (ESC); PUTP; CH := CHR (LCY); PUTP END; WRITELN; WRITE(CHR(7),CHR(7)); WRITELN; WRITE('Do you want to use Fortran Carriage Controls?'); READLN(KEYBOARD,CH); WRITELN; IF CH IN ['y','Y'] THEN FORTRANCONTROL := TRUE (* USE FORTRAN CARRIAGE CONTROLS *) ELSE FORTRANCONTROL := FALSE; (* USE PAGED AND TITLED OUTPUT *) END; (*INITIALIZE*) PROCEDURE FORTRAN; (* IF SELECTED, THIS OPTION USES THE CHARACTER IN COLUMN ONE FOR CARRIAGE CONTROL *) BEGIN BOLDFACE := FALSE; WHILE NOT EOF(F) DO BEGIN FIRSTPOS := TRUE; WHILE NOT EOLN (F) DO BEGIN IF FIRSTPOS THEN BEGIN READ(F,CH); CASE CH OF '1' : BEGIN (* TOP OF FORM CASE *) CH := CHR(FF); PUTP; FIRSTPOS := FALSE END; '+' : BEGIN (* OVERSTRIKE CASE *) BOLDFACE := TRUE; FIRSTPOS := FALSE END; '0' : BEGIN (* SKIP TWO LINES CASE *) CH := CHR (LF); PUTP; PUTP; FIRSTPOS := FALSE END; '-' : BEGIN (* SKIP THREE LINES CASE *) CH := CHR (LF); PUTP; PUTP; PUTP; FIRSTPOS := FALSE END END; (*CASE*) IF FIRSTPOS THEN BEGIN LASTCH := CH; CH := CHR(LF); PUTP; CH := LASTCH; PUTP; WRITE(CH); FIRSTPOS := FALSE END; END ELSE BEGIN IF BOLDFACE THEN (* COMPENSATE FOR '+' IN COLUMN ONE *) BEGIN BOLDFACE := FALSE; CH := ' '; PUTP END ELSE BEGIN READ(F,CH); PUTP; WRITE(CH) END END END; READLN(F); CH := CHR(CR); PUTP; WRITELN; END; END; (* PROCEDURE FORTRAN *) PROCEDURE NOFORTRAN; (* PRINTS A HEADER (TITLE AND PAGE) WITH THE APPROPRIATE NUMBER OF LINES (DEPENDING ON COLUMN/CHARACTER OPTIONS SELECTED *) VAR NOLINES, NOPAGES, MAXLINES : INTEGER; PROCEDURE WRITEHEADER; PROCEDURE HEADER; (* HANDLES HEADER SPACING, LITERAL CONVERSION, AND ACTUAL OUTPUT TO THE PRINTER *) VAR FIRSTDIGIT, LASTDIGIT, NUMBLANKS : INTEGER; FIRSTCH, LASTCH : CHAR; PAGE : STRING; BEGIN (* HEADER *) CASE COLUMNOPTION OF 1, 4, 7 : NUMBLANKS := 80 - LENGTH(FIRSTPART) - 7; 2, 5, 8 : NUMBLANKS := 96 - LENGTH(FIRSTPART) - 7; 3, 6, 9 : NUMBLANKS := 132 - LENGTH(FIRSTPART) - 7 END; (* CASE *) FOR I := 1 TO (NUMBLANKS - 1) DO BEGIN CH := ' '; PUTP; WRITE(CH) END; FIRSTDIGIT := NOPAGES DIV 10; LASTDIGIT := NOPAGES MOD 10; FIRSTCH := CHR ( FIRSTDIGIT + ORD ('0')); LASTCH := CHR (LASTDIGIT + ORD ('0')); IF FIRSTCH = '0' THEN FIRSTCH := ' '; CH := 'P'; PUTP; WRITE(CH); CH := 'a'; PUTP; WRITE(CH); CH := 'g'; PUTP; WRITE(CH); CH := 'e'; PUTP; WRITE(CH); CH := ' '; PUTP; WRITE(CH); CH := FIRSTCH; PUTP; WRITE(CH); CH := LASTCH; PUTP; WRITE(CH); CH := CHR(LF); PUTP; PUTP; WRITELN; END; (* HEADER *) BEGIN (* WRITEHEADER *) CH := CHR(FF); PUTP; IF FIRSTPART[1] = '#' (* STRIP FROM FILENAME FOR TITLING *) THEN FIRSTPART[1] := ' '; IF FIRSTPART[2] IN ['4'..'5'] THEN FIRSTPART[2] := ' '; IF FIRSTPART[3] = ':' THEN FIRSTPART[3] := ' '; FOR I := 1 TO LENGTH (FIRSTPART) DO BEGIN CH := FIRSTPART[I]; PUTP; WRITE(CH) END; HEADER; END; (* WRITEHEADER *) BEGIN (* NOFORTRAN *) IF LINESPERINCH = 1 THEN MAXLINES := 60 ELSE MAXLINES := 80; NOPAGES := 1; NOLINES := 3; REPEAT (* MAIN LOOP : EXECUTE ONCE PER PAGE *) WRITEHEADER; REPEAT (* INNER LOOP : EXECUTE ONCE PER LINE *) NOLINES := SUCC (NOLINES); WHILE NOT EOLN(F) DO BEGIN READ(F, CH); PUTP; WRITE(CH) END; READLN(F); WRITELN; CH := CHR(LF); PUTP UNTIL (NOLINES = MAXLINES) OR (EOF(F)); (* LINE LOOP *) NOLINES := 3; NOPAGES := SUCC(NOPAGES) UNTIL EOF(F); (* PAGE LOOP *) END; (* NOFORTRAN *) PROCEDURE GETFILE; (* SOLICIT FILE NAME TO BE PRINTED FROM USER *) BEGIN WRITE('Please enter text file name--> '); READLN(INPUT,FIRSTPART); FILENAME := CONCAT(FIRSTPART,'.text'); RESET(F,FILENAME); (* NOW GIVE USER OPTION TO NAME OUTPUT *) IF NOT FORTRANCONTROLS THEN BEGIN WRITE(' 1) Use your title or 2) Use Filename --> '); READLN(CH); WRITELN; IF CH = '1' THEN BEGIN WRITE('Please enter your title--> '); READLN(FIRSTPART); WRITELN END END; END; (* GETFILE *) PROCEDURE ASKFORMORE; (* MORE FILES TO PRINT? *) BEGIN WRITE('Do you want to print any more files? '); READLN(KEYBOARD,CH); IF (CH IN ['y','Y']) THEN CLOSE(F,LOCK); (* CAN ONLY OPEN ONE FILE AT A TIME *) END; (*ASKFORMORE*) BEGIN (*PROGRAM H14 MAIN*) FORTRANCONTROL := FALSE; REPEAT (* MAIN PROGRAM LOOP : EXECUTED ONCE PER FILE PRINTED *) INITIALIZE; GETFILE; IF FORTRANCONTROL THEN FORTRAN ELSE NOFORTRAN; ASKFORMORE UNTIL CH IN ['n','N']; END. (*PROGRAM H14 MAIN*) ======================================================================================== DOCUMENT :usus Folder:VOL2A:h19.doc.text ======================================================================================== Oct 29, 1979 From Walter Hess to users of the Heath H19 terminal: First, you should initially set the switches in the H19 as follows: S401 0 0 1 1 0 0 0 1 S402 0 0 0 0 0 0 1 0 I could not get the BACKSPACE key to do its thing and after much work and frustration, I put a "Patch" into SYSSEGS.TEXT (which is part of the source program for SYSTEM.PASCAL) consisting of an assignment of "CHR(8)" to the variable CRTINFO.CHARDEL. This solved the problem in all parts of the system and also in my own programs. ======================================================================================== DOCUMENT :usus Folder:VOL2A:h19.gotoxy ======================================================================================== (* Program Author: Walter Hess 1460 Seven Pines Rd. Schaumberg, IL 60193 *) (*$U-,S+*) PROCEDURE H19GOTOXY (X,Y : INTEGER); VAR T : PACKED ARRAY[0..3] OF CHAR; BEGIN T[0] := CHR(27); (* ESC *) T[1] := CHR(89); (* "Y" *) IF X < 0 THEN T[3] := CHR(32) ELSE IF X > 79 THEN T[3] := CHR(32+79) ELSE T[3] := CHR(X + 32); IF Y < 0 THEN T[2] := CHR(32) ELSE IF Y > 23 THEN T[2] := CHR(32 + 23) ELSE T[2] := CHR(Y + 32); UNITWRITE(1,T,4) END; BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL2A:h19.miscinfo ======================================================================================== Ò«:df¦¿¶¿¦¿vßþßߤ¿ððq*E>ÿIO HJKCAlEßPABDC?  !"#$%&'()*+,-./AAAAAAAAAA:O^S¡S¡ ======================================================================================== DOCUMENT :usus Folder:VOL2A:hazel.miscinfo ======================================================================================== ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿ  ÝP \? ÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿÿO^ ======================================================================================== DOCUMENT :usus Folder:VOL2A:hexout.text ======================================================================================== PROGRAM HEXTEST; VAR CH : CHAR; I : 0..1; PROCEDURE HEXOUT (C:CHAR); TYPE HEX = PACKED ARRAY[0..1] OF 0..15; ALIASTYPE = RECORD CASE BOOLEAN OF TRUE: (CHAREP:CHAR); FALSE: (HEXREP:HEX) END; VAR ALIAS:ALIASTYPE; BEGIN ALIAS.CHAREP:=C; FOR I:=1 DOWNTO 0 DO IF ALIAS.HEXREP[I] < 10 THEN WRITE(ALIAS.HEXREP[I]) ELSE WRITE(CHR(ALIAS.HEXREP[I]+55)); END; BEGIN REPEAT WRITELN; READ(KEYBOARD,CH); HEXOUT(CH); UNTIL CH='Z' END. j ======================================================================================== DOCUMENT :usus Folder:VOL2A:kbstat.text ======================================================================================== .FUNC KBSTAT,0 .PRIVATE RETADDR POP HL LD (RETADDR),HL POP HL ;CORRECT STACK POP HL LD HL,RADDR ; RETURN ADDRESS PUSH HL LD HL,(1) LD L,6 JP (HL) RADDR OR A ; SET FLAGS LD HL,1 JP NZ,DONE ;READY LD HL,0 ;FALSE DONE PUSH HL LD HL,(RETADDR) JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL2A:linecountr.text ======================================================================================== (* Program Author: Frank Monaco 679 Lowell Drive Marietta, GA 30060 404-424-1460 Rewritten to include improved filename input and blockreads to speed it up: Jim Gagne Datamed Research 1433 Roscomare Road Los Angeles, CA 90024 *) program lcnt; (*counts lines in any file*) var numberoflines, i, j : integer; infilename: string [30]; typed: string; infile: file; chararray: PACKED ARRAY [0..1023] OF char; PROCEDURE GetString (x,y, maxlength: integer); VAR j, k: integer; Gotstring: boolean; bell: char; BEGIN bell := CHR (7); Gotstring := false; REPEAT Gotoxy (x,y); FOR j := 1 TO maxlength DO write ('.'); Gotoxy (x,y); Readln (typed); k := length (typed); IF k > maxlength THEN BEGIN Gotoxy (x,y); Write (' ':k); Gotoxy (0,23); Write (bell, 'You have entered too many characters in this line. ', 'Please try again.') END ELSE Gotstring := true UNTIL Gotstring; Gotoxy ((x+k),y); Write (' ':(maxlength - k)); Gotoxy (2,22); Write (' ':70); Gotoxy (0,73); Write (' ':70) END (*GetString*); PROCEDURE GetFile; VAR gotfn: boolean; bell, response: char; BEGIN Bell := CHR (7); REPEAT Gotoxy (11,20); Write ('Please type the name of the desired input file.'); Gotoxy (15,21); Write ('--> '); Gotoxy (11,22); Write (' (Or just press the key if you wish to quit.)'); Typed := ''; GetString (20,21, 23); IF LENGTH (typed) = 0 THEN BEGIN Gotoxy (11,23); Write ('Would you prefer to quit this program (Y/N)? '); Read (Keyboard, response); Gotoxy (11,23); Write (' ':47); IF (Response = 'Y') OR (Response = 'y') THEN EXIT (Program) END ELSE BEGIN Infilename := Typed; (*$I-*) Reset (Infile, Infilename); IF IORESULT > 0 THEN Reset (Infile, CONCAT (Infilename, '.TEXT')); (*$I+*) Gotfn := IORESULT = 0; IF NOT Gotfn THEN BEGIN Gotoxy (0,23); Write (bell, '<<**** ERROR ****>> ', 'Wrong volume or file name. Type to continue.'); REPEAT Read (Keyboard, Response) UNTIL Response = ' '; Gotoxy (0,23); Write (' ':78) END END(*else*) UNTIL Gotfn; END (*GetFile*); begin writeln(' *** This program counts number of lines in a text file ***'); GETFILE; numberoflines := 0; GOTOXY (3,4); write ('...counting'); while not eof(infile) do begin i := Blockread (Infile, chararray, 2); IF i > 0 THEN BEGIN IF i = 2 THEN i := 1023 ELSE i := 511; FOR j := 0 TO i DO IF chararray [j] = CHR (13) THEN BEGIN numberoflines := succ(numberoflines); gotoxy(1,4); write(numberoflines); END; END; end; writeln; writeln('Your file ', InfileName, ' contains ', numberoflines, ' lines...'); end. ======================================================================================== DOCUMENT :usus Folder:VOL2A:movram.text ======================================================================================== .PROC MOVRAM,3 ; COPYRIGHT 1979 BY BARRY A. COLE ; THIS MAY BE FREELY DISTRIBUTED IF COPYRIGHT NOTICE RETAINED ; PURPOSE: MOVE BUFFER DOWN TO TOADDR) ; PASCAL CALL: CPMRAM(FROMADDR,TOADDR,#BYTES); ; INTENDED USE: GENERATE CODE, CALL CPMRAM, SWITCH TO ; CPM DISK, BOOT CPM, SAVE XX FILE POP HL ;RETURN ADDRESS POP BC ;#BYTES POP DE ;MOVE TO ADDRESS POP HL ;BUFFER ADDRESS LDIR ;MOVE THEM HALT ; AND WAIT FOR DISKETTE CHANGE .END ======================================================================================== DOCUMENT :usus Folder:VOL2A:new.gotoxy.text ======================================================================================== (*The following is a sample gotoxy procedure for the HAZELTINE-2000*) (*TO PUT IT INTO THE SYSTEM, COMPILE IT, RUN 'BINDER' (YOU'VE GOT TO HAVE 60 BLOCKS OF UNUSED AREA ON THE DISK), TELL BINDER THE NAME OF THIS FILE, AND REBOOT THE SYSTEM ('I' TO COMMAND WON'T DO IT.).*) (*$U-*) PROGRAM DUMMY; PROCEDURE FGOTOXY(X,Y:INTEGER); CONST ESC = 126; CLRSCREEN = 28; XYCHR = 17; DELETELINE = 19; BEGIN IF (X = -1) AND (Y = -1) THEN WRITE(CHR(ESC),CHR(CLRSCREEN)) ELSE BEGIN IF (X = -2) AND (Y = -2) THEN WRITE(CHR(ESC),CHR(DELETELINE)) (* THIS DELETES THE ENTIRE LINE THAT THE CURSOR IS ON AND CLOSES UP THE SCREEN FROM THE BOTTOM. *) ELSE BEGIN IF X<0 THEN X:=0; IF X>74 THEN X:=73; IF Y<0 THEN Y:=0; IF Y>26 THEN Y:=26; WRITE (CHR(ESC),CHR(XYCHR),CHR(X+32),CHR(Y+32)); END; END; END; BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL2A:pe1100.gotoxy ======================================================================================== (* This is a GOTOXY procedure for the Perkin-Elmer Data Systems 1100 (Fox) terminal. Author: Paul Gilliam P.O. Box 2202 Pullman, WA 99163 *) PROGRAM DUMMY; PROCEDURE MYGOTOXY(X,Y: INTEGER); VAR P : PACKED ARRAY [0..5] OF CHAR; BEGIN IF X < 0 THEN X := 0; IF X > 79 THEN X := 79; IF Y < 0 THEN Y := 0; IF Y > 23 THEN Y := 23; P[0] := CHR(27); P[1] := 'X'; P[2] := CHR(Y+32); P[3] := CHR(27); P[4] := 'Y'; P[5] := CHR(X+32); UNITWRITE(2,P,6); END { MYGOTOXY }; BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL2A:peruse.pg.text ======================================================================================== (* Program Author: Frank Monaco 679 Lowell Drive Marietta, GA 30060 404-424-1460 *) program perusepage; var i : integer; ch : char; file1, f1 : string; source : text; more : boolean; begin more := true; i := 0; write('enter file to be perused- - -> '); readln(f1); file1 := concat(f1,'.text'); reset(source,file1); while (not eof(source) and more) do begin while not eoln(source) do begin read(source, ch); write(ch) end; readln(source); writeln; i := succ(i); if i = 23 then begin write('more? '); readln(ch); if ch = 'q' then begin more := false end else begin i := 0; reset(input) end end end end. ======================================================================================== DOCUMENT :usus Folder:VOL2A:policy.doc.text ======================================================================================== INTERIM POLICY OF THE UCSD PASCAL USERS' GROUP LIBRARY Obtaining Library Software. Floppy disks full of donated Pascal programs are available from the Library as follows: 8-inch, single-sided, single-density UCSD- or CP/M-format disks are $10 each postpaid (California residents MUST add 6% sales tax; Canadian and Mexican recipients should add $3 per order for the extra hassle involved; other out-of-country sales must add $8 for the first disk of an order and $1.50 per each additional disk to cover air mail) from Jim Gagne, Datamed Research, 1433 Roscomare Road, Los Angeles CA 90024. Both UCSD Pascal and CP/M- compatible Pascals are supported, though UCSD programs will require modification to run under other systems. 5-1/4 inch diskettes of UCSD software (2 or 3 are required to hold an 8- inch volume) are available from Bruce Sherman, SofTech Microsystems, 9494 Black Mountain Road, San Diego CA 92126. Pricing is not yet established, but will probably exceed $20 per volume due to order processing costs. (We are looking for volunteers to distribute the various 5-1/4 inch formats so we can offer them at lower cost.) Software of interest only to users of certain systems will as a rule not be distributed to incompatible systems. Contact Bruce for further information. Western Digital has indicated an interest in distributing Users' Group software on 8-inch disks compatible with the Microengine (these are NOT UCSD compatible because of differences in disk sectoring). In addition, they can provide Microengine users with software that will enable them to convert UCSD standard disks on their machines. Contact them directly for more information. You can obtain a free disk volume of your choice by donating software to the group if the software is accepted (see below). Any user may copy Users' Group software and give it away to others FREE for nothing. This includes OEM's and retailers. However, if any charge whatsoever is made to the recipient of the software, then: 1) the maximum charge is limited to a $5 fee per volume plus the retail cost of each floppy disk and 2) the Users' Group must be reimbursed $2 per disk volume sold. (A disk volume is the contents of one 8-inch, single-sided, single-density diskette.) These charges apply no matter how indirectly the seller obtains Users' Group software. These editing fees should be paid to Datamed Research at the above address, within a month's time of the sale. All software is furnished with the understanding that no one may sell it for profit without the written consent of the author. In addition, the software MAY NOT be copied without continuing to carry whatever statements of authorship it may now contain. Finally, despite hard work to maintain the highest standards possible, we of course cannot guarantee in any way that programs obtained from the Users' Group Library will be suitable for your intended purpose. Submitting Software. We are interested in receiving software from anyone who may wish to contribute. Every type of program is welcomed, and we are particularly eager to receive donations of software tools: those procedures and programs you have developed to make your programming simpler and more productive, and which may be of broad interest to the Pascal community. Such items as double- precision integer packages, business math routines, generic input/output processing, program timers and debuggers, system utilities, and reports of specific techniques to speed UCSD programs are particularly desired. It is clear that if we can all develop the habit of donating particularly useful tools to the Users' Group, a broad base of software support will quickly develop which will benefit us all enormously. To be accepted, software must: 1) be in source form, 2) be relatively free of bugs, 3) be reasonably clearly written and documented so that it may be easily modified, 4) come with sufficient instructions so that we can use it, 5) be capable of being placed in the public domain, and 6) not have been received previously from someone else. If you have an especially long program or one that is for some reason tricky to compile, you may wish to submit object code as well as source. Certain items may be submitted in object form only: if you have a quality program undergoing development that you eventually wish to sell, we would be willing to pilot it for you if it is of sufficient interest to the group at large and works moderately well. I am certain many members would enjoy writing you with their comments, and you should wind up with a product of much higher quality in a much shorter time than is the rule. We are also interested in reports of bugs in the system or user software (preferably with fixes or kludges to get around them) and documentation of the more obscure aspects of UCSD Pascal. Editors. Many people have written to UCSD and SofTech wishing to assist in the organization of a users group library. We think this is grand. Because it makes little sense for the collection and distribution of programs to be scattered all around the country, we plan to set up the following structure for now and see how it works: Anyone who wishes to collect a disk full of software may submit it to the Users' Group (send them to Datamed Research; 8- inch diskettes preferred). Fundamentally, the requirements for the acceptance for the software are those stated previously; in addition, the disk editor must have checked out the programs and organized them in some way. You should have a catalog of the files on the disk, and a separate file containing: 1) descriptions of each program, 2) what you think of it, and 3) any remaining documentation required for use. Note that we are specifically committed to full and complete documentation ON THE DISK whenever possible. Programs should be of general interest, although it is all right to include hardware-specific programs if they solve a pressing need. (I would prefer to put most of the hardware-specific material on a special disk, which users can ignore if they wish.) If you submit a disk that is reasonably well put together, you will: 1) be listed as editor of that volume, 2) receive $1 for each disk SOLD (remember, many will be given to friends), and 3) be placed on the official UCSD Pascal Users' Group Library Roster of Editors, and receive all past and future volumes of the Users' Group library, so we can coordinate our efforts. (I reserve the right not to send you ALL the Users' Group volumes if this thing gets too big and you haven't contributed for a while.) A word of warning: most of the Pascal disks now floating around have much less work put into them than we feel is required for them to be generally useful. I, in particular, am a FANATIC about making our products helpful and/or fun to programmers of various persuasions. So the $1 payment per disk is intended to reimburse you in part for the very real effort required to create a disk with truly useful contents. ======================================================================================== DOCUMENT :usus Folder:VOL2A:prime1.text ======================================================================================== program primenumbers (input,output); const firstprime=2; maximum=30000; tab=9; var sieve : packed array[firstprime ..maximum] of boolean; leftin,range,factor,multiple: 0..maximum; begin writeln('PRIME NUMBER GENERATOR'); write('Enter upper bound: '); read(range); for factor:=firstprime to range do sieve[factor]:=true; leftin:=range-firstprime+1; factor:=firstprime-1; repeat factor:=factor+1; if sieve[factor] then {factor is a prime } begin writeln(factor{,chr(tab)}); multiple:=1; while factor*multiple<=range do begin if sieve[factor*multiple] then begin sieve[factor*multiple]:=false; leftin:=leftin-1 end; multiple:=multiple+1 end { while } end until leftin=0 end. {primenumbers} ======================================================================================== DOCUMENT :usus Folder:VOL2A:prime2.text ======================================================================================== program primes; var range,sample,test : integer; prime: boolean; begin read(range); writeln(2); for sample:=3 to range do begin prime:=TRUE; test:=1; repeat begin test:=test+1; if sample mod test=0 then prime:=FALSE; end until (not prime) or (test>=sample div test); if prime then write(CHR(9),sample); end; end. ======================================================================================== DOCUMENT :usus Folder:VOL2A:ptp.doc.text ======================================================================================== The PTP system is made up of a large Pascal program and 6 small assembly language routines. The large Pascal program should work with most systems and because it requires 56K to compile a precomplied version PTP.CODE has been provided. If you can recompile this program you should do so after changing the constant called SYSTEMNAME which is intended to contain the latitude/ longitude, phone number, and a short system for your system. With the exception of the routine KBSTAT most of the assembly language will have to modified to work with your system. The routine KBSTAT should work with most systems that use CP/M BIOS. Two versions of serveral routines have been provided, one for use with an acoustic coupler system, the other for use with a D C Hayes modem board. After modifing these routines for your system they can be entered a library which is then linked with PTP.CODE (be sure to use another name for the output file so as to not destroy this file). If you do not understand the library procedures you can link the program by entering each of the routine names when the linker asks for lib file. PTP.CODE is always used as the host file. The library "system.library" is not used by this program and automatic linking which may occur if you say run after compiling will not work correctly. The following files make up the Pascal Transfer Program: PTP.TEXT - This the main program written entirely Pascal. PTP.CODE - A compiled but not linked version of the main program PTP.TEXT. PTP.TEXT requires a 56K system to compile therefore this precompiled version can be used as the main program during linking by those with less memory. Be sure not to call the outfile of the linker PTP.CODE or this file will be destroyed. KBSTAT - An assembly language function which return a TRUE if there is a character ready at the keyboard port. Since this routine calls the CP/M keyboard status routine, it should work with most system that use the standard CP/M BIOS jump table with a vector at address 1. THE FOLLOWING FUNCTIONS ARE CONTAINED IN "DCHAYES.IO.TEXT", AND MAY REQUIRE ALTERATION TO RUN PROPERLY ON YOUR SYSTEM. DCHREAD - Performs the same function as SERREAD except for use with the D C Hayes modem. DCHWRITE - Performs the same function as SERWRITE except for use with the D C Hayes modem. DCHMODINIT - An extremely primitive assemble language procedure which initializes a D C Hayes modem for use with PTP. The program performs a brute force auto answer but has no dialing capability. This routine was written only to perform initial testing and should not be used as guide for more reasonable modem interfaces. DCHHANGUP - A primitive assemble language procedure which causes the D C Hayes modem to hangup. Comments made about DCHMODINIT apply here. THE FOLLOWING ROUTINES ARE CONTAINED IN "ACOUSTIC.TEXT", AND MAY REQUIRE ALTER- ATION AS NOTED ABOVE. ACSMODINIT - A dummy routine for use with acoustic coupler systems. ACSHANGUP - A dummy routine used with acoustic coupler systems. An Introduction to Using the Pacsal Transfer Program This brief introduction will hopefully provide you with enough informa- tion to run PTP. The first question you will be asked after starting PTP is if you want to run answer or orginate mode. This question applies to the PTP prog- ram itself since it has an answer and orginate mode just as the modem does. The PTPs must be in different modes to communicate. In the case of the D C Hayes modem, the modem board will be set to the same mode as the program. This would seem a resonable standard for other modems also. This is the only ques- tion, after which the program will start. In the case of answer mode for the D C Hayes modem the program will go into a loop waiting for the phone to ring. If you have made contact with another PTP, both programs should now be in a loop sending empty packets back and forth. The first thing you will see after a connection is established is the ID of the other program. At this point you may try to send a terminal-to-terminal message. To do this type the first character of the message and wait for a ">" follwed by the character you typed. Type the rest of the message and hit return (if the message is to long echoing will stop and the first part will be sent). The message will then be sent to the other PTP. It should be realised that whenever a PTP program is waiting for a character from the keyboard, it will not be listening or sending on the modem line. This will cause the PTP on the other end to timeout while waiting for a transmission and display a receiver timeout message. If this were to continue for a long time, the PTP on the other end would finally give up and abort. Also, even after you finish typing your message it may take several transmissions for the programs to get their half duplex transmissions resynced (both programs may be sending at the same time and miss part of the other's transmission). This condition should correct itself shortly, since the timeout for answer and orginate modes are different. To send files or perform other functions it is first necessary to get the attention of the PTP; to do this type a control-E and wait. A menu should be displayed shortly, similar to the type displayed by the UCSD Pascal system. It should be remembered that when the program is in this mode, the other PTP will be experiencing receiver timeouts. To exit the menu function and return control to PTP just hit a carriage return while in the menu display. The following is a description of the current menu functions: Get - Get a file from the other system. It should be noted that you must already know the name ow the file you wish transfered and there is no remote list directory function. For this reason it would be a good idea if each system contained a file with the well know name "dir.text" which contains the name of the files which that person is willing to have transfered. Send - Send a file from your system to the other system. The PTP program will not create a file on a system if it already exists. This is to prevent overwriting files on the other system which you did not know existed. Raw - This puts you in a raw terminal mode in which makes the system look like a half duplex terminal and is intented mainly to allow logging into timesharing systems. Type a control-E to exit this mode. Init - This function will reinitialize most of the counters in the program. If you are in contact with another PTP this will result in a loss of sequencing from which there is no recovery. This function was included to allow the program to be reinitialized without having to exit the program which will generally cause the modem to hangup. Exit - Will cause PTP to terminate and hangup the phone (if you have modem control). If the program is currently busy transfering a file you will be warned and asked if you still wish to exit. Monitor - This allows you to control various trace and other options as described below: Trace LTB - Trace the link transmission blocks. This trace dumps the variously encoded forms of all transmissions sent and received. It is helpful in gaining an understanding of how the program works but does a lot of data and must be used with CRT type terminal. Trace PPS - Trace the process to process stream functions. In general this trace is not very helpful unless you already know what you are looking for. Trace FTP - Trace the file transfer functions and data. Local loopback test - This puts the program in a mode where it talks to itself and can be very useful in testing the program especially when combined with the LTB trace. You should try this mode before attempting to use this program with another PTP to see if the program will run on your system. Enter data size - Allows use to specify the max amount of unencoded data that will be sent in one transmission block. The normal answer is 64. If you have a noisy line you may notice a message from PTP that it is reducing this size. Because of the low baud rates that our modems use and the encoding done in the PCNET format, the transmission of files will be very slow. However, the transferred file should contain no transmission errors, and any type of file including binary can be transferred. In addition, files can be transfered in both directions at the same time, and the terminal to terminal mode can still be used. In order to give you some assurance that the file is being transferred, a dot or comma will be printed after each block has been transferred. Best of luck, and please contact me with errors, questions, or suggestions you may have. Mark Gang 408-267-4913 ======================================================================================== DOCUMENT :usus Folder:VOL2A:ptp.text ======================================================================================== {$S+} {$G+} {***************************************************************} { } { PTP } { } { PASCAL TRANSFER PROGRAM } { } { } { (C) COPYRIGHT 1979 J. MARK GANG } { } { } { PERMISSION GRANTED FOR NON-COMMERCIAL USE BY INDIVIDUALS. } { ALL OTHER RIGHTS RESERVED. } { } { HISTORY: } { VERSION 1.0 JULY 1979 } { } {***************************************************************} {Note 1: In several places in this program it was necessary to set the length of a string. The length is held in byte 0 of the string. In order to assign to this byte it is necessary that range checking be turned of. } program ptp (); const SYSTEMNAME = '34.52N098.16W408-267-4913/MARKG'; {UNIQUE FOR EACH SYSTEM} ATTENCHAR=05; {^E - used to get to menu} BLKSZ = 512; {disk block size} MAXR41SZ=127; {maximum radix 41 character count} MAXDATASZ = 64; {max amount of data in LTB blocks} MAXREXMIT = 16; {maximum number of retransmit attempts} MAXDUPSEQ = 5; {max allowed dup seq before correction} NOPPS = 2; {number of pps streams -1} ANSTIMEOUT = 6000; {receiver timeout (1000 = 1 sec at 4mHz)} ORGTIMEOUT = 5000; {a different timeout for org made} LTBHDLEN = 2; {length of the LTB header} XPPSTBLSZ = 20; {maximum xmit process to process streams} RPPSTBLSZ = 20; {maximum rec process to process streams} {process numbers} CTRL = 0; {process number of control process} LSTNER=1; {process number of file xfer listener} FTPREC = 2; {process number of file xfer receiver} FTPSND = 3; {process number of file xfer sender} TERM = 4; {process number of terminal hanndler} GETFILE = 5; {process number of remote file requester} SINK = 6; {dummy process to dump unwamted input} {control messages codes} IWN = 0; {I won't} PDN = 64; {Please don't - hex 40} IW = 128; {I will - hex 80} PD = 192; {Please do - hex C0} SF = 17; {send file - hex 11} RF = 18; {receive file - hex 12} AF = 19; {accept file - hex 13} type string20=string[20]; seqno=0..7; bytesz=0..255; iam= (ORG, ANS); coroutine = (rltb, xltb, done); blk= packed array [0..BLKSZ] of char; word = record case integer of {address word as int or two char} 0: (intval: integer); 1: (byteval: packed record hibyte, lobyte : char; end); end; byte = packed record case char of 'a':(hdr: packed record {LTB header format} oob: seqno; seq: seqno; esc: 0..1; oa : iam; end); 'b':(ppsh: packed record {PPS header format} seq: seqno; fil: seqno; lst: boolean; fst: boolean; end); 'c':(bte:bytesz); 'd':(ch: char); 'e':(op: packed record {control character format} msg: 0..63; flavor: 0..3; end); end; ltbarray = packed array [0..MAXR41SZ] of byte; {LTB buffer} datarray = packed array [0..MAXDATASZ] of byte; {send data buffer} pps = packed record {PPS header record format} ppsnum:bytesz; pseq:seqno; active:boolean; fstblk:boolean; lstblk:boolean; srcproc:bytesz; destproc:bytesz; end; xppsrec = array [0..XPPSTBLSZ] of pps; {open PPS xmit table} rppsrec = array [0..RPPSTBLSZ] of pps; {open PPS receive table} {---------------- GLOBALS ------------------------------------------} var c:char; {-- TEST --} ppsmon:boolean; {indicates PPS tracing is on} ftpmon:boolean; {indicates ftp tracing is on} loopbk:boolean; {internal loop back for debugging} trace:boolean; {LTB tracing} serbuf:array[0..512] of char; {loopback buffer} serptr:integer; {loopback buffer pointer} {-- SCHEDULING/SEQUENCE/FLOW --} mynode:iam; {indicates sex of this site during a connection} i:integer; {answer delay counter} timeout: integer; {holds timeout constant} ansbrkt,orgbrkt:char; {hold answer and orignate break characters} xmtgen:seqno; {seq no for next LTB generated} rcvoob:seqno; {old block not yet received } xmtoob:seqno; {oldest LTB not yet acked by other end} sch:coroutine; {next LTB process to be run} {-- XMIT LTB --} r41:string; {holds r41 character set} datasize: integer; {current data size} rexmtcnt:integer; {number of consetive rexmits attempted} xbuf,tbuf:ltbarray; {LTB xmit buffers} xlen,tlen:integer; {LTB xmit buffer pointers} {-- REC LTB --} dupseqcnt: integer; {cnt of consetive dup seq received} {-- PPS --} rppstbl:rppsrec; {receive PPS table} xppstbl:xppsrec; {xmit PPS table} pollpps:bytesz; {next process to be polled by PPS xmitter} {-- CTRL --} ctrlppsno:bytesz; {hold control process PPS number (always 0)} {--- TERMINAL---} termppsno:bytesz; {holds terminal handler PPS number} {-- FTP XMITTER --} xfile:file; {fileid of file to be xmitted} xfilptr:integer; {xmit file pointer} xblk:blk; {number of blocks xmitted} xbufptr:integer; {pointer into xmit data buffer} xname:string20; {name of file to be xmitted} destname:string20; {destination name of file being xmitted} xeof:boolean; {xmit file EOF flag} xppsno:bytesz; {holds xmit ftp process number} xfiletype:bytesz; {indicates type of file being xfered (not used in version 1.0)} xfilesize:word; {indicates size of file to be xfered (not used in version 1.0)} fsndstate: (idle, initiate, request, send, terminate, ack, extabort); {state of file xfer xmitter process} fsndcode:bytesz; {holds control to be sent} {---- LISTENER ------} lstnerxpps:bytesz; {holds listener reply process number} lstnreply:byte; {holds listener reply control code to be sent} {---- FTP RECEIVER ----} rfile:file; {ftp receive file fileid} rfilptr:integer; {receive file block pointer} rblk:blk; {receive buffer} rbufptr:integer; {receive buffer pointer} rname:string20; {receive file name} srcname:string20; {name of file at sending end} receiving:boolean; {indicates ftp receiver is active} frxpps:bytesz; {receiver reply PPS process number} frreply:byte; {ftp receiver reply code} rectype:bytesz; {file type to be received(not used in version 1.0)} recsize:word; {size of file to be received (not used in version 1.0)} {--- GET FILE ---} getstr:string[41]; {name of remote file to be gotten} {---- TERMINAL---} kbinterrupt:boolean; {keyboard has a character ready} kbchar:char; {character from keyboard} {--- MENU --- } menuexit:boolean; {flag to indicate to exit the menu} procedure xpps (var xbuf:ltbarray; var xlen:integer); forward; procedure rpps (var rbuf:ltbarray; var rstrt:integer; var rcnt:integer); forward; procedure sched; forward; procedure ctrlxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); forward; procedure ctrlrec (buf:ltbarray; strt, last:integer; ppstat:pps); forward; procedure fsndxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); forward; procedure lstnerrec (buf:ltbarray; strt, last:integer; ppstat:pps); forward; procedure lstnerxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); forward; procedure fsndrec (buf:ltbarray; strt, last:integer; ppstat:pps); forward; function frecstart(buf:ltbarray; strt, last:integer):boolean; forward; function rmtsndstart(buf:ltbarray; strt, last:integer):boolean; forward; procedure frecxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); forward; procedure frecrec (buf:ltbarray; strt, last:integer; ppstat:pps); forward; procedure getxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); forward; procedure getrec (buf:ltbarray; strt, last:integer; ppstat:pps); forward; procedure termxmit (var dbuf:datarray; var dlen:integer; ppstat:pps); forward; procedure termrec (buf:ltbarray; strt, last:integer; ppstat:pps); forward; procedure sinker (buf:ltbarray; strt, last:integer; ppstat:pps); forward; procedure menu; forward; procedure init; forward; {--- external procedures ----} function serread:char; external; procedure serwrite(c:char); external; function kbstat: boolean; external; function srecstat: boolean; external; procedure modemInit (direction: iam); external; procedure hangup; external; {-------------------- LTB RECEIVER SECTION --------------------------------} procedure byteprint (c: char); {purpose: Print all characters use decimal when not a printing character} begin if (ord(c) < 32) or (ord(c) = 255) then write ('<',ord(c),'>') else write (c); end; procedure getserial(var c:char); {purpose : Get a character for the LTB receiver from either the loopback buffer or the serial line - if no character arrives on the serial line by TIMEOUT return a turnaround character } var i:integer; begin if loopbk then begin c := serbuf[serptr]; if trace then byteprint (c); serptr := serptr +1; end else begin i:=0; repeat i:=i+1; until (i=timeout) or (srecstat=TRUE); if i=timeout then begin if trace then writeln ('RECEIVER TIMEOUT'); if mynode = ORG then c:=ansbrkt else c:=orgbrkt; end else begin c := serread ; if trace then byteprint (c); end; end; end; procedure m41wd1 (var buf:ltbarray; var len:integer); {purpose: Convert 3 bytes of mod 41 to 2 bytes of binary repeat thur entire buffer, output is placed back in source buffer, length is set to the length of the converted form. } var i,j:integer; tmp:word; begin j:=0; i:=0; while j < len do begin tmp.intval := buf[j].bte + ((buf[j+1].bte + (buf[j+2].bte*41))*41); buf[i].ch := tmp.byteval.lobyte; buf[i+1].ch := tmp.byteval.hibyte; j:= j+3; i:= i+2; end; len := i; end; procedure r41m41(var c:char); {purpose: Converts a character from radix 41 character set to mod 41} var co,cv,i:integer; begin co := ord(c); if c = '(' then cv := 0 else if (co > 47) and (co < 58) then {'0' to '9'} cv := co - 47 else if (co > 64) and (co < 91) then {'A' to 'Z'} cv := co - 54 else if c = '*' then cv := 37 else if c = '+' then cv := 38 else if c = '-' then cv := »9 else if c = ')' then cv := 40 else cv := 41; {invalid character} c := chr (cv); {convert back to char} end; procedure hdxscanner (var rbuf:ltbarray; var rcnt:integer); {purpose: Pack incomming stream into LTB packets. Expects one packet per transmission. } var turncnt, atcnt:integer; c:char; begin if trace then begin writeln; write ('LTB REC ='); writeln; end; atcnt := 3; turncnt:=3; rcnt := 0; repeat getserial(c); {get character from serial line} if c = '@' then begin if turncnt < 3 then turncnt := turncnt+1; if (rcnt = 0) and (atcnt > 0) then atcnt := atcnt -1; if rcnt <> 0 then atcnt := 1; {stop after first data block} end else if ((c=ansbrkt) and (mynode=ORG)) or ((c=orgbrkt) and (mynode=ANS)) then begin turncnt:=turncnt-1; end else begin if (rcnt < MAXR41SZ) and (atcnt = 0) then begin r41m41(c); if ord(c)<>41 then {valid char} begin rbuf[rcnt].ch := c; rcnt := rcnt+1; end end else if atcnt < 3 then atcnt := atcnt+1; end until turncnt=0; end; function ckcksum (rbuf:ltbarray; rcnt:integer) : boolean; {purpose: Check checksum of an incomming LTB packet} var ck0,ck1:integer; {running checksums} i:integer; begin ck0 := 0; ck1 := 0; i:=0; while i < rcnt do begin ck0 := ck0 + ord(rbuf[i].ch); i:=i+1; ck1 := ck1 + ord(rbuf[i].ch); i := i+1; end; ck0 := ck0 mod 256; ck1 := ck1 mod 256; if (ck0 <> 0) or (ck1 <> 0) then begin writeln ('ck0=',ck0,' ck1=',ck1); ckcksum := false end else ckcksum := true; end; procedure ltbframer; {purpose: Checks validity of incomming LTB packet. Updates sequence numbers as needed. Check to see if a character has been typed on the keyboard before returning to the LTB xmitter. } label 1; var rbuf:ltbarray; rstrt, rcnt,i:integer; c:char; ch:packed array [0..0] of char; begin hdxscanner (rbuf, rcnt); if rcnt >= MAXR41SZ then begin writeln; writeln ('REC ERROR - LTB TOO LONG'); goto 1; end; if (rcnt mod 3) <> 0 then begin writeln; writeln ('REC ERROR - NOT MULTIPLE OF THREE RADIX-41 CHARACTERS'); goto 1; end; m41wd1 (rbuf, rcnt); {convert 3 byte m41 to 2 binary} if rcnt < 4 then begin writeln; writeln ('REC ERROR - TIMEOUT OR LTB TOO SHORT.'); goto 1; end; if ckcksum (rbuf, rcnt) = FALSE then begin writeln; writeln ('REC ERROR - RECEIVE CHECKSUM'); goto 1; end; if (odd(ord(rbuf[1].ch))) and (ord(rbuf[rcnt-1].ch)=0) then rcnt:=rcnt-1; rcnt:=rcnt-2; {delete checksum bytes} if trace then begin writeln; writeln ('RECEIVED ',rcnt,' BYTES'); end; if rcnt <> ord(rbuf[1].ch) then {lengths not equal} begin writeln; writeln ('REC ERROR - LTB LENGTH CHECK ERROR'); goto 1; end; with rbuf[0], hdr do begin if (oa = mynode) and not loopbk or (oa <> mynode) and loopbk then begin writeln; writeln ('REC ERROR - LTB O/A MODE INCORRECT.'); goto 1; end; if esc = 1 then {should always be zero} begin writeln; writeln ('REC ERROR - PROTOCOL ESCAPE NON ZERO.'); goto 1; end; if loopbk then xmtoob := (seq+1) mod 8 else xmtoob:= oob; if seq = rcvoob-1 then begin writeln; writeln ('REC ERROR - DUPLICATE SEQUENCE RECEIVED.'); if dupseqcnt = MAXDUPSEQ then begin datasize := datasize div 2; writeln; writeln ('DATA SIZE REDUCED TO ',datasize); if datasize < 8 then datasize := 8; dupseqcnt := dupseqcnt + 1; end else dupseqcnt := dupseqcnt + 1; goto 1; end; if seq <> rcvoob then begin writeln; writeln ('REC ERROR - UNEXPECTED SEQUENCE RECEIVED.'); goto 1; end else rcvoob:=(rcvoob+1) mod 8; rstrt := LTBHDLEN; end; {if length less than or equal to LTBHDLEN then no data in this LTB} if rcnt > LTBHDLEN then rpps (rbuf, rstrt, rcnt); 1: if sch<>done then sch := xltb; if kbstat then {this is a safe place to check for a keyboard interrupt} begin unitread(2,ch[0],1,0,0); if ch[0]=chr(ATTENCHAR) then menu else begin kbinterrupt:=TRUE; kbchar:=ch[0] end end end; {--------------- LTB XMITTER SECTION ----------------------------} procedure mkhdr(var buf:ltbarray; length:integer); {purpose: Create LTB header for packet to sent} begin with buf[0], hdr do begin oob := rcvoob; seq := (xmtgen+7) mod 8; esc := 0; oa := mynode; end; buf[1].ch := chr(length); end; procedure gencksum( var buf:ltbarray; var len:integer ); {purpose: Generate checksum for LTB packet to be sent} var ck0,ck1,i:integer; begin ck0 := 0; ck1 := 0; i := 0; buf[ ord(buf[1].ch) ].ch := chr(0); while i= MAXREXMIT then begin writeln; writeln ('EXCESSIVE RETRANSMISSION ATTEMPTS -- CONNECTION ABORTED'); sch := done; end else begin if xmtoob = xmtgen then begin xlen := 2; xpps (xbuf, xlen); rexmtcnt := 0; dupseqcnt := 0; xmtgen := (xmtgen+1) mod 8; {increment seq number} ylen := xlen; ltbsend (xbuf, ylen); end else begin rexmtcnt := rexmtcnt+1; ylen := xlen; ltbsend (xbuf, ylen); end; end; if sch<>done then sch := rltb; end; {----------- LTB GENERAL ------------------------------------} procedure sched; {purpose: Low level dispatcher for the LTB receiver and transmitter.} begin repeat serptr := 0; case sch of xltb:xmitltb; rltb:ltbframer; end; until sch=done; end; procedure ltbinit; {purpose: Initialize LTB values at startup.} begin { Define radix 41 character set. } r41 := '(0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ*+-)'; xmtgen := 0; rcvoob := 0; xmtoob := 0; rexmtcnt := 0; serptr:=0; dupseqcnt := 0; datasize := MAXDATASZ; if loopbk then sch := xltb else sch := rltb; end; {-------------------- PPS TRANSMIT --------------------------} procedure ppsinit; {purpose:Initialize PPS tables at startup.} var i:integer; begin for i:= 0 to XPPSTBLSZ do begin with xppstbl[i] do begin active := FALSE; ppsnum := i; end; end; for i:= 0 to RPPSTBLSZ do begin rppstbl[i].active := FALSE; end; pollpps:=0; end; procedure ppsopen (src, dest:integer; var ppsno:bytesz); {purpose: Open a new xmit PPS, enter the source and the destination process numbers in the xmit PPS table. The number of the PPS that is opened is returned to the caller. } begin ppsno := 0; while xppstbl[ppsno].active and (ppsno<>XPPSTBLSZ) do ppsno := ppsno+1; if ppsno = XPPSTBLSZ then begin writeln; writeln('PPS xmit table full'); end else begin with xppstbl[ppsno] do begin active := TRUE; srcproc := src; destproc := dest; pseq := 0; fstblk := TRUE; lstblk := FALSE; if ppsmon then begin writeln; writeln ('Opening xmit PPS ',ppsno,' source ',src, ' destination ',dest); end; end; end; end; procedure ppsclose (ppsno:bytesz); {purpose: Close the specified xmit PPS number. Note: One more transmission (last block) will occur on this stream. } begin if xppstbl[ppsno].active = FALSE then begin if ppsmon then begin writeln; writeln ('Request to close inactive xmit PPS ',ppsno); end end else begin xppstbl[ppsno].lstblk := TRUE; if ppsmon then begin writeln; writeln ('Closing xmit PPS ',ppsno); end; end; end; procedure mkppshdr (var xbuf:ltbarray; var xlen:integer; dbuf:datarray; dlen:integer; ppsno:integer); {purpose: Build the PPS header.} var i,len:integer; begin with xppstbl[ppsno] do begin if ppsmon then begin writeln; write ('Sending PPS ',ppsno,' seq no ',pseq); if fstblk then write(' - first block'); if lstblk then write(' - last block'); end; with xbuf[xlen], ppsh do begin fst := fstblk; lst := lstblk; fil := 0; {zero filler} seq := pseq; end; xbuf[xlen+1].ch := chr(ppsno); if fstblk then begin xbuf[xlen+2].ch := chr(dlen+5); len:=dlen+5; xbuf[xlen+3].ch := chr(srcproc); xbuf[xlen+4].ch := chr(destproc); xlen := xlen+5; fstblk := FALSE; end else begin xbuf[xlen+2].ch := chr(dlen+3); len:=dlen+3; xlen := xlen+3; end; if ppsmon then writeln (' - length ',len); pseq := (pseq +1) mod 8; if lstblk then begin active := FALSE; lstblk := FALSE; end; end; for i:=0 to dlen-1 do {move user data to xmit buffer} begin xbuf[xlen].ch := dbuf[i].ch; xlen := xlen+1; end; end; procedure xpps; {purpose: Poll processes with active xmit PPS's for one with something to send. } var dbuf:datarray; orgxlen,dlen:integer; ppstat:pps; ppsno:bytesz; begin orgxlen := xlen; dlen :=0; ppsno:= pollpps; {Continue from where last poll + 1} repeat {poll sending processes for out going} if xppstbl[ppsno].active then begin ppstat := xppstbl[ppsno]; with ppstat do begin case ord(srcproc) of {as you can see dynamic process creation is impossible} CTRL: ctrlxmit (dbuf, dlen, ppstat); LSTNER: lstnerxmit (dbuf, dlen, ppstat); FTPREC: frecxmit (dbuf, dlen, ppstat); FTPSND: fsndxmit (dbuf, dlen, ppstat); TERM: termxmit (dbuf, dlen, ppstat); GETFILE: getxmit (dbuf, dlen, ppstat); end; if (dlen>0) or fstblk or lstblk then mkppshdr (xbuf, xlen, dbuf, dlen, ppsno); end; end; ppsno := (ppsno +1)mod XPPSTBLSZ; until (ppsno = pollpps) or (xlen > orgxlen); pollpps := ppsno; end; {--------- PPS RECEIVER ---------------} procedure rpps; {purpose: Check incomming PPS packets and pass to destination process.} label 1; var i:integer; {debug} index,ppsno:bytesz; ppstat:pps; begin ppsno := rbuf[rstrt+1].bte; if ppsmon then begin writeln; writeln ('Receiving PPS ',ppsno,' length ',rbuf[rstrt+2].bte); end; index:=0; while (index ppsno) or (rppstbl[index].active=FALSE)) do index := index+1; with rbuf[rstrt].ppsh do begin if index=RPPSTBLSZ then {not in table} begin if not fst then begin writeln; writeln ('PPS ERROR - received packet on inactive PPS number ',ppsno); goto 1; end else {add new pps to table} begin index:=0; while (index pseq then begin writeln; writeln ('REC PPS ERROR - unexpected sequence number ',seq); pseq := seq; {for now we simply correct set the number} end else pseq := (pseq+1) mod 8; if lst then active := FALSE; end; ppstat := rppstbl[index]; case ord(ppstat.destproc) of CTRL: ctrlrec ( rbuf, rstrt, rcnt-1, ppstat); LSTNER: lstnerrec ( rbuf, rstrt, rcnt-1, ppstat); FTPREC: frecrec ( rbuf, rstrt, rcnt-1, ppstat); FTPSND: fsndrec ( rbuf, rstrt, rcnt-1, ppstat); TERM: termrec ( rbuf, rstrt, rcnt-1, ppstat); GETFILE: getrec ( rbuf, rstrt, rcnt-1, ppstat); SINK: sinker (rbuf, rstrt, rcnt-1, ppstat); end; end; 1: end; procedure rppsredirect (ppsno, newdest:bytesz); {purpose: Redirect all further packets received on the specified PPS stream to the specified destination process. } var index:integer; begin index:=0; while (index ppsno) or (rppstbl[index].active=FALSE)) do index := index+1; if index<>RPPSTBLSZ then begin with rppstbl[index] do begin destproc:=newdest; if ppsmon then begin writeln; writeln ('PPS REC - Redirecting PPS ',ppsnum,' to destination ',destproc); end; end; end; end; {------------------ SINK ----------------------} {a dummy receiver process to dump unwanted input } procedure sinker; begin end; {--------------- CONTROL PROCESS ----------------------} {In version 1.0 this process only sends the system address.} procedure ctrlinit; begin ppsopen (CTRL, CTRL, ctrlppsno); end; procedure ctrlxmit; var i:integer; sysname: string[40]; begin sysname := SYSTEMNAME; if ppstat.fstblk then begin for i:=1 to length (SYSTEMNAME) do dbuf[i-1].ch:=sysname[i]; dlen:=i-1 end end; procedure ctrlrec; var i:integer; begin for i:=strt to last do byteprint (buf[i].ch); end; {--------------- FTP SENDER ---------------------------} procedure fsndinit; {purpose: Initialize ftp sender at startup.} begin fsndstate:=idle; xfiletype:=0; xfilesize.intval:=0; end; procedure ftpstart; {purpose: Does setup for file sending when requested locally.} var cnt:integer; begin if fsndstate<>idle then begin {$I-} writeln;writeln ('Sender is busy transfering ',xname,' to ',destname); write ('Do you wish to abort this transfer ? (Y/N):'); read (c); writeln; if c in ['Y','y'] then begin {set up conditions that indicate end to sender} fsndstate:=extabort; fsndcode:=PDN + AF; {abort receiver} menuexit := TRUE; end; end else begin writeln; writeln; write ('Name of file to be sent: '); readln (xname); writeln; write ('Name of destination file: '); readln (destname); writeln; reset (xfile, xname); if IORESULT <> 0 then begin writeln ('Unable to open ',xname); end else begin fsndstate:=initiate; ppsopen (FTPSND, LSTNER, xppsno); menuexit := TRUE; end; end; {$I+} end; function rmtsndstart; {purpose: Does setup for file sending when requested from remote.} var i,slash:integer; begin {$I-} {$R-} if fsndstate<>idle then {already busy} rmtsndstart:=FALSE else begin i:=strt; while buf[i].ch<>'/' do i:=i+1; slash:=i; xname[0]:=chr(slash-strt); {See Note 1} for i:= 0 to slash-strt do xname[i+1]:=buf[strt+i].ch; destname[0]:=chr(last-slash); {See Note 1} for i:=1 to last-slash do destname[i]:=buf[slash+i].ch; if ftpmon then begin writeln;writeln ('Remote start opening ',xname,' to ',destname); end; reset (xfile, xname); if IORESULT<>0 then {counld not open file} rmtsndstart:=FALSE else begin ppsopen (FTPSND, LSTNER, xppsno); fsndstate:=initiate; rmtsndstart:=TRUE end end {$R+} {$I+} end; procedure fsndxmit; {purpose: Transmits file contents to FTP receiver.} var i, cnt:integer; c:char; tmpstr:string[41]; begin if (fsndstate=terminate) or (fsndstate=extabort) then begin ppsclose (xppsno); close (xfile); dbuf[dlen].bte:=fsndcode; dlen := 1; if fsndstate=extabort then fsndstate:=idle else fsndstate:=ack; end; while (dlen 0 then begin fsndstate:=terminate; fsndcode:=PDN + AF; writeln; writeln ('File sender I/O error ',IORESULT,' file ', xname,'...'); end else xbufptr := 0; end end else begin dbuf[dlen].ch := xblk[xbufptr]; if ftpmon then byteprint (dbuf[dlen].ch); dlen := dlen+1; xbufptr := xbufptr+1; end; end; if (fsndstate=initiate) and ppstat.fstblk then begin writeln; write ('Request to transfer ',xname,' to ',destname,'...'); dbuf[0].bte:= PD + RF; { please do receive file} dbuf[1].bte:= xfiletype; {always 0 in version 1.0} dbuf[2].ch:= xfilesize.byteval.lobyte; {in blocks - 0 if not known} dbuf[3].ch:= xfilesize.byteval.hibyte; {in blocks - 0 if not known} dlen:=3; tmpstr:= concat(xname,'/',destname); for i:= 1 to length(tmpstr) do dbuf[i+dlen].ch:=tmpstr[i]; dlen:=i+dlen; xeof:= FALSE; xbufptr := BLKSZ; xfilptr:=0; fsndstate:=request; end end; procedure fsndrec; {purpose: Receives control information from FTP receiver.} begin case fsndstate of request: if buf[strt].bte= (IW + RF) then { i will receive file} begin writeln ('accepted'); fsndstate:=send; end else begin writeln ('refused'); fsndstate:=extabort; end; ack: begin if buf[strt].bte= (IW + AF) then { i will accept this file} writeln('accepted') else writeln ('refused - code: ',buf[strt].bte); fsndstate:=idle end; send: if buf[strt].bte= (IWN + AF) then begin writeln; writeln ('Transfer of ',xname,' to ',rname,' aborted by receiver.'); fsndcode:=PDN + AF; fsndstate:=extabort; end end end; {------- LISTNEER ------------} { This process acts as a well known process to setup file transfers.} procedure lstnerrec; {purpose: Receiver for listener.} var i:integer; begin {$I-} if ppstat.fstblk then begin if ftpmon then begin writeln; writeln ('Listener requested to:',buf[strt].bte); end; if buf[strt].bte= (PD + RF) then { please receive file} begin ppsopen (LSTNER, ppstat.srcproc, lstnerxpps); ppsclose (lstnerxpps); strt:=strt+1; if frecstart (buf,strt,last) then {FTP receiver ready} begin lstnreply.bte:= IW + RF; { i will receive file}; rppsredirect (ppstat.ppsnum, FTPREC) end else {receiver not ready} begin lstnreply.bte := IWN + RF; { i will not receive file} rppsredirect (ppstat.ppsnum, SINK) {sink any futher input} end end else if buf[strt].bte= (PD + SF) then { please do send file} begin ppsopen (LSTNER, ppstat.srcproc, lstnerxpps); ppsclose (lstnerxpps); strt:=strt+1; if rmtsndstart(buf, strt, last) then lstnreply.bte := IW + SF { i will send file} else lstnreply.bte := IWN + SF; { i will not send file} if ftpmon then begin writeln; write ('LISTENER - remote request to transfer '); if lstnreply.bte= (IWN + SF) then writeln(' refused') else writeln(' accepted'); end; end else {unknown request} if ftpmon then begin writeln; writeln ('LISTENER - Unknown request type ',buf[strt].bte) end; end else {not first block} if ftpmon then begin writeln; writeln ('LISTENER - Not first block on PPS ',ppstat.ppsnum); end; {$I+} end; procedure lstnerxmit; {purpose: Sends listener control responses.} begin dbuf[0].ch := lstnreply.ch; dlen:=1; if ftpmon then begin writeln; writeln ('Listener reply:',lstnreply.bte); end; end; {------- FTP RECEIVER -------------} procedure frecinit; {purpose: Initializes FTP receiver at startup.} begin receiving:=FALSE; end; function frecstart; {purpose: Setup receiver for a file transfer.} var slash,i:integer; begin frecstart:=FALSE; if not receiving then begin {initialization for receiver } rectype:=buf[strt].bte; strt:=strt+1; recsize.byteval.lobyte:=buf[strt].ch; strt:=strt+1; recsize.byteval.hibyte:=buf[strt].ch; i:=strt+1; while buf[i].ch<>'/' do i:=i+1; slash:=i; {$R-} srcname[0]:=chr(slash-strt-1); {See Note 1} {$R+} for i:= 1 to slash-strt-1 do srcname[i]:=buf[strt+i].ch; {$R-} rname[0]:=chr(last-slash); {See Note 1} {$R+} for i:=1 to last-slash do rname[i]:=buf[slash+i].ch; writeln('Receiving file ',rname,' from ',srcname, ' type=',rectype,' size (blocks)=',recsize.intval); {$I-} reset (rfile,rname); if IORESULT=0 then {file already exists} begin writeln ('Local file ',rname,' already exists, transfer aborted.'); close (rfile); end else begin rewrite (rfile, rname); if IORESULT<>0 then writeln ('Unable to create local file ',rname) else begin rfilptr:=0; rbufptr := 0; receiving := TRUE; frecstart:=TRUE; end end end {$I+} end; procedure frecrec; {purpose: Receives data sent by FTP sender.} var cnt,i:integer; begin {$I-} if ppstat.lstblk then {last block of a file transfer} begin receiving := FALSE; writeln; if buf[strt].bte= (PDN + AF) then begin close (rfile); rppsredirect (ppstat.ppsnum, SINK); writeln ('Received abort request on transfer of ',rname); end else begin close (rfile, lock); if IORESULT <> 0 then begin writeln ('FTP REC - close error ',IORESULT,' on ',rname); ppsopen (FTPREC, ppstat.srcproc, frxpps); ppsclose (frxpps); frreply.bte:=IWN + AF; end else begin writeln ('FTP REC - transfered ',rfilptr,' blocks to ',rname); ppsopen (FTPREC, ppstat.srcproc, frxpps); ppsclose (frxpps); frreply.bte:=IW + AF; {i will accept file} end end end; if ppstat.fstblk then {the first block of a file transfer} begin if ftpmon then begin writeln; writeln ('FTP REC - received unexpected first block from ', ppstat.ppsnum) end end else {not first block} if receiving then begin if ftpmon then begin writeln; writeln ('REC='); end; i:= strt; while (i<=last) and (receiving) do begin rblk[rbufptr] := buf[i].ch; if ftpmon then byteprint (rblk[rbufptr]); i:=i+1; rbufptr := rbufptr+1; if rbufptr = BLKSZ then begin write (','); cnt := blockwrite (rfile, rblk, 1, rfilptr); rfilptr := rfilptr+1; rbufptr := 0; if IORESULT <> 0 then begin receiving := FALSE; writeln; frreply.bte:=IWN + AF; {i will not accept file} end; end; end; end; {$I+} end; procedure frecxmit; {purpose: Sender FTP receiver control messages to FTP sender.} begin dbuf[0].ch := frreply.ch; dlen:=1; end; {------------ GET - REQUEST A FILE FROM REMOTE ----------------} {Local process to request a file from remote node.} procedure getftp; {purpose: Get name of remote file from user.} var getxpps:bytesz; gname,localname:string[20]; begin writeln;writeln; write ('Transfer remote file: '); readln (gname); writeln; write ('To local file: '); readln (localname); writeln; write ('Transfer of ',gname,' to ',localname,'...'); ppsopen (GETFILE, LSTNER, getxpps); ppsclose (getxpps); getstr:=concat (gname,'/',localname); menuexit:=TRUE; end; procedure getxmit; {purpose: Send remote transfer request to remote listener.} var i:integer; begin dbuf[0].bte:= PD + SF; { please do send file} for i:=1 to length(getstr) do dbuf[i].ch:=getstr[i]; dlen:=i; end; procedure getrec; begin if buf[strt].bte= (IW + SF) then {i will send file} writeln ('initiated') else writeln ('refused - code: ',buf[strt].bte); end; {----------------- TERMINAL PROCESS --------------------------------} procedure terminit; {purpose: Initialize terminal process at setup time.} begin kbinterrupt:=FALSE; ppsopen (TERM, TERM, termppsno); end; procedure termrec; {purpose: Receive messages from remote terminal process.} var i:integer; begin writeln ; for i:=strt to last do begin write (buf[i].ch); end; writeln; end; procedure termxmit; {purpose: Send ~erminal communications to remote terminal process.} var c : char; chc:packed array[0..0] of char; begin if kbinterrupt then {user wants wants to talk} begin kbinterrupt:=FALSE; writeln; write ('> '); write (kbchar); dbuf[0].ch := kbchar; dlen := dlen+1; while (dbuf[dlen-1].ch<>chr(13)) and (dlenMAXDATASZ) then datasize := MAXDATASZ; writeln; end; procedure exiter; {purpose : Terminates PTP program after warning user if transfers are in progress.} var c:char; begin {$I-} if receiving or (fsndstate <> idle) then begin writeln; write('Currently engaged in file transfer.'); writeln; write ('Are you sure you want to exit? (Y/N): '); read (c); if (c='Y') or (c='y') then begin close (rfile,lock); close (xfile); hangup; exit(ptp); end; end else begin hangup; exit(ptp); end; {$I+} end; procedure menu; {purpose: Main menu loop.} begin menuexit := FALSE; repeat writeln; write ('G(et S(end M(onitor R(aw I(nitialize E(xit: '); read (c); case c of 'S','s':ftpstart; 'E','e':exiter; 'M','m':monitor; 'R','r':rawterm; 'I','i':init; 'G','g':getftp; end; until eoln or menuexit; end; {------------------- INITIALIZATION -----------------} procedure init; {purpose: Calls individual initialization procedures.} begin ltbinit; ppsinit; ctrlinit; terminit; frecinit; fsndinit; modemInit (mynode); end; begin {main} writeln; writeln ('Pascal Transfer Program (PTP) Version 1.0 7/24/79'); writeln; trace := FALSE; ppsmon := FALSE; ftpmon := FALSE; loopbk := FALSE; ansbrkt := '['; orgbrkt := ']'; repeat writeln; write('Answer or Originate ? (A/O)'); read(c); case c of 'a','A': begin mynode := ANS; timeout := ANSTIMEOUT end; 'o','O': begin mynode := ORG; timeout := ORGTIMEOUT end; end; until c in ['a','A','o','O']; writeln; init; if mynode = ANS then begin for i:=0 to 10000 do; {should really wait for carrier detect} endxmit end; sched; hangup; end. ======================================================================================== DOCUMENT :usus Folder:VOL2A:punch.tape.text ======================================================================================== (* Program Author: Walter Hess 1460 Seven Pines Rd. Schaumberg, IL 60193 *) (* RTAPE and PUNCH If you have the HEATH Paper Tape System, these two programs will transfer files between the paper tape system and disc files. I have not used them much but I believe they work OK.*) (*$L SCRVOL:LPUNCH.TEXT*) PROGRAM PUNCH; (* VERSION "O" 06/11/79 WIH *) TYPE LSTR = STRING[132]; POINTER = ^CHAR; VAR PCH,PCHS : POINTER; INSTR,FLSTR : LSTR; INFIL : TEXT; J : INTEGER; PROCEDURE INITPT (VAR PNT,PNTS : POINTER); CONST PUNCHADD = -146; TYPE REP = (POINTREP,INTREP); ALIAST = RECORD CASE REP OF POINTREP: (POINTVAL : POINTER); INTREP: (INTVAL : INTEGER); END; (* CASE *) VAR ALIAS : ALIAST; BEGIN ALIAS.INTVAL := PUNCHADD; PNT := ALIAS.POINTVAL; ALIAS.INTVAL := PUNCHADD - 2; PNTS := ALIAS.POINTVAL; END; PROCEDURE WASTE; VAR K : INTEGER; BEGIN REPEAT K := ORD(PCHS^); UNTIL K = 128; END; PROCEDURE PUNCHST (PUSTR : LSTR); VAR J : INTEGER; BEGIN FOR J := 1 TO LENGTH(PUSTR) DO BEGIN PCH^ := PUSTR[J]; WRITE(PUSTR[J]); WASTE; END; PCH^ := CHR(13); WRITE(CHR(13)); WASTE; END; BEGIN (* MAIN PROGRAM *) INITPT(PCH,PCHS); WRITELN(' ENTER NAME OF FILE TO BE PUNCHED'); READLN(FLSTR); RESET(INFIL,FLSTR); FOR J := 1 TO 100 DO BEGIN PCH^ := CHR(0); WASTE; END; REPEAT READLN(INFIL,INSTR); PUNCHST(INSTR); UNTIL EOF(INFIL); PCH^ := CHR(4); WASTE; FOR J := 1 TO 100 DO BEGIN PCH^ := CHR(0); WASTE; END; CLOSE(INFIL) END. ======================================================================================== DOCUMENT :usus Folder:VOL2A:randombyte.text ======================================================================================== .FUNC RANDIT,0 LD A,R LD B,0 LD C,A POP HL PUSH BC JP (HL) .END ======================================================================================== DOCUMENT :usus Folder:VOL2A:read.tape.text ======================================================================================== (* Program Author: Walter Hess 1460 Seven Pines Rd. Schaumberg, IL 60193 *) (* RTAPE and PUNCH If you have the HEATH Paper Tape System, these two programs will transfer files between the paper tape system and disc files. I have not used them much but I believe they work OK.*) (*$L SCRVOL:LRTAPE.TEXT*) PROGRAM RTAPE; (* VERSION "O" 06/12/79 WIH *) TYPE LSTR = STRING[132]; POINTER = ^CHAR; VAR PCH,PCHS : POINTER; INSTR,FLSTR : LSTR; OUTFIL : TEXT; J : INTEGER; CH : CHAR; PROCEDURE INITR (VAR PNT,PNTS : POINTER); CONST RTAPEADD = -150; TYPE REP = (POINTREP,INTREP); ALIAST = RECORD CASE REP OF POINTREP: (POINTVAL : POINTER); INTREP: (INTVAL : INTEGER); END; (* CASE *) VAR ALIAS : ALIAST; BEGIN ALIAS.INTVAL := RTAPEADD; PNT := ALIAS.POINTVAL; ALIAS.INTVAL := RTAPEADD - 2; PNTS := ALIAS.POINTVAL; END; PROCEDURE GETCH; VAR K : INTEGER; BEGIN PCHS^ := CHR(1); REPEAT K := ORD(PCHS^) UNTIL K = 128; CH := PCH^; END; BEGIN (* MAIN PROGRAM *) INITR(PCH,PCHS); WRITELN(' ENTER NAME OF FILE TO WRITE TO FROM READER'); READLN(FLSTR); REWRITE(OUTFIL,FLSTR); GETCH; WHILE CH <> CHR(4) DO BEGIN IF CH <> CHR(0) THEN BEGIN WRITE(OUTFIL,CH); WRITE(CH); END; GETCH; END; CLOSE(OUTFIL,LOCK); END. ======================================================================================== DOCUMENT :usus Folder:VOL2A:shellmsort.text ======================================================================================== PROGRAM SORT; { SOURCE FILE ASCENDING ORDERSORT } { COPYRIGHT 1979 BY BARRY A. COLE 3450 SAWTELLE BL#332 LOS ANGELES, CA 90066 THIS MAY BE USED FREELY IF NOT SOLD AND IF THIS MESSAGE IS RETAINED IN THE SOURCE. } CONST SIZE=400; { MAXIMUM LINES TO BE SORTED} VAR FROM,TOFIL: STRING[15]; SRCFIL,DSTFIL: TEXT; SLOT: PACKED ARRAY[1..SIZE] OF STRING[80]; RECNUM: ARRAY[1..SIZE] OF INTEGER; i,gap,j,jg,lines,temp: INTEGER; BCHAR: CHAR; PROCEDURE BLIP; BEGIN IF BCHAR='X' THEN BCHAR:='O' ELSE BCHAR:='X'; WRITE(BCHAR,CHR(8)); END; procedure chekswap; begin while j>0 do begin jg:=j+gap; if SLOT[recnum[j]]<=SLOT[recnum[jg]] then exit(chekswap); temp:=recnum[j]; recnum[j]:=recnum[jg]; recnum[jg]:=temp; j:=j-gap; end; end; BEGIN lines:=0; WRITE('SORT SOURCE FILE? '); READLN(FROM); WRITE('SORT DEST. FILE? '); READLN(TOFIL); RESET(SRCFIL,FROM); REWRITE(DSTFIL,TOFIL); WRITELN('READING FROM FILE: ',FROM); WHILE NOT EOF(SRCFIL) DO BEGIN lines:=lines+1; RECNUM[lines]:=lines; READLN(SRCFIL,SLOT[lines]); BLIP; END; WRITELN(lines,' LINES TO BE SORTED'); gap:=lines; while gap>0 do begin gap:=gap div 2; for i:=gap+1 to lines do begin j:=i-gap; chekswap; end; end; { FOR I:=0 TO LINES DO BEGIN BLIP; FOR J:=I TO LINES DO IF SLOT[RECNUM[I]]>SLOT[RECNUM[J]] THEN BEGIN temp:=RECNUM[I]; RECNUM[I]:=RECNUM[J]; RECNUM[J]:=temp; END; END; } WRITELN('SORT OPERATION COMPLETE'); FOR I:=1 TO lines DO WRITELN(DSTFIL,SLOT[RECNUM[I]]); CLOSE(DSTFIL,LOCK); WRITELN(TOFIL,' HAS BEEN UPDATED'); END. ======================================================================================== DOCUMENT :usus Folder:VOL2A:smartremot.text ======================================================================================== (* Program Author: Walter Hess 1460 Seven Pines Rd. Schaumberg, IL 60193 *) (* SMTTERM BEWARE!!! This program has only been finished (I think) during the last week. It requires a serial card at addresses 177570 thru 177576 (octal). the VECTOR address is 270 but is not used as PASCAL has no provision for servicing an interrupt from this card. The resultant RS232 port is connected to a coupler for dial-up to the remote computer. The biggest problem I had was in writing to a disc file from the remote computer due to the fact that PASCAL stores data for a file in temporary storage someplace and periodically actually writes it to disc. The period while it is writing to disc is relatively long and since the remote computer keeps sending data, some information would be lost. I solved the problem by writing to an array, and when the array is nearly full, I send the remote computer an ESC "H" which is the command sequence which halts the particular remote computer I use (see PROCEDURE WARRY). After a short wait while the remote computer stops during which time arriving characters are accepted, I write the array to the disc file and then tell the remote computer to resume by sending an ESC which restarts the remote computer (see PROCEDURE WFILE). The particular commands will, of course, be different for different computers. Another tricky area was the use of "BREAK". If you want to send a "BREAK" to the remote computer, do not use the "BREAK" key as this will locally interrupt PASCAL. Instead, I simulate a "BREAK" with the top row f5 which does the job nicely. The program uses certain of the ESC functions created by the top row of keys as program commands and passes all other ESC sequences to the remote computer. If the remote computer needs one of the top row sequences, the command structure will have to be modified. It seems that Heath uses sequences for the top row which are not commonly used elsewhere.*) PROGRAM SMTTERM; { VERSION "O" 10/20/79 W.I.H. } CONST ARLEN = 100; TYPE POINTER = ^CHAR; VAR PCH,PCHS,PCHR,PCHRS,CCH,CCHS,CCHR,CCHRS : POINTER; TCHAR : PACKED ARRAY[0..1] OF CHAR; ARINDEX,CFULL,PRINDEX,COLM,LNCT,LNLINE,LNINCH,LNPAGE,L : INTEGER; NFULL,HALT,LESC,FDUP,CMD,PRINTON,RCRDON,PLBKON,TERMINATE : BOOLEAN; FILENAME : STRING[30]; PRARRY : PACKED ARRAY[1..ARLEN] OF STRING[132]; SSTRING : STRING[1]; PRFILE : TEXT; R : REAL; RCH,CH,ESCH : CHAR; PROCEDURE INITPT; TYPE REP = (POINTREP,INTREP); ALIAST = RECORD CASE REP OF POINTREP: (POINTVAL : POINTER); INTREP: (INTVAL : INTEGER); END; { CASE } VAR ALIAS : ALIAST; BEGIN ALIAS.INTVAL := -130; CCH := ALIAS.POINTVAL; ALIAS.INTVAL := -132; CCHS := ALIAS.POINTVAL; ALIAS.INTVAL := -134; CCHR := ALIAS.POINTVAL; ALIAS.INTVAL := -136; CCHRS := ALIAS.POINTVAL; ALIAS.INTVAL := -178; PCH := ALIAS.POINTVAL; ALIAS.INTVAL := -180; PCHS := ALIAS.POINTVAL; ALIAS.INTVAL := -182; PCHR := ALIAS.POINTVAL; ALIAS.INTVAL := -184; PCHRS := ALIAS.POINTVAL; END; PROCEDURE WASTE; VAR K : INTEGER; BEGIN REPEAT K := ORD(PCHS^); UNTIL K = 128; END; {Waste} PROCEDURE COMM(CH : CHAR); VAR L : INTEGER; BEGIN REPEAT L := ORD(CCHS^); UNTIL L = 128; CCH^ := CH END; {Comm} PROCEDURE CARRAY; VAR J : INTEGER; BEGIN FOR J := 2 TO ARLEN DO PRARRY[J] := ''; END; {Carray} PROCEDURE WARRY; BEGIN IF ORD(CH) > 127 THEN CH := CHR(ORD(CH) - 128); IF CH = CHR(10) THEN CH := CHR(127); IF (CH = CHR(13)) THEN BEGIN PRINDEX := 1; ARINDEX := ARINDEX + 1; IF ARINDEX = ARLEN - 3 THEN BEGIN NFULL := TRUE; COMM(ESCH);COMM('H'); END; END ELSE BEGIN IF CH <> CHR(127) THEN BEGIN SSTRING[1] := CH; INSERT(SSTRING,PRARRY[ARINDEX],PRINDEX); PRINDEX := PRINDEX + 1; END; END; END; {Warry} PROCEDURE WFILE; VAR K,J : INTEGER; BEGIN K := 1; IF LENGTH(PRARRY[1]) = 0 THEN K := 2; FOR J := K TO ARINDEX - 1 DO WRITELN(PRFILE,PRARRY[J]); IF PRINDEX > 1 THEN PRARRY[1] := PRARRY[ARINDEX] ELSE PRARRY[1] := ''; ARINDEX := 1; CARRAY; NFULL := FALSE; COMM(ESCH); END; {Wfile} PROCEDURE PRINT (PRTCHR : CHAR); BEGIN IF PRTCHR = CHR(13) THEN PRTCHR := CHR(10); WASTE;PCH^ := PRTCHR; END; {Print} PROCEDURE PRINTER; BEGIN WRITE(ESCH,'Y8 ',ESCH,'l','Enter printer characters per line '); WRITE('80, 96 or 132) '); PCH^ := ESCH;WASTE;PCH^ := CHR(117);WASTE; REPEAT READLN(LNLINE); IF LNLINE = 80 THEN BEGIN PCH^ := CHR(1);WASTE; END ELSE IF LNLINE = 96 THEN BEGIN PCH^ := CHR(20);WASTE; END ELSE IF LNLINE = 132 THEN BEGIN PCH^ := CHR(36);WASTE; END; UNTIL (LNLINE = 80) OR (LNLINE = 96) OR (LNLINE = 132); WRITE(ESCH,'Y8 ',ESCH,'l','Enter lines per inch (6 or 8) '); PCH^ := ESCH;WASTE; REPEAT READLN(LNINCH); IF LNINCH = 6 THEN BEGIN PCH^ := CHR(120);WASTE; END ELSE IF LNINCH = 8 THEN BEGIN PCH^ := CHR(121);WASTE; END; UNTIL (LNINCH = 6) OR (LNINCH = 8); END; {Printer} PROCEDURE COMMAND; VAR GCHAR : BOOLEAN; PROCEDURE DISPLAY; BEGIN WRITE(ESCH,'Y8 ',ESCH,'l',ESCH,'F^',ESCH,'G'); IF CMD THEN WRITE(ESCH,'p'); WRITE('BLUE Cmd',ESCH,'q',ESCH,'F^',ESCH,'G'); IF PLBKON THEN WRITE(ESCH,'p'); WRITE('RED Playback',ESCH,'q',ESCH,'F^',ESCH,'G'); IF RCRDON THEN WRITE(ESCH,'p'); WRITE('GREY Record',ESCH,'q',ESCH,'F^',ESCH,'G'); IF NOT FDUP THEN WRITE(ESCH,'p'); WRITE('f1 Half Duplex',ESCH,'q',ESCH,'F^',ESCH,'G'); IF PRINTON THEN WRITE(ESCH,'p'); WRITE('f2 Print',ESCH,'q',ESCH,'F^',ESCH,'G','f3 Terminate', ESCH,'F^',ESCH,'G'); END; {Display} PROCEDURE RCORD; VAR TRYAGAIN : BOOLEAN; BEGIN {$I-} REPEAT WRITE(ESCH,'Y8 ',ESCH,'l','Enter File Name (.TEXT Assumed)'); WRITE(' Or CR to Terminate '); READLN(FILENAME); IF LENGTH(FILENAME) = 0 THEN BEGIN RCRDON := FALSE; EXIT(RCORD); END; FILENAME := CONCAT(FILENAME,'.TEXT'); RESET(PRFILE,FILENAME); IF IORESULT = 0 THEN BEGIN CLOSE(PRFILE); WRITE(ESCH,'Y8 ',ESCH,'l','File exists, do you want to '); WRITE('replace it (Y or N) '); REPEAT READ(CH); UNTIL (CH = 'Y') OR (CH = 'N') OR (CH = 'y') OR (CH = 'n'); IF (CH = 'N') OR (CH = 'n') THEN TRYAGAIN := TRUE ELSE TRYAGAIN := FALSE; END ELSE TRYAGAIN := FALSE; IF NOT TRYAGAIN THEN REWRITE(PRFILE,FILENAME); UNTIL (IORESULT = 0) AND (NOT TRYAGAIN); {$I+} WRITE(ESCH,'k'); END; {Rcord} PROCEDURE PLAYBACK; VAR J : INTEGER; BEGIN {$I-} REPEAT WRITE(ESCH,'Y8 ',ESCH,'l','Enter File Name (.TEXT Assumed)'); WRITE(' Or CR to Terminate '); READLN(FILENAME); FILENAME := CONCAT(FILENAME,'.TEXT'); IF LENGTH(FILENAME) = 0 THEN BEGIN PLBKON := FALSE; EXIT(PLAYBACK); END; RESET(PRFILE,FILENAME); UNTIL IORESULT = 0; {$I+} WRITE(ESCH,'k'); COMM(ESCH);COMM('E');COMM(CHR(17)); WHILE NOT EOF(PRFILE) DO BEGIN READ(PRFILE,RCH); COMM(RCH); WRITE(RCH); IF EOLN(PRFILE) THEN BEGIN COMM(CHR(13)); WRITE(CHR(13)); READ(PRFILE,RCH); END; END; {While} IF ORD(CCHRS^) = 128 THEN IF ORD(CCHR^) = 7 THEN FOR J := 1 TO 1000 DO R := 6.2*164.83*9.5/17.84; PLBKON := FALSE; WRITE(ESCH,'j'); CLOSE(PRFILE); COMM(ESCH);COMM('E');COMM(CHR(19)); END; {Playback} BEGIN {Command} WRITE(ESCH,'x5',ESCH,'j'); CMD := TRUE; DISPLAY; REPEAT GCHAR := FALSE; REPEAT READ(CH); IF CH = ESCH THEN BEGIN GCHAR := TRUE; READ(CH); END ELSE WRITE(CHR(7)); UNTIL GCHAR AND (CH IN ['P'..'U']); CASE CH OF 'P' : CMD := FALSE; 'Q' : IF PLBKON THEN PLBKON := FALSE ELSE BEGIN PLBKON := TRUE; DISPLAY; PLAYBACK; END; 'R' : IF RCRDON THEN BEGIN RCRDON := FALSE; WFILE; CLOSE(PRFILE,LOCK); END ELSE BEGIN RCRDON := TRUE; PRINDEX := 1; ARINDEX := 1; CARRAY; NFULL := FALSE; PRARRY[1] := ''; RCORD; END; 'S' : IF FDUP = TRUE THEN FDUP := FALSE ELSE FDUP := TRUE; 'T' : IF PRINTON THEN BEGIN PRINT(CHR(12)); PRINTON := FALSE END ELSE BEGIN PRINTON := TRUE; PRINTER; END; 'U' : TERMINATE := TRUE; END; {Case} DISPLAY; UNTIL (NOT CMD) OR TERMINATE; WRITE(ESCH,'y5',ESCH,'k'); END; {Command} BEGIN { Smtterm } WRITELN; WRITELN(CHR(7),' ** NOTE ** f5 SENDS A "BREAK". ENTER SPACE TO CONTINUE'); READ(CH); ESCH := CHR(27); WRITE(ESCH,'x1'); SSTRING := ' '; CFULL := 0; INITPT; NFULL := FALSE;TERMINATE := FALSE; HALT := FALSE; FDUP := TRUE;CMD := FALSE;PRINTON := FALSE;RCRDON := FALSE;PLBKON := FALSE; WRITE(ESCH,'y6'); COMMAND; REPEAT UNITREAD(2,TCHAR[0],1,,1); WHILE UNITBUSY(2) DO BEGIN L := ORD(CCHRS^); IF NFULL THEN CFULL := CFULL + 1; IF L = -32640 THEN BEGIN CH := CCHR^; WRITE(CH); IF PRINTON THEN PRINT(CH); IF RCRDON THEN WARRY; END; IF CFULL = 5000 THEN BEGIN WFILE; CFULL := 0; END; END; {While} IF LESC THEN BEGIN LESC := FALSE; IF TCHAR[0] = 'P' THEN COMMAND ELSE BEGIN IF TCHAR[0] = 'W' THEN BEGIN CCHS^ := CHR(1); FOR L := 1 TO 10 DO R := 6.2*164.83*9.5/17.84; CCHS^ := CHR(0); END ELSE BEGIN COMM(ESCH);COMM(TCHAR[0]); IF TCHAR[0] = 'H' THEN HALT := TRUE; END; END; END ELSE IF (TCHAR[0] = ESCH) AND (NOT HALT) THEN LESC := TRUE ELSE BEGIN COMM(TCHAR[0]); IF TCHAR[0] = ESCH THEN HALT := FALSE ELSE IF NOT FDUP THEN WRITE(TCHAR[0]); END; UNTIL TERMINATE; WRITE(ESCH,'k'); WRITE(ESCH,'z'); END. {Smtterm} ======================================================================================== DOCUMENT :usus Folder:VOL2A:timing.doc.text ======================================================================================== COMMENTS ON FLOPPY DISK TIMING RE THE 512-BYTE SECTORED DISK A friend remarked recently that the only reason many of the disk i/o drivers have worked so well is that they drive systems like CP/M, where intersystem timing differences have been overwhelmed by having to wait for every sixth sector to come by on the disk. The distribution UCSD system, though faster than CP/M, still respects the timing needs of many (but not most) disk drives and controllers. My old Micromation controller (quite similar to the single-density Discus) did all its CRC calculations in SOFTWARE (!?!?) and could not read 128-byte sectors faster than one in four, and even then was unreliable. Because it could not keep up with the every-other-sector reading of the UCSD system, I had to wait for a disk revolution per sector, slowing the system down unmanageably (45 seconds to boot up!). Even when one is equipped with a decent LSI-based disk controller, there are subtle timing constraints that are rarely taken into account in the disk i/o software I have seen, but will cause trouble if they are not respected in a high-performance system like the one on these two disks. The problem is that different drives and different controllers have different timing constraints, so our software may not run unaltered on all systems: 1) When you change disk drives, your system requires a head-settling time of approximately 35 milliseconds. 2) Track-to-track accesses must be followed by settling time on the order of 10 to 15 milliseconds, higher if more distance is gone. 3) The number of sectors you can pack onto a disk track depends on how closely your disk drives revolve at 360 RPM's. There is a specified tolerance of 2%, meaning that if your disk is formatted when running slightly slow and written to when going slightly fast, you can wipe out addresses or data on a successive sector unless there is an adequate intersector gap (see the recent article in Byte magazine on this subject). So, although many disk drives will run happily with nine 512-byte sectors per track, others will occasionally clobber the disk, and require the increased intersector gap afforded by eight sectors per track. The practical application of the above data is as follows: the 512-byte programs listed in 512.DOC.TEXT have been tested on a number of systems and seem to run well. A number of delay loops have been included, particularly in the SETDSK (change to new disk drive) and SETTRK (move the head) routines. These delays may or may not be adequate for your system. You may require the additional delay when changing tracks of a track-to-track offset. You can achieve this by altering the disk access routines in PBIOS to start accessing the next track at sector number (TrackNumber MOD 8), or format your disks with DFOCO so that the PHYSICAL sector number is offset by 1 (though see the notes in 512.DOC about the funny way you must tell DFOCO to do this). The way to find out how your system responds to the timing presently in the 512-byte system is to USE it. Try doing a bad-block scan of a newly formatted 512-byte disk, and see if your drives step at 6 tracks a second. If there is hesitation, you'll have to fiddle with sector offsets. ======================================================================================== DOCUMENT :usus Folder:VOL2A:tvi912c.gotoxy ======================================================================================== (* This is a GOTOXY procedure for the TelVideo 912 CRT. Program Author is Paul Gilliam, P. O. Box 2202, Pullman, WA 99163. *) PROGRAM DUMMY; PROCEDURE MYGOTOXY(X,Y: INTEGER); { for tvi 912c } VAR P : PACKED ARRAY [0..3] OF CHAR; BEGIN IF X < 0 THEN X := 0; IF X > 79 THEN X := 79; IF Y < 0 THEN Y := 0; IF Y > 23 THEN Y := 23; P[0] := CHR(27); P[1] := '='; P[2] := CHR(Y+32); P[3] := CHR(X+32); UNITWRITE(2,P,4); END { MYGOTOXY }; BEGIN END. ======================================================================================== DOCUMENT :usus Folder:VOL2A:update.doc.text ======================================================================================== 30 March 1980 AN UPDATE ON THE PRESENT STATUS OF THE UCSD PASCAL USERS' GROUP A Visit with SofTech. A recent development of the UCSD Pascal Users' Group is my recent visit with Al Irvin and Bruce Sherman at SofTech Microsystems, the primary licensee of UCSD Pascal. They responded to my inquiry with great enthusiasm, and I will summarize our discussion and its results. As you have probably already learned, in early 1979 Bowles' group at UCSD was notified that it would have to discontinue the software distribution business because of the threat to the nonprofit standing of the University of California system caused by the financial success of UCSD Pascal. Months of deliberations followed to determine which course would be the fairest to all yet protect the hardware independence of the UCSD Pascal system. Ultimately, an established East coast software firm, SofTech, created a San Diego subsidiary, SofTech Microsystems, which became the primary UCSD Pascal licensee. Its job is specifically to distribute UCSD Pascal as widely as possible, while improving it and offering the vigorous user support Bowles' students could not provide. (In addition, a number of other firms obtained OEM licenses which are still in effect; the best known is Apple computers.) Many users have written to UCSD and SofTech asking for a newsletter, regional meetings, and possibly a job bulletin board. There were many volunteers. As a result, SofTech has been planning to sponsor the birth of a users group with a meeting in San Diego this summer. Once it is formed, they will turn over its management to volunteers not associated with UCSD or SofTech. A number of users have begun sharing UCSD Pascal software and have indicated an interest in forming a UCSD Pascal library. In order to utilize their contributions, SofTech drafted a proposal for a users library that would be contributed to by a number of software "editors," who would compile and submit disk volumes of quality software not previously included in the library, along with adequate documentation and estimation of the quality of the software contents. These volumes would be forwarded to one or more central distribution points. To partially compensate the editors for their time, they would receive a small payment per disk sold, with the understanding that users would be encouraged to copy and distribute the users group disks for free, and that the editors would receive no payment for disks not sold. kctual payment of editing fee would be on a quarterly basis. Since the software sharing system organized by Datamed Research is similar to what SofTech was planning to develop, we have agreed to cooperate with each other as much as possible. To avoid confusion with a UCSD Pascal Users' Group that would publish a newsletter, hold meetings, etc., the present sharing of software will be called the UCSD Pascal Users' Group Library, and I have taken the role of interim librarian. I like their proposal for a system of editors a great deal. To avoid duplication, however, someone must coordinate the library centrally. For example, I have already seen four copies of the Pascal prettyprinters floating around. I have presented a proposal for the way editors may interface with the group in POLICY.DOC.TEXT elsewhere on this volume. The Multitude of Floppies. There are a multitude of disk formats that now run UCSD Pascal. For two years, the system utilized virtually exclusively one 8-inch, single-density format on a number of different machines. Now, with the rise of UCSD Pascal on the Apple, the TRS-80 Mod I, the North Star, the Microengine (yes, the disks are close but not compatible), and a host of other drives (e.g., the Micropolis, and also I've heard of it running on a Helios hard-sector floppy) with more to come, it may seem impossible to support all these different disk drives. Certainly, the job is too large for one person, but there are signs of help on the way. Western Digital is quite interested in supporting their system directly, and you can get routines from them that will move data from a UCSD disk to a Microengine disk and vice versa, all on a Microengine system. I have received offers of help from several users with dual systems of varying types. Because so little RAM is available for the system, the TRS-80 Mod I has a fatal flaw: only small to mid-sized programs will compile, and it is almost useless. Because it requires a lot of memory to compile a UNIT, this facility is not available. (Hot tip -- if you want to make a bundle, figure out a way to replace the Level II BASIC ROM card with a card that holds the UCSD Z-80 interpreter in ROM, preferably switch-selectable with the BASIC card.) This leaves the Apple as the other major UCSD system that requires support. Indeed, I've received quite a number of inquiries from Apple users in the past two weeks since the announcement of the Users' Group. SofTech has agreed to download programs from master 8- inch floppies to the Apple and TRS-80 and possibly other, 5- 1/4 inch disk systems. They are concerned, however, about how expensive it is for them to just process an order. So we're looking for some other means of distributing Apple Pascal programs. In other words, HELP!!! Those of you who have a dual- disk Apple system and would like to earn a small fee ($2) per disk volume shipped, please get in touch. If you are nearby, I can supply you with raw materials (disks and cartons). Other Pascals Supported. In addition to UCSD Pascal, the users group software library will also support Pascal M, Pascal/Z, and Pascal/MT, the other major Pascals available that run under CP/M. Other CP/M-compatible Pascals may be added as they become available. Please contact Datamed Research if you would like to contribute software that runs under these systems. However, because of time limitations, we cannot convert UCSD Pascal programs to the other systems; we will supply UCSD Pascal library software on CP/M disks for you to complete your own conversions. (As it turns out, the syntax of Pascal M is virtually identical to that of UCSD, and the other systems lack primarily GET, PUT, variant records, and compatibility with nonstandard extensions. So with Pascal/Z or /MT, your major problem is file i/o. Also, if the program is large, you'll have to find a way to fit it in memory.) Other Activities of DATAMED RESEARCH As a certified Pascal fanatic, I also plan to become a major retailer of proprietary Pascal utilities and application software. In addition, I am interested in selling other Pascal systems as well as UCSD. Please contact me if you have Pascal software that you would like to offer for sale to the computing community. In addition, Datamed Research has announced a call for software related to health care for its new disk-based software journal, SOFTDOC, to be published quarterly beginning in June. Contact me directly for further information. Sincerely, Jim Gagne, President DATAMED RESEARCH 1433 Roscomare Road Los Angeles, CA 90024 ======================================================================================== DOCUMENT :usus Folder:VOL2A:vol.2b.doc.text ======================================================================================== DOCUMENTATION FOR THE FILES ON VOLUME 2B: (nominally) CP/M FORMAT I packed the CP/M format disk with the maximum number of files that would fit, so documentation resides in this file and elsewhere on this disk as noted below. BOOTER.ASM DFOCO.ASM PGEN.ASM MACRO.LIB SAMPLEIO.ASM These programs are all documented within 512.DOC.TEXT, elsewhere on this disk. They form the CP/M portion of the 512-byte BIOS al- terations for the UCSD system and require CP/M software (principally the Digital Research macroassembler) to be assembled (unless modified). Specific documentation regarding DFOCO is contained in DFOCO.DOC.TEXT on this disk. UCSD2CPM.MAC UCSD2CPM.COM This assembly-language program translates UCSD-format textfiles to the CP/M format. It runs under CP/M. It is written for the Microsoft assembler with Zilog memnomics, and will run on a Z-80 only, I believe, though it should not be hard to modify for an 8080 if you so desire. One bug: the utility sometimes can't find UCSD files even though you typed the filename correctly. To overcome this problem, keep typing the correct name until the program finds the file. I have filled up the rest of the disk with my favorite CP/M utilities, including some quite helpful for disk maintenance in a UCSD system: CAT.COM CAT.SUB FMAP.COM UCAT.COM These utilities form Ward Christensen's CP/M disk cataloging package from the CP/M Users' Group, Volume 25, and available in source form from me or them. To use, insert a dummy filename on each disk of the format "-xxxxxxx.nnn", where "xxxxxxx" is any name relevant to the purpose of that disk (one to seven alphanumeric characters) and "nnn" is the unique serial or volume number of that disk (e.g., 001, 010, 289, etc.). The hyphen in front of the disk name ensures that it comes first in an alphabetical listing of directory entries, and is required for the cataloging program to function. Next, create a file with your favorite CP/M editor called "MAST.CAT", and include within this file a list of all files you do NOT wish listed in the master catalog (such as ED.COM, ASM.COM, and other fairly universal files) in the following format: each filename must be on a separate line in alphabetic order. The first name is preceeded by a left parenthesis, and the last followed by a right parenthesis, in the following manner: (ASM.COM ED.COM STAT.COM) Next pick a disk which will contain your master catalog, MAST.CAT, and add the dummy directory entry "-xxxxxxx.nnn" to each disk as noted above. To add the directory data on a disk to the catalog, first make a file of the directory data by typing "FMAP : F", where diskletter is one of "A" through "D". Then type "UCAT" to merge the "NAMES.SUB" file created by FMAP with the catalog file. You can follow this procedure each time a disk is created or significantly changed, since UCAT automatically deletes catalog entries not present on the updated directory file and adds any new entries it finds. To delete an entire volume, create a "NAMES.SUB" file consisting only of the volume name you wish to delete (in the usual "-xxxxxxx.nnn" format) and run UCAT. Finally, to use the catalog, there is CAT.COM, which is invoked like the DIR command in the CP/M distribution system (same types of wildcard references) except that there is another pair of parameters, the volume name and number: CAT . . (note that the hyphen in front of the diskname is DELETED once it's within the catalog). So typical commands would be: CAT --> list entire catalog; CAT *.ASM --> list all ASM files on all disks; CAT *.* *.002 --> list all the files on volume 002; CAT A*.* --> list all files starting with "A"; CAT *.ASM UCSD.* --> list all .ASM files on disks with volumename UCSD. For those of us with a large number of CP/M disks, this VERY much helps to locate files. As you may imagine, I would be quippled tink if someone would write a similar program for the UCSD system (without, I would hope, the necessity to write a separate file of filenames before combining a disk directory's contents with the master file). CLEAN.COM This utility is a super-PIP, allowing rapid copying of one or more files from one disk to another. It is simple and self-documenting. D.COM This program replaces CP/M's DIR, providing an alphabetized display of all the files on a CP/M disk. File size is displayed, as well as the remaining number of bytes of room on a disk. The display is in three columns for the viewing of up to 57 files of a disk on the screen at one time. In addition to typing just "D " when at the CP/M command level, you can type "D : consists of one of the letters A through D, to see the contents of a disk other than the one currently logged. If you have a terminal smaller than 80 x 24, you will have to send a blank disk with return postage to Sam Singer (address in the DFOCO listing) or get the CP/M Users Group volume #24, which contains the source (named XDIR). Earlier versions of D, however, add up the remaining room on the disk incorrectly and report one more Kbyte then really exists. NOTE: We BADLY need a utility of this sort in the UCSD system, which would allow us to read the contents of a disk directory WITHOUT invoking the filer and fitting one or two columns of filenames on a screen at once, all in alphabetical order. If you take on this one, write the directory-reading portion of the utility in such a manner that it is generally usable. DUMP.ASM This is Sam's disk dumping utility, allowing you access to hex and ASCII listings (in a format like DDT's D command) of files, tracks, sectors, and the CP/M logical groups. The Map facility gives you a picture of disk usage by viewing the occupied groups (CP/M's way of organizing disk data). If you ignore the CP/M features, this program will work just fine for UCSD- format disks. Note that it works only with 3740-compatible disks (single density, each track with 26 sectors of 128 bytes); you'll have to put up with UCSD's Patch utility to fix 512-byte sectored disks. This is a nice utility, but I prefer my program: SPAT.ASM This is heavily modified from the version published in the first CP/M Users Group and is designed specifically to write to a 16 x 64 memory-mapped video terminal. If you want to use it with a conventional terminal (i.e., accessed via I/O ports), you'll have to write the display to a buffer at the end of the program, then write out the buffer to your terminal via the CONSLOUT vector in the BIOS jump table. In addition, some means of GOTOXY should be included to obtain data entry instead of the direct screen entry utilized when data is requested. Look at the code carefully before you try to assemble it; there are hardware-specific features (such as an ASCII formfeed character to clear the screen) that are moderately well documented. VDMLC is the memory address of the terminal; VDMPG is the number of 256-byte pages within the terminal memory. SPAT has a number of nice features. It works with a single 128-byte sector at a time, displaying the hex and ASCII data separately and laid out so you can see what data is where within the sector. Fixes are easily made, and there is a STATUS byte at the top of the screen, so you can check out the 1771- type status word directly from the chip. I've added direct access to the CP/M logical units of "Group" (the series of 8 logically contiguous 128-byte sectors which makes up the logical unit of disk storage) and "Fraction" (my name for the relative logical sector within a group, ranging from 0 to 7). If you type "M", the screen fills up with the contents of the entire group written in ASCII, speeding your access to troubled source or other textfiles. I find SPAT of enormous use in fixing disk problems ranging from restoring an erroneously erased directory entry (change the first byte of the entry from E5 hex to 00), to marking bad sectors as a file GARBAGE.BAD within the directory (first, discover the logical Group number corresponding to the physical sector you have found to be bad, then create the directory entry and stick the correct group number therein), to actually repairing a damaged sector. NOTE WELL: if you are a beginner to CP/M, GET HELP before fooling around with a disk directory, as you can REALLY make a MESS!!! This brief description does not constitute adequate instructions in how to proceed. ======================================================================================== DOCUMENT :usus Folder:VOL2A:volume.2.text ======================================================================================== DOCUMENTATION OF THE FILES IN VOL 2: MACHINE-SPECIFIC PROGRAMS AND MISCELLANY This disk contains the documentation of Volume 2B (normally CP/M format) in the files: VOL.2B.DOC.TEXT DFOCO.DOC.TEXT. A. Terminal and printer drivers and documentation. I have not tried any of them. The following files may help you if you have one of the listed devices: H19.GOTOXY (Change the name to something.TEXT so you can edit & compile.) PE1100.GOTOXY (ditto; terminal is Perkin Elmer Model 1100 [Fox]) TVI912.GOTOXY (ditto) HAZEL.MISCINFO (Don't forget to change the name to SYSTEM.MISCINFO.) H19.MISCINFO (ditto) H19.DOC.TEXT H14.DRIVER.TEXT (Lists files on the Heath printer at full speed.) PUNCH.TAPE.TEXT (UCSD files to Heath tape.) READ.TAPE.TEXT (Heath tape to UCSD.). B. 512-byte disk sectoring routines for Z-80's running with a Western Digital-based floppy controller. This system is the one I use, and is the reason for the separate CP/M volume. See the Volume 2B documentation noted above, and also: 512.DOC.TEXT TIMING.DOC.TEXT CPMIO.DOC.TEXT. C. Interfacing CP/M with UCSD disks: BOOTASM.TEXT MOVRAM.TEXT (BOOTASM is written in Pascal and uses MOVRAM as an assembly- language EXTERNAL file. You can use the UCSD assembler to create CP/M-compatible software, then move it to 100H and save it on a CP/M disk.) BOOTCPM.TEXT (Before, you could boot up Pascal from CP/M. Now, you can get at CP/M from Pascal, if you'd ever want to.) UCSD2CPM.MAC UCSD2CPM.COM (These files are on the CP/M disk and allow you to transfer files from UCSD format to CP/M. See VOL.2B.DOC.) D. Two more modem drivers: PTP.TEXT PTP.DOC.TEXT DCHAYES.IO.TEXT ACOUSTIC.TEXT KBSTAT.TEXT (These files form the Pascal Transfer Program, which will drive either a DC Hayes or an acoustic modem. It looks well written, and I haven't tried it. If you don't have an 8080, you should still have no problem getting this to run, in contrast to the work required with the modem drivers in Volume 1. KBSTAT is yet another keyboard status routine; we MUST standardize these before I go nutz. Let me know how you like this.) SMARTREMOT.TEXT (This claims to turn your machine into a smart terminal. Again, I haven't tried it; let me know.) E. Miscellany: NEW.GOTOXY.TEXT (A good idea for an expanded GOTOXY that uses codes, e.g., GOTOXY (-1, -1) to drive CRT functions like CLEARSCREEN. The point is that if we all agree on the codes, we can put the drivers in SYSTEM.PASCAL and forget about having to include them in our applications programs.) PRIME1.TEXT (Two prime number generators written in Pascal.) PRIME2.TEXT HEXOUT.TEXT (A Pascal program to write integers in hexadecimal format.) PERUSE.PG.TEXT (This little thing allows you to peruse a textfile one page at a time on your CRT. It needs work: reading and writing strings in UCSD Pascal is hopelessly slow, unless you utilize a blockread approach and hunt for ASCII carriage returns in the resulting character array on your own. Also, the file opening routine is crummy and could use something like GETFILE in my CRT.I.O.TEXT in the last volume. Finally, I always seem to skip past the page I want when checking out files; it would be nice to be able to back up one page. Anyone?) DELETE.LF.TEXT (This quickie deletes extraneous linefeed characters in text- files transferred from other computers. I was going to com- plain about this one, too, but rewrote it instead. It's about 5 to 10 times faster with blockread/write.) LINECOUNTR.TEXT (Ever wanted to count the lines of a text or source file? I rewrote this one, too.) RANDOMBYTE.TEXT (A quick assembly-language routine to load the contents of the R register of a Z-80 into a Pascal program; good to initialize a random-number generator. This would be nice to include in our products so we don't always have to start games, "Type a number." A good alternative if you have a clock is to load the lowest byte of the TIME function. We'll have to make this universal; see UNIVERSAL.TEXT, coming up in Volume 3.) SHELLMSORT.TEXT (This little routine sorts a text file list alphabetically, using the Shell-Metzner sorting algorithm. Each entry is assumed to start on a new line. Not well documented, but it is so short and cute. Only problem is that damn string READLN and WRITELN again; the program runs slowly. I decided to leave in Barry's BLIP procedure so you can see one man's way of fol- lowing the progress of his program; it flips a spot on the screen from one character to another.) WRITER.TEXT WRITER.DOC.TEXT (WRITER is a very nice little text printer that is well menu driven. It needs little documentation, as a HELP command is actually built in!! I am impressed.) F. More about the UCSD Pascal Users' Group Library. UPDATE.DOC.TEXT (Tells you what's been going on with the UCSD Pascal Users' Group.) POLICY.DOC.TEXT (Most recent formulation of how the Library works, how to order disks, how to become an editor, etc.) ACKNOWLEDGEMENTS The following folks wrote or gathered most of the software on this disk: Sam Singer, 17226 Bonita, Perris, CA 92370. As far as I'm concerned, Sam is one of the best assembly-language programmers I know. His contributions to the CP/M Users Group (contained on Volume 2B) are the best in that group to date. He's worked on the 512-byte sector system (first authored and gotten running by George Bolthoff) to extend its scope to double-density/sided and utilize more controllers than the single-density Tarbell. Barry Cole, Sawtelle Blvd., West Los Angeles, California Jim McCord, 330 Vereda Leyenda, Goleta, California 93017. (VERY interested in UCSD Pascal on PDP-11 hardware; started an LSI-11 UCSD Pascal Users' Group.) The Pascal Advancement Society Library, c/o Joe Sharp, Palo Alto, California. ======================================================================================== DOCUMENT :usus Folder:VOL2A:writer.doc.text ======================================================================================== WRITER Writer is a program which is designed to read a given file and print it, along with a few optional organization and clarification aids. It is not to be considered a for- matter, but it is designed to be an improvement over an or- dinary printout. The options available are Date, Margins, Pagenumbers, Doublespacing, Instructions, and a List of Printfiles. A prompt line will explain all commands, and if they are not understood, command H ( Help ) will explain them furthur, along with all defaults. Up to 9 files are allowed, and when the user is satisfied with the current values of the parameters a carrige return will begin the printing. NOTE: ALL PARAMETERS WILL BE DEFAULTED WITH THE EX- CEPTION OF DATE AND FILENAME, AND AT ALL TIMES WHILE WAITING FOR A COMMAND A LIST OF PARAMETERS AND THEIR DEFAULTES WILL BE DISPLAYED. The easiest way to run this program is to type 'F', followed by one to nine filenames, followed by two carrige returns. ======================================================================================== DOCUMENT :usus Folder:VOL2A:writer.text ======================================================================================== PROGRAM WRT; VAR FILES : ARRAY [ 1..9 ] OF STRING ; GOTFILES : BOOLEAN ; FILENAME : STRING ; DATE : STRING ; DOUBLESPACE : CHAR ; COMMAND : CHAR ; NUMBERS : CHAR ; TOPORBOTTOM : CHAR ; PAPERSIZE : INTEGER ; LEFTMARGIN : INTEGER ; TOPMARGIN : INTEGER ; BOTTOMMARGIN : INTEGER ; NUMFILES : INTEGER ; NUMPRINTS : INTEGER ; ENDLINES : INTEGER ; { * * * * * * * * * * } PROCEDURE WRTPAGE ( PRINTFILE : STRING ) ; VAR INP : TEXT ; CH : CHAR ; PR : FILE OF CHAR; LINE : STRING ; DONE : BOOLEAN ; MARGINLINES : INTEGER ; PAGENUMBER : INTEGER ; EXTRALINES : INTEGER ; FILLERLINES : INTEGER ; MARGINSPACES : INTEGER ; LINESLEFT : INTEGER ; LINESUSED : INTEGER ; PROMPTER : CHAR ; { ------------------- } BEGIN WRITELN ( 'Printing...' ) ; REWRITE (PR,'PRINTER : '); RESET ( INP, PRINTFILE ) ; PAGE ( PR ) ; PAGENUMBER := 0 ; DONE := FALSE ; WHILE NOT EOF (INP) DO BEGIN PAGENUMBER := PAGENUMBER + 1 ; WRITELN ( PR ) ; IF ( NUMBERS = 'Y' ) AND ( TOPORBOTTOM = 'T' ) THEN BEGIN WRITELN ( PR , '-' : 36 , PAGENUMBER , '-' ) ; END ; IF PAGENUMBER = 1 THEN BEGIN WRITELN ( PR , DATE : 67 ) ; WRITELN ( PR , PRINTFILE : 42 ) ; IF TOPORBOTTOM = 'T' THEN LINESUSED := TOPMARGIN + 4 ELSE LINESUSED := TOPMARGIN + 3 ; END { IF } ELSE IF TOPORBOTTOM = 'T' THEN LINESUSED := TOPMARGIN + 2 ELSE LINESUSED := TOPMARGIN + 1 ; FOR MARGINLINES := 1 TO TOPMARGIN DO WRITELN (PR) ; LINESLEFT := PAPERSIZE - LINESUSED ; { WRITELN ( LINESUSED ) ; WRITELN ( LINESLEFT ) ; WRITELN ( ENDLINES ) ; READ ( KEYBOARD , PROMPTER ) ; } WHILE ( LINESLEFT > ENDLINES ) AND ( NOT DONE ) DO BEGIN FOR MARGINSPACES := 1 TO LEFTMARGIN DO WRITE ( PR , ' ' ) ; READLN ( INP, LINE ) ; WRITELN ( PR, LINE ) ; IF DOUBLESPACE = 'Y' THEN BEGIN WRITELN (PR) ; LINESLEFT := LINESLEFT - 2 ; END ELSE LINESLEFT := LINESLEFT - 1 ; IF EOF ( INP ) THEN DONE := TRUE ; END { WHILE } ; FOR MARGINLINES := 1 TO BOTTOMMARGIN DO WRITELN ( PR ) ; IF EOF ( INP ) THEN BEGIN EXTRALINES := ( LINESLEFT - ENDLINES ) ; FOR FILLERLINES := 1 TO EXTRALINES DO WRITELN ( PR ) ; END ; IF ( NUMBERS = 'Y' ) AND ( TOPORBOTTOM = 'B' ) THEN BEGIN WRITELN ( PR , '-' : 36 , PAGENUMBER , '-' ) ; END ; { PAGE ( PR ) ; } { ------------------- } END ; CLOSE (INP) ; END { WRTPAGE } ; { * * * * * * * * * * } PROCEDURE HELPINSTR ; VAR PROMPTER : CHAR ; FILLERLINES : INTEGER ; BEGIN PAGE ( OUTPUT ) ; WRITELN ; WRITELN ( 'INSTRUCTIONS:' ) ; WRITELN ( 'TO USE ANY OF THE FOLLOWING COMMANDS,' ) ; WRITELN ( 'SIMPLY ENTER THE FIRST LETTER OF THAT' ) ; WRITELN ( 'COMMAND, AND THE REST IS SELF-EXPLANATORY.' ) ; WRITELN ( 'WHEN YOU ARE READY TO BEGIN PRINTING,' ) ; WRITELN ( 'SIMPLY TYPE A CARRIAGE RETURN' ) ; FOR FILLERLINES := 1 TO 8 DO WRITELN ; WRITE ( '( < CR > to continue ) ' ) ; READLN ( KEYBOARD , PROMPTER ) ; PAGE ( OUTPUT ) ; END { HELPINSTR } ; { * * * * * * * * * * } PROCEDURE HELPCMNDS ; VAR PROMPTER : CHAR ; FILLERLINES : INTEGER ; BEGIN WRITELN ; WRITELN ( 'COMMANDS:' ) ; WRITELN ( 'D : DATE' ) ; WRITELN ( 'F : FILENAME ( UP TO 9 )' ) ; WRITELN ( 'H : HELP' ) ; WRITELN ( 'L : LIST OF PRINTFILES' ) ; WRITELN ( 'M : MARGINS ( LEFT, TOP, BOTTOM' ) ; WRITELN ( 'N : PAGENUMBERS ( TOP OR BOTTOM OF PAGE ) ' ) ; WRITELN ( 'P : PAPERSIZE ( NUMBER OF LINES )' ) ; WRITELN ( 'S : DOUBLSPACING' ) ; FOR FILLERLINES := 1 TO 5 DO WRITELN ; WRITE ( '( < CR > to continue ) ' ) ; END { HELPCMNDS } ; { * * * * * * * * * * } PROCEDURE HELPDFLTS ; VAR PROMPTER : CHAR ; FILLERLINES : INTEGER ; BEGIN READLN ( KEYBOARD , PROMPTER ) ; PAGE ( OUTPUT ) ; WRITELN ; WRITE ( 'REMEMBER - THE FOLLOWING FUNCTIONS ARE ' ) ; WRITELN ( 'AUTOMATICALLY SET:' ) ; WRITELN ( 'LEFT MARGIN:10' ) ; WRITELN ( 'TOP MARGIN:4' ) ; WRITELN ( 'BOTTOM MARGIN:4' ) ; WRITELN ( 'PAGENUMBERS:YES ( TOP OF PAGE ) ' ) ; WRITELN ( 'PAPERSIZE:66 LINES' ) ; WRITELN ( 'DOUBLESPACES:YES' ) ; FOR FILLERLINES := 1 TO 7 DO WRITELN ; WRITE ( '( < CR > to continue ) ' ) ; READLN ( KEYBOARD , PROMPTER ) ; PAGE ( OUTPUT ) ; END { HELPDFLTS } ; { * * * * * * * * * * } PROCEDURE MARGINS ; VAR MARGINTYPE : CHAR ; BEGIN REPEAT BEGIN WRITE ( 'MARGINS: L(eft, T(op, B(ottom ' ) ; WRITELN ( '( < CR > to leave ) ' ) ; READ ( KEYBOARD , MARGINTYPE ) ; CASE MARGINTYPE OF 'L' : BEGIN WRITE ( 'left margin?' ) ; READLN ( INPUT , LEFTMARGIN ) ; END ; 'T' : BEGIN WRITE ( 'top margin?' ) ; READLN ( INPUT , TOPMARGIN ) ; END ; 'B' : BEGIN WRITE ( 'bottom margin?' ) ; READLN ( INPUT , BOTTOMMARGIN ) ; END ; END { CASE } ; PAGE ( OUTPUT ) ; END { REPEAT } ; UNTIL MARGINTYPE = ' ' ; END { MARGINS } ; { * * * * * * * * * * } PROCEDURE HELPMARGINS ; BEGIN IF COMMAND = 'M' THEN MARGINS ELSE BEGIN HELPINSTR ; HELPCMNDS ; HELPDFLTS ; END { IF } ; END { HELPMARGINS } ; { * * * * * * * * * * } PROCEDURE READFILENAME ; VAR COUNTER : INTEGER ; STILLREADING : BOOLEAN ; BEGIN GOTFILES := TRUE ; COUNTER := 1 ; STILLREADING := TRUE ; WHILE ( COUNTER < 10 ) AND ( STILLREADING = TRUE ) DO BEGIN WRITE ( 'FILENAME / CR : ' ) ; READLN ( FILENAME ) ; IF FILENAME <> '' THEN BEGIN FILES [ COUNTER ] := FILENAME ; NUMFILES := COUNTER ; COUNTER := COUNTER + 1 ; END { IF } ELSE STILLREADING := FALSE ; END { WHILE } ; END { READFILENAME } ; { * * * * * * * * * * } PROCEDURE CARRYOUT ; VAR NEWDATE , NEWFILE : STRING ; PROMPTER : CHAR ; LIST : INTEGER ; BEGIN CASE COMMAND OF 'D' : BEGIN WRITE ( 'date today?' ) ; READLN ( NEWDATE ) ; IF NEWDATE <> '' THEN DATE := NEWDATE ; END ; 'F' : READFILENAME ; 'H' : HELPMARGINS ; 'L' : BEGIN WRITELN ( '( < CR > to continue ) ' ) ; FOR LIST := 1 TO NUMFILES DO WRITELN ( FILES [ LIST ] ) ; READ ( KEYBOARD , PROMPTER ) ; END ; 'M' : HELPMARGINS ; 'N' : REPEAT BEGIN PAGE ( OUTPUT ) ; WRITE ( 'do you want pagenumbers?' ) ; READ ( KEYBOARD , NUMBERS ) ; PAGE ( OUTPUT ) ; IF NUMBERS = 'Y' THEN BEGIN WRITE ( 'T(op or B(ottom?' ) ; READ ( KEYBOARD , TOPORBOTTOM ) ; END END ; UNTIL ( NUMBERS = 'Y' ) OR ( NUMBERS = 'N' ) ; 'P' : BEGIN WRITE ( 'what is your papersize? ' ) ; READLN ( INPUT , PAPERSIZE ) ; END ; 'S' : REPEAT BEGIN PAGE ( OUTPUT ) ; WRITE ( 'do you want doublespaces?' ) ; READ ( KEYBOARD , DOUBLESPACE ) ; END ; UNTIL ( DOUBLESPACE = 'Y' ) OR ( DOUBLESPACE = 'N' ) ; END { CASE } ; END { CARRYOUT } ; { * * * * * * * * * * } PROCEDURE SETVARS ; VAR NUMSETS : INTEGER ; BEGIN GOTFILES := FALSE ; LEFTMARGIN := 10 ; TOPMARGIN := 4 ; BOTTOMMARGIN := 4 ; NUMBERS := 'Y' ; DOUBLESPACE := 'N' ; PAPERSIZE := 66 ; DATE := ' ' ; TOPORBOTTOM := 'T' ; NUMFILES := 0 ; FOR NUMSETS := 1 TO 9 DO FILES [ NUMSETS ] := ' ' ; END ; { * * * * * * * * * * } PROCEDURE INITIALIZE ; VAR TORB : STRING ; INTROSPACES : INTEGER ; DELAY , DELAYARG : INTEGER ; ASTERISKS : INTEGER ; BEGIN PAGE ( OUTPUT ) ; FOR INTROSPACES := 1 TO 4 DO WRITELN ; FOR ASTERISKS := 1 TO 63 DO WRITE ( '*' ) ; WRITELN ; WRITELN ; WRITELN ( ' WELCOME TO WRITER VER.I.' ) ; WRITELN ; FOR ASTERISKS := 1 TO 63 DO WRITE ( '*' ) ; FOR DELAY := 1 TO 2000 DO BEGIN DELAYARG := 0 ; DELAYARG := DELAYARG + 1 ; END ; SETVARS ; PAGE ( OUTPUT ) ; REPEAT WRITE ( 'WRITER: D(ate, F(ilename, H(elp, ' ) ; WRITELN ( 'L(ist, M(argins, N(umbers, ' ) ; WRITELN ( 'P(apersize, S(pacing ( < CR > to leave )' ) ; { DATE, FILENAME, HELP, LIST, MARGINS, NUMBERS, PAPERSIZE, SPACING } WRITELN ; IF TOPORBOTTOM = 'T' THEN TORB := 'TOP' ELSE TORB := 'BOTTOM' ; WRITELN ( 'number of files:' , NUMFILES ) ; WRITELN ( 'date:' , DATE ) ; WRITELN ( 'left margin:' , LEFTMARGIN ) ; WRITELN ( 'top margin:' , TOPMARGIN ) ; WRITELN ( 'bottom margin:' , BOTTOMMARGIN ) ; WRITELN ( 'doublespaces:' , DOUBLESPACE ) ; WRITE ( 'pagenumbers:' , NUMBERS ) ; IF NUMBERS = 'Y' THEN WRITELN ( ' ( ' , TORB , ' OF PAGE )' ) ELSE WRITELN ; WRITELN ( 'papersize:' , PAPERSIZE ) ; READ ( KEYBOARD , COMMAND ) ; PAGE ( OUTPUT ) ; CARRYOUT ; PAGE ( OUTPUT ) ; UNTIL COMMAND = ' ' ; IF TOPORBOTTOM = 'T' THEN ENDLINES := BOTTOMMARGIN ELSE ENDLINES := BOTTOMMARGIN + 3 ; END { INITIALIZE } ; { * * * * * * * * * * } BEGIN INITIALIZE ; IF GOTFILES = FALSE THEN READFILENAME ; FOR NUMPRINTS := 1 TO NUMFILES DO WRTPAGE ( FILES [ NUMPRINTS ] ) ; END. ======================================================================================== DOCUMENT :usus Folder:VOLUK03:ada.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOLUK03:ada.text ======================================================================================== (*$L PRINTER:*) (*$S+*) {$G+} program asc; USES (*$U FILECHECK.CODE*) FILECHECK; {$I #5:types.text} procedure er_error_message (error_number : er_errornumber_range; error_type : er_error_type; error_position : so_position; error_symbol : lu_sym_descriptor); forward; (* SPECIFIES AN ERROR MESSAGE*) function er_num_of_errors : integer; forward; (* RETURNS THE ACTUAL NUMBER OF ERRORS*) function er_number_of_warnings : integer; forward; (* RETURNS THE ACTUAL NUMBER OF WARNINGS*) procedure er_init; forward; (* TO INITIALIZE THE COUNTERS*) (*END ERROR_MESSAGE_HANDLER;*) procedure co_int_to_string (int : integer; base : co_base_type; leading0 : boolean; last_char : integer; var str : string); forward; (* INT IS CONVERTED TO STRING REPRESENTATION TO BASE BASE*) (* IT IS IN STR(STR'FIRST..LAST_CHAR) WITH LEADING ZEROS OR*) (* BLANKS (LEADING0). IF IT DOES NOT FIT IT IS LEFT TRUNCATED.*) (* IF INT<0, THEN "-" IS IN FRONT OF THE DIGITS*) procedure co_its_left (int : integer; base : co_base_type; var outp_last_char : integer; var str : string); forward; (* INT IS CONVERTED TO STRING REPRESENTATION TO BASE BASE.*) (* THE DIGITS ARE LEFT ADJUSTED IN STR(STR'FIRST..LAST_CHAR)*) (* IF INT<0 THEN "-" IS IN FRONT OF THE DIGITS.*) (* ONLY NECESSARY PART OF STR IS USED*) procedure co_string_to_int (buffer : string; firstc, lastc : integer; base : integer; var outp_too_large : boolean; var outp_int : integer); forward; (* THE DIGITS] IN BUFFER(FIRSTC..LASTC) ARE CONVERTED TO*) (* BINARY VALUE WITH BASE BASE. TOO_LARGE INDICATES WHETHER AN*) (* OVERFLOW HAS OCCURED; THEN INT=MAX_INT.*) (* IN EVERY CASE ALL DIGITS ARE TESTED, THAT THEY ARE CORRECT.*) (* LASTC < FIRSTC IS ALLOWED, THEN INT=0.*) (*END CONVERSION;*) procedure st_init; forward; (* INITIALIZATION: MUST BE CALLED BEFORE USE*) (* SETS THE SYMBOL TABLE EMPTY. CAN BE CALLED AT EVERY STAGE.*) (*---------------------------------------------------------------*) (* CODING: STRING --> ST_SYMBOL*) (*---------------------------------------------------------------*) function st_get_sub_code (str : string; firstc, lastc : integer; enter : boolean) : st_symbol; forward; (* IF SYMBOL STR(FIRSTC..LASTC) IS ALREADY ENTERED THEN*) (* RETURN ITS CODE*) (* ELSIF ENTER THEN INSERT STR(FIRSTC..LASTC)*) (* ELSE RETURN ST_NIL*) function st_get_code (str : st_literal; l : integer) : st_symbol; forward; (* ST_GET_SUB_CODE( STR, STR'FIRST, STR'LAST, TRUE);*) function st_get_char_code (chr : char) : st_symbol; forward; (* ST_GET_CODE( (1=> CHR)); NO 1-CHARACTER STRINGS*) (*---------------------------------------------------------------*) (* RECODING: ST_SYMBOL --> STRING*) (*---------------------------------------------------------------*) procedure st_get_string (code : st_symbol; var str : string; var outp_last_char : integer); forward; (* RETURN STR(STR'FIRST .. OUTP_LAST_CHAR) OF SYMBOL "CODE"*) (*END SYMBOL_TABLE;*) (* procedure lu_init; forward; ---> removed since segment procedure *) (*---------------------------------------------------------------*) (* LEXICAL UNITS FOR ERROR HANDLING*) (*---------------------------------------------------------------*) (* procedure lu_error_symbol (lex_unit : lu_lexical_unit;*) (* var result : lu_sym_descriptor);*) (* forward; MADE INTO SEG PROCEDURE *) (*---------------------------------------------------------------*) (* LEXICAL UNITS AS STRINGS*) (*---------------------------------------------------------------*) procedure lu_str_of (symbol : lu_sym_descriptor; var str : string; var outp_last_char : integer); (* RETURNS THE STRING REPRESENTATION*) forward; (*END LEXICAL_UNITS;*) (* procedure la_init; forward; ----> removed since segment procedure *) (* INITIALIZATION: MUST BE CALLED BEFORE LA_NEXT_SYM*) procedure la_next_sym (var outp_sym : lu_sym_descriptor; var outp_pos : so_position); forward; (* DELIVERS IN OUTP_SYMBOL THE NEXT LEXICAL UNIT*) (* OUTP_POS IS THE POSITION OF THE FIRST CHARACTER OF THE UNIT*) (*END LEXICAL_ANALYZER;*) {$I #5:luerror.text} {$I #5:luinit.text} {$I #5:lainit.text} {$I #5:parser.text} {$I #5:coint.text} {$I #5:stget.text} {$I #5:lanext.text} procedure so_init; begin so_nil_position.sourceline := 0; so_nil_position.column := 1; end; procedure st_init ; (*-------------------------------------------------------------------*) (* -*) (* DESCRIPTION: SYMTAB_ENTRIES ARE DELETED. SYMTAB_STRINGS IS SET-*) (* ------------ TO STB_EMPTY. ST_NIL BECOMES "". -*) (* -*) (*-------------------------------------------------------------------*) var loop_i : st_symbol; begin for loop_i := 1 to st_sym_ubound do stb_s_tab_entries [loop_i].textb := stb_empty; (*END LOOP;*) stb_number_char := stb_empty; stb_texttable_full := false; stb_hashtable_full := false; stb_s_tab_entries [st_nil] := stb_s_tab_entries [ st_get_code (' ',7)]; end; (*ST_INIT;*) (*-------------------------------------------------------------------*) procedure lu_str_of; (* (SYMBOL : LU_SYMBOL_DESCRIPTOR; VAR STR : STRING; VAR OUTP_LAST_CHAR : INTEGER); *) (*-------------------------------------------------------------------*) (* -*) (* DESCRIPTION: RETURNS THE EXTERNAL STRING OF THE LEXICAL UNIT -*) (* ------------ -*) (*-------------------------------------------------------------------*) VAR DISCRIM : LU_SELECTOR; SHIFT : INTEGER; I, J, K, L : INTEGER; BEGIN DISCRIM :=SYMBOL.DISCRIM; CASE DISCRIM OF LU_ID : BEGIN ST_GET_STRING (SYMBOL.IDCODE, STR, L); IF SYMBOL.SYM = LU_CHARACTER_SYM THEN BEGIN STR [SFIRST + 1] := STR[SFIRST]; STR [SFIRST] := ''''; STR [SFIRST + 2] := ''''; OUTP_LAST_CHAR := SFIRST + 2; END ELSE IF SYMBOL.SYM = LU_STRING_SYM THEN BEGIN SHIFT := 1; FOR I := L DOWNTO SFIRST DO BEGIN STR [I + 1] := STR[I]; IF STR[I] = '"' THEN BEGIN FOR J:= L + SHIFT DOWNTO I + 2 DO STR[J+1] := STR[J]; STR[I+2] := '"'; SHIFT :=SHIFT + 1; END; END;(*LOOP*) STR[SFIRST] := '"'; OUT_PLAST_CHAR := L + SHIFT + 1; STR[OUTP_LAST_CHAR] := '"'; END ELSE OUTP_LAST_CHAR := L; END; lu_int : begin str [sfirst] := '0'; outp_last_char := sfirst; end; lu_real : begin str [sfirst] := '0'; str [sfirst+1] := '.'; str [sfirst+2] := '0'; outp_last_char := sfirst+2; end; lu_other : begin outp_last_char := sfirst + 1; case symbol.sym of lu_dot_sym : begin str [sfirst] := '.'; outp_last_char := sfirst; end; lu_interval_sym : begin str [sfirst] := '.'; str [sfirst + 1] := '.'; end; lu_left_label_sym : begin str [sfirst] := '<'; str [sfirst + 1] := '<'; end; lu_box_sym : begin str [sfirst] := '<'; str [sfirst + 1] := '>'; end; lu_lpar_sym : begin str [sfirst] := '('; outp_last_char := sfirst; end; lu_separator_sym : begin str [sfirst] := '!'; outp_last_char := sfirst; end; lu_rpar_sym : begin str [sfirst] := ')'; outp_last_char := sfirst; end; lu_semicolon_sym : begin str [sfirst] := ';'; outp_last_char := sfirst; end; lu_comma_sym : begin str [sfirst] := ','; outp_last_char := sfirst; end; lu_right_label_sym : begin str [sfirst] := '>'; str [sfirst + 1] := '>'; end; lu_colon_sym : begin str [sfirst] := ':'; outp_last_char := sfirst; end; lu_assign_sym : begin str [sfirst] := ':'; str [sfirst + 1] := '='; end; lu_quote_sym : begin str [sfirst] := ''''; outp_last_char := sfirst; end; lu_arrow_sym : begin str [sfirst] := '='; str [sfirst + 1] := '>'; end; lu_identifier_sym , lu_integer_sym , lu_real_sym , lu_character_sym , lu_string_sym, lu_eof_sym , lu_abort_sym , lu_accept_sym, lu_access_sym, lu_all_sym , lu_and_sym , lu_array_sym , lu_at_sym , lu_begin_sym , lu_body_sym , lu_case_sym , lu_constant_sym , lu_declare_sym , lu_delay_sym , lu_delta_sym , lu_digits_sym, lu_do_sym , lu_else_sym , lu_elsif_sym , lu_end_sym , lu_entry_sym , lu_exception_sym , lu_exit_sym , lu_for_sym , lu_function_sym , lu_generic_sym , lu_goto_sym , lu_if_sym , lu_in_sym , lu_is_sym , lu_limited_sym , lu_loop_sym , lu_mod_sym , lu_new_sym , lu_not_sym , lu_null_sym , lu_of_sym , lu_or_sym , lu_others_sym, lu_out_sym , lu_package_sym , lu_pragma_sym, lu_private_sym , lu_procedure_sym , lu_raise_sym , lu_range_sym , lu_record_sym, lu_rem_sym , lu_renames_sym , lu_return_sym, lu_reverse_sym , lu_salect_sym, lu_seperate_sym , lu_subtype_sym , lu_task_sym , lu_terminate_sym , lu_then_sym , lu_type_sym , lu_use_sym , lu_when_sym , lu_while_sym , lu_with_sym , lu_xor_sym , lu_minus_sym , lu_less_sym , lu_less_equal_sym , lu_plus_sym , lu_catenation_sym , lu_multiply_sym , lu_exponentiation_sym , lu_divide_sym, lu_not_equal_sym , lu_greater_sym , lu_greator_equal_sym , lu_equal_sym : begin str [sfirst] := 'e'; str [sfirst + 1] := 'o'; str [sfirst + 2] := 'f'; outp_last_char := sfirst + 2; end; (*END CASE;*) end; end; (*END CASE;*) end; end; (* LU_STRING_OF;*) (*-------------------------------------------------------------------*) procedure er_init; begin errors_count := 0; warnings_count := 0; error_no := 0; erb_last_pos := so_nil_position; end; (*-------------------------------------------------------------------*) procedure er_error_message;(*(ERROR_NUMBER : ER_ERRORNUMBER_RANGE; ERROR_TYPE : ER_ERROR_TYPE; ERROR_POSITION : SO_POSITION; ERROR_SYMBOL : LU_SYMBOL_DESCRIPTOR);*) (*-------------------------------------------------------------------*) (* DESCRIPTION: PUTS THE MESSAGE DIRECTLY TO THE LISTING. -*) (* ------------ -*) (* ERROR_NO STARTS FROM 0. ERRORS WITH ERROR_TYPE HAVING THE -*) (* VALUE ER_SYMBOL_INSERTED OR ER_RESET_POSITION ARE NOT -*) (* COUNTED AS ERRORS -*) (*-------------------------------------------------------------------*) var str : so_symbol_string; l, i : integer; begin if (error_type <> er_reset_position) or (error_position.sourceline <> erb_last_pos.sourceline) or (error_position.column <> erb_last_pos.column) then begin (* RESET AT SAME POSITION IS IGNORED *) if error_type <> er_sym_inserted then begin if error_type = er_reset_position then l := error_position.column + 3 else l := error_position.column + 4; for i := sfirst to l do write ( '-' ); write ( '!' ); end (*IF*); if error_type = er_syntax_error then begin erb_last_pos := error_position; writeln ('syntax error') end else if error_type = er_sym_inserted then begin (* ONLY MESSAGE ABOUT INSERTED SYMBOL*) write ('symbol inserted: '); lu_str_of (error_symbol, str, l); for i := sfirst to l do write ( str [i]); writeln; end else if error_type = er_reset_position then writeln ('symbols ignored up to here') else if error_number = 1400 then writeln ('symbol table overflow') else if error_number = 1401 then writeln ('text table overflow') else if error_number = 1500 then writeln ('character not allowed here') else if error_number = 1501 then writeln ('(extended) digits expected') else if error_number = 1502 then writeln ('sharp or colon expected') else if error_number = 1503 then writeln ('string must end with line"') else if error_number = 1504 then writeln ('illegal insertion of underscore') else if error_number = 1505 then writeln ('adjacent identifiers/numbers must be separated') else if error_number = 1508 then writeln ( 'base not within 2..16') else if error_number = 1601 then writeln ( 'illegal exponent value') else if error_number = 1509 then writeln ( 'digit too large for base') else if error_number = 5097 then writeln ( 'inconsistent parser tables') else if error_number = 5099 then writeln ( 'parser stack overflow') else writeln ( 'compiler error: unknown error'); end (*IF*); if error_type = er_warning then (* COUNT THE ERRORS*) warnings_count := warnings_count + 1 else if (error_type <> er_sym_inserted) and (error_type <> er_reset_position) then errors_count := errors_count + 1; error_no := error_no + 1; end; (* ER_ERROR_MESSAGE;*) (*-------------------------------------------------------------------*) function er_num_of_errors; (* RETURN INTEGER IS*) begin er_num_of_errors := errors_count; end; (* ER_NUMBER_OF_ERRORS;*) (*-------------------------------------------------------------------*) function er_number_of_warnings; (* RETURN INTEGER IS*) begin er_number_of_warnings := warnings_count; end ; (* ER_NUMBER_OF_WARNINGS;*) (*END ERROR_MESSAGE_HANDLER;*) begin morefiles:=false; repeat write ( '*********************'); write ('*** START ADA SYNTAX CHECKER ***'); writeln ( '********************'); writeln ; writeln ; so_init; er_init; st_init; lu_init; la_init; CHECKINPUTMODE; parser; writeln; writeln; writeln; writeln ( er_num_of_errors:5, ' errors reported.'); writeln; write ( '********************'); write ( '*** END ADA SYNTAX CHECKER ***'); writeln ( '********************'); writeln; writeln; writeln; writeLN('Do you want to check any other Ada Files? --> type Y/N '); repeat read(reply); if reply ='Y' then morefiles:=true else if reply ='N' then morefiles:=false else write('Invalid Reply....Type again --> Y/N '); until reply in ['N','Y']; until MOREFILES=false; end. ======================================================================================== DOCUMENT :usus Folder:VOLUK03:adadoc.text ======================================================================================== DOCUMENTATION FOR THE SYNTAX CHECKER BY EDGAR DE SOUZA SWURCC MICRO UNIT _1. _O_b_j_e_c_t_i_v_e_s SWURCC initially obtained a copy of the Ada Syntax Checker, with the intention that we would distribute the Syntax Checker to the U.K Universities. In our opinion (after several months) we realised that not many micro units in the UK Universities wanted the Syntax Checker in its original form, since it could only run on machines with vast amounts of main memory (i.e mainframes). Therefore it was decided that the Syntax Checker should be modified to run on smaller machines which would be easily accessible to the majority of UK Universities. As the Micro Unit at SWURCC had a Onyx microcomputer running the popular Unix Operating System, we decided on trying to get the Syn- tax Checker running on this machine. When this was achieved, Ali Tabatabai had completed his pro- ject on getting the UCSD Operating System to run on top of the Unix Operating System. Therefore it was agreed that I should try running the Syntax Checker under UCSD with the aim of allowing Universities with their 8 bit micros to use the Checker. On completing this task I transfered the Syntax Checker to the Apple microcomputer thus putting the syntax checker on two five and a quarter inch floppy disks. It was decided that a copy of these floppies should be made avail- able to the USUS library, enabling all UCSD users to have access to this software. 2. The Ada Syntax Checker running under the Unix Operating System on the Onyx Microcomputer. NB- In order to run the checker I had to insure that the parser tables had to be converted from a text file into a file of integer. I did this by writing a short pascal pro- gram named "gendat.text". This program converts 'textdat.text' into 'tabdat.t'. Once the parser tables (i.e. the file tabdat.t) consisting of 19486 numbers was set up I managed to run the program. (Note to run the syntax checker, the file ada.code must be executed). At this stage it must be noted that Ada programs were entered via the keyboard and the checked Ada program with error messages was written to a file. I modified this by redirecting the error messages to the console so one could immediately see the errors as the program was being checked. I then tried running the syntax checker (which was written in standard Pascal) on the UCSD operating system which was running on top of Unix. The firstproblem I encountered was the size of the UCSD stack (64K). It was impossible for the whole syntax checker to be run, but it was possible to run the checker with a bigger stack under Ali's UCSD implementa- tion which had a stack size of 68K. However this did not achieve the objective of running the syntax checker on a standard UCSD machine, although it was useful in the initial stages of modifying the checker for the UCSD system. The way I finally overcame this problem was by setting up seg- ment procedures. Initially I tried cutting down some ineffi- cient text of the program, these changes are as follows: (a) new_symbol in procedure lu_error_symbol (b) new_current_char in procedure la_next_sym etc. Finally I created the following segment procedures: (a) segment procedure parser - which initializes the parser tables and does the actual syntax checking using these parser tables. (b) segment procedure lu_init - which initializes the reserved word table (c) segment procedure la_init - which initializes the character set (d) segment procedure lu_error_symbol - which is used for error output The reason for choosing the above is: (a) I had to choose procedure parser (even though it is heavily used) since it is the biggest procedure and space had to be created to load the next two initializ- ing procedures. (b)+(c) In the case of the init's (la-init and lu_init) they are only used at the beginning for initialisation and never againn. (d) In the case of lu_error_symbol this procedure will only be used if errors are encountered. In order to set up these segments I had to split the file up into logical units in Unix before passing them over to UCSD as the UCSD editor has a maximum limit of about 20K and my program was about 64K. I wrote two simple shell programs which facilitated the import and export of Unix files to and from UCSD. I split the program up into the above segment procedures, as well as the other files listed below: (1) st_get.text (2) la_next.text (3) co_int.text (NB- all these three files are used in the input part of the syntax checker, validating the input and passing it over to the parser). (4) types.text - This file contains all the global declarations of constants, types and varables. On inspection of my program it can be seen that I have included 7 files in the main program entitled "asc" found in the file "ada.text". Each file included in the program has a compiler directive put in front of the filename, which informs the compiler that the source from an external file must be compiled and the code must be added to the code of the program. The compiler directive and the filename must be enclosed within a comment i.e. (*$I filename *). On creating the above segment procedures and using the included files, I managed to run the program on UCSD (which was running on the Onyx). One point to notice is that all the text for the segment procedures must occur before any other text from the program or other ordinary procedures. Also if any ordinary procedures are used by a segment pro- cedure the ordinary procedure must be declared FORWARD. _4. _T_h_e _A_d_a _S_y_n_t_a_x _C_h_e_c_k_e_r _r_u_n_n_i_n_g _u_n_d_e_r _U_C_S_D _o_n _t_h_e _A_p_p_l_e _M_i_c_r_o_c_o_m_p_u_t_e_r My final goal was to transport this program over to the Apple running UCSD Version 2.1. I managed to get the syntax checker over after several file transfers. I then modified the checker to accept more than one file of input, (via the keyboard only) thus avoiding the overhead of loading the parser tables each time a program was checked. I then included a printer unit named filecheck which allowed input from a file possible as well as input from the termi- nal. In order to achieve this last goal (usually a simple task in 'UCSD' Pascal). I had to create a unit 'Filecheck.text' The reason being is that I needed to use the UCSD 'string' intrinsic which in the program was defined as a packed array of char in standard Pascal. With the presence of the unit filecheck in the Ada syntax checker, the unit must now be compiled and the code linked to the code of the main program. The checker running under UCSD successfully checks the test Ada program named "adatest.text" which contains all the con- structs of the Ada language. This program is part of the original distribution. If the checker is working properly no errors should be found. I have also checked another short Ada program of my own, it is entitled "dial.text". One final point to note under the present UCSD version of the checker is that the end of file (eof) character is the '$', this can be changed to suit your system. Also when typ- ing in from the keybaord the '$' character must be typed in after the Ada program is typed in. ======================================================================================== DOCUMENT :usus Folder:VOLUK03:adatest.text ======================================================================================== 1 ) , 1 ) * ( 1 in ID ( 1 .. 1 => 1 ) , 1 ) ** ( 1 and 1 and 1 , 1 ) ) ; use ID ( ID ' ( 1 , 1 ) ) ( 1 or 1 or 1 , ID ( 1 xor 1 xor 1 ) range ( 1 and then 1 and then 1 , 1 ) + ( 1 or else 1 or else 1 , 1 ) * 1 .. 1 => 1 ) ; procedure ID is ID : ID ; for ID use 1 ; procedure ID ( ID : ID ) is begin null ; end ; generic package ID is ID : constant ID ; use ID ; ID : constant array ( ID range <> ) of ID := 1 ; end ; begin accept ID ; << ID >> if 1 then pragma ID ; ID := 1 ; elsif 1 then exit ; return ; end if ; exception when ID => return 1 ; goto ID ; end ID ; pragma ID ( 1 , 1 ) ; procedure ID ; pragma ID ( ID => 1 ) ; procedure ID ; package ID is end ; package body ID is end ; separate ( ID ) package body ID is end ; generic procedure ID ; procedure ID is new ID ; function ID is new ID ; function ID return ID ; procedure ID ( ID : ID ) ; procedure ID ( ID : ID ; ID : ID ) ; procedure ID ( ID , ID : ID ) ; procedure ID ( ID : in ID ) ; procedure ID ( ID : out ID ) ; procedure ID ( ID : in out ID ) ; procedure ID ( ID , ID , ID : ID ) ; function "**" return ID ; generic ID : ID ; procedure ID ; generic type ID is private ; procedure ID ; generic with procedure ID ; procedure ID ; generic with procedure ID is ID ; procedure ID ; generic with procedure ID is <> ; procedure ID ; generic type ID ( ID : ID ) is private ; procedure ID ; generic type ID ( ID : ID ; ID : ID ) is private ; procedure ID ; generic type ID ( ID , ID : ID ) is private ; procedure ID ; generic type ID is ( <> ) ; procedure ID ; generic type ID is range <> ; procedure ID ; generic type ID is delta <> ; procedure ID ; generic type ID is digits <> ; procedure ID ; generic type ID is array ( ID ) of ID ; procedure ID ; generic type ID is access ID ; procedure ID ; generic type ID is array ( ID range <> , ID range <> ) of ID ; procedure ID ; generic type ID is array ( ID , ID ) of ID ; procedure ID ; generic type ID is array ( 1 .. 1 ) of ID ; procedure ID ; generic type ID is limited private ; procedure ID ; generic with function ID return ID is ID ; procedure ID ; procedure ID is for ID use 1 ; begin null ; end ; procedure ID is procedure ID is separate ; begin null ; end ; procedure ID is ID , ID : constant ID ; begin null ; end ; procedure ID is ID , ID : constant array ( ID ) of ID ; begin null ; end ; procedure ID is ID : constant := 1 ; begin null ; end ; procedure ID is ID , ID : constant := 1 ; begin null ; end ; procedure ID is type ID is private ; begin null ; end ; procedure ID is type ID ; begin null ; end ; procedure ID is subtype ID is ID ; begin null ; end ; procedure ID is procedure ID ; begin null ; end ; procedure ID is package ID is end ; begin null ; end ; procedure ID is task ID ; begin null ; end ; procedure ID is ID : exception ; begin null ; end ; procedure ID is ID , ID : exception ; begin null ; end ; procedure ID is ID : ID renames ID ; begin null ; end ; procedure ID is ID : exception renames ID ; begin null ; end ; procedure ID is package ID renames ID ; begin null ; end ; procedure ID is task ID renames ID ; begin null ; end ; procedure ID is procedure ID renames ID ; begin null ; end ; procedure ID is pragma ID ; begin null ; end ; procedure ID is ID : array ( ID ) of ID ; begin null ; end ; procedure ID is ID , ID : array ( ID ) of ID ; begin null ; end ; procedure ID is type ID is ( ID ) ; begin null ; end ; procedure ID is type ID is range 1 .. 1 ; begin null ; end ; procedure ID is type ID is digits 1 ; begin null ; end ; procedure ID is type ID is array ( ID ) of ID ; begin null ; end ; procedure ID is type ID is record end record ; begin null ; end ; procedure ID is type ID is access ID ; begin null ; end ; procedure ID is type ID is new ID ; begin null ; end ; procedure ID is type ID is ( ID , ID ) ; begin null ; end ; procedure ID is type ID is ( 'A' ) ; begin null ; end ; procedure ID is type ID is record null ; end record ; begin null ; end ; procedure ID is type ID is record ID : ID ; end record ; begin null ; end ; procedure ID is type ID is record case ID is end case ; end record ; begin null ; end ; procedure ID is type ID is record case ID is when 1 => end case ; end record ; begin null ; end ; procedure ID is package ID is new ID ; begin null ; end ; procedure ID is package ID is private end ; begin null ; end ; procedure ID is package ID is private for ID use 1 ; end ; begin null ; end ; procedure ID is package ID is private for ID use record end record ; end ; begin null ; end ; procedure ID is package ID is private for ID use at 1 ; end ; begin null ; end ; procedure ID is package ID is private for ID use record at mod 1 ; end record ; end ; begin null ; end ; procedure ID is package ID is private for ID use record ID at 1 range 1 .. 1 ; end record ; end ; begin null ; end ; procedure ID is package ID is private for ID use 1 ; pragma ID ; end ; begin null ; end ; procedure ID is package ID is private for ID use 1 ; for ID use 1 ; end ; begin null ; end ; procedure ID is package ID is end ID ; begin null ; end ; procedure ID is task type ID ; begin null ; end ; procedure ID is task ID is end ; begin null ; end ; procedure ID is task ID is entry ID ; end ; begin null ; end ; procedure ID is task ID is entry ID ( ID ) ; end ; begin null ; end ; procedure ID is for ID use 1 ; task ID ; begin null ; end ; procedure ID is for ID use 1 ; procedure ID is separate ; begin null ; end ; procedure ID is for ID use 1 ; task body ID is begin null ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin null ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin delay 1 ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin abort ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin raise ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin ID ' ( 1 ) ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin exit ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin exit when 1 ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin case 1 is end case ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin loop null ; end loop ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin ID : loop null ; end loop ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin begin null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin ID : begin null ; end ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select terminate ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select ID ; else null ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select ID ; or delay 1 ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin if 1 then null ; else null ; end if ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin case 1 is when 1 => null ; end case ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin for ID in ID loop null ; end loop ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin for ID in reverse ID loop null ; end loop ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin while 1 loop null ; end loop ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin declare begin null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin begin null ; exception when ID ! ID => null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin begin null ; exception when others => null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept ID do null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept "**" ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept ID . ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept ID . "**" ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept ID ( 1 ) ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select when 1 => terminate ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select accept ID ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select delay 1 ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select accept ID ; null ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select terminate ; or terminate ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is separate ; begin null ; end ; procedure ID is for ID use 1 ; task body ID is separate ; begin null ; end ; procedure ID is for ID use 1 ; task ID ; pragma ID ; begin null ; end ; procedure ID is package body ID is end ; begin null ; end ; ======================================================================================== DOCUMENT :usus Folder:VOLUK03:coint.text ======================================================================================== procedure co_int_to_string;(* (INT : INTEGER; BASE : CO_BASE_TYPE; LEADING0 : BOOLEAN; LAST_CHAR : INTEGER; VAR STR : STRING); *) (*-------------------------------------------------------------------*) (* -*) (* INT IS CONVERTED TO STRING REPRESENTATION TO BASE BASE -*) (* IT IS IN STR(STR'FIRST..LAST_CHAR) WITH LEADING ZEROS OR -*) (* BLANKS (LEADING0). IF IT DOES NOT FIT IT IS LEFT TRUNCATED. -*) (* IF INT<0 THEN "-" IS IN FRONT OF THE DIGITS. -*) (* -*) (*-------------------------------------------------------------------*) label 1701; var int1 : integer; digit, i : integer; c : char; minus : boolean; loop_j : integer; begin (* CO_INT_TO_STRING*) int1 := int; minus := false; if int1 < 0 then minus :=true; (*END IF;*) i := last_char; repeat digit := int1 mod base; if digit < 0 then digit := - digit; (*END IF;*) if(0 <= digit)and(digit <= 9)then str [i] := chr (digit + ord ('0')) else str [i] := chr (digit - 10 + ord ('A')); (*END IF;*) int1 := int1 div base; i := i - 1; if (i < sfirst)or(int1 = 0) then goto 1701; until false; 1701 : if i >= sfirst then begin if leading0 then c := '0' else c := ' '; (*END IF;*) if minus then begin str [i] := '-'; i := i - 1; end; (*END IF;*) for loop_j := sfirst to i do str [loop_j] := c; end (*END LOOP;*) (*END IF;*) end; (* CO_INT_TO_STRING;*) (*-------------------------------------------------------------------*) procedure co_its_left; (* (INT : INTEGER; BASE : CO_BASE_TYPE; VAR OUTP_LAST_CHAR : INTEGER; VAR STR : STRING); *) (*-------------------------------------------------------------------*) (* -*) (* INT IS CONVERTED TO STRING REPRESENTATION TO BASE BASE. -*) (* THE DIGITS ARE LEFT ADJUSTED IN STR(STR'FIRST..LAST_CHAR) -*) (* IF INT<0 THEN "-" IS IN FRONT OF THE DIGITS. -*) (* ONLY NECESSARY PART OF STR IS USED -*) (* -*) (*-------------------------------------------------------------------*) label 1702; var int1 : integer; begin (* CO_ITS_LEFT*) int1 := int; (* COMPUTE NUMBER OF DIGITS*) if int1 < 0 then outp_last_char := sfirst + 1 else outp_last_char := sfirst; (*END IF;*) repeat int1 := int1 div base; if int1 = 0 then goto 1702; outp_last_char := outp_last_char + 1; until false; 1702 : (* CALL CO_INT_TO_STRING*) co_int_to_string (int, base, false, outp_last_char, str); end; (* CO_ITS_LEFT;*) (*-------------------------------------------------------------------*) procedure co_string_to_int; (* (BUFFER : STRING; FIRSTC, LASTC : INTEGER; BASE : INTEGER; VAR OUTP_TOO_LARGE : BOOLEAN; VAR OUTP_INT : INTEGER); *) (*-------------------------------------------------------------------*) (* THE DIGITS] IN BUFFER(FIRSTC..LASTC) ARE CONVERTED TO -*) (* BINARY VALUE WITH BASE BASE. TOO_LARGE INDICATES WHETHER AN -*) (* OVERFLOW HAS OCCURED; THEN INT=MAX_INT. -*) (* LASTC < FIRSTC IS ALLOWED, THEN INT=0. -*) (* -*) (*-------------------------------------------------------------------*) label 1703; var digit : integer; err : boolean; loop_i : integer; begin (* CO_STRING_TO_INT*) err := false; outp_int := 0; outp_too_large := false; for loop_i := firstc to lastc do begin case buffer [loop_i] of '0' , '1' , '2' , '3' , '4' , '5' , '6' , '7' , '8' , '9' : digit := ord (buffer [loop_i]) - ord ('0'); 'A' , 'B' , 'C' , 'D' , 'E' , 'F' : digit := ord (buffer [loop_i]) - ord ('A') + 10; 'G' , 'H' , 'I' , 'J' , 'K' , 'L' , 'M' , 'N' , 'O' , 'P' , 'Q' , 'R' , 'S' , 'T' , 'U' , 'V' , 'W' , 'X' , 'Y' , 'Z' : err :=true; end; (* CASE;*) if err or (digit >= base) then begin er_error_message (1700, er_compiler_error, so_nil_position, lu_no_symbol ); goto 1703; end; (*END IF;*) if outp_int >((max_int - digit) div base)then begin outp_too_large :=true; outp_int := max_int; end else outp_int := outp_int * base + digit; (*END IF;*) end; (*END LOOP;*) 1703 : end; (* CO_STRING_TO_INT;*) (*-------------------------------------------------------------------*) (*END CONVERSION; *) ======================================================================================== DOCUMENT :usus Folder:VOLUK03:contents.text ======================================================================================== USUS(UK) SOFTWARE LIBRARY VOLUME 3 25th August 1982 Contents of this volume Edgar De Souza, SWURCC ____________________________________________________ Ada Syntax checker The files on the disk are the following: COINT.TEXT 14 27-Jan-82 STGET.TEXT 12 27-Jan-82 LUERROR.TEXT 14 27-Jan-82 LAINIT.TEXT 8 27-Jan-82 LUINIT.TEXT 16 27-Jan-82 PARSER.TEXT 40 14-May-82 TYPES.TEXT 18 14-May-82 LANEXT.TEXT 40 14-May-82 ADA.TEXT 34 14-May-82 FILECHECK.TEXT 4 20-May-82 ADADOC.TEXT 20 14-May-82 ADATEST.TEXT 26 14-May-82 CONTENTS.TEXT 4 25-Aug-82 TEXTDAT.TEXT 142 27-Jan-82 DIAL.TEXT 2 14-May-82 ADA.CODE 33 20-May-82 GENDAT.TEXT 4 14-May-82 GENDAT.CODE 2 14-May-82 IN ORDER TO RUN THE CHECKER PLACE UKVOL3 IN DRIVE 5, AND EXECUTE THE CODE FILE ADA.CODE. DOCUMENTATION FOR THIS PROGRAM IS ADADOC.TEXT ======================================================================================== DOCUMENT :usus Folder:VOLUK03:filecheck.text ======================================================================================== UNIT FILECHECK; INTERFACE VAR FILEIN:TEXT; FILEINPUT:BOOLEAN; PROCEDURE CHECKINPUTMODE; IMPLEMENTATION PROCEDURE CHECKINPUTMODE; VAR INFILE:STRING; ERROR:INTEGER; MODE:CHAR; BEGIN WRITE('DO YOU WANT TO INPUT FROM A F)ILE OR K)EYBOARD-->TYPE F/K '); REPEAT READ(MODE); WRITELN; IF MODE = 'F' THEN BEGIN WRITELN('ENTER FILENAME'); REPEAT READLN(INFILE); (*$I- *) RESET(FILEIN,INFILE); (*$I+ *) ERROR:=IORESULT; IF ERROR <> 0 THEN WRITELN('ERROR IN FILENAME-->TYPE AGAIN'); UNTIL ERROR=0; FILEINPUT:=TRUE; END ELSE IF MODE = 'K' THEN FILEINPUT:=FALSE ELSE WRITELN('FILE NOT FOUND--> TYPE AGAIN F/K '); UNTIL MODE IN ['F','K']; WRITELN; WRITELN; WRITELN; END; END. ======================================================================================== DOCUMENT :usus Folder:VOLUK03:gendat.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOLUK03:gendat.text ======================================================================================== PROGRAM GENDAT; VAR I:INTEGER; TABDAT:FILE OF INTEGER; TEXTDAT:TEXT; BEGIN WRITELN('START TABDAT GENERATION'); REWRITE(TABDAT,'#5:TABDAT.T'); RESET(TEXTDAT,'#5:TEXTDAT.TEXT'); I:=0; READ(TEXTDAT,TABDAT^); WHILE NOT EOF(TEXTDAT) DO BEGIN I:=SUCC(I); PUT(TABDAT); READ(TEXTDAT,TABDAT^); END; WRITELN; CLOSE(TABDAT,LOCK); WRITELN('END TABDAT GENERATION'); WRITELN('THERE ARE ', I , ' NUMBERS GENERATED'); END. ======================================================================================== DOCUMENT :usus Folder:VOLUK03:lainit.text ======================================================================================== (*END LEXICAL_UNITS;*) segment procedure la_init; (*------------------------------------------------------------------*) (* -*) (* DESCRIPTION: INITIALIZATION OF BUFFER -*) (* ------------ -*) (* -*) (* SPECIALITIES: MUST BE CALLED BEFORE FIRST CALL OF LA_NEXT_SYM -*) (* ------------- -*) (*------------------------------------------------------------------*) const smallest_char_num = 0; (*ADJUST*) biggest_char_num = 255; (*ADJUST*) var loop_i , chr_type : char; begin (* LA_INIT*) (* CHAR_TYPE_TABLE INIT*) for loop_i := chr(smallest_char_num) to chr(biggest_char_num) do char_type_table [loop_i] := non_ada; for chr_type := 'A' to 'F' do char_type_table [chr_type] := letter_a_f; for chr_type := 'G' to 'Z' do char_type_table [chr_type] := letter_g_z; for chr_type := 'a' to 'z' do char_type_table [chr_type] := low_letter; for chr_type := '0' to '9' do char_type_table [chr_type] := digit; char_type_table [eof_char] := eofc; char_type_table [chr (cr) ] := nwline; char_type_table [chr (lf) ] := nwline; char_type_table [chr (vt) ] := nwline; char_type_table [chr (ff) ] := nwline; char_type_table [chr (nul)] := ignore; char_type_table [chr (del)] := ignore; char_type_table [chr (ht) ] := htab; char_type_table ['''']:= quote; char_type_table ['"'] := dquote; char_type_table ['%'] := dquote; char_type_table ['-'] := hyphen; char_type_table ['&'] := ampersand; char_type_table ['('] := lpar; char_type_table [')'] := rpar; char_type_table ['*'] := asterisk; char_type_table ['+'] := plus; char_type_table [','] := comma; char_type_table ['.'] := point; char_type_table ['/'] := slash; char_type_table [':'] := colon; char_type_table [';'] := semicolon; char_type_table ['<'] := langle; char_type_table ['='] := equal; char_type_table ['>'] := rangle; char_type_table ['|'] := vbar; char_type_table ['!'] := vbar; char_type_table ['_'] := underscore; char_type_table [' '] := blank; char_type_table ['#'] := other_graphics; char_type_table ['?'] := other_graphics; char_type_table ['@'] := other_graphics; char_type_table ['['] := other_graphics; char_type_table [']'] := other_graphics; char_type_table ['~'] := other_graphics; char_type_table ['|'] := other_graphics; char_type_table ['['] := other_graphics; (* BUFFER INITIALIZATION*) line_no := 0; current := sfirst; last_char := current; current_char := chr (cr) ; buffer [current] := chr (cr) ; buffer [current + 1] := chr (cr); lu_error_symbol (lu_eof_sym, last_symbol); last_pos := so_nil_position; end; (*LA_INIT*) ======================================================================================== DOCUMENT :usus Folder:VOLUK03:lanext.text ======================================================================================== (*------------------------------------------------------------------*) procedure la_next_sym; (*(VAR OUTP_SYMBOL : LU_SYMBOL_DESCRIPTOR;*) (* VAR OUTP_POS : SO_POSITION);*) (*------------------------------------------------------------------*) (* OUTP_SYMBOL : NEXT LEXICAL UNIT -*) (* OUTP_POS : POSITION OF THE FIRST CHARACTER OF THE UNIT -*) (* EXTRACTS THE NEXT LEXICAL ELEMENT AND ENTERS IT IN THE -*) (* CORRESPONDING TABLE. -*) (* -*) (* SPECIALITIES: ENTRY/EXIT INVARIANT: CURRENT IS NEXT CHARACTER -*) (* ------------- (SEE ALSO BUFFER) -*) (*------------------------------------------------------------------*) label 88, 66, 55, 11; var sharp_char, string_bracket : char; current_type : character_type; uflag, error : boolean; firstc, pos1, pos2, pos3, exp_last : so_sorcecolumn_range; base : integer; exp_positive : boolean; i_code : st_symbol; hstr : so_sorce_string; error_pos : so_position; procedure new_current_char; begin current := succ(current); current_char := buffer [current]; end; procedure new_sym (new_discrim : lu_selector; new_symbol : lu_lexical_unit; new_idcode : st_symbol); begin outp_sym.discrim := new_discrim; outp_sym.sym := new_symbol; outp_sym.idcode := new_idcode; end; procedure sequence (sbase : integer; start_shift : so_sorcecolumn_range; var outp_shiftp : so_sorcecolumn_range); (* SCANS A SEQUENCE OF (EXTENDED) DIGITS WITH UNDERSCORES*) (* SHIFTS THEM TO HSTR TO DELETE THE UNDERSCORES*) (*AFTERWARDS THE STRING IS FOUND IN HSTR(START_SHIFT..OUTP_SHIFTP-1)*) (* LOW LETTERS ARE REPLACED BY UPPER LETTERS*) (* THE DIGITS ARE CHECKED TO BE LESS THAN SBASE*) (* AT LEAST ONE DIGIT MUST BE THERE*) (* CURRENT IS THE FIRST CHAR OF THE SEQUENCE*) label 99; var err, uflg : boolean; first_time : boolean; curr_type : character_type; c : char; begin err := false; uflg := false; first_time:= true; outp_shiftp := start_shift; repeat curr_type := char_type_table [current_char]; if curr_type = low_letter then begin c := chr( ord('A') + ord(current_char) - ord('a')); curr_type := char_type_table [c]; end else c := current_char; (*END IF;*) if (curr_type = digit) or ((sbase > 10)and (curr_type = letter_a_f))then begin if (curr_type = digit) and (ord(c) - ord('0') >= sbase) or (curr_type = letter_a_f) and (ord(c) - ord('A') +10 >= sbase) then begin (* NO CORRECT DIGIT FOR THIS BASE*) error_pos.sourceline := line_no; error_pos.column := current; er_error_message (1509, er_symbol_error, error_pos, lu_no_symbol); c := '0'; end (*IF*); hstr [outp_shiftp] := c; outp_shiftp := outp_shiftp + 1; uflg := false; end else if curr_type = underscore then begin if uflg or first_time then err := true; (*END IF;*) uflg := true; end else goto 99; (*END IF;*) first_time := false; new_current_char; until false; 99 : if uflg or err then er_error_message ( 1504, er_symbol_error, outp_pos, lu_no_symbol ) else if first_time then er_error_message (1501, er_symbol_error, outp_pos, lu_no_symbol ); (*END IF;*) end; (* SEQUENCE;*) (*----------------------------------------------------------*) procedure exponent ( expf : so_sorcecolumn_range; var outp_expl : so_sorcecolumn_range; var outp_expp : boolean); (* SCANS AN OPTIONAL INTEGER OR REAL EXPONENT*) (* SYNTAX: E ([+] ! -) INTEGER*) (* THE EXPONENT DIGITS ARE AFTERWARDS IN HSTR(EXPF..OUTP_EXPL)*) (* OUTP_EXPP INDICATES WHETHER THE EXPONENT IS POSITIVE*) (* CURRENT MUST BE THE FIRST CHARACTER*) begin if(current_char = 'E')or(current_char = 'e')then begin (* SCAN THE EXPONENT*) new_current_char; outp_expp := current_char <> '-'; if(current_char = '-')or(current_char = '+')then new_current_char; (*END IF;*) sequence (10, expf, outp_expl); outp_expl := outp_expl - 1; end else begin outp_expl := expf - 1; outp_expp := false; end; (*END IF;*) end; (* EXPONENT;*) (*----------------------------------------------------------*) procedure readbuffer ; var i,j : integer; CHARA : char; begin last_char := sfirst; line_no := line_no + 1; if eof (input) then buffer [last_char] := eof_char else begin (* READ (CHRC); *) (*ADJUST*) (*OVERREADS EOL CHAR*) write (line_no : 4,':'); IF FILEINPUT THEN BEGIN READ(FILEIN,CHARA); WRITE(CHARA); END ELSE read(CHARA); while not eoln(input) do begin buffer[last_char] := CHARA; { adjusted from read(buffer[last_char]); by EDS } last_char := last_char + 1; END; IF FILEINPUT THEN BEGIN READ(FILEIN,CHARA); WRITE(CHARA); END ELSE read(CHARA); last_char := last_char - 1; (* DELETE NUL, DEL*) for i := sfirst to last_char do begin if(buffer[i] = chr(nul))or(buffer[i] = chr(del))then begin last_char := last_char - 1; for j := i to last_char do buffer[j] := buffer[j+1]; end; end; last_char := last_char + 1; buffer [last_char] := chr (cr); buffer [last_char + 1] := chr (cr); end; (*END IF;*) current := sfirst; current_char := buffer [current]; end; (* READBUFFER;*) procedure case_digit; begin base := 10; sequence (10, sfirst, pos1); if(current_char = '#')or(current_char = ':')then begin (* BASED NUMBER, COMPUTE BASE *) co_string_to_int (hstr, sfirst, pos1-1, 10, error, base); if error or (base < 2) or (base > 16) then begin er_error_message (1508, er_symbol_error, outp_pos, lu_no_symbol); base := 16; end (*IF*); sharp_char := current_char; (* MUST BE USED THROUGOUT*) new_current_char; sequence (base, sfirst, pos2); (* BASED REAL NUMBER*) if current_char = '.' then begin new_current_char; sequence (base, pos2+1, pos3); if current_char <> sharp_char then begin (*ERRONEOUS*) er_error_message (1502, er_symbol_error, outp_pos, lu_no_symbol); end else new_current_char; (*END IF;*) exponent (pos3 + 1, exp_last, exp_positive); new_sym (lu_real, lu_real_sym, outp_sym.idcode); end (* BASED INTEGER NUMBER*) else begin if current_char <> sharp_char then begin (*ERRONEOUS*) er_error_message (1502, er_symbol_error, outp_pos, lu_no_symbol); end else new_current_char; (*END IF;*) exponent (pos2 + 1, exp_last, exp_positive); new_sym (lu_int, lu_integer_sym, outp_sym.idcode); end; end (*END IF;*) else if(current_char = '.')and (char_type_table [buffer [current + 1]] = digit)then begin (* REAL LITERAL*) new_current_char; sequence (10, pos1+1, pos2); exponent (pos2 + 1, exp_last, exp_positive); new_sym (lu_real, lu_real_sym, outp_sym.idcode); end (* INTEGER LITERAL*) else begin exponent (pos1, exp_last, exp_positive); new_sym (lu_int, lu_integer_sym, outp_sym.idcode); end (*IF*); (* TEST THAT NO IDENTIFIER OR NUMBER FOLLOWS IMMEDIATELY*) current_type := char_type_table [current_char]; if(current_type = letter_a_f)or(current_type = letter_g_z)or (current_type = low_letter)or(current_type = digit)then begin error_pos.sourceline := outp_pos.sourceline; error_pos.column := current; er_error_message (1505, er_symbol_error, error_pos, lu_no_symbol ); end (*IF*); end; (* CASE_DIGIT *) procedure case_letter; label 77; begin (* UFLAG := FALSE; NOT NECESSARY BECAUSE LETTER ANALYZED*) error := false; pos1 := sfirst; repeat case char_type_table [current_char] of letter_a_f , letter_g_z , digit : uflag := false; low_letter : begin current_char := chr( ord('A') + ord(current_char) - ord('a')); uflag := false; end; underscore : begin if uflag then error := true; (*END IF;*) uflag := true; end; dquote, quote, hyphen, ampersand, lpar, rpar,asterisk, plus, comma, point, slash, colon, semicolon, langle, equal, rangle, vbar, nwline, ignore, blank, htab, eofc, other_graphics, non_ada : goto 77; end; (* CASE;*) hstr [pos1] := current_char; pos1 := pos1 + 1; new_current_char; until false; 77 : if uflag or error then er_error_message (1504, er_symbol_error, outp_pos, lu_no_symbol ); (*END IF;*) i_code := st_get_sub_code (hstr, sfirst, pos1-1, false); if last_symbol.sym <> lu_quote_sym then (* IDENTIFY RESERVED WORDS*) new_sym (lu_id, lu_reserved_word[i_code], i_code) else (* ATTRIBUTE NAME*) new_sym (lu_id, lu_identifier_sym, i_code); (*END IF;*) end; (* CASE_LETTER *) (*-------------------------------------------------------------------*) begin (* LA_NEXT_SYM -----------------------------------*) outp_pos.sourceline := line_no; 11 : outp_pos.column := current; current_type := char_type_table [current_char]; case current_type of digit : begin case_digit; (* INTEGER OR REAL LITERAL*) goto 88; end; (* IDENTIFIER*) letter_a_f , letter_g_z , low_letter : begin case_letter; goto 88; end; (* CHARACTER_LITERAL OR QUOTE*) quote : begin new_current_char; if(buffer [current + 1] <> '''')or(last_symbol.sym = lu_identifier_sym)then new_sym (lu_other, lu_quote_sym, outp_sym.idcode) else begin current_type := char_type_table [current_char]; if(current_type = nwline)or(current_type = ignore)or (current_type = htab)or(current_type = non_ada)then begin error_pos.sourceline := outp_pos.sourceline; error_pos.column := current; er_error_message (1500, er_symbol_error, error_pos, lu_no_symbol ); end; (*END IF;*) new_sym (lu_id, lu_character_sym, st_nil); current := current + 1; new_current_char; end; (*END IF;*) goto 88; end; (* CHARACTER STRING*) dquote : begin string_bracket := current_char; pos1 := sfirst; repeat new_current_char; current_type := char_type_table [current_char]; if current_type = nwline then begin er_error_message (1503, er_symbol_error, outp_pos, lu_no_symbol ); goto 66; end else if(current_type = ignore)or(current_type = htab)or (current_type = non_ada)then begin error_pos.sourceline := outp_pos.sourceline; error_pos.column := current; er_error_message (1500, er_symbol_error, error_pos, lu_no_symbol ); end else if current_char = string_bracket then begin new_current_char; if current_char <> string_bracket then goto 66; end else if current_char = '"' then begin (* MUST BE %-STRING, " IS NOT ALLOWED*) error_pos.sourceline := outp_pos.sourceline; error_pos.column := current; er_error_message (1500, er_symbol_error, error_pos, lu_no_symbol ); end; (*END IF;*) hstr [pos1] := current_char; pos1 := pos1 + 1; until false; 66 : new_sym (lu_id, lu_string_sym, st_nil); goto 88; end; (* DOT OR INTERVAL*) point : begin new_current_char; if current_char = '.' then begin new_current_char; new_sym (lu_other, lu_interval_sym, outp_sym.idcode); end else new_sym (lu_other, lu_dot_sym, outp_sym.idcode); (*END IF;*) goto 88; end; (* LESS OR LESS_EQUAL OR LEFT_LABEL_BRACKET OR BOX*) langle : begin new_current_char; if current_char = '>' then new_sym (lu_other, lu_box_sym, outp_sym.idcode) else if current_char = '=' then new_sym (lu_id, lu_less_equal_sym, lu_cde_less_equal) else if current_char = '<' then new_sym (lu_other, lu_left_label_sym, outp_sym.idcode) else begin new_sym (lu_id, lu_less_sym, lu_code_less); goto 88; end; (*END IF;*) new_current_char; goto 88; end; (* LEFT PARENTHESIS*) lpar : begin new_current_char; new_sym (lu_other, lu_lpar_sym, outp_sym.idcode); goto 88; end; (* PLUS*) plus : begin new_current_char; new_sym (lu_id, lu_plus_sym, lu_code_plus); goto 88; end; (* SEPARATOR*) vbar : begin new_current_char; new_sym (lu_other, lu_separator_sym, outp_sym.idcode); goto 88; end; (* MULTIPLY OR EXPONENTIATION*) asterisk : begin new_current_char; if current_char = '*' then begin new_current_char; new_sym (lu_id, lu_exponentiation_sym, lu_code_exponentiation); end else (*END IF;*) new_sym (lu_id, lu_multiply_sym, lu_code_multiply); goto 88; end; (* RIGHT PARENTHESIS*) rpar : begin new_current_char; new_sym (lu_other, lu_rpar_sym, outp_sym.idcode); goto 88; end; (* MINUS OR COMMENT*) hyphen : begin new_current_char; if current_char = '-' then begin repeat new_current_char; current_type := char_type_table [current_char]; if current_type = nwline then goto 55; if(current_type = ignore)or(current_type = non_ada) then begin error_pos.sourceline := outp_pos.sourceline; error_pos.column := current; er_error_message (1500, er_symbol_error, error_pos, lu_no_symbol ); end; (*END IF;*) until false; 55 : end else begin new_sym (lu_id, lu_minus_sym, lu_code_minus); goto 88; end; (*END IF;*) end; (* DIVIDE OR NOT_EQUAL*) slash : begin new_current_char; if current_char = '=' then begin new_current_char; new_sym (lu_id, lu_not_equal_sym, lu_code_not_equal); end else new_sym (lu_id, lu_divide_sym, lu_code_divide); (*END IF;*) goto 88; end; (* COMMA*) comma : begin new_current_char; new_sym (lu_other, lu_comma_sym, outp_sym.idcode); goto 88; end; (* GREATER OR GREATER_EQUAL OR RIGHT_LABEL_BRACKET*) rangle : begin new_current_char; if current_char = '=' then begin new_current_char; new_sym (lu_id, lu_greator_equal_sym, lu_cde_greater_equal);end else if current_char = '>' then begin new_current_char; new_sym (lu_other, lu_right_label_sym, outp_sym.idcode); end else new_sym (lu_id, lu_greater_sym, lu_code_greater); (*END IF;*) goto 88; end; (* COLON OR ASSIGN*) colon : begin new_current_char; if current_char = '=' then begin new_current_char; new_sym (lu_other, lu_assign_sym, outp_sym.idcode); end else new_sym (lu_other, lu_colon_sym, outp_sym.idcode); (*END IF;*) goto 88; end; (* ARROW OR EQUAL *) EQUAL : BEGIN NEW_CURRENT_CHAR; IF CURRENT_CHAR = '>' THEN BEGIN NEW_CURRENT_CHAR; NEW_SYM (LU_OTHER, LU_ARROW_SYM, OUTP_SYM.IDCODE); END ELSE NEW_SYM (LU_ID, LU_EQUAL_SYM, LU_CODE_EQUAL); (* END IF;*) GOTO 88; END; (* SEMICOLON *) SEMICOLON : BEGIN NEW_CURRENT_CHAR; NEW_SYM (LU_OTHER, LU_SEMICOLON_SYM, OUTP_SYM.IDCODE); GOTO 88; END; (* CATENATION *) AMPERSAND : BEGIN NEW_CURRENT_CHAR; NEW_SYM(LU_ID, LU_CATENATION_SYM, LU_CODE_CATENATION); GOTO 88; END; (* NEWLINE CHARACTER (MUST NOT BE EOL) *) NWLINE : BEGIN IF CURRENT = LAST_CHAR THEN (* IT IS EOL*) BEGIN READBUFFER; OUTP_POS.SOURCELINE := LINE_NO END ELSE NEW_CURRENT_CHAR; END; (* END IF;*) (* EOFC*) eofc : begin if(current <> last_char) and(current <> sfirst)(*DELETE THIS LINE IF NO $-EOF*) then begin new_current_char; er_error_message (1500, er_symbol_error, outp_pos, lu_no_symbol); end else begin new_sym (lu_other, lu_eof_sym, outp_sym.idcode); goto 88; end; (*END IF;*) end; (* BLANK - SKIP*) blank , htab , ignore : begin new_current_char; end; (* OTHERS ARE NOT ALLOWED HERE*) underscore , other_graphics , non_ada : begin new_current_char; er_error_message (1500, er_symbol_error, outp_pos, lu_no_symbol ); end; end; (* CASE;*) goto 11; 88 : (* THE LEXICAL ELEMENT HAS BEEN RECOGNIZED*) last_symbol :=outp_sym; last_pos := outp_pos; end; (* LA_NEXT_SYM;*) (*-------------------------------------------------------------------*) (*END LEXICAL_ANALYZER; *) ======================================================================================== DOCUMENT :usus Folder:VOLUK03:luerror.text ======================================================================================== SEGMENT procedure lu_error_symbol (LEX_UNIT : LU_LEXICAL_UNIT; VAR RESULT : LU_SYM_DESCRIPTOR); (*-------------------------------------------------------------------*) (* -*) (* DESCRIPTION: BUILDS AN DESCRIPTOR FOR ERRORNEOUS CASES -*) (* ------------ (E.G. INSERTION BY PARSER). -*) (* -*) (*-------------------------------------------------------------------*) label 1401; var symbol : lu_sym_descriptor; code : st_symbol; i : integer; begin case lex_unit of lu_identifier_sym : begin symbol.discrim := lu_id; symbol.sym := lu_identifier_sym; symbol.idcode := lub_cde_identifier; end; lu_integer_sym : begin symbol.discrim := lu_id; symbol.sym := lu_identifier_sym; symbol.idcode := lub_code_integer; end; lu_real_sym : begin symbol.discrim := lu_id; symbol.sym := lu_identifier_sym; symbol.idcode := lub_code_real; end; lu_character_sym : begin symbol.discrim := lu_id; symbol.sym := lu_identifier_sym; symbol.idcode := lub_code_character ; end; lu_string_sym : begin; symbol.discrim := lu_id; symbol.sym := lu_identifier_sym; symbol.idcode := lub_code_string ; end; lu_eof_sym , lu_dot_sym , lu_interval_sym , lu_left_label_sym , lu_box_sym , lu_lpar_sym , lu_separator_sym , lu_rpar_sym , lu_semicolon_sym , lu_comma_sym , lu_right_label_sym , lu_colon_sym , lu_assign_sym , lu_quote_sym , lu_arrow_sym : begin symbol.discrim := lu_other; symbol.sym := lex_unit; end; lu_minus_sym : begin symbol.discrim := lu_id; symbol.sym := lu_minus_sym; symbol.idcode := lu_code_minus; end; lu_less_sym : begin symbol.discrim := lu_id; symbol.sym := lu_less_sym; symbol.idcode := lu_code_less ; end; lu_less_equal_sym : begin symbol.discrim := lu_id; symbol.sym := lu_less_equal_sym; symbol.idcode := lu_cde_less_equal ; end; lu_plus_sym : begin symbol.discrim := lu_id; symbol.sym := lu_plus_sym; symbol.idcode := lu_code_plus; end; lu_catenation_sym : begin symbol.discrim := lu_id; symbol.sym := lu_catenation_sym; symbol.idcode := lu_code_catenation; end; lu_multiply_sym : begin symbol.discrim := lu_id; symbol.sym := lu_multiply_sym; symbol.idcode := lu_code_multiply ; end; lu_exponentiation_sym : begin symbol.discrim := lu_id; symbol.sym := lu_exponentiation_sym; symbol.idcode := lu_code_exponentiation ; end; lu_divide_sym : begin symbol.discrim := lu_id; symbol.sym := lu_divide_sym; symbol.idcode := lu_code_divide ; end; lu_not_equal_sym : begin symbol.discrim := lu_id; symbol.sym := lu_not_equal_sym; symbol.idcode := lu_code_not_equal ; end; lu_greater_sym : begin symbol.discrim := lu_id; symbol.sym := lu_greater_sym; symbol.idcode := lu_code_greater ; end; lu_greator_equal_sym : begin symbol.discrim := lu_id; symbol.sym := lu_greator_equal_sym; symbol.idcode := lu_cde_greater_equal ; end; lu_equal_sym : begin symbol.discrim := lu_id; symbol.sym := lu_equal_sym; symbol.idcode := lu_code_equal ; end; lu_abort_sym , lu_accept_sym, lu_access_sym, lu_all_sym , lu_and_sym , lu_array_sym , lu_at_sym , lu_begin_sym , lu_body_sym , lu_case_sym , lu_constant_sym , lu_declare_sym , lu_delay_sym , lu_delta_sym , lu_digits_sym, lu_do_sym , lu_else_sym , lu_elsif_sym , lu_end_sym , lu_entry_sym , lu_exception_sym , lu_exit_sym , lu_for_sym , lu_function_sym , lu_generic_sym , lu_goto_sym , lu_if_sym , lu_in_sym , lu_is_sym , lu_limited_sym , lu_loop_sym , lu_mod_sym , lu_new_sym , lu_not_sym , lu_null_sym , lu_of_sym , lu_or_sym , lu_others_sym, lu_out_sym , lu_package_sym , lu_pragma_sym, lu_private_sym , lu_procedure_sym , lu_raise_sym , lu_range_sym , lu_record_sym, lu_rem_sym , lu_renames_sym , lu_return_sym, lu_reverse_sym , lu_salect_sym, lu_seperate_sym , lu_subtype_sym , lu_task_sym , lu_terminate_sym , lu_then_sym , lu_type_sym , lu_use_sym , lu_when_sym , lu_while_sym , lu_with_sym , lu_xor_sym : begin code := lub_cde_identifier; for i := 1 to st_sym_ubound do begin (* LOOP*) if lu_reserved_word [i] = lex_unit then begin code := i; goto 1401; end; (* IF;*) end; (* LOOP;*) 1401 : symbol.discrim := lu_id; symbol.sym := lex_unit; symbol.idcode := code ; end; end; (* CASE;*) (* RETURN SYMBOL;*) result := symbol; end; (*LU_ERROR_SYMBOL;*) ======================================================================================== DOCUMENT :usus Folder:VOLUK03:luinit.text ======================================================================================== (*-------------------------------------------------------------------*) segment procedure lu_init; (*------------------------------------------------------------------*) (* -*) (* DESCRIPTION: CODING OF THE STRINGS IN SYMBOL TABLE -*) (* ------------ -*) (* -*) (* SPECIALITIES: MUST BE CALLED BEFORE FIRST CALL OF LA_NEXT_SYM -*) (* ------------- -*) (*------------------------------------------------------------------*) var i : integer; procedure lu_init_part2; begin lu_reserved_word [st_get_code ('PRIVATE ', 7)] := lu_private_sym; lu_reserved_word [st_get_code ('PROCEDURE', 9)] := lu_procedure_sym; lu_reserved_word [st_get_code ('RAISE ', 5)] := lu_raise_sym; lu_reserved_word [st_get_code ('RANGE ', 5)] := lu_range_sym; lu_reserved_word [st_get_code ('RECORD ', 6)] := lu_record_sym; lu_reserved_word [st_get_code ('REM ', 3)] := lu_rem_sym; lu_reserved_word [st_get_code ('RENAMES ', 7)] := lu_renames_sym; lu_reserved_word [st_get_code ('RETURN ', 6)] := lu_return_sym; lu_reserved_word [st_get_code ('REVERSE ', 7)] := lu_reverse_sym; lu_reserved_word [st_get_code ('SELECT ', 6)] := lu_salect_sym; lu_reserved_word [st_get_code ('SEPARATE ', 8)] := lu_seperate_sym; lu_reserved_word [st_get_code ('SUBTYPE ', 7)] := lu_subtype_sym; lu_reserved_word [st_get_code ('TASK ', 4)] := lu_task_sym; lu_reserved_word [st_get_code ('TERMINATE', 9)] := lu_terminate_sym; lu_reserved_word [st_get_code ('THEN ', 4)] := lu_then_sym; lu_reserved_word [st_get_code ('TYPE ', 4)] := lu_type_sym; lu_reserved_word [st_get_code ('USE ', 3)] := lu_use_sym; lu_reserved_word [st_get_code ('WHEN ', 4)] := lu_when_sym; lu_reserved_word [st_get_code ('WHILE ', 5)] := lu_while_sym; lu_reserved_word [st_get_code ('WITH ', 4)] := lu_with_sym; lu_reserved_word [st_get_code ('XOR ', 3)] := lu_xor_sym; (* SYMBOL TABLE CODES FOR OPERATORS*) lu_code_minus := st_get_char_code ('-'); lu_code_less := st_get_char_code ('<'); lu_cde_less_equal := st_get_code ( '<= ', 2); lu_code_plus := st_get_char_code ('+'); lu_code_catenation := st_get_char_code ('&'); lu_code_multiply := st_get_char_code ('*'); lu_code_exponentiation := st_get_code ( '** ', 2); lu_code_divide := st_get_char_code ('/'); lu_code_not_equal := st_get_code ( '/= ', 2); lu_code_greater := st_get_char_code ('>'); lu_cde_greater_equal := st_get_code ( '>= ', 2); lu_code_equal := st_get_char_code ('='); (* ERROR ITEMS INITIALIZATION*) lub_cde_identifier := st_nil; (* IS ""*) lub_code_integer := st_get_code ( '', 9); lub_code_real := st_get_code ( ' ', 6); lub_code_string := lub_cde_identifier; (* IF STRING IS INSERTED THEN ALSO IDENTIFIER MAY BE INSERTED*) lub_code_character := st_get_code ( ' ', 6); end; (* LU_INIT_PART2 *) begin (* LU_INIT *) lu_no_symbol.discrim := lu_id; lu_no_symbol.sym := lu_identifier_sym; lu_no_symbol.idcode := st_nil; for i := 0 to st_sym_ubound do lu_reserved_word [i] := lu_identifier_sym; (*END LOOP;*) lu_reserved_word [st_get_code ('ABORT ', 5)] := lu_abort_sym; lu_reserved_word [st_get_code ('ACCEPT ', 6)] := lu_accept_sym; lu_reserved_word [st_get_code ('ACCESS ', 6)] := lu_access_sym; lu_reserved_word [st_get_code ('ALL ', 3)] := lu_all_sym; lu_reserved_word [st_get_code ('AND ', 3)] := lu_and_sym; lu_reserved_word [st_get_code ('ARRAY ', 5)] := lu_array_sym; lu_reserved_word [st_get_code ('AT ', 2)] := lu_at_sym; lu_reserved_word [st_get_code ('BEGIN ', 5)] := lu_begin_sym; lu_reserved_word [st_get_code ('BODY ', 4)] := lu_body_sym; lu_reserved_word [st_get_code ('CASE ', 4)] := lu_case_sym; lu_reserved_word [st_get_code ('CONSTANT ', 8)] := lu_constant_sym; lu_reserved_word [st_get_code ('DECLARE ', 7)]:= lu_declare_sym; lu_reserved_word [st_get_code ('DELAY ', 5)] := lu_delay_sym; lu_reserved_word [st_get_code ('DELTA ', 5)] := lu_delta_sym; lu_reserved_word [st_get_code ('DIGITS ', 6)] := lu_digits_sym; lu_reserved_word [st_get_code ('DO ', 2)] := lu_do_sym; lu_reserved_word [st_get_code ('ELSE ', 4)] := lu_else_sym; lu_reserved_word [st_get_code ('ELSIF ', 5)] := lu_elsif_sym; lu_reserved_word [st_get_code ('END ', 3)] := lu_end_sym; lu_reserved_word [st_get_code ('ENTRY ', 5)] := lu_entry_sym; lu_reserved_word [st_get_code ('EXCEPTION', 9)] := lu_exception_sym; lu_reserved_word [st_get_code ('EXIT ', 4)] := lu_exit_sym; lu_reserved_word [st_get_code ('FOR ', 3)] := lu_for_sym; lu_reserved_word [st_get_code ('FUNCTION ', 8)] := lu_function_sym; lu_reserved_word [st_get_code ('GENERIC ', 7)] := lu_generic_sym; lu_reserved_word [st_get_code ('GOTO ', 4)] := lu_goto_sym; lu_reserved_word [st_get_code ('IF ', 2)] := lu_if_sym; lu_reserved_word [st_get_code ('IN ', 2)] := lu_in_sym; lu_reserved_word [st_get_code ('IS ', 2)] := lu_is_sym; lu_reserved_word [st_get_code ('LIMITED ', 7)] := lu_limited_sym; lu_reserved_word [st_get_code ('LOOP ', 4)] := lu_loop_sym; lu_reserved_word [st_get_code ('MOD ', 3)] := lu_mod_sym; lu_reserved_word [st_get_code ('NEW ', 3)] := lu_new_sym; lu_reserved_word [st_get_code ('NOT ', 3)] := lu_not_sym; lu_reserved_word [st_get_code ('NULL ', 4)] := lu_null_sym; lu_reserved_word [st_get_code ('OF ', 2)] := lu_of_sym; lu_reserved_word [st_get_code ('OR ', 2)] := lu_or_sym; lu_reserved_word [st_get_code ('OTHERS ', 6)] := lu_others_sym; lu_reserved_word [st_get_code ('OUT ', 3)] := lu_out_sym; lu_reserved_word [st_get_code ('PACKAGE ', 7)] := lu_package_sym; lu_reserved_word [st_get_code ('PRAGMA ', 6)] := lu_pragma_sym; lu_init_part2; end; (* LU_INIT;*) (*-------------------------------------------------------------------*) ======================================================================================== DOCUMENT :usus Folder:VOLUK03:newadatest.text ======================================================================================== --*************************************************************** -- -- SYNTAX TEST FOR REVISED ADA -- -- The programs are generated from the LALR(1) grammar used in -- the Ada Syntax Checker. Every rule is applied at least once. -- --*************************************************************** procedure ID ; pragma ID ; procedure ID ; pragma ID ( 1 ) ; with ID ; with ID ( 1 ) , "**" ( ) ' ID . "**" . all . ID ( 1 .. 1 , ID ( ID digits 1 ) ( 1 => ID digits 1 , 1 and 1 ) range + 1 * 1 + 1 ** 1 / 4.5 ** 'A' .. - null - ( 1 , 1 ) mod ID ( 1 or 1 ) ( 1 xor 1 , 1 and then 1 ) ** new ID ( 1 or else 1 ) ( 1 = 1 , 1 in 1 .. 1 ) ! ID ( 1 in ID ) ( ID ' ( 1 ) , ( 1 ) ) range not ( 1 => 1 ) & ( 1 , 1 , 1 ) rem ( 1 => 1 , 1 ) ** ( 1 /= 1 , 1 ) .. ( 1 < 1 , 1 ) + ( 1 <= 1 , 1 ) * ( 1 > 1 , 1 ) ** ( 1 >= 1 , 1 ) => ( 1 not in 1 .. 1 , 1 ) + ( 1 in ID digits 1 , 1 ) * ( 1 in ID ( ID range 1 .. 1 ) , 1 ) ** ( 1 in ID ( ID delta 1 ) , 1 ) = ( 1 in ID ( ID digits 1 range 1 .. 1 ) , 1 ) + ( 1 in ID ( others => 1 ) , 1 ) * ( 1 in ID ( 1 .. 1 => 1 ) , 1 ) ** ( 1 and 1 and 1 , 1 ) ) ; use ID ( ID ' ( 1 , 1 ) ) ( 1 or 1 or 1 , ID ( 1 xor 1 xor 1 ) range ( 1 and then 1 and then 1 , 1 ) + ( 1 or else 1 or else 1 , 1 ) * 1 .. 1 => 1 ) ; procedure ID is ID : ID ; for ID use 1 ; procedure ID ( ID : ID ) is begin null ; end ; generic package ID is ID : constant ID ; use ID ; ID : constant array ( ID range <> ) of ID := 1 ; end ; begin accept ID ; << ID >> if 1 then pragma ID ; ID := 1 ; elsif 1 then exit ; return ; end if ; exception when ID => return 1 ; goto ID ; end ID ; pragma ID ( 1 , 1 ) ; procedure ID ; pragma ID ( ID => 1 ) ; procedure ID ; package ID is end ; package body ID is end ; separate ( ID ) package body ID is end ; generic procedure ID ; procedure ID is new ID ; function ID is new ID ; function ID return ID ; procedure ID ( ID : ID ) ; procedure ID ( ID : ID ; ID : ID ) ; procedure ID ( ID , ID : ID ) ; procedure ID ( ID : in ID ) ; procedure ID ( ID : out ID ) ; procedure ID ( ID : in out ID ) ; procedure ID ( ID , ID , ID : ID ) ; function "**" return ID ; generic ID : ID ; procedure ID ; generic type ID is private ; procedure ID ; generic with procedure ID ; procedure ID ; generic with procedure ID is ID ; procedure ID ; generic with procedure ID is <> ; procedure ID ; generic type ID ( ID : ID ) is private ; procedure ID ; generic type ID ( ID : ID ; ID : ID ) is private ; procedure ID ; generic type ID ( ID , ID : ID ) is private ; procedure ID ; generic type ID is ( <> ) ; procedure ID ; generic type ID is range <> ; procedure ID ; generic type ID is delta <> ; procedure ID ; generic type ID is digits <> ; procedure ID ; generic type ID is array ( ID ) of ID ; procedure ID ; generic type ID is access ID ; procedure ID ; generic type ID is array ( ID range <> , ID range <> ) of ID ; procedure ID ; generic type ID is array ( ID , ID ) of ID ; procedure ID ; generic type ID is array ( 1 .. 1 ) of ID ; procedure ID ; generic type ID is limited private ; procedure ID ; generic with function ID return ID is ID ; procedure ID ; procedure ID is for ID use 1 ; begin null ; end ; procedure ID is procedure ID is separate ; begin null ; end ; procedure ID is ID , ID : constant ID ; begin null ; end ; procedure ID is ID , ID : constant array ( ID ) of ID ; begin null ; end ; procedure ID is ID : constant := 1 ; begin null ; end ; procedure ID is ID , ID : constant := 1 ; begin null ; end ; procedure ID is type ID is private ; begin null ; end ; procedure ID is type ID ; begin null ; end ; procedure ID is subtype ID is ID ; begin null ; end ; procedure ID is procedure ID ; begin null ; end ; procedure ID is package ID is end ; begin null ; end ; procedure ID is task ID ; begin null ; end ; procedure ID is ID : exception ; begin null ; end ; procedure ID is ID , ID : exception ; begin null ; end ; procedure ID is ID : ID renames ID ; begin null ; end ; procedure ID is ID : exception renames ID ; begin null ; end ; procedure ID is package ID renames ID ; begin null ; end ; procedure ID is task ID renames ID ; begin null ; end ; procedure ID is procedure ID renames ID ; begin null ; end ; procedure ID is pragma ID ; begin null ; end ; procedure ID is ID : array ( ID ) of ID ; begin null ; end ; procedure ID is ID , ID : array ( ID ) of ID ; begin null ; end ; procedure ID is type ID is ( ID ) ; begin null ; end ; procedure ID is type ID is range 1 .. 1 ; begin null ; end ; procedure ID is type ID is digits 1 ; begin null ; end ; procedure ID is type ID is array ( ID ) of ID ; begin null ; end ; procedure ID is type ID is record end record ; begin null ; end ; procedure ID is type ID is access ID ; begin null ; end ; procedure ID is type ID is new ID ; begin null ; end ; procedure ID is type ID is ( ID , ID ) ; begin null ; end ; procedure ID is type ID is ( 'A' ) ; begin null ; end ; procedure ID is type ID is record null ; end record ; begin null ; end ; procedure ID is type ID is record ID : ID ; end record ; begin null ; end ; procedure ID is type ID is record case ID is end case ; end record ; begin null ; end ; procedure ID is type ID is record case ID is when 1 => end case ; end record ; begin null ; end ; procedure ID is package ID is new ID ; begin null ; end ; procedure ID is package ID is private end ; begin null ; end ; procedure ID is package ID is private for ID use 1 ; end ; begin null ; end ; procedure ID is package ID is private for ID use record end record ; end ; begin null ; end ; procedure ID is package ID is private for ID use at 1 ; end ; begin null ; end ; procedure ID is package ID is private for ID use record at mod 1 ; end record ; end ; begin null ; end ; procedure ID is package ID is private for ID use record ID at 1 range 1 .. 1 ; end record ; end ; begin null ; end ; procedure ID is package ID is private for ID use 1 ; pragma ID ; end ; begin null ; end ; procedure ID is package ID is private for ID use 1 ; for ID use 1 ; end ; begin null ; end ; procedure ID is package ID is end ID ; begin null ; end ; procedure ID is task type ID ; begin null ; end ; procedure ID is task ID is end ; begin null ; end ; procedure ID is task ID is entry ID ; end ; begin null ; end ; procedure ID is task ID is entry ID ( ID ) ; end ; begin null ; end ; procedure ID is for ID use 1 ; task ID ; begin null ; end ; procedure ID is for ID use 1 ; procedure ID is separate ; begin null ; end ; procedure ID is for ID use 1 ; task body ID is begin null ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin null ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin delay 1 ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin abort ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin raise ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin ID ' ( 1 ) ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin exit ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin exit when 1 ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin case 1 is end case ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin loop null ; end loop ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin ID : loop null ; end loop ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin begin null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin ID : begin null ; end ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select terminate ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select ID ; else null ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select ID ; or delay 1 ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin if 1 then null ; else null ; end if ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin case 1 is when 1 => null ; end case ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin for ID in ID loop null ; end loop ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin for ID in reverse ID loop null ; end loop ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin while 1 loop null ; end loop ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin declare begin null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin begin null ; exception when ID ! ID => null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin begin null ; exception when others => null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept ID do null ; end ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept "**" ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept ID . ID ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept ID . "**" ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin accept ID ( 1 ) ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select when 1 => terminate ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select accept ID ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select delay 1 ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select accept ID ; null ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is begin select terminate ; or terminate ; end select ; end ; begin null ; end ; procedure ID is for ID use 1 ; package body ID is separate ; begin null ; end ; ======================================================================================== DOCUMENT :usus Folder:VOLUK03:parser.text ======================================================================================== (**********************************************************************) segment procedure parser; label 1; (* PARSER EXIT *) const stackend = 100 ; startstate = 1 ; (**********************************************************************) (* GENERATED PARSER CONSTANTS *) (**********************************************************************) zemaxbit2 = 63; (*ADJUST*) (*MAX SET ELEMENT*) zemax2bits = 64; (*ADJUST*) (*MAX SET SIZE*) zemaxterminalcode = 93; zemaxrslaenge = 11; zemaxprodnrliste = 180; zeanzzst = 487; zemaxfez = 153; zemaxfes = 77; zemaxteintrag = 196; zeanzotzst = 38; zeanzots = 37; zemaxnteintrag = 62; zeanzonzst = 82; zeanzons = 19; zeanznt = 124; zeanzprod = 345; zemaxztv = 223; zemaxznv = 82; zemaxtv = 37; zemaxnv = 19; zetindex = 1;(*ADJUST*)(*ZEMAXTERMINALCODE/ZEMAXBITS2*) zezuindex = 7;(*ADJUST*) (*ZEANZZST / ZEMAXBITS2*) zefindex = 1;(*ADJUST*) (*ZEMAXFES / ZEMAXBITS2*) zezplusn = 7; zezplust = 5; zestopsymbol = 5; type (**********************************************************************) (* PARSER TYPES *) (**********************************************************************) state = 1..zeanzzst; production = 1..zeanzprod; terminalsymbol= 0..zemaxterminalcode; errorsymbol = 0..zemaxfes; errorstate = 1..zemaxfez; nonterminal = 1..zeanznt; prodnrliste = 0..zemaxprodnrliste; (* 0 == ERROR EXIT *) termin_set = array[0..zetindex] of set of 0..zemaxbit2; errorset = array[0..zefindex] of set of 0..zemaxbit2; statesset = array[0..zezuindex] of set of 0..zemaxbit2; ttabtyp = array[1..zeanzotzst,1..zeanzots] of 0..zemaxteintrag; ntabtyp = array[1..zeanzonzst,1..zeanzons] of 0..zemaxnteintrag; ztvtyp = array[state] of 1..zemaxztv; znvtyp = array[state] of 1..zemaxznv; termtermtyp = array[terminalsymbol] of 0..zemaxtv; ntnttyp = array[nonterminal] of 1..zemaxnv; termzutyp = array[terminalsymbol] of 0..zeanzzst; ntzutyp = array[nonterminal] of 0..zeanzzst; termprotyp = array[terminalsymbol] of 0..zeanzprod; ntprotyp = array[nonterminal] of 0..zeanzprod; zupltyp = array[state] of prodnrliste; plprotyp = array[prodnrliste] of production; pronttyp = array[production] of nonterminal; errortyp = array[errorstate] of errorset; prorsltyp = array[production] of 0..zemaxrslaenge; zutermtyp = array[state] of terminalsymbol; zuzplusttyp = array[state] of 1..zezplust; termzplusttyp = array[terminalsymbol] of 1..zezplust; zuzplusntyp = array[state] of 1..zezplusn; ntzplusntyp = array[nonterminal] of 1..zezplusn; stackpointer = 0..stackend; parserstack = array [ stackpointer ] of state ; (* PARSERSTACK [ 0 ] = 'dummy' *) parseraction = (handleerror,read,reduce, readreduce); table_entry = record case action : parseraction of (* HANDLEERROR: *) read:( nextstate : state ); reduce,readreduce: ( product_snr : production ) end; token_type = record syntaxcode : terminalsymbol; pos : so_position; symbol : lu_sym_descriptor end; (**********************************************************************) (* STATE VARIABLES OF THE PARSER *) (**********************************************************************) var stack : parserstack; pointer : stackpointer; entry : table_entry; token : token_type; (**********************************************************************) (* PARSER TABLES AND CONSTANTS *) (**********************************************************************) error : errortyp; ztv : ztvtyp; tv : termtermtyp; ttab : ttabtyp; znrtv : termzutyp; pnrtv : termprotyp; ptl : plprotyp; ptla : zupltyp; ft : zuzplusttyp; gt : termzplusttyp; fez : array[state] of 0..zemaxfez; fes : array[terminalsymbol] of 0..zemaxfes; ls : pronttyp; lengthrs : prorsltyp; ntab : ntabtyp; znv : znvtyp; nv : ntnttyp; znrnv : ntzutyp; pnrnv : ntprotyp; fn : zuzplusntyp; gn : ntzplusntyp; fsymbol, rsymbol : zutermtyp; semklammer, overread : termin_set; emptystateset : statesset; (**********************************************************************) (**********************************************************************) function is_stopentry (e : table_entry) : boolean; begin is_stopentry := false; if e.action = read then if e.nextstate = startstate then is_stopentry := true; end; (**********************************************************************) function inset(m : termin_set; i : terminalsymbol ): boolean; begin inset:=(i mod zemax2bits) in m[i div zemax2bits]; end; (* VON INSET *) (**********************************************************************) function infeset(m : errorset; i : errorsymbol): boolean; begin infeset:=(i mod zemax2bits) in m[i div zemax2bits]; end; (* INFESET *) (**********************************************************************) function instateset( m : statesset ; i : state ) : boolean; begin instateset:=(i mod zemax2bits) in m[i div zemax2bits]; end; (* INSTATESET *) (**********************************************************************) procedure tostateset( var m : statesset ; i : state ); begin m [ i div zemax2bits ] := m [ i div zemax2bits ] + [ i mod zemax2bits ] ; end; (* TOSTATESET *) (**********************************************************************) PROCEDURE TTABLE( Z:STATE; S:TERMINALSYMBOL; VAR E:TABLE_ENTRY); (* TTABLE DETERMINES THE ACTION, WHICH IS EXECUTED NEXT *) (* IF THE CURRENT SYMBOL IS A TERMINAL *) VAR TET:INTEGER; BEGIN WITH E DO IF INFESET(ERROR[FEZ[Z]],FES[S]) THEN ACTION:=HANDLEERROR ELSE BEGIN IF FT[Z]GT[S] THEN TET:=TV[S] ELSE TET:=TTAB[ZTV[Z],TV[S]]; CASE TET MOD 3 OF 0: BEGIN ACTION:=READ; NEXTSTATE:=ZNRTV[S] + (TET DIV 3); END; 1: BEGIN ACTION:=READREDUCE; PRODUCT_SNR:=PNRTV[S] + (TET DIV 3); END; 2: BEGIN ACTION:=REDUCE; PRODUCT_SNR:=PTL[PTLA[Z] + (TET DIV 3)]; END; END; END; END; (* TTABLE *) (*********************************************************************) PROCEDURE NTABLE( Z:STATE; S:NONTERMINAL; VAR E:TABLE_ENTRY); (* NTABLE DETERMINES THE ACTION WHICH IS EXECUTED NEXT *) (* IF THE CURRENT SYMBOL IS A NONTERMINAL *) VAR TET:INTEGER; BEGIN with e do begin if fn[z]gn[s] then tet:=nv[s] else tet:=ntab[znv[z],nv[s]]; case tet mod 2 of 0: begin action:=read; nextstate:=znrnv[s] + (tet div 2); end; 1: begin action:=readreduce; product_snr:=pnrnv[s] + (tet div 2); end; end; end; end; (* NTABLE *) (**********************************************************************) (* INITIALIZATION OF THE PARSER TABLES AND CONSTANTS *) (**********************************************************************) procedure parserinitialization; var z : 0 .. zezuindex; (**********************************************************************) (* PARSERINITIALIZATION . PARSERREAD *) (**********************************************************************) procedure parserread(*TABDAT*); (**********************************************************************) (* FILES : *) (* TABDAT : FILE OF INTEGER; (INPUT) *) (* CONTAINS THE PARSER TABLES *) (**********************************************************************) var i,j : integer; emptyterset : termin_set; emptyerrorset : errorset; (**********************************************************************) procedure zertest(i : integer); begin if tabdat^ <> i then begin er_error_message (5097, er_compiler_error, token.pos, lu_no_symbol); exit(parser); (******* PARSER STOP *******) end; get(tabdat); end; (* ZERTEST *) (**********************************************************************) procedure zuterset(var t : termin_set; i : terminalsymbol); var j : 0..zetindex; begin j:=i div zemax2bits; t[j]:=t[j]+[i mod zemax2bits]; end; (* ZUTERSET *) (**********************************************************************) procedure zufeset(var f : errorset; i : errorsymbol); var j : 0..zefindex; begin j:=i div zemax2bits; f[j]:=f[j]+[i mod zemax2bits]; end; (* ZUFESET *) (**********************************************************************) procedure parser_2_read; begin zertest( -13); for i := 0 to zemaxterminalcode do begin tv[i] := tabdat^; get(tabdat); znrtv[i] := tabdat^; get(tabdat); pnrtv[i] := tabdat^; get(tabdat); gt[i] := tabdat^; get(tabdat); end; zertest(-14); for i:=1 to zeanzotzst do for j:=1 to zeanzots do begin ttab[i,j] := tabdat^; get(tabdat); end; zertest( -15); reset(tabdat); end; (* PARSER_2_READ *) begin (* PARSERREAD *) writeln('Initialising Parser Tables...Takes about 10 minutes'); for i:=0 to zetindex do emptyterset[i]:=[]; for i:=0 to zefindex do emptyerrorset[i] := []; semklammer:=emptyterset; overread:=emptyterset; for i := 0 to 4 do zuterset( overread, i); zuterset( semklammer, 5); zuterset( semklammer, 13); zuterset( semklammer, 17); zuterset( semklammer, 24); zuterset( semklammer, 29); zuterset( semklammer, 30); zuterset( semklammer, 45); zuterset( semklammer, 48); zuterset( semklammer, 59); reset(tabdat, '#5:tabdat.t' ); for i:=1 to zeanzzst do begin fsymbol[i] := tabdat^; get(tabdat); rsymbol[i] := tabdat^; get(tabdat); end; zertest( -1 ); for i:=1 to zeanzonzst do for j:=1 to zeanzons do begin ntab[i,j] := tabdat^; get(tabdat); end; zertest( -2 ); for i:=1 to zeanzzst do begin znv[i] := tabdat^; get(tabdat); fn[i] := tabdat^; get(tabdat); end; zertest( -3 ); for i:=1 to zeanznt do begin nv[i] := tabdat^; get(tabdat); znrnv[i] := tabdat^; get(tabdat); pnrnv[i] := tabdat^; get(tabdat); gn[i] := tabdat^; get(tabdat); end; zertest( -4 ); for i:=1 to zeanzzst do begin fez[i] := tabdat^; get(tabdat); end; zertest( -5 ); for i:=0 to zemaxterminalcode do begin fes[i] := tabdat^; get(tabdat); end; zertest( -6 ); for i:=1 to zemaxfez do begin error[i] := emptyerrorset; while tabdat^ <> -8 do begin zufeset(error[i], tabdat^); get(tabdat); end; get(tabdat); end; zertest( -9 ); for i:=1 to zeanzzst do begin ptla[i] := tabdat^; get(tabdat); end; zertest( -10); for i:=0 to zemaxprodnrliste do begin ptl[i] := tabdat^; get(tabdat); end; zertest( -11); for i:=1 to zeanzprod do begin ls[i] := tabdat^; get(tabdat); lengthrs[i] := tabdat^; get(tabdat); end; zertest( -12); for i:=1 to zeanzzst do begin ztv[i] := tabdat^; get(tabdat); ft[i] := tabdat^ ; get(tabdat); end; parser_2_read; end; begin (* PARSERINITIALIZATION *) if not morefiles then parserread; for z := 0 to zezuindex do emptystateset [ z ] := [ ]; end (* PARSERINITIALIZATION *) ; (**********************************************************************) (* SYNTAX ERROR RECOVERY *) (**********************************************************************) procedure errorhandling ( var stack : parserstack; var pointer : stackpointer; var token : token_type; var entry : table_entry); (**********************************************************************) (* ERRORHANDLING . SEARCHRESTART *) (**********************************************************************) procedure searchrestart ; var starkestates , schwachestates : statesset ; gefunden : boolean ; zz : 0 .. zeanzzst; e : table_entry; schwach : boolean; (**********************************************************************) (* ERRORHANDLING . SEARCHRESTART . REACHABLESTATES *) (**********************************************************************) procedure reachablestates; var kel : parserstack; peg : stackpointer; e : table_entry; t : terminalsymbol; starkephase : boolean ; begin (* REACHABLESTATES *) schwachestates := emptystateset; starkestates := emptystateset ; starkephase := true ; kel := stack ; peg := pointer - 1; e . nextstate := stack [ pointer ] ; repeat if peg = stackend then begin er_error_message (5099, er_comp_restriction, token.pos, lu_no_symbol); (*************************) exit(parser); (* PARSER STOP*) (*************************) end; peg := peg + 1; kel [ peg ] := e . nextstate ; if instateset ( schwachestates , e . nextstate ) then t := fsymbol [ e . nextstate ] else t := rsymbol [ e . nextstate ] ; tostateset ( schwachestates , e . nextstate ); if starkephase then tostateset ( starkestates , e . nextstate ); ttable ( e . nextstate , t , e ); if e . action = reduce then begin peg := peg - 1; e . action := readreduce end else if inset ( semklammer , t ) then starkephase := false; while e . action = readreduce do begin peg := peg - lengthrs [ e . product_snr ] + 1 ; ntable ( kel [ peg ] , ls [ e . product_snr ] , e ); end; until is_stopentry(e); end (* REACHABLESTATES *) ; begin (* SEARCHRESTART *) ; reachablestates; gefunden := false; repeat if token . syntaxcode = zestopsymbol then gefunden := true else if not inset ( overread , token . syntaxcode ) then begin schwach := inset ( semklammer , token . syntaxcode ); zz := 0; repeat zz := zz + 1; if schwach then gefunden := instateset ( schwachestates , zz ) else gefunden := instateset ( starkestates , zz ); if gefunden then begin ttable ( zz , token . syntaxcode , e ); if not ( e . action in [ read , readreduce ] ) then gefunden := false; end; until gefunden or ( zz = zeanzzst ); end; if not gefunden then begin la_next_sym (token.symbol, token.pos); token.syntaxcode := ord (token.symbol.sym); end; until gefunden; er_error_message (5001, er_reset_position, token . pos, lu_no_symbol); end (* SEARCHRESTART *) ; (**********************************************************************) (* ERRORHANDLING . REACHRESTART *) (**********************************************************************) procedure reachrestart; var aktivestates : statesset; t : terminalsymbol; e : table_entry; fdeskr : token_type; eingefuegt : boolean; peg : stackpointer; l : lu_lexical_unit; begin (* REACHRESTART *) aktivestates := emptystateset; e . nextstate := stack [ pointer ]; pointer := pointer - 1; repeat if pointer = stackend then begin er_error_message (5099, er_comp_restriction, token.pos, lu_no_symbol); (************************) exit(parser); (* PARSER STOP *) (*************************) end; pointer := pointer + 1; stack [ pointer ] := e . nextstate; ttable ( e . nextstate , token . syntaxcode , entry ); if not ( entry . action in [ read , readreduce ] ) then begin if instateset ( aktivestates , e . nextstate ) then t := fsymbol [ e . nextstate ] else t := rsymbol [ e . nextstate ]; tostateset ( aktivestates , e . nextstate ); ttable ( e . nextstate , t , e ); if e . action = reduce then begin pointer := pointer - 1; e . action := readreduce end else begin fdeskr.pos := token.pos; fdeskr.syntaxcode := t; l := lu_identifier_sym; while ord (l) <> t do begin l := succ (l); end; lu_error_symbol (l, fdeskr.symbol); er_error_message (5002, er_sym_inserted, fdeskr.pos, fdeskr.symbol); end; while e . action = readreduce do begin pointer := pointer - lengthrs [ e . product_snr ] + 1; ntable(stack[ pointer ], ls[ e . product_snr ], e); end; end; until ( entry . action in [ read , readreduce ] ) or is_stopentry(e); if is_stopentry(e) then begin entry := e; end; end (* REACHRESTART *); (**********************************************************************) (* START ERRORHANDLING *) (**********************************************************************) begin (* ERRORHANDLING *) er_error_message (5000, er_syntax_error, token.pos,lu_no_symbol); searchrestart; reachrestart; end (* ERRORHANDLING *) ; (**********************************************************************) (* START PARSER *) (**********************************************************************) begin (* PARSER *) pointer := 0; entry . nextstate := startstate; parserinitialization; la_next_sym (token.symbol, token.pos); token.syntaxcode := ord (token.symbol.sym); repeat if pointer = stackend then begin er_error_message (5099, er_comp_restriction, token.pos, lu_no_symbol); (************************) goto 1; (* PARSER STOP*) (*************************) end; pointer := pointer + 1; stack [ pointer ] := entry . nextstate; ttable ( entry . nextstate , token . syntaxcode , entry ); if entry . action = handleerror then errorhandling ( stack , pointer , token , entry ); if entry . action = reduce then begin pointer := pointer - 1; entry . action := readreduce end else begin la_next_sym (token.symbol, token.pos); token.syntaxcode := ord (token.symbol.sym); end; while entry . action = readreduce do begin pointer := pointer - lengthrs [ entry . product_snr ] + 1; ntable( stack[ pointer ], ls[ entry . product_snr ], entry ); end; until is_stopentry(entry); (**************************************) 1: (* PARSER STOP*) (***************************************) end (* PARSER *) ; (**********************************************************************) ======================================================================================== DOCUMENT :usus Folder:VOLUK03:stget.text ======================================================================================== (*-------------------------------------------------------------------*) function st_get_sub_code; (* (STR : STRING; FIRSTC, LASTC : INTEGER; ENTER : BOOLEAN) : ST_SYMBOL; *) (*-------------------------------------------------------------------*) (* -*) (* DESCRIPTION: THE STRING IN STR (FIRSTC..LASTC) IS SEARCHED. -*) (* ------------ IF IT IS ALREADY IN THE TABLE THE CODE IS -*) (* RETURNED. OTHERWISE IF ENTER IT IS STORED IN THE TEXTTABLE AND-*) (* IN THE HASHTABLE. THE HASHTABLE INDEX IS THE ST_SYMBOL. -*) (* HASH FUNCTION IS THE SUM OF THE FIRST 8 CHARACTER. -*) (* REHASHING IS DONE BY ADD-THE-HASH-REHASH (SEE [GRIES]). -*) (* 44hhPP -*) (*-------------------------------------------------------------------*) label 1410; var this : stb_s_tab_rec; last_char, length, hash : integer; epos, ind : st_symbol; flag : boolean; loop_i, loop_j : integer; function hashval : integer ; (* THE HASH FUNCTION IS THE SUM OF THE FIRST 8 CHAR*) var loop_i, sum, e : integer; begin sum := 0; if last_char >= firstc + 8 then e := firstc + 7 else e := last_char; (*END IF;*) for loop_i := firstc to e do sum := sum + ord (str [loop_i]); (*END LOOP;*) sum := sum mod st_sym_ubound; if sum = 0 then sum := 12; (*END IF;*) hashval := sum; end; (* HASHVAL;*) begin (*----------------- ST_GET_SUB_CODE ---------------------- *) if lastc < firstc-1 then (* ADJUST LASTC FOR ALL EMPTY STRINGS*) last_char := firstc - 1 else last_char := lastc; (*END IF;*) hash := hashval; epos := hash; length := last_char - firstc + 1; for loop_i := 1 to st_sym_ubound do begin (*NUMBER OF REHASH POSSIBILITIES*) ind := 1 + epos; this := stb_s_tab_entries [ind]; if this.textb = stb_empty then begin if enter then begin if stb_str_ubound < stb_number_char + length then begin if not stb_texttable_full then (* ALREADY MESSAGED?*) begin er_error_message (1401, er_comp_restriction, so_nil_position, lu_no_symbol ); stb_texttable_full := true; end; (*END IF;*) length := 0; end; (*END IF;*) stb_s_tab_entries [ind].textb := stb_number_char + 1; stb_s_tab_entries [ind].texte := stb_number_char + length; for loop_j := stb_number_char + 1 to stb_number_char + length do stb_s_tab_strings [ loop_j ] := str [firstc + loop_j - (stb_number_char + 1) ]; stb_number_char := stb_number_char + length; st_get_sub_code := ind; goto 1410; end (*RETURN IND;*) else st_get_sub_code := st_nil; goto 1410; (*RETURN ST_NIL;*) end (*END IF;*) else if length = this.texte - this.textb + 1 then begin flag := true; for loop_j := firstc to lastc do flag := flag and (str [loop_j] = stb_s_tab_strings [this.textb + loop_j - firstc]); if flag then (* SYMBOL HAS ALREADY BEEN ENTERED*) begin st_get_sub_code := ind; goto 1410; end; end; (*RETURN IND;*) (*END IF;*) (*END IF;*) (* LAST ALTERNATIVE REHASH*) epos := (epos + hash) mod st_sym_ubound; end; (*END LOOP;*) (* NOW THE HASH TABLE MUST BE FULL*) if not stb_hashtable_full then begin er_error_message (1400, er_comp_restriction, so_nil_position, lu_no_symbol ); stb_hashtable_full := true; end; (*END IF;*) st_get_sub_code := st_nil; goto 1410; (*RETURN ST_NIL;*) 1410 : end; (* ST_GET_SUB_CODE;*) (* -*) (*-------------------------------------------------------------------*) (*------------------------------------------------------------------*) function st_get_code; (*(STR : ST_LITERAL; L : INTEGER):ST_SYMBOL;*) var s : string; i : integer; begin for i := sfirst to l do s[i] := str[i]; st_get_code := st_get_sub_code (s, sfirst, l, true); end; (* ST_GET_CODE;*) (*-------------------------------------------------------------------*) function st_get_char_code; (*(CHR : CHAR) : ST_SYMBOL;*) var str : string ; begin str [sfirst] := chr; st_get_char_code := st_get_sub_code (str, sfirst, sfirst, true); end ; (* ST_GET_CHAR_CODE;*) (*---------------------------------------------------------------------------*) procedure st_get_string; (* (CODE : ST_STRING; VAR STR : STRING; VAR OUTP_LAST_CHAR : INTEGER); *) var e : stb_s_tab_rec; loop_j :integer; begin e := stb_s_tab_entries [code]; outp_last_char := e.texte - e.textb + sfirst; for loop_j := sfirst to outp_last_char do str [loop_j] := stb_s_tab_strings [e.textb + loop_j - sfirst]; end; (* ST_GET_STRING;*) ======================================================================================== DOCUMENT :usus Folder:VOLUK03:textdat.text ======================================================================================== 29 29 5 5 22 22 21 21 82 82 82 82 82 82 54 54 54 54 54 54 22 22 24 24 24 24 24 24 24 24 24 24 24 24 24 24 22 22 22 22 24 24 24 24 24 24 24 24 82 82 82 82 82 82 34 34 82 82 82 82 82 82 82 82 82 82 82 82 82 82 82 82 50 50 82 82 82 82 82 82 10 10 10 10 77 77 70 70 10 10 10 10 4 4 81 81 93 93 93 93 93 93 93 93 93 93 61 61 81 81 82 82 93 93 82 82 82 82 82 82 34 34 61 61 82 82 81 81 81 81 81 81 0 0 24 24 81 81 81 81 81 81 81 81 82 82 82 82 82 82 82 82 81 81 81 81 0 0 82 82 13 13 73 73 57 57 0 0 34 34 50 50 12 12 77 77 36 36 82 82 82 82 81 81 64 64 82 82 82 82 82 82 82 82 10 10 82 82 82 82 82 82 82 82 34 34 82 82 82 82 10 10 82 82 63 63 82 82 10 10 10 10 10 10 81 81 10 10 82 82 77 77 82 82 77 77 29 29 29 29 48 48 85 85 82 82 82 82 82 82 82 82 82 82 82 82 82 82 89 89 89 89 89 89 89 89 24 24 24 24 24 24 24 24 24 24 36 36 36 36 13 13 13 13 24 24 24 24 24 24 24 24 60 60 60 60 22 22 24 24 24 24 22 22 24 24 22 22 82 82 82 82 82 82 82 82 34 34 82 82 82 82 82 82 82 82 82 82 24 24 24 24 13 13 13 13 24 24 13 13 24 24 13 13 24 24 24 24 13 13 13 13 13 13 13 13 54 54 54 54 54 54 54 54 54 54 82 82 81 81 81 81 24 24 81 81 93 93 24 24 81 81 81 81 81 81 10 10 34 34 82 82 81 81 81 81 82 82 82 82 45 45 48 48 49 49 24 24 4 4 4 4 4 4 4 4 82 82 82 82 24 24 82 82 82 82 24 24 82 82 4 4 10 10 10 10 4 4 82 82 82 82 82 82 10 10 10 10 24 24 82 82 82 82 89 89 89 89 82 82 34 34 87 87 33 33 82 82 53 53 34 34 89 89 69 69 82 82 34 34 34 34 82 82 82 82 34 34 53 53 34 34 82 82 34 34 34 34 89 89 34 34 10 10 89 89 82 82 34 34 82 82 4 4 4 4 4 4 4 4 4 4 61 61 75 75 4 4 37 37 4 4 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 82 82 82 82 4 4 4 4 4 4 4 4 0 0 4 4 73 73 4 4 73 73 4 4 0 0 0 0 0 0 4 4 4 4 4 4 15 15 56 56 0 0 56 56 32 32 82 82 82 82 56 56 82 82 15 15 51 51 51 51 36 36 82 82 82 82 82 82 82 82 0 0 24 24 82 82 82 82 64 64 0 0 4 4 4 4 4 4 4 4 4 4 4 4 4 4 82 82 4 4 4 4 0 0 24 24 0 0 24 24 38 38 57 57 47 47 57 57 47 47 24 24 4 4 0 0 0 0 38 38 38 38 0 0 47 47 0 0 4 4 4 4 4 4 4 4 4 4 4 4 33 33 82 82 82 82 4 4 4 4 7 7 18 18 4 4 4 4 22 22 14 14 0 0 14 14 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 82 82 4 4 73 73 4 4 73 73 4 4 82 82 0 0 0 0 4 4 4 4 4 4 4 4 4 4 4 4 4 4 82 82 4 4 4 4 82 82 82 82 82 82 7 7 82 82 82 82 82 82 75 75 0 0 0 0 0 0 14 14 0 0 82 82 0 0 0 0 4 4 4 4 0 0 0 0 0 0 4 4 4 4 43 43 43 43 43 43 4 4 4 4 4 4 48 48 4 4 4 4 4 4 4 4 4 4 4 4 0 0 81 81 82 82 0 0 0 0 3 3 73 73 4 4 4 4 0 0 0 0 81 81 4 4 4 4 4 4 43 43 43 43 4 4 82 82 41 41 41 41 45 45 82 82 22 22 0 0 0 0 29 29 3 3 4 4 4 4 4 4 4 4 4 4 4 4 0 0 0 0 4 4 4 4 4 4 4 4 4 4 13 13 4 4 26 26 0 0 0 0 4 4 4 4 4 4 4 4 0 0 0 0 0 0 0 0 0 0 4 4 4 4 4 4 4 4 -1 0 0 18 3 12 0 3 0 3 3 0 4 60 3 0 0 2 0 4 3 6 3 0 4 7 6 2 7 2 5 6 30 2 5 3 4 3 4 0 0 0 3 0 0 2 0 3 3 0 2 60 5 0 0 2 0 4 0 0 0 0 2 0 4 0 3 0 0 0 62 5 0 0 0 0 0 0 0 0 5 0 0 6 0 3 0 0 0 38 5 0 0 0 3 0 0 3 0 3 20 0 3 0 3 3 0 4 60 5 0 0 2 0 4 0 5 0 3 20 0 8 0 3 3 0 4 60 5 0 0 2 0 4 2 2 5 3 20 5 8 4 9 3 5 4 60 3 7 4 2 3 4 0 8 24 3 0 0 4 3 3 3 0 0 60 3 0 0 2 3 2 0 4 8 4 6 7 8 0 3 2 0 0 38 3 0 0 0 3 2 0 10 3 6 4 3 6 2 7 4 5 4 38 5 5 0 4 3 4 0 12 10 16 8 0 2 2 3 8 3 6 34 3 3 0 4 3 4 2 3 5 3 16 5 8 2 11 3 5 4 10 9 7 4 2 4 4 0 7 18 3 20 0 2 0 3 3 0 4 60 3 0 0 2 0 4 0 0 18 3 6 0 5 0 3 3 0 4 60 3 0 0 2 0 4 0 0 2 3 16 3 4 5 3 3 0 4 44 3 0 0 2 3 4 0 0 20 10 0 0 8 0 3 5 0 0 38 3 0 0 0 3 0 0 0 18 12 0 0 4 0 3 0 0 0 38 3 0 0 0 3 0 0 0 4 5 0 0 0 0 3 3 0 0 60 3 0 0 2 0 0 0 0 6 3 3 0 0 0 3 3 0 4 60 3 0 0 2 0 4 0 0 12 3 2 0 0 0 3 3 0 4 60 3 0 0 2 0 4 0 2 16 3 20 0 0 2 3 3 0 4 60 3 0 0 2 0 4 0 2 22 3 20 0 0 16 3 3 0 4 60 3 0 0 2 0 4 0 0 26 3 10 0 0 0 3 3 0 4 60 3 0 0 2 0 4 0 9 28 3 20 0 0 0 3 3 0 4 60 3 0 0 2 0 4 0 0 14 3 8 0 0 0 3 3 0 4 60 3 0 0 2 0 4 0 0 0 0 4 0 0 0 0 0 0 0 18 0 0 0 0 0 0 0 2 0 3 20 0 0 18 0 3 0 4 60 0 0 0 2 0 4 0 0 0 3 16 5 0 3 0 3 0 4 10 0 0 0 2 0 4 0 0 0 8 0 0 0 0 0 0 0 0 38 0 0 0 0 3 0 0 0 0 3 4 0 0 0 0 3 0 4 60 0 0 0 2 0 4 0 0 0 7 0 0 0 0 0 0 0 0 38 0 0 0 0 3 0 0 0 0 9 0 0 0 0 0 0 0 0 38 0 0 0 0 3 0 0 0 0 11 0 0 0 0 0 0 0 0 38 0 0 0 0 3 0 0 11 0 3 20 0 0 0 0 3 0 4 60 0 0 0 2 0 4 0 13 0 3 20 0 0 0 0 3 0 4 60 0 0 0 2 0 4 0 0 0 0 2 0 0 0 0 0 0 0 18 0 0 0 0 0 0 0 0 0 3 16 2 0 0 0 3 0 4 60 0 0 0 2 0 4 0 0 0 3 16 7 0 0 0 3 0 4 60 0 0 0 2 0 4 0 0 0 2 0 0 0 0 0 0 0 0 38 0 0 0 0 3 0 0 0 0 13 0 0 0 0 0 0 0 0 38 0 0 0 0 3 0 0 2 0 3 20 0 0 14 0 3 0 4 60 0 0 0 2 0 4 0 0 0 18 0 0 0 0 0 0 0 0 38 0 0 0 0 3 0 0 0 0 3 16 5 0 5 0 3 0 4 10 0 0 0 2 0 4 0 15 0 3 20 0 0 0 0 3 0 4 60 0 0 0 2 0 4 0 17 0 3 20 0 0 0 0 3 0 4 60 0 0 0 2 0 4 0 2 0 3 20 0 0 20 0 3 0 4 60 0 0 0 2 0 4 0 0 0 0 4 0 0 0 0 0 0 0 62 0 0 0 0 0 0 0 0 0 3 14 9 2 0 3 3 0 4 56 0 0 0 2 0 4 0 0 0 3 14 9 4 0 3 3 0 4 56 0 0 0 2 0 4 0 0 0 0 3 0 0 0 0 0 0 0 8 0 0 0 0 0 0 0 2 0 3 20 0 0 3 0 3 0 4 60 0 0 0 2 0 4 0 2 0 3 20 0 0 8 0 3 0 4 60 0 0 0 2 0 4 0 2 0 3 20 0 0 5 0 3 0 4 60 0 0 0 2 0 4 0 0 0 0 6 0 0 0 0 0 0 0 62 0 0 0 0 0 0 0 19 0 3 20 0 0 0 0 3 0 4 60 0 0 0 2 0 4 0 21 0 3 20 0 0 0 0 3 0 4 60 0 0 0 2 0 4 0 0 0 3 5 0 0 0 0 3 0 4 60 0 0 0 2 0 4 0 0 0 3 16 5 0 7 3 3 0 4 16 0 0 0 2 0 4 0 2 0 3 18 9 10 22 3 3 0 4 56 2 0 0 2 0 4 0 2 0 3 18 4 8 7 3 3 0 4 52 3 0 0 2 5 4 0 2 0 3 18 9 10 26 3 3 0 4 56 2 0 0 2 0 4 0 2 0 3 20 0 0 9 3 3 0 4 60 0 0 0 2 0 4 0 0 0 0 5 0 0 0 0 0 0 0 8 0 0 0 0 0 0 0 0 0 3 14 9 0 0 5 3 0 4 56 0 0 0 2 0 4 0 0 0 0 0 0 0 0 0 3 0 0 60 0 0 0 3 0 0 0 0 0 3 16 5 0 9 0 3 0 4 10 0 0 0 2 0 4 0 0 0 0 0 0 0 0 5 0 0 0 4 0 0 0 0 0 0 0 2 0 3 18 4 8 7 3 3 0 4 52 5 0 0 2 5 4 0 2 0 3 18 9 6 11 3 3 0 4 56 3 0 0 2 0 4 0 2 0 3 18 9 6 11 3 3 0 4 56 5 0 0 2 0 4 0 2 0 3 20 0 0 9 5 3 0 4 60 0 0 0 2 0 4 0 0 0 14 0 0 0 0 0 6 0 0 38 0 0 0 0 3 0 0 0 0 16 0 0 0 0 0 8 0 0 38 0 0 0 0 3 0 0 2 0 3 20 0 0 6 0 3 0 4 60 0 0 0 2 0 4 0 2 0 3 20 0 0 10 0 3 0 4 60 0 0 0 2 0 4 0 2 0 3 20 0 0 13 0 3 0 4 60 0 0 0 2 0 4 0 2 0 3 20 0 0 12 0 3 0 4 60 0 0 0 2 0 4 0 2 0 3 20 0 0 15 0 3 0 4 60 0 0 0 2 0 4 0 2 0 3 20 0 0 17 0 3 0 4 28 0 0 0 2 7 4 0 2 0 3 20 0 0 24 0 3 0 4 60 0 0 0 2 0 4 0 2 0 3 20 0 0 19 0 3 0 4 60 0 0 0 2 0 4 -2 1 7 2 1 1 7 2 7 3 7 3 7 3 7 3 7 3 7 4 7 3 7 3 7 3 7 3 7 3 7 3 7 3 7 4 7 3 7 3 7 5 7 3 7 6 7 7 7 2 7 12 7 12 7 13 7 2 1 6 1 15 7 3 1 5 1 7 1 9 1 8 7 8 7 13 7 13 7 11 7 3 1 8 7 11 7 12 7 2 1 2 1 9 7 16 7 17 7 18 7 19 7 20 7 3 7 10 7 13 7 13 7 4 7 5 7 6 7 7 7 21 7 15 7 21 7 22 7 23 7 24 7 2 1 23 7 10 7 11 7 26 7 24 7 4 1 8 1 10 1 12 1 14 7 25 7 22 7 27 7 4 1 46 1 6 1 6 1 9 7 31 7 32 7 33 7 10 7 35 7 36 7 10 7 38 7 39 7 39 7 40 7 41 7 11 7 43 7 44 7 11 7 17 7 11 7 46 7 47 7 11 7 49 7 50 7 51 7 2 7 53 7 7 1 55 7 56 7 57 7 58 7 13 7 8 7 5 5 5 3 12 7 13 7 61 7 62 7 63 7 64 7 65 7 66 7 8 7 2 7 18 7 16 7 17 7 12 7 68 7 2 1 70 7 71 7 2 1 4 1 74 7 73 7 74 7 73 7 12 7 75 7 13 7 8 7 2 1 4 1 20 7 79 7 14 7 15 7 82 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 2 7 2 7 11 7 7 7 2 1 7 7 2 1 6 1 8 7 8 7 8 7 2 1 13 7 13 7 11 7 9 7 12 7 11 7 12 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 10 7 10 7 2 7 6 1 16 7 17 7 18 7 19 7 7 7 2 1 7 7 7 7 7 7 7 7 7 7 20 7 2 1 2 1 3 7 7 7 7 7 7 7 2 1 2 1 7 7 7 7 7 7 7 7 7 7 10 7 7 7 7 7 7 7 4 1 3 1 2 1 7 7 7 7 2 1 7 7 7 7 13 7 4 1 2 1 7 7 7 7 3 1 4 1 7 7 7 7 7 7 7 7 7 7 13 7 7 7 7 7 4 7 2 1 5 7 6 7 7 7 7 7 7 7 21 7 7 7 15 7 21 7 22 7 23 7 24 7 25 7 7 7 7 7 7 7 7 7 7 7 7 7 2 1 23 7 10 7 11 7 3 3 26 7 7 7 24 7 7 7 1 7 26 7 10 7 12 7 14 7 25 7 22 7 7 7 7 7 7 7 7 7 7 7 2 1 4 1 7 7 7 7 7 7 7 7 7 7 7 7 3 1 6 1 7 7 5 1 7 7 2 1 7 7 7 7 27 7 7 7 48 1 2 1 4 1 6 1 8 1 10 1 20 1 7 7 28 7 29 7 7 7 2 1 2 3 2 1 7 7 2 3 13 7 4 3 5 3 2 1 30 7 4 1 4 3 7 7 7 7 4 1 7 7 9 7 31 7 32 7 36 1 40 1 42 1 54 1 7 7 7 7 7 7 33 7 34 7 2 1 2 1 35 7 36 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 2 1 7 7 7 7 7 7 7 7 7 7 37 7 38 7 7 7 39 7 7 7 39 7 7 7 2 1 2 1 12 1 14 1 24 1 26 1 32 1 40 7 41 7 42 7 43 7 44 7 7 7 7 7 7 7 22 3 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 7 16 7 17 7 45 7 46 7 7 7 7 7 7 7 47 7 48 7 49 7 50 7 51 7 52 7 53 7 54 7 2 1 55 7 56 7 57 7 7 7 7 7 58 7 7 7 7 7 7 7 13 7 8 7 7 7 7 7 59 7 60 7 9 7 13 7 61 7 62 7 58 1 63 7 64 7 65 7 66 7 8 7 7 7 7 7 2 7 7 7 18 7 16 7 17 7 5 3 5 1 67 7 68 7 69 7 70 7 71 7 72 7 7 7 7 7 50 1 73 7 74 7 73 7 74 7 2 1 73 7 12 7 2 1 4 1 75 7 76 7 77 7 78 7 5 1 7 7 7 7 19 7 20 7 79 7 80 7 81 7 82 7 -3 2 0 0 2 2 1 0 2 1 2 0 7 4 3 1 7 2 4 1 7 3 10 2 7 6 24 2 7 3 0 4 4 4 27 6 7 3 0 12 7 5 36 14 7 6 0 16 7 6 46 19 7 3 0 19 2 2 47 21 2 7 48 21 7 8 53 21 7 9 66 30 7 13 67 30 7 2 68 30 2 2 69 30 7 2 70 40 2 9 0 40 7 2 71 42 2 10 72 42 7 2 76 44 2 2 77 44 2 7 78 44 7 6 0 44 7 11 0 47 7 11 0 49 7 3 0 51 2 2 80 52 2 6 0 52 7 12 81 54 7 9 0 54 7 13 84 56 7 14 115 56 7 6 116 60 7 4 118 64 2 3 0 64 4 2 120 66 2 15 0 66 7 15 0 68 7 14 121 71 7 15 0 73 7 8 122 75 7 5 123 77 7 7 129 81 7 2 133 81 2 3 134 81 2 3 0 82 2 3 0 83 2 2 135 84 2 7 136 84 7 4 138 84 2 4 140 84 2 7 142 84 7 4 146 85 2 2 148 85 7 7 149 86 7 7 150 86 7 16 152 88 7 5 154 89 7 3 0 89 2 3 0 90 2 7 157 91 7 2 159 91 2 3 0 91 7 5 160 93 7 9 0 93 7 6 164 98 2 3 0 98 4 7 167 100 7 10 170 101 7 4 172 102 2 2 175 102 7 7 176 103 7 3 178 103 2 2 183 104 2 8 184 104 7 2 185 108 2 3 0 108 2 7 186 109 7 3 0 109 2 2 187 111 2 5 0 111 7 2 188 113 2 7 189 113 7 2 190 113 2 2 191 113 2 2 192 113 2 4 0 113 7 17 193 115 7 18 194 116 7 2 196 117 2 14 0 117 7 18 0 119 7 2 197 122 2 3 0 122 2 10 198 123 7 2 199 125 2 17 200 125 7 3 0 125 4 9 0 127 7 2 202 129 2 7 203 129 7 7 204 129 7 7 205 129 7 7 207 129 7 5 208 129 7 7 210 129 7 19 211 129 7 2 213 129 2 10 214 129 7 7 215 130 7 14 0 130 7 12 216 132 7 2 218 132 2 3 0 132 2 7 219 133 7 7 220 133 7 19 222 133 7 7 224 133 7 -4 1 2 3 4 5 5 6 7 7 7 8 9 9 10 10 11 10 11 3 8 11 10 11 11 5 5 5 12 13 13 5 14 14 14 14 15 16 5 5 5 17 17 18 19 20 21 22 23 24 24 24 24 24 25 26 5 27 5 5 5 12 25 5 23 23 23 28 29 30 31 30 23 13 13 13 13 23 23 32 5 33 34 35 36 37 38 39 40 41 42 42 43 44 42 42 42 42 45 46 42 47 42 48 42 42 49 42 50 51 52 53 54 55 53 51 56 5 56 1 1 57 58 5 5 5 5 5 5 5 59 59 59 59 60 61 62 61 61 63 63 64 64 61 61 61 61 65 65 66 66 61 67 10 3 68 68 68 69 12 5 5 70 5 5 71 72 73 64 74 64 75 76 75 75 76 33 33 33 77 78 78 78 77 5 26 79 80 23 24 29 81 82 81 83 12 15 79 23 5 5 84 85 86 28 87 88 88 22 5 89 61 5 5 61 5 87 90 90 22 5 5 5 91 91 29 5 5 59 92 93 12 94 95 69 96 97 59 98 69 12 12 99 15 99 100 12 93 97 12 59 12 101 59 96 12 93 88 88 88 102 87 25 103 87 104 87 105 105 105 105 105 32 32 32 32 5 5 88 87 106 106 36 87 107 87 107 87 105 105 105 87 87 87 108 109 32 109 110 111 111 109 5 108 112 112 63 111 111 113 111 32 29 5 70 114 32 88 88 88 88 88 88 88 5 87 115 116 29 36 29 117 35 118 119 120 80 88 72 73 121 117 122 123 105 87 88 88 88 88 88 95 5 5 88 88 124 125 126 87 127 128 32 129 128 32 128 32 71 32 32 32 32 32 113 87 107 130 107 87 5 131 132 88 88 88 88 88 88 88 133 88 87 5 5 5 134 5 5 5 103 32 135 136 129 135 5 105 105 87 87 32 32 32 137 88 138 138 139 87 87 87 140 88 87 87 88 141 87 32 26 5 87 87 142 107 87 138 32 32 143 138 88 87 139 138 22 93 144 144 145 5 146 32 32 147 142 87 88 138 138 138 87 32 32 88 148 148 88 88 149 150 150 151 151 87 87 87 87 152 32 153 105 105 87 87 87 87 -5 1 2 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 19 20 21 22 23 24 25 6 26 27 28 6 29 30 31 8 32 33 34 35 36 37 38 39 40 41 42 43 27 6 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 17 59 60 61 62 63 64 6 65 64 66 61 67 68 46 69 70 71 46 64 72 64 73 64 74 75 76 64 77 -6 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 29 30 31 32 33 34 35 36 37 38 39 40 43 44 45 46 47 48 49 50 52 53 54 55 56 57 58 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 29 30 31 32 33 34 35 36 37 38 39 40 43 44 45 46 47 48 49 50 52 53 54 55 56 57 58 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 8 9 10 11 12 14 16 19 20 22 24 25 27 28 30 31 33 34 35 37 39 40 41 43 44 45 46 47 49 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 8 9 10 11 12 14 16 19 20 24 25 27 28 30 31 33 34 35 37 38 39 40 41 43 44 45 46 47 49 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 8 9 10 11 12 14 16 19 20 21 22 24 25 27 28 30 31 33 34 35 37 38 39 40 41 43 44 45 46 47 49 51 52 53 54 55 56 57 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 8 9 10 11 12 14 16 19 20 21 22 24 25 27 28 30 31 33 34 35 37 38 39 40 41 43 44 45 46 47 49 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 8 9 10 11 12 14 16 19 20 21 22 24 27 28 30 31 33 34 35 37 38 39 40 41 43 44 45 46 47 49 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 72 73 74 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 33 34 35 36 37 39 40 41 42 43 45 46 48 49 50 51 52 53 54 56 57 58 59 61 62 63 64 65 66 67 68 69 73 74 76 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 64 65 66 68 69 70 71 72 73 74 75 76 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 31 32 33 34 36 37 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 61 62 65 66 68 69 71 73 74 75 76 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 33 34 36 37 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 56 57 58 59 61 62 63 65 66 67 68 69 73 74 75 76 -8 0 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 35 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 71 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 68 69 70 71 72 73 74 75 76 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 -8 0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 56 57 58 59 60 61 62 63 64 65 66 67 68 69 73 74 75 76 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 33 34 35 36 37 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 56 57 58 59 61 62 63 64 65 66 67 68 69 73 74 75 76 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 14 15 16 17 18 19 20 21 22 24 25 26 29 30 31 32 33 34 35 36 37 38 39 40 43 44 45 46 47 48 49 50 51 52 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 14 15 16 17 18 19 20 21 22 23 24 25 29 30 31 32 33 34 35 36 37 38 39 40 43 44 45 46 47 48 49 50 54 55 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 14 15 16 17 18 19 20 21 22 23 24 25 29 30 31 32 33 34 35 36 37 38 39 40 43 44 45 46 47 48 49 50 51 54 55 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 70 71 72 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 70 71 72 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 70 71 72 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 68 69 70 71 72 73 74 75 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 34 35 36 37 38 39 40 41 42 43 45 47 48 49 50 51 52 53 54 55 56 57 58 59 60 64 65 67 71 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 70 72 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 34 35 36 37 38 39 40 41 42 43 45 47 48 49 50 51 52 53 54 55 56 57 58 59 60 64 65 67 71 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 59 60 61 63 64 65 67 68 69 70 72 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 20 21 22 23 24 25 26 27 28 29 31 32 34 36 37 39 40 41 42 43 45 47 48 49 50 51 52 53 54 55 56 57 58 59 63 65 67 71 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 70 72 73 74 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 45 46 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 70 72 73 74 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 45 46 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 72 73 74 77 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 20 21 22 23 24 25 26 27 28 29 30 34 35 36 37 39 40 41 42 43 45 47 48 49 50 51 52 53 54 56 57 58 59 64 65 67 73 74 75 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 58 59 60 61 63 64 65 67 68 69 70 71 72 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 70 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 20 21 22 23 24 25 26 27 28 29 31 32 34 36 37 39 40 41 42 43 45 47 48 49 50 51 52 53 54 55 56 57 58 59 65 71 73 74 75 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 34 36 37 39 40 41 42 43 45 48 49 50 51 52 53 54 56 57 58 59 65 73 74 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 31 32 34 36 37 39 40 41 42 43 45 47 48 49 50 51 52 53 54 55 56 57 58 59 65 71 73 74 75 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 71 72 73 74 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 68 69 71 73 74 75 76 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 29 30 31 32 33 34 35 36 37 38 39 40 42 43 44 45 46 47 48 49 50 52 53 54 55 56 57 58 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 73 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 16 17 18 19 20 21 22 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 8 9 10 11 12 13 14 15 16 17 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 22 24 25 26 27 28 29 30 31 32 33 34 35 36 37 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 24 25 29 30 31 32 33 34 35 36 37 38 39 40 43 44 45 46 47 48 49 50 51 54 55 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 24 25 26 29 30 31 32 33 34 35 36 37 38 39 40 44 45 46 47 48 49 50 51 54 55 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 14 15 16 17 18 19 20 21 22 24 25 29 30 31 32 33 34 35 36 37 38 39 40 43 44 45 46 47 48 49 50 51 54 55 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 14 15 16 17 18 19 20 21 22 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 24 25 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 14 15 16 17 18 19 20 21 22 24 25 29 30 31 32 33 34 35 36 37 38 39 40 43 44 45 46 47 48 49 50 51 52 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 25 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 33 34 35 36 37 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 56 57 58 59 60 61 62 63 64 65 66 67 68 69 73 74 75 76 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 56 57 58 59 61 62 63 64 65 66 67 68 69 73 74 75 76 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 34 36 37 39 40 41 42 43 45 48 49 50 51 52 53 54 56 57 58 59 62 65 66 73 74 76 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 42 43 44 45 46 47 48 49 50 51 52 53 54 55 57 58 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 28 29 30 31 32 33 34 35 36 37 38 39 40 42 43 44 45 46 47 48 49 50 51 52 53 54 55 57 58 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 8 9 10 11 12 14 16 19 20 21 22 23 24 25 27 28 30 31 33 34 35 37 38 39 40 41 42 43 44 45 46 47 49 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 33 34 36 37 39 40 41 42 43 45 46 48 49 50 51 52 53 54 56 57 58 59 62 65 66 69 73 74 76 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 34 36 37 39 40 41 42 43 45 48 49 50 51 52 53 54 56 57 58 59 62 65 66 69 73 74 76 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 31 32 34 36 37 39 40 41 42 43 45 47 48 49 50 51 52 53 54 55 56 57 58 59 65 67 71 73 75 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 63 64 65 67 68 69 70 72 73 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 31 32 34 36 37 39 40 41 42 43 44 45 47 48 49 50 51 52 53 54 55 56 57 58 59 63 65 67 71 73 74 75 -8 0 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 56 57 58 59 60 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 8 9 10 11 12 14 16 19 20 21 22 23 24 25 27 28 30 31 33 34 35 37 38 39 40 41 43 44 45 46 47 49 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 59 60 61 62 63 64 65 66 67 68 69 70 72 73 74 75 76 77 -8 0 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 37 38 39 40 41 42 43 44 45 46 47 48 50 51 52 53 54 55 56 57 58 59 60 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 9 10 12 13 14 15 16 17 18 20 21 22 23 24 25 26 27 28 29 30 31 32 33 35 36 37 38 39 40 41 42 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 14 15 16 17 18 19 20 21 22 24 25 29 30 31 32 33 34 35 36 37 38 39 40 43 44 45 46 47 48 49 50 54 55 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 9 10 12 13 14 15 16 17 18 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 14 15 16 17 18 19 20 21 22 23 24 25 29 30 31 32 33 35 36 37 38 39 40 43 44 45 46 47 48 49 50 54 55 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 24 25 26 29 30 31 32 33 35 36 37 38 39 40 44 45 46 47 48 49 50 51 54 55 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 8 9 10 11 12 13 14 15 16 17 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 55 56 57 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 22 23 24 25 26 27 28 29 30 31 32 33 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 62 63 64 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 16 17 18 19 20 21 22 24 25 26 27 28 29 30 31 32 33 34 35 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 11 13 14 15 16 17 18 19 20 21 22 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 62 63 64 65 67 68 69 70 72 73 74 75 76 77 -8 0 2 3 5 6 8 9 10 11 12 13 14 15 16 17 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 55 56 57 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 5 6 7 8 9 10 11 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 37 38 39 40 41 42 43 44 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 37 38 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 37 38 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 62 63 64 65 67 68 69 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 28 29 30 31 32 33 34 35 36 37 38 39 40 42 43 44 45 46 47 48 49 50 51 52 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 8 9 10 11 12 14 16 19 20 22 23 24 25 27 28 30 31 33 34 35 37 39 40 41 43 44 45 46 47 49 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 29 30 31 32 33 34 35 36 37 38 39 40 42 43 44 45 46 47 48 49 50 52 53 54 55 56 58 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 1 2 3 4 5 6 7 8 9 10 11 12 14 15 16 18 19 20 21 22 23 24 25 27 28 29 30 31 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 12 13 14 15 17 18 19 20 21 22 23 24 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 31 32 33 34 35 36 37 38 39 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 67 68 69 70 71 72 73 74 75 76 77 -8 0 2 3 4 5 6 7 8 9 10 11 12 13 14 16 17 18 19 20 21 22 24 25 26 27 28 29 30 31 32 33 34 35 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 -8 -9 0 1 3 5 6 6 6 6 6 6 6 8 10 12 14 15 17 18 20 22 24 26 27 29 31 31 31 31 31 32 33 33 34 35 36 37 38 38 38 38 38 39 40 41 41 43 44 44 44 44 44 44 44 44 44 44 44 44 44 44 44 44 44 44 45 46 47 48 48 49 50 51 51 52 53 54 55 55 55 55 55 56 56 57 58 58 58 58 59 61 61 61 63 64 64 64 64 64 65 65 65 66 66 67 67 67 69 69 69 70 71 72 73 73 74 75 77 77 79 80 81 81 81 81 81 81 81 81 81 81 81 81 81 81 82 82 83 83 83 83 83 83 83 83 83 83 83 83 83 84 85 85 85 87 89 89 89 89 89 89 89 89 89 89 89 90 91 92 92 93 93 94 95 96 96 97 98 99 100 101 102 103 104 105 105 105 105 106 106 106 107 108 109 110 111 111 112 112 112 112 112 112 112 114 114 114 114 114 114 114 115 115 115 115 115 115 115 116 117 117 117 117 117 118 119 119 119 119 119 120 121 121 121 121 122 123 123 123 124 125 125 125 126 127 128 128 128 129 130 130 130 130 131 131 132 132 132 132 132 132 132 132 132 132 132 132 132 133 134 135 136 137 137 137 137 137 137 137 137 137 137 137 138 138 138 138 138 138 139 140 141 141 141 141 141 141 141 141 141 142 143 143 143 143 143 143 143 144 145 146 147 147 148 148 148 149 149 149 149 149 149 149 149 149 149 149 149 150 151 152 153 153 154 154 155 155 156 156 157 158 159 159 160 160 161 161 161 161 161 161 161 161 161 161 161 161 162 162 162 162 162 162 162 162 162 162 162 162 163 163 163 163 163 163 164 164 164 164 164 164 164 165 166 166 166 166 166 166 166 166 166 166 166 166 166 166 167 167 167 167 167 167 167 167 167 167 167 168 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 169 170 170 170 170 170 172 172 172 173 173 173 173 173 173 173 173 173 173 173 173 173 173 173 175 175 175 176 177 177 177 177 177 177 177 178 179 180 180 180 180 -10 1 276 277 276 278 279 280 278 281 278 282 278 283 278 284 278 278 285 278 278 285 278 286 278 287 278 285 278 278 285 278 285 288 288 288 288 288 288 12 289 289 290 291 290 291 26 28 26 292 293 294 295 288 288 288 288 296 297 297 298 289 299 299 289 300 299 301 301 301 299 302 299 303 299 299 304 59 58 64 305 306 306 307 308 309 308 278 279 278 279 310 311 312 313 314 314 315 316 296 317 318 280 280 280 280 280 314 319 320 321 322 323 117 324 325 326 327 328 329 330 134 280 331 280 134 331 280 331 332 280 332 134 280 278 278 278 278 278 297 278 278 278 333 333 333 333 334 333 335 336 337 338 297 339 297 297 340 297 297 159 297 278 341 297 336 342 343 341 278 278 280 278 279 344 324 325 345 345 342 278 278 -11 53 1 70 3 122 5 113 7 68 1 102 1 21 3 8 2 68 2 25 6 25 6 70 5 98 2 68 1 21 3 39 3 10 3 10 3 81 2 94 1 115 3 121 2 56 2 97 1 23 1 45 1 48 2 45 3 97 3 23 3 22 3 22 3 92 4 92 4 90 3 90 3 20 4 20 4 91 3 91 3 24 1 24 3 68 1 102 1 33 1 77 1 41 6 41 2 29 1 41 2 29 1 29 1 33 1 77 1 16 1 16 3 12 1 98 2 36 2 68 1 21 3 81 1 38 2 36 1 2 3 2 2 41 2 66 1 41 2 66 1 77 1 15 3 15 3 50 2 66 1 82 1 82 3 101 5 101 5 47 4 47 4 124 5 51 2 117 2 112 3 61 4 60 2 60 2 120 1 42 5 72 2 66 1 77 1 117 1 40 2 66 1 76 2 78 2 72 2 65 1 57 2 76 2 78 2 80 1 56 4 56 5 27 1 27 3 84 2 86 1 86 3 88 1 88 3 123 1 123 3 93 3 5 1 99 1 99 3 9 1 97 1 97 3 103 2 96 1 96 3 68 1 102 1 26 1 26 3 94 1 6 1 6 2 117 2 37 1 4 1 7 1 79 1 4 3 37 3 85 1 49 3 49 3 37 3 94 1 94 1 94 1 85 1 37 1 4 1 79 1 4 3 37 3 37 3 103 1 108 1 108 2 35 6 35 4 35 3 28 4 110 1 119 1 94 1 36 1 87 1 109 2 109 1 104 1 104 2 68 4 110 1 119 1 13 1 116 1 102 2 102 2 105 3 102 2 116 1 119 1 13 1 13 1 110 1 14 3 4 4 115 5 14 5 94 3 67 3 68 3 95 3 37 4 102 3 37 3 83 7 83 4 3 4 32 11 3 8 31 9 66 5 18 4 75 6 63 3 120 4 66 6 66 6 120 3 75 5 53 3 66 6 66 6 120 3 66 5 66 5 120 2 66 4 43 6 43 6 44 6 100 4 107 7 46 2 66 6 66 6 66 6 66 6 46 5 46 5 120 3 73 3 66 4 66 6 100 3 43 2 43 3 30 8 100 2 100 6 120 3 44 3 44 2 120 2 120 4 69 5 69 4 53 9 53 6 71 3 52 7 53 7 53 6 66 4 66 4 53 9 51 2 120 2 75 9 120 2 53 10 53 9 53 8 34 6 34 6 34 3 60 2 100 4 71 6 110 1 116 1 116 1 106 4 116 1 116 1 59 3 40 0 1 1 106 0 62 0 5 0 54 5 19 5 89 5 55 2 58 0 62 1 54 0 48 0 12 0 36 1 21 1 107 0 17 1 17 1 17 1 78 0 72 0 87 1 94 1 111 1 9 1 64 3 94 2 64 1 97 1 42 0 52 0 55 0 61 0 114 2 114 0 74 1 112 0 76 0 114 4 74 3 74 5 74 3 58 2 17 1 17 1 17 1 93 1 57 0 56 0 121 0 11 2 11 1 118 3 118 1 122 0 67 0 7 0 80 0 89 0 111 0 109 1 124 0 19 0 84 0 59 0 50 0 18 0 65 0 109 0 -12 5 1 8 3 1 5 2 5 4 1 7 1 3 5 3 1 6 1 12 1 1 5 1 5 1 5 1 5 4 5 1 5 5 5 1 5 1 5 1 5 1 5 6 5 1 5 1 5 13 1 16 1 19 1 4 1 7 5 7 5 22 1 7 5 7 5 7 5 7 5 8 5 3 1 25 1 28 1 31 1 9 5 9 5 10 5 3 1 11 5 9 5 12 5 13 5 14 5 6 1 15 5 12 5 16 5 3 1 7 1 34 1 4 1 37 1 40 1 43 1 9 1 6 1 46 1 17 5 18 5 19 5 5 1 8 5 20 5 10 5 21 5 22 5 7 5 7 5 7 5 7 5 9 1 6 1 6 1 49 1 5 1 23 5 24 5 5 1 25 5 25 5 23 5 23 5 9 5 26 5 27 5 1 5 23 5 25 5 28 5 29 5 17 5 30 5 1 5 18 5 20 5 19 5 10 5 31 5 24 5 9 5 32 5 23 5 23 5 30 5 23 5 30 5 25 5 33 5 23 5 1 5 85 1 1 5 15 5 15 5 33 5 18 1 88 1 91 1 94 1 97 1 100 1 103 1 106 1 12 5 25 5 7 5 24 1 10 5 33 1 14 5 15 1 24 1 3 1 3 1 3 1 9 1 9 1 18 1 27 1 48 1 3 1 3 1 5 1 14 5 6 1 6 1 1 5 1 5 14 5 15 5 6 5 30 5 24 1 118 1 121 1 16 5 127 1 124 1 2 5 2 5 28 5 6 1 33 5 15 1 5 1 5 1 34 5 15 5 34 5 5 1 14 5 14 5 6 5 7 5 7 5 7 5 6 5 130 1 3 1 4 5 5 3 28 5 25 5 14 5 20 5 20 5 21 5 34 5 7 1 35 5 5 5 29 5 133 1 136 1 22 5 22 5 8 5 23 5 12 5 4 1 4 1 12 5 139 1 34 5 45 1 142 1 145 1 51 1 148 1 12 5 36 5 36 5 12 5 151 1 154 1 157 1 2 5 2 5 3 1 160 1 163 1 4 5 16 5 35 5 6 1 4 1 3 1 37 5 7 5 22 5 5 5 8 5 37 5 15 1 21 1 22 5 37 5 36 5 14 5 30 1 7 5 36 5 33 1 31 5 36 1 8 5 27 1 13 5 45 1 11 5 4 1 7 1 4 1 12 5 12 5 12 1 15 1 12 5 3 1 12 5 1 5 1 5 1 5 1 5 1 5 18 1 45 1 48 1 78 1 169 1 172 1 4 1 12 5 12 5 30 5 5 1 12 5 4 1 12 5 7 1 12 5 1 5 1 5 1 5 12 5 12 5 12 5 3 1 3 1 3 1 6 1 3 1 33 5 33 5 9 1 175 1 6 1 4 1 3 1 4 1 33 5 33 5 9 5 33 5 15 1 5 1 178 1 38 5 23 5 24 1 4 1 9 5 9 5 9 5 9 5 9 5 4 1 184 1 12 5 12 5 36 5 5 1 5 1 5 1 6 1 31 5 5 5 36 5 4 5 5 1 4 1 5 1 5 1 16 5 9 1 36 5 7 1 1 5 12 5 4 1 4 1 4 1 4 1 4 1 7 1 187 1 190 1 4 1 4 1 15 5 3 1 12 5 12 5 12 1 11 5 60 1 12 1 7 5 72 1 17 5 93 1 5 1 30 1 33 1 51 1 66 1 87 1 23 5 12 5 10 1 12 5 13 1 12 5 193 1 36 5 36 5 4 1 4 1 4 1 4 1 4 1 4 1 4 1 12 5 4 1 12 5 199 1 202 1 205 1 12 5 208 1 211 1 214 1 33 1 63 1 19 5 29 5 3 1 29 5 217 1 1 5 1 5 12 5 12 5 42 1 57 1 69 1 12 5 4 1 12 5 12 5 23 5 12 5 12 5 12 5 9 1 4 1 12 5 12 5 18 5 25 5 12 5 21 1 31 1 220 1 14 5 14 5 13 5 3 1 12 5 12 5 36 1 84 1 12 5 12 5 4 1 15 5 23 5 12 5 12 5 7 5 3 1 6 1 23 5 223 1 1 5 36 1 84 1 15 5 13 5 12 5 4 1 12 5 12 5 12 5 15 5 25 1 28 1 4 1 4 3 4 3 4 1 4 1 14 5 23 5 12 5 1 5 1 5 12 5 12 5 12 5 12 5 34 5 31 1 36 5 1 5 1 5 12 5 12 5 12 5 12 5 -13 1 225 133 5 4 0 143 2 4 0 144 2 2 0 145 5 3 0 147 5 5 0 152 2 4 256 152 5 5 257 152 5 3 258 152 2 4 0 152 2 6 259 153 5 3 262 153 2 7 263 153 5 8 266 153 5 9 271 153 5 10 275 153 5 8 279 153 5 4 281 153 5 5 282 153 5 11 283 153 5 11 285 153 5 12 287 153 5 13 288 153 5 14 292 153 5 9 293 153 5 3 310 153 2 15 311 153 5 4 314 153 5 4 315 153 5 10 317 153 5 16 0 153 5 4 322 154 5 17 323 154 5 18 325 154 5 19 327 156 5 3 342 159 2 20 343 159 5 21 344 160 5 22 345 161 5 2 350 161 5 17 351 162 5 26 353 163 5 13 355 163 5 17 0 163 5 23 0 165 5 24 360 167 5 15 366 167 5 25 367 167 5 10 368 169 5 4 373 169 5 26 374 169 5 27 379 169 5 21 0 170 5 27 382 171 5 28 387 171 5 3 391 171 2 10 392 171 5 7 396 171 5 25 400 171 5 24 401 171 5 5 405 171 2 19 406 171 5 3 410 171 5 4 413 171 5 25 415 171 5 4 420 171 5 23 421 171 5 29 423 171 5 30 0 171 5 11 425 173 5 5 427 173 5 18 0 173 5 4 428 174 5 31 429 174 5 18 0 178 5 32 431 179 5 30 0 179 5 28 443 181 5 33 0 181 5 21 0 182 5 34 445 183 5 14 446 183 5 35 451 194 5 21 0 268 5 18 0 269 5 12 455 270 5 18 0 270 5 5 0 271 5 18 0 272 5 23 465 273 5 36 474 273 5 31 478 273 5 18 0 273 5 37 480 274 5 -14 5 0 5 5 5 0 0 5 8 5 6 8 8 8 3 0 5 6 0 5 5 0 7 0 8 9 0 5 0 5 3 27 5 5 67 3 5 75 5 6 6 5 5 0 0 5 3 3 5 5 5 3 4 0 5 5 5 4 0 0 6 3 5 5 5 5 5 0 6 5 0 5 5 5 0 0 0 0 0 0 0 0 0 0 0 3 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 10 0 0 5 0 5 5 5 0 0 5 12 5 3 27 0 19 3 0 5 0 0 5 0 0 6 0 4 12 0 5 0 0 0 12 0 0 6 0 0 5 0 5 5 5 0 0 5 21 5 6 27 0 25 3 0 5 0 0 5 0 3 12 0 4 15 6 5 0 0 0 9 0 0 9 0 0 5 0 5 5 5 0 0 5 39 5 0 30 0 0 3 0 5 0 42 5 0 0 0 0 0 0 0 5 0 0 0 24 0 0 12 0 0 60 0 0 0 0 0 0 0 9 0 0 24 0 5 0 0 0 0 12 0 0 0 18 0 0 0 5 5 0 0 0 24 0 0 5 9 0 39 5 4 3 3 5 0 5 30 12 5 5 5 5 0 0 6 5 4 8 5 0 15 0 6 0 5 9 5 5 5 5 5 5 5 5 21 13 3 10 0 8 5 0 0 0 0 6 5 5 5 0 0 0 4 5 5 8 0 0 0 0 15 5 0 5 8 3 27 8 8 5 5 5 9 0 0 0 3 3 0 0 5 9 6 5 9 5 0 0 0 0 5 5 0 0 0 0 5 15 5 5 3 0 6 27 0 0 5 5 5 90 3 0 0 3 5 0 0 9 0 0 5 5 5 0 0 0 4 0 0 0 0 0 0 0 0 0 8 5 0 0 36 0 0 166 0 8 4 4 4 0 5 0 9 6 0 0 0 24 9 34 9 0 4 0 9 0 0 15 3 0 15 0 9 6 0 4 10 30 0 0 196 6 15 22 7 0 0 0 0 0 0 0 0 0 15 0 4 0 0 0 0 39 0 0 0 0 0 0 0 5 0 0 0 0 24 0 0 5 0 0 12 4 4 3 0 0 0 5 5 6 0 30 3 3 3 4 4 0 45 8 0 15 0 3 9 0 12 6 0 4 0 30 0 0 109 0 3 81 4 4 6 5 0 5 0 42 5 0 30 0 0 3 5 4 0 0 0 0 15 5 5 15 0 0 6 0 4 0 30 0 0 112 0 12 5 5 5 5 5 5 5 5 0 5 5 27 5 5 5 5 0 5 0 0 5 6 27 5 5 5 15 6 5 5 5 5 5 5 124 0 18 90 0 0 0 0 0 0 0 12 0 6 5 0 10 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 27 0 0 64 0 0 16 0 13 0 0 0 0 0 0 0 6 5 0 13 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 27 0 0 70 0 0 27 0 3 0 0 0 0 0 6 0 6 5 0 16 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 27 0 0 73 0 0 0 0 0 0 0 9 0 0 0 0 6 5 12 5 0 0 0 0 5 5 0 0 0 0 0 15 3 0 6 0 6 27 0 0 5 5 5 0 0 0 0 0 6 0 0 0 0 0 5 15 5 0 0 0 0 5 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 5 0 5 84 0 9 0 0 0 0 0 0 12 0 21 0 15 0 0 0 0 10 0 0 0 3 15 0 0 0 0 0 0 0 24 0 0 5 0 0 4 5 4 3 5 5 3 3 36 6 6 5 5 5 6 0 7 5 5 5 5 0 0 9 5 5 5 5 5 5 6 27 5 5 5 5 5 5 0 5 5 0 0 9 5 0 5 6 0 0 0 5 5 0 0 0 0 0 0 0 5 5 0 0 0 0 0 6 27 0 0 79 0 0 19 0 16 0 0 0 0 0 0 0 6 24 0 12 0 0 0 0 3 0 0 0 9 0 0 6 0 3 0 0 6 27 0 0 58 0 9 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 27 0 0 52 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 27 0 0 55 0 0 75 0 6 6 0 0 0 5 5 15 6 3 0 22 3 4 0 0 0 0 0 0 0 12 3 0 0 0 0 0 6 27 0 0 3 0 0 54 0 3 0 0 0 0 0 6 0 6 12 0 28 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 27 0 0 61 0 0 4 5 4 0 5 5 0 0 0 0 6 5 5 5 0 0 0 5 18 0 5 0 0 0 0 15 0 5 5 5 3 27 5 5 115 12 5 5 0 5 5 0 0 3 5 0 5 6 27 0 0 5 5 0 0 0 0 0 0 21 5 5 0 0 0 0 0 6 27 0 0 76 0 0 0 0 0 0 0 0 0 0 0 0 6 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 6 27 0 0 82 0 0 10 5 0 0 5 5 12 12 5 15 6 5 5 5 0 4 0 5 5 5 5 0 6 18 0 5 5 5 5 5 3 27 5 5 5 5 5 31 5 0 6 5 5 0 5 5 6 0 5 5 5 3 4 0 5 5 5 5 0 0 3 12 5 5 5 5 5 0 18 5 3 5 5 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 7 0 0 0 0 0 0 0 5 0 0 0 0 3 0 0 5 0 0 5 5 5 5 5 5 6 5 5 5 0 5 5 5 5 5 3 5 5 5 0 12 4 5 5 5 5 5 5 7 0 21 4 0 5 5 5 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 27 0 0 0 0 0 0 0 9 0 0 0 0 0 0 0 5 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 6 0 0 0 0 0 0 0 181 0 0 -15 ======================================================================================== DOCUMENT :usus Folder:VOLUK03:types.text ======================================================================================== const (********************************************************) sfirst = 1; (* FIRST INDEX OF STRINGS*) so_max_sorceline = 9998; (* DESCRIPTION OF SOURCE LINES*) so_max_sourcecolumn = 257; (*ADJUST*) (*MUST BE MAX INPUT LENGTH+1*) st_nil = 0; (* NULL CODING; USED TO INDICATE THAT SYMBOL IS NOT FOUND*) st_sym_ubound = 101; (* MUST BE PRIME *) st_word_length = 9; (* MAX RESERVED WORD LENGTH *) stb_empty = 0; (*EMPTY TEXT TABLE REFERENCE*) stb_str_ubound = 600; (*TEXT TABLE SIZE*) (* DECLARATIONS FROM LA*) (* SPECIAL CHARACTER FOR END OF FILE MARKING*) eof_char = '$'; (* CONSTANTS REPRESENTING CONTROL CHARACTERS IN ASCII *) nul = 0; ht = 5; del= 7; vt = 11; ff = 12; cr = 13; lf = 37; (*ADJUST*) max_int = 32767; { adjusted from 2147483647, by EDS } (*ADJUST*) type (********************************************************) so_sorceline_range = 0 .. 9999 (*SO_MAX_SOURCELINE + 1*); (* ONLY VALID FROM 1 .. 9998*) so_sorcecolumn_range = sfirst .. so_max_sourcecolumn; (* ALL COLUMNS ARE VALID*) string = packed array[so_sorcecolumn_range] of char; (* ONLY THIS STRING TYPE IS USED*) so_sorce_string = string;(* SOURCE LINES*) so_symbol_string = string;(* SYMBOLS HAVE AT MOST LINE SIZE*) (* SOURCE LINE POSITION DESCRIPTION USED THROUGHOUT THE COMPILER*) so_position = record sourceline : so_sorceline_range; column : so_sorcecolumn_range end; (* THE RANGE OF ERROR NUMBERS*) er_errornumber_range = 0 .. 9999; { adjusted, one 9 removed by EDS } (* DIFFERENT ERROR KINDS*) er_error_type = (er_warning , er_symbol_error , er_syntax_error , er_sym_inserted, er_reset_position , er_semantic_error , er_comp_restriction, er_compiler_error , er_io_error ); co_base_type = 2 .. 16; st_symbol = 0 .. st_sym_ubound; (* POSSIBLE RESULT OF CODING, INCLUDES THE NULL CODING*) st_literal = packed array [sfirst .. st_word_length] of char; (*---------------------------------------------------------------*) (* ENUMERATION TYPE FOR ALL LEXICAL UNITS*) (*---------------------------------------------------------------*) lu_lexical_unit = (* LEXICAL UNITS WHICH ARE CODED*) ( lu_identifier_sym , lu_integer_sym , lu_real_sym , lu_character_sym , lu_string_sym, (* END OF FILE*) lu_eof_sym , (* RESERVED WORDS*) lu_abort_sym , lu_accept_sym, lu_access_sym, lu_all_sym , lu_and_sym , lu_array_sym , lu_at_sym , lu_begin_sym , lu_body_sym , lu_case_sym , lu_constant_sym , lu_declare_sym , lu_delay_sym , lu_delta_sym , lu_digits_sym, lu_do_sym , lu_else_sym , lu_elsif_sym , lu_end_sym , lu_entry_sym , lu_exception_sym , lu_exit_sym , lu_for_sym , lu_function_sym , lu_generic_sym , lu_goto_sym , lu_if_sym , lu_in_sym , lu_is_sym , lu_limited_sym , lu_loop_sym , lu_mod_sym , lu_new_sym , lu_not_sym , lu_null_sym , lu_of_sym , lu_or_sym , lu_others_sym, lu_out_sym , lu_package_sym , lu_pragma_sym, lu_private_sym , lu_procedure_sym , lu_raise_sym , lu_range_sym , lu_record_sym, lu_rem_sym , lu_renames_sym , lu_return_sym, lu_reverse_sym , lu_salect_sym, lu_seperate_sym , lu_subtype_sym , lu_task_sym , lu_terminate_sym , lu_then_sym , lu_type_sym , lu_use_sym , lu_when_sym , lu_while_sym , lu_with_sym , lu_xor_sym , (* DELIMITERS*) lu_minus_sym , lu_dot_sym , lu_interval_sym , lu_less_sym , lu_left_label_sym , lu_box_sym , lu_less_equal_sym , lu_lpar_sym , lu_plus_sym , lu_separator_sym , lu_catenation_sym , lu_multiply_sym , lu_exponentiation_sym , lu_rpar_sym , lu_semicolon_sym , lu_divide_sym, lu_not_equal_sym , lu_comma_sym , lu_greater_sym , lu_right_label_sym, lu_greator_equal_sym , lu_colon_sym , lu_assign_sym, lu_quote_sym , lu_equal_sym , lu_arrow_sym ); (*---------------------------------------------------------------*) (* DESCRIPTOR OF LEXICAL UNITS*) (*---------------------------------------------------------------*) lu_selector = (lu_id, lu_int, lu_real, lu_other); (* THIS IS NEEDED FOR DISCRIMINANT SELECTION*) lu_sym_descriptor = record sym : lu_lexical_unit; case discrim : lu_selector of lu_id : (* LU_IDENTIFIER_SYM, LU_STRING_SYM*) (* LU_CHARACTER_SYM, RESERVED_WORDS*) (* OPERATORS*) (idcode : st_symbol) (*OTHERS ARE NOT CODED*) end; (* RECORD;*) lu_symbol_string = so_symbol_string; (* TEXT TABLE*) stb_str_0range = 0 .. stb_str_ubound; stb_str_range = 1 .. stb_str_ubound; stb_s_tab_rec = record textb, texte : stb_str_0range end; (* DECLARATIONS FROM LA*) character_type = (letter_a_f , letter_g_z , low_letter , digit , dquote , quote , hyphen , ampersand , lpar , rpar , asterisk, plus , comma , point , slash , colon , semicolon , langle , equal , rangle , vbar , underscore , nwline , ignore , blank , htab , eofc , other_graphics , non_ada ); var (********************************************************) (* SPECIAL POSITIONS*) so_nil_position : (* USED IF NO POSITION AVAILABLE*) (*CONSTANT*) so_position (* := (SOURCELINE => SO_SOURCELINE_RANGE'FIRST *) (* COLUMN => SO_SOURCECOLUMN_RANGE'FIRST)*); lu_reserved_word : array [st_symbol] of lu_lexical_unit; (* RESERVED WORD INDICATOR*) lu_code_minus, lu_code_less, lu_cde_less_equal, lu_code_plus, lu_code_catenation, lu_code_multiply, lu_code_exponentiation, lu_code_divide, lu_code_not_equal, lu_code_greater, lu_cde_greater_equal, lu_code_equal : st_symbol; lu_no_symbol : lu_sym_descriptor; (*---------------------------------------------------------------*) (* INITIALIZATION*) (*---------------------------------------------------------------*) (*TEXT TABLE*) stb_s_tab_strings : packed array [stb_str_range] of char; stb_number_char : stb_str_0range; (*HASH TABLE*) stb_s_tab_entries : array [st_symbol] of stb_s_tab_rec; stb_texttable_full, stb_hashtable_full : boolean; (*-------------------------------------------------------------------*) (* SYMBOL TABLE CODES FOR ERROR UNITS*) lub_cde_identifier, lub_code_integer, lub_code_real,lub_code_string, lub_code_character : st_symbol; (*------------------------------------------------------------------*) (* DECLARATIONS FROM LA*) char_type_table : array [char] of character_type; (* BUFFER, BUFFER-POINTER*) (* ASSERT: CURRENT_CHAR == BUFFER(CURRENT);*) (* BUFFER(LAST_CHAR..LAST_CHAR+1)=(CR,CR) OR BUFFER(FIRST)=EOFC*) (* CURRENT IS ALWAYS NEXT CHARACTER*) buffer : so_sorce_string; (* LOOKAHEAD=2*) current, last_char : integer; current_char : char; line_no : integer; (* LAST RECOGNIZED LEXICAL UNIT (BECAUSE QUOTE AMBIGUITIES)*) last_symbol : lu_sym_descriptor; last_pos : so_position; (*------------------------------------------------------------------*) errors_count : integer; warnings_count : integer; error_no : integer; erb_last_pos : so_position; (*-------------------------------------------------------------------*) tabdat : file of integer; (********************************************************) morefiles:boolean; reply:char; ======================================================================================== DOCUMENT :usus Folder:VOLUK03:voluk3.doc.text ======================================================================================== USUS Library Volume UK3 An ADA Syntax Checker Submitted by USUS(UK) VOLUK3: ADADOC.TEXT 20 Documentation of the ADA Syntax Checker ADA.TEXT 34 The main program of the ADA Syntax Checker COINT.TEXT 14 an include file LAINIT.TEXT 8 ditto LANEXT.TEXT 40 ditto LUERROR.TEXT 14 ditto LUINIT.TEXT 16 ditto PARSER.TEXT 40 ditto TYPES.TEXT 18 ditto STGET.TEXT 12 ditto TEXTDAT.TEXT 136 A data file FILECHECK.TEXT 4 A utility program ADA.CODE 33 A code file of the ADA Syntax Checker that won't run under IV.0 GENDAT.TEXT 4 Generates the file TEXTDAT.TEXT GENDAT.CODE 2 ADATEST.TEXT 21 A non-UCSD text file of a sample ADA test case NEWADATEST.TEXT 24 A version of ADATEST.TEXT converted to UCSD format but without proper indentation CONTENTS.TEXT 6 The original UK contents file VOLUK3.DOC.TEXT 6 You're reading it. __________________________________________________________________________ Please transfer the text below to a disk label if you copy this volume. USUS Volume UK3 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by USUS(UK) from material collected by their Library committee. __________________________________________________________________________ ======================================================================================== DOCUMENT :usus Folder:VOLUK04:apl.text ======================================================================================== (*$L PRINTER:*) (*$D+*) (*$R-*) (**************************************************************) (* This program is an adaptation for UCSD pascal of a program *) (* that appears in the Byte Book Of Pascal. The changes made *) (* were very small, so it is still fairly inefficient. *) (* There are still probably a few typos in it as well as *) (* common or garden bugs. *) (* The APL subset that has been implemented so far is fairly *) (* small and limiting, such as no character strings, plus *) (* things like restictions on where generalised matrices may *) (* be used (bracketing them sometimes helps). *) (* If you find any bugs or write any enhancements I would be *) (* grateful if you could forward them on to me either via *) (* USUS or Inmos Ltd., *) (* Whitefriars, *) (* Lewins Mead, *) (* Bristol BS1 2NP, *) (* England. *) (* Greg Nunan 10/10/80. *) (**************************************************************) program scanner(infile, outfile, cherfile); const maxvarnamelength = 10; maxinputline = 80; maxoutputline = 80; inputarraysize = 82; numberofmessages = 75; messagelength = 50; spectablength = 6; doptablength = 16; chartablength = 12; redtablength = 16; moptablength = 12; numofopspertable = 16; norminfile = 'console:'; normoutfile = 'console:'; indent = ' '; extrabytes = 2; (* heap *) blocksize = 64; (* heap *) blockbytes = 128; (* heap *) endofstore = 0; (* heap *) used = 1; (* heap *) unused = 0; (* heap *) type packedstring = packed array[1..maxvarnamelength] of char; tokennoun = (formres, formarg, globvar, monadoper, reductoper, dyadoper, specoper, constant, statend); values = record realval: real; nextvalue: ^values end; vartab = record varname: packedstring; (* v1 *) functabptr: ^functab; (* v2 - ftab *) valtabptr: ^valtab; (* v3 - vtab *) deferedvaltabptr: ^fparmtab; nextvartabptr: ^vartab end; valtab = record intermedresult: boolean; dimensions: integer; firstdimen: ^dimeninfo; forwardorder: boolean; firstvalue: ^values; nextvaltablink: ^valtab end; tokentable = record nextoken: ^tokentable; case noun: tokennoun of (* p *) formres, formarg, globvar: (vartabptr: ^vartab); (* vtab *) monadoper: (monindx: integer); reductoper: (redindx: integer); dyadoper: (dopindx: integer); specoper: (charindx: integer); constant: (valtabptr: ^valtab); statend: (endadj: integer) end; vfunc = record nextstmnt: ^tokentable; nextvfuncptr: ^vfunc; statlabel: packedstring end; functab = record funcname: packedstring; (* f1 *) arity: (niladic, monadic, dyadic); (* f2 *) result: boolean; (* true = explicit f3 *) resultname: packedstring; (* f4 *) leftarg: packedstring; (* f5 *) rightarg: packedstring; (* f6 *) firstatement: ^vfunc; nextfunctabptr: ^functab; numofstatements: integer end; fparmtab = record ptrval: ^valtab; (* sd1 and sd2 *) lastparm: ^fparmtab (* link to last sd1 or sd2 *) end; dimeninfo = record nextdimen: ^dimeninfo; dimenlength: integer end; oprecord = record opindex: integer; opsymbol : char end; operandtab = record operptr: ^valtab; (* sval *) lastoper: ^operandtab (* link to last sval *) end; subrtab = record (* sf *) calledsubr: ^functab; (* s1 *) tokencallingsubr: ^tokentable; (* s2 *) statemcallingsubr: ^vfunc; (* s3 *) lastsubrptr: ^subrtab (* link to last sf *) end; optable = array[1..numofopspertable] of oprecord; vartabptrtype = ^vartab; typevaltabptr = ^valtab; tokenptr = ^tokentable; ptrfunctab = ^functab; typevaluesptr = ^values; typevfuncptr = ^vfunc; (* heap *) fparmptr = ^fparmtab; (* heap *) dimenptr = ^dimeninfo; (* heap *) operandptr = ^operandtab; (* heap *) typesubrtabptr = ^subrtab; (* heap *) aplcharset = (asymbol, bsymbol, csymbol, dsymbol, esymbol, fsymbol, gsymbol, hsymbol, isymbol, jsymbol, ksymbol, lsymbol, msymbol, nsymbol, osymbol, psymbol, qsymbol, rsymbol, ssymbol, tsymbol, usymbol, vsymbol, wsymbol, xsymbol, ysymbol, zsymbol, onesymbol, twosymbol, threesymbol, foursymbol, fivesymbol, sixsymbol, sevensymbol, eightsymbol, ninesymbol, zerosymbol, colon, rightarrow, leftarrow, smallcircle, period, leftparen, rightparen, leftbracket, rightbracket, semicolon, quadrangle, space, plus, minus, times, divide, asterisk, iota, rho, comma, tilde, equals, notequal, lessthan, lessorequal, greaterorequal, greaterthan, andsymbol, orsymbol, ceiling, floor, largecircle, forwardslash, doublequote, negative, questionmark, omega, epsilon, uparrow, downarrow, alpha, underscore, del, delta, singlequote, eastcap, westcap, southcap, northcap, ibeam, tbeam, verticalstroke, backwardslash); block = array[1..blocksize] of integer; (* heap *) pointer = ^integer; (* heap *) storeptr = record (* heap *) case integer of (* heap *) 0: (ptr: ^integer); (* heap *) 1: (int: integer) (* heap *) end; (* heap *) xxx = record (* heap *) case integer of (* heap *) 0: (ptr: ^integer); (* heap *) 1: (valus: typevaluesptr); (* heap *) 2: (ops: operandptr); (* heap *) 3: (tokens: tokenptr); (* heap *) 4: (funcs: ptrfunctab); (* heap *) 5: (subrs: typesubrtabptr); (* heap *) 6: (fparms: fparmptr); (* heap *) 7: (vars: vartabptrtype); (* heap *) 8: (valts: typevaltabptr); (* heap *) 9: (vfuncs: typevfuncptr); (* heap *) 10: (dims: dimenptr); (* heap *) 11: (int: integer) (* heap *) end; (* heap *) var xcolonsym, xrightarrow, xleftarrow, xlittlecircle, xperiod, xleftpar, xrightpar, xleftbracket, xrightbracket, xsemicolsym, xquadsym: integer; character: array[aplcharset] of char; aplstatement: packed array[1..inputarraysize] of char; digits: array[onesymbol..zerosymbol] of integer; errormsgs: packed array[1..numberofmessages] of string[messagelength]; infile, outfile: interactive; cherfile: text; moptab, doptab, redtab, chartab, spectab: optable; savelabel: packedstring; name: packedstring; newtokenptr, oldtokenptr, holdtokenptr, savetokenptr: ^tokentable; testfuncptr, newfunctabptr, oldfunctabptr: ^functab; newvartabptr, oldvartabptr: ^vartab; leftvalptr, rightvalptr, valptr: ^values; newvalues, newvalptr: ^values; newdim: ^dimeninfo; dimptr, newptr, leftdimptr, rightdimptr: ^dimeninfo; varpointer: ^vartab; oldvfuncptr, newvfuncptr: ^vfunc; newvaltablink, oldvaltablink: ^valtab; position: integer; linelength: integer; code, colcnt: integer; funcstatements: integer; tokenerror, firstfunction: boolean; linetoolong, haslabel: boolean; switch, funcmode, tokenswitch, itsanidentifier: boolean; opertabptr: ^operandtab; (* sv *) ptrlastoper: ^operandtab; subrtabptr: ^subrtab; rparmptr: ^fparmtab; (* p1 *) lparmptr: ^fparmtab; (* p2 *) vfuncptr: ^vfunc; (* nl *) hold: ^tokentable; (* holds last symbol *) totaldigs, afterdigs: integer; realsperline: integer; rollnum: integer; freestore: storeptr; (* heap *) areasize: integer; (* heap *) procedure setupheap; forward; (* heap *) procedure getvalu(var valu: typevaluesptr); forward; (* heap *) procedure getoper(var oper: operandptr); forward; (* heap *) procedure gettoken(var token: tokenptr); forward; (* heap *) procedure getfunc(var func: ptrfunctab); forward; (* heap *) procedure getsubr(var subr: typesubrtabptr); forward; (* heap *) procedure getfparm(var fparm: fparmptr); forward; (* heap *) procedure getvarr(var varr: vartabptrtype); forward; (* heap *) procedure getvalt(var valt: typevaltabptr); forward; (* heap *) procedure getvfunc(var vfunk: typevfuncptr); forward; (* heap *) procedure getdim(var dim: dimenptr); forward; (* heap *) procedure ridvalu(var valu: typevaluesptr); forward; (* heap *) procedure ridoper(var oper: operandptr); forward; (* heap *) procedure ridtoken(var token: tokenptr); forward; (* heap *) procedure ridfunc(var func: ptrfunctab); forward; (* heap *) procedure ridsubr(var subr: typesubrtabptr); forward; (* heap *) procedure ridfparm(var fparm: fparmptr); forward; (* heap *) procedure skipspaces; forward; procedure getaplstatement; forward; function namesmatch(nameone, nametwo: packedstring): boolean; forward; procedure makeanumber(var realnumber: real; var itsanumber: boolean); forward; procedure reverselinklist(var argptr: typevaltabptr); forward; function nameinvartable(name: packedstring; var varpointer: vartabptrtype; testfuncptr: ptrfunctab): boolean; forward; function funcalreadydefined(var newfuname: packedstring; var funcindex: ptrfunctab): boolean; forward; (*$I aplinit.text*) (*$I aplparse0.text*) (*$I aplparse1.text*) (*$I aplparse2.text*) (*$I aplparse3.text*) (*$I aplprocs.text*) (*$I aplheap.text*) begin {scanner} aplinit; write(outfile, areasize/(memavail*2): 4: 2, ': '); getaplstatement; while (aplstatement[1] <> character[forwardslash]) or (aplstatement[2] <> character[asterisk]) (* /* ends program *) do begin skipspaces; tokenswitch := true; while (position <= linelength) and (not tokenerror) and (not linetoolong) do begin (* scanning *) if aplstatement[position] = character[del] (* function delimiter *) then (* del encountered !!!! *) if funcmode then begin (* end of current function *) if newfunctabptr <> nil then newfunctabptr^.numofstatements := funcstatements; if funcstatements > 0 then begin newfunctabptr^.nextfunctabptr := oldfunctabptr; oldfunctabptr := newfunctabptr; newvfuncptr^.nextvfuncptr := nil end else serror(75); (* function defined with no statements *) funcmode := false; position := position + 1 end else processfunctionheader (* start of a new function *) else (* not a del encountered *) begin if tokenswitch = true then begin (* this is start of a new statement *) tokenswitch := false; holdtokenptr := oldtokenptr; (* save starting position *) maketokenlink; newtokenptr^.noun := statend; newtokenptr^.endadj := 0; haslabel := false end; maketokenlink; identifier(name, itsanidentifier); if not itsanidentifier then trytogetanumber else begin (* process identifier *) skipspaces; if (aplstatement[position] = character[colon]) and (newtokenptr^.nextoken^.noun = statend) then begin (* process statement label *) savelabel := name; haslabel := true; position := position + 1 end else begin (* process variable name *) if not funcmode then newtokenptr^.noun := globvar else if namesmatch(name, newfunctabptr^.resultname) then newtokenptr^.noun := formres else if (namesmatch(name, newfunctabptr^.leftarg)) or (namesmatch(name, newfunctabptr^.rightarg)) then newtokenptr^.noun := formarg else newtokenptr^.noun := globvar; if newtokenptr^.noun <> globvar then testfuncptr := newfunctabptr else testfuncptr := nil; if not nameinvartable(name, varpointer, testfuncptr) then begin addnametovartable(name); newtokenptr^.vartabptr := newvartabptr end else newtokenptr^.vartabptr := varpointer end end end; skipspaces end; if newtokenptr <> nil then if (tokenerror) or (newtokenptr^.noun = statend) then destroystatement else if funcmode then begin funcstatements := funcstatements + 1; if funcstatements > 0 then begin (* calatogue function statement *) getvfunc(newvfuncptr); if funcstatements = 1 then newfunctabptr^.firstatement := newvfuncptr else oldvfuncptr^.nextvfuncptr := newvfuncptr; oldvfuncptr := newvfuncptr; if haslabel then newvfuncptr^.statlabel := savelabel; newvfuncptr^.nextstmnt := newtokenptr end end else if aplstatement[1] <> character[del] then begin parser(newtokenptr, newvaltablink); destroystatement end; tokenerror := false; write(outfile, areasize/(memavail*2): 4: 2, ': '); getaplstatement end end. ======================================================================================== DOCUMENT :usus Folder:VOLUK04:aplchers.text ======================================================================================== abcdefghijklmnopqrstuvwxyz1234567890 { normal chars } :RLO.()[];@ +-X%*!P,~=#<{}>&VCFQ/"-?Z`^DA_$^'EWSNIT|\ { special chars } NOT USED digit must follow a decimal point extraneous characters follow function header invalid character encountered function already defined illegal name to right of explicit result invalid function/argument name result of assignment not valid variable invalid function right argument name invalid expression symbol not found statement number to branch to not integer dydadic operator not preceded by primary invalid expression within parentheses mismatched parentheses NOT USED left argument of dyadic function not a primary NOT USED value not boolean attempted division by zero argument not a scalar argument is negative argument is not an integer argument is a scalar or empty vector NOT USED invalid outer product expression invalid inner product expression NOT USED left argument is not a vector NOT USED NOT USED error in function argument error in function argument invalid index expression non-scalar indices assigned expression not a scalar non-integer indices index out of range invalid index expression NOT USED NOT USED NOT USED NOT USED NOT USED wrong number of subscripts NOT USED NOT USED NOT USED NOT USED number and base of different sign argument is a vector of length one arguments not compatible for inner product argument(s) with rank greater than one attempted inverse of zero arguments incompatible for dyadic operation left argument not a vector NOT USED NOT USED NOT USED greater than three dimensions nil re-enter last line input NOT USED NOT USED NOT USED NOT USED NOT USED variable not assigned a value identifier too long input line too long invalid reduction operator dyadic reduction reference monadic reference to dyadic operator function defined with no statements ======================================================================================== DOCUMENT :usus Folder:VOLUK04:aplheap.text ======================================================================================== (*$D-*) (* note that these are dirty routines that are machine/implementation *) (* dependant, particularly the mixing of integer/byte sizes/pointers *) procedure outofheap; begin writeln('**** out of heap space (', areasize, ' allocated) ****'); exit(scanner) end; {outofheap} procedure setupheap; begin areasize := 0; if memavail < 1 then outofheap else begin new(freestore.ptr); writeln(')APL : ', memavail*2, ' bytes available'); freestore.ptr^ := endofstore end end; {setupheap} procedure getextrablock(pptr: pointer; var sizethisone: integer); var blockptr: ^block; begin if memavail < blocksize then outofheap else begin new(blockptr); sizethisone := blockbytes + pptr^; blockptr^[blocksize] := endofstore; areasize := areasize + blockbytes end end; {getextrablock} procedure getxxx(size: integer; var heap: xxx); var p, q: storeptr; sizethisarea: integer; begin p.ptr := freestore.ptr; q.ptr := freestore.ptr; size := size + extrabytes + (size mod 2); sizethisarea := 0; while (sizethisarea < size) and (q.ptr^ <> endofstore) do begin p.ptr := q.ptr; while (p.ptr^ mod 2) = used do p.int := p.int + p.ptr^ - used; q.ptr := p.ptr; while ((q.ptr^ mod 2) = unused) and (q.ptr^ <> endofstore) do q.int := q.int + q.ptr^; sizethisarea := q.int - p.int; (* note that this sets the unused flag *) if p.ptr^ <> endofstore then p.ptr^ := sizethisarea end; while sizethisarea < size do getextrablock(p.ptr, sizethisarea); if sizethisarea > size then begin q.int := p.int + size; q.ptr^ := sizethisarea - size (* note that this sets the unused flag *) end; p.ptr^ := size + used; p.int := p.int + extrabytes; heap.ptr := p.ptr end; {getxxx} procedure getvalu{var valu: typevaluesptr}; var dummyvalu: values; dummyxxx: xxx; begin getxxx(sizeof(dummyvalu), dummyxxx); valu := dummyxxx.valus end; {getvalu} procedure getoper{var oper: operandptr}; var dummyoper: operandtab; dummyxxx: xxx; begin getxxx(sizeof(dummyoper), dummyxxx); oper := dummyxxx.ops end; {getoper} procedure gettoken{var token: tokenptr}; var dummytoken: tokentable; dummyxxx: xxx; begin getxxx(sizeof(dummytoken), dummyxxx); token := dummyxxx.tokens end; {gettoken} procedure getfunc{var func: ptrfunctab}; var dummyfunc: functab; dummyxxx: xxx; begin getxxx(sizeof(dummyfunc), dummyxxx); func := dummyxxx.funcs end; {getfunc} procedure getsubr{var subr: typesubrtabptr}; var dummysubr: subrtab; dummyxxx: xxx; begin getxxx(sizeof(dummysubr), dummyxxx); subr := dummyxxx.subrs end; {getsubr} procedure getfparm{var fparm: fparmptr}; var dummyfparm: fparmtab; dummyxxx: xxx; begin getxxx(sizeof(dummyfparm), dummyxxx); fparm := dummyxxx.fparms end; {getfparm} procedure getvalt{var valt: typevaltabptr}; var dummyvalt: valtab; dummyxxx: xxx; begin getxxx(sizeof(dummyvalt), dummyxxx); valt := dummyxxx.valts end; {getvalt} procedure getvarr{var varr: vartabptrtype}; var dummyvarr: vartab; dummyxxx: xxx; begin getxxx(sizeof(dummyvarr), dummyxxx); varr := dummyxxx.vars end; {getvarr} procedure getvfunc{var vfunk: typevfuncptr}; var dummyvfunc: vfunc; dummyxxx: xxx; begin getxxx(sizeof(dummyvfunc), dummyxxx); vfunk := dummyxxx.vfuncs end; {getvfunc} procedure getdim{var dim: dimenptr}; var dummydim: dimeninfo; dummyxxx: xxx; begin getxxx(sizeof(dummydim), dummyxxx); dim := dummyxxx.dims end; {getdim} procedure ridxxx(var heap: xxx); begin heap.int := heap.int - extrabytes; heap.ptr^ := heap.ptr^ - used end; {ridxxx} procedure ridvalu{var valu: typevaluesptr}; var dummyxxx: xxx; begin dummyxxx.valus := valu; ridxxx(dummyxxx) end; {ridvalu} procedure ridoper{var oper: operandptr}; var dummyxxx: xxx; begin dummyxxx.ops := oper; ridxxx(dummyxxx) end; {ridoper} procedure ridtoken{var token: tokenptr}; var dummyxxx: xxx; begin dummyxxx.tokens := token; ridxxx(dummyxxx) end; {ridtoken} procedure ridfunc{var func: ptrfunctab}; var dummyxxx: xxx; begin dummyxxx.funcs := func; ridxxx(dummyxxx) end; {ridfunc} procedure ridsubr{var subr: typesubrtabptr}; var dummyxxx: xxx; begin dummyxxx.subrs := subr; ridxxx(dummyxxx) end; {ridsubr} procedure ridfparm{var fparm: fparmptr}; var dummyxxx: xxx; begin dummyxxx.fparms := fparm; ridxxx(dummyxxx) end; {ridfparm} (*$D+*) ======================================================================================== DOCUMENT :usus Folder:VOLUK04:aplinit.text ======================================================================================== (*$D-*) segment procedure aplinit; procedure initparser; begin opertabptr := nil; subrtabptr := nil; lparmptr := nil; rparmptr := nil; vfuncptr := nil; hold := nil; xcolonsym := 1; xrightarrow := 2; xleftarrow := 3; xlittlecircle := 4; xperiod := 5; xleftpar := 6; xrightpar := 7; xleftbracket := 8; xrightbracket := 9; xsemicolsym := 10; xquadsym := 11; getoper(opertabptr); opertabptr^.lastoper := nil; ptrlastoper := opertabptr end; {initparser} procedure readcherfile; (* read character set and error msgs from file *) var aplchar: char; symbolindex: aplcharset; msgrow: integer; begin reset(cherfile, 'aplchers.text'); for symbolindex := asymbol to backwardslash do begin read(cherfile, aplchar); if symbolindex = zerosymbol then readln(cherfile); character[symbolindex] := aplchar end; readln(cherfile); for msgrow := 1 to numberofmessages do readln(cherfile, errormsgs[msgrow]); close(cherfile) end; {readcherfile} procedure fillupoptables; begin (* monadic operators *) moptab[1].opsymbol := character[plus]; moptab[1].opindex := 2; moptab[2].opsymbol := character[minus]; moptab[2].opindex := 3; moptab[3].opsymbol := character[times]; moptab[3].opindex := 4; moptab[4].opsymbol := character[divide]; moptab[4].opindex := 5; moptab[5].opsymbol := character[asterisk]; moptab[5].opindex := 6; moptab[6].opsymbol := character[iota]; moptab[6].opindex := 21; moptab[7].opsymbol := character[rho]; moptab[7].opindex := 22; moptab[8].opsymbol := character[comma]; moptab[8].opindex := 23; moptab[9].opsymbol := character[tilde]; moptab[9].opindex := 1; moptab[10].opsymbol := character[ceiling]; moptab[10].opindex := 9; moptab[11].opsymbol := character[floor]; moptab[11].opindex := 10; moptab[12].opsymbol := character[questionmark]; moptab[12].opindex := 7; (* dyadic operators *) doptab[1].opsymbol := character[plus]; doptab[1].opindex := 52; doptab[2].opsymbol := character[minus]; doptab[2].opindex := 53; doptab[3].opsymbol := character[times]; doptab[3].opindex := 54; doptab[4].opsymbol := character[divide]; doptab[4].opindex := 55; doptab[5].opsymbol := character[asterisk]; doptab[5].opindex := 56; doptab[6].opsymbol := character[iota]; doptab[6].opindex := 87; doptab[7].opsymbol := character[rho]; doptab[7].opindex := 88; doptab[8].opsymbol := character[comma]; doptab[8].opindex := 89; doptab[9].opsymbol := character[equals]; doptab[9].opindex := 71; doptab[10].opsymbol := character[notequal]; doptab[10].opindex := 72; doptab[11].opsymbol := character[lessthan]; doptab[11].opindex := 73; doptab[12].opsymbol := character[lessorequal]; doptab[12].opindex := 74; doptab[13].opsymbol := character[greaterorequal]; doptab[13].opindex := 75; doptab[14].opsymbol := character[greaterthan]; doptab[14].opindex := 76; doptab[15].opsymbol := character[andsymbol]; doptab[15].opindex := 77; doptab[16].opsymbol := character[orsymbol]; doptab[16].opindex := 78 end; {fillupoptables} procedure fillupspectables; begin (* special characters *) chartab[1].opsymbol := character[colon]; chartab[2].opsymbol := character[rightarrow]; chartab[3].opsymbol := character[leftarrow]; chartab[4].opsymbol := character[smallcircle]; chartab[5].opsymbol := character[period]; chartab[6].opsymbol := character[leftparen]; chartab[7].opsymbol := character[rightparen]; chartab[8].opsymbol := character[leftbracket]; chartab[9].opsymbol := character[rightbracket]; chartab[10].opsymbol := character[semicolon]; chartab[11].opsymbol := character[quadrangle]; chartab[12].opsymbol := character[space]; spectab[1].opsymbol := character[colon]; spectab[2].opsymbol := character[rightarrow]; spectab[3].opsymbol := character[leftarrow]; spectab[4].opsymbol := character[leftparen]; spectab[5].opsymbol := character[semicolon]; spectab[6].opsymbol := character[leftbracket] end; {fillupspectables} procedure fillupredtables; begin (* reduction operators *) redtab[1].opsymbol := character[plus]; redtab[1].opindex := 2; redtab[2].opsymbol := character[minus]; redtab[2].opindex := 3; redtab[3].opsymbol := character[times]; redtab[3].opindex := 4; redtab[4].opsymbol := character[divide]; redtab[4].opindex := 5; redtab[5].opsymbol := character[asterisk]; redtab[5].opindex := 6; redtab[6].opsymbol := character[equals]; redtab[6].opindex := 21; redtab[7].opsymbol := character[notequal]; redtab[7].opindex := 22; redtab[8].opsymbol := character[lessthan]; redtab[8].opindex := 23; redtab[9].opsymbol := character[lessorequal]; redtab[9].opindex := 24; redtab[10].opsymbol := character[greaterorequal]; redtab[10].opindex := 25; redtab[11].opsymbol := character[greaterthan]; redtab[11].opindex := 26; redtab[12].opsymbol := character[andsymbol]; redtab[12].opindex := 27; redtab[13].opsymbol := character[orsymbol]; redtab[13].opindex := 28; redtab[14].opsymbol := character[ceiling]; redtab[14].opindex := 29; redtab[15].opsymbol := character[floor]; redtab[15].opindex := 30; redtab[16].opsymbol := character[largecircle]; redtab[16].opindex := 31 end; {fillupredtables} procedure fillupdigittables; begin (* digit characters *) digits[onesymbol] := 1; digits[twosymbol] := 2; digits[threesymbol] := 3; digits[foursymbol] := 4; digits[fivesymbol] := 5; digits[sixsymbol] := 6; digits[sevensymbol] := 7; digits[eightsymbol] := 8; digits[ninesymbol] := 9; digits[zerosymbol] := 0 end; {fillupdigittables} begin {aplinit} setupheap; (* heap *) readcherfile; initparser; (* initialize tables etc. *) fillupoptables; fillupspectables; fillupredtables; fillupdigittables; funcmode := false; firstfunction := true; oldvaltablink := nil; oldfunctabptr := nil; oldvartabptr := nil; oldtokenptr := nil; newtokenptr := nil; newfunctabptr := nil; newvfuncptr := nil; holdtokenptr := nil; tokenerror := false; newvaltablink := nil; newvartabptr := nil; totaldigs := 12; afterdigs := 2; rollnum := 5006; rewrite(outfile, normoutfile); reset(infile, norminfile); realsperline := (maxoutputline-6{sizeof(indent)}) div (totaldigs+1) end; {aplinit} (*$D+*) ======================================================================================== DOCUMENT :usus Folder:VOLUK04:aplparse0.text ======================================================================================== procedure parser(var tokentabptr: tokenptr; var ptrtoda: typevaltabptr); var vfunchold: ^vfunc; (* hold while searching *) auxopertabptr: ^operandtab; auxsubrtabptr: ^subrtab; auxrparmptr: ^fparmtab; auxlparmptr: ^fparmtab; validexp: boolean; (* true if valid expression *) cnt: integer; npv: integer; (* number of indices *) assign, assign1: boolean; (* assignment in progress *) donesuccessor: boolean; doneparse: boolean; procedure expression(var validexp: boolean); forward; procedure error(errorindex: integer); begin writeln(outfile, 'error ',errorindex,': ', errormsgs[errorindex]); exit(parser) (* return to scanner *) end; {error} procedure release; begin (* realease oprtab *) opertabptr := ptrlastoper; while opertabptr^.lastoper <> nil do begin auxopertabptr := opertabptr; opertabptr := opertabptr^.lastoper; ridoper(auxopertabptr) end end; {release} procedure returntocallingsubr; var nameptr: ^vartab; begin (* returntocallingsubr *) if subrtabptr^.calledsubr^.result then begin (* place explicit result in opertab *) if not nameinvartable(subrtabptr^.calledsubr^.resultname, nameptr, subrtabptr^.calledsubr) then error(11) (* symbol not found *) else begin auxopertabptr := opertabptr; getoper(opertabptr); opertabptr^.lastoper := auxopertabptr; ptrlastoper := opertabptr; opertabptr^.operptr := nameptr^.valtabptr end end; (* return to calling function *) vfuncptr := subrtabptr^.statemcallingsubr; tokentabptr := subrtabptr^.tokencallingsubr^.nextoken; if subrtabptr^.calledsubr^.arity <> niladic then begin (* monadic or dyadic *) auxrparmptr := rparmptr; rparmptr := rparmptr^.lastparm; ridfparm(auxrparmptr); if subrtabptr^.calledsubr^.arity = dyadic then begin (* dyadic only *) auxlparmptr := lparmptr; lparmptr := lparmptr^.lastparm; ridfparm(auxlparmptr) end end; auxsubrtabptr := subrtabptr; subrtabptr := subrtabptr^.lastsubrptr; ridsubr(auxsubrtabptr) end; {returntocallingsubr} function specsymbol(sym: integer): boolean; var validsym: boolean; begin (* specsymbol *) validsym := false; if tokentabptr^.noun = specoper then if tokentabptr^.charindx = sym then begin hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; validsym := true end; specsymbol := validsym end; {specsymbol} procedure callsubr; var ptrtovartab: ^vartab; begin (* callsubr *) if subrtabptr^.calledsubr^.arity <> niladic then begin if not nameinvartable(subrtabptr^.calledsubr^.rightarg, ptrtovartab, subrtabptr^.calledsubr) then error(32); (* error in function argument *) if ptrtovartab^.functabptr <> subrtabptr^.calledsubr then error(32); (* program logic error, variable name of *) (* function argument not found in symbol table *) auxrparmptr := rparmptr; getfparm(rparmptr); rparmptr^.lastparm := auxrparmptr; ptrtovartab^.deferedvaltabptr := rparmptr; if subrtabptr^.calledsubr^.arity = dyadic then begin (* if dyadic *) if not nameinvartable(subrtabptr^.calledsubr^.leftarg, ptrtovartab, subrtabptr^.calledsubr) then error(33); (* same as error(32) *) if ptrtovartab^.functabptr <> subrtabptr^.calledsubr then error(33); auxlparmptr := lparmptr; getfparm(lparmptr); lparmptr^.lastparm := auxlparmptr; ptrtovartab^.deferedvaltabptr := lparmptr; lparmptr^.ptrval := opertabptr^.operptr; auxopertabptr := opertabptr; opertabptr := opertabptr^.lastoper; ridoper(auxopertabptr); ptrlastoper := opertabptr end; rparmptr^.ptrval := opertabptr^.operptr; auxopertabptr := opertabptr; opertabptr := opertabptr^.lastoper; ridoper(auxopertabptr); ptrlastoper := opertabptr end; subrtabptr^.tokencallingsubr := tokentabptr; tokentabptr := subrtabptr^.calledsubr^.firstatement^.nextstmnt; vfuncptr := subrtabptr^.calledsubr^.firstatement end; {callsubr} function functcall: boolean; var ptrtofunctab: ^functab; nameoffunc: packedstring; validfn: boolean; begin (* functcall *) validfn := false; if tokentabptr^.noun = globvar then begin nameoffunc := tokentabptr^.vartabptr^.varname; if funcalreadydefined(nameoffunc, ptrtofunctab) then begin auxsubrtabptr := subrtabptr; getsubr(subrtabptr); subrtabptr^.lastsubrptr := auxsubrtabptr; subrtabptr^.calledsubr := ptrtofunctab; subrtabptr^.tokencallingsubr := tokentabptr; subrtabptr^.statemcallingsubr := vfuncptr; hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; validfn := true end end; functcall := validfn end; {functcall} procedure numwrite(realno: real); var prefix, root: integer; sigdig, colcnt: integer; begin (* output a number *) if realno >= 0.0 then write(outfile, ' ', realno:totaldigs:afterdigs) (* output positive number *) else begin (* output negative number *) realno := -1.0 * realno; sigdig := trunc((ln(realno))/(ln(10.0))); for colcnt := 1 to (((totaldigs - afterdigs) - 3) - sigdig) do write(outfile, ' '); write(outfile, character[negative]); sigdig := sigdig + afterdigs + 3; write(outfile, realno:sigdig:afterdigs) end end; {numwrite} procedure outputval; var cnt: integer; auxvaluesptr: ^values; dimhold: integer; dimen1, dimen2, dimen3: integer; outcnt1, outcnt2, outcnt3: integer; idimens: integer; begin (* outputval *) cnt := 0; write(outfile, indent); if not opertabptr^.operptr^.forwardorder then reverselinklist(opertabptr^.operptr); auxvaluesptr := opertabptr^.operptr^.firstvalue; idimens := opertabptr^.operptr^.dimensions; if not (idimens in [0..3]) then write(outfile, errormsgs[60]) else if auxvaluesptr = nil then write(outfile, errormsgs[61]) else if idimens = 0 then numwrite(auxvaluesptr^.realval) else begin dimen1 := opertabptr^.operptr^.firstdimen^.dimenlength; if idimens >= 2 then dimen2 := opertabptr^.operptr^.firstdimen^.nextdimen^.dimenlength else dimen2 := 1; if idimens = 3 then dimen3 := opertabptr^.operptr^.firstdimen^.nextdimen^.nextdimen^.dimenlength else dimen3 := 1; if idimens = 3 then begin (* rotate dimensions *) dimhold := dimen1; dimen1 := dimen2; dimen2 := dimen3; dimen3 := dimhold end; for outcnt3 := 1 to dimen3 do begin for outcnt2 := 1 to dimen1 do begin for outcnt1 := 1 to dimen2 do begin cnt := cnt + 1; if (((cnt-1) mod realsperline) = 0) and (cnt <> 1) then writeln(outfile); numwrite(auxvaluesptr^.realval); auxvaluesptr := auxvaluesptr^.nextvalue end; if idimens >= 2 then begin writeln(outfile); write(outfile, indent); cnt := 0 end end; if idimens = 3 then begin writeln(outfile); writeln(outfile); write(outfile, indent) end end end; writeln(outfile) end; {outputval} ======================================================================================== DOCUMENT :usus Folder:VOLUK04:aplparse1.text ======================================================================================== function variable: boolean; var globordummy: boolean; (* gord *) passedadj: ^vartab; (* k *) rarg: boolean; (* rd *) parmptr: ^valtab; (* pt *) validvar: boolean; validindex: boolean; procedure inputval; var auxptrtoda: ^valtab; auxvaluesptr: ^values; aux2valuesptr: ^values; realv: real; boolv: boolean; ccntr, cnt: integer; auxdimeninfoptr: ^dimeninfo; begin (* inputval *) cnt := 0; position := 1; auxptrtoda := ptrtoda; getvalt(ptrtoda); if auxptrtoda = nil then auxptrtoda := ptrtoda else auxptrtoda^.nextvaltablink := ptrtoda; auxopertabptr := opertabptr; getoper(opertabptr); ptrlastoper := opertabptr; opertabptr^.lastoper := auxopertabptr; opertabptr^.operptr := ptrtoda; getvalu(aux2valuesptr); ptrtoda^.firstvalue := aux2valuesptr; getaplstatement; repeat makeanumber(realv, boolv); skipspaces; if not boolv then begin for colcnt := 1 to messagelength do write(outfile, errormsgs[62, colcnt]); writeln(outfile); position := 1; cnt := 0; aux2valuesptr := opertabptr^.operptr^.firstvalue; getaplstatement end else begin cnt := cnt + 1; auxvaluesptr := aux2valuesptr; getvalu(aux2valuesptr); auxvaluesptr^.realval := realv; auxvaluesptr^.nextvalue := aux2valuesptr end until position > linelength; ridvalu(aux2valuesptr); auxvaluesptr^.nextvalue := nil; ptrtoda^.intermedresult := false; ptrtoda^.dimensions := 1; ptrtoda^.forwardorder := true; ptrtoda^.nextvaltablink := nil; getdim(auxdimeninfoptr); ptrtoda^.firstdimen := auxdimeninfoptr; auxdimeninfoptr^.dimenlength := cnt; auxdimeninfoptr^.nextdimen := nil end; {inputval} procedure getarrayposition(var valuesptr: typevaluesptr); var indice: real; kcnt: integer; sl: integer; auxdimeninfoptr: ^dimeninfo; begin (* getarrayposition *) if npv <> parmptr^.dimensions then error(45); (* wrong number of subscripts *) sl := 0; auxopertabptr := opertabptr; auxdimeninfoptr := parmptr^.firstdimen; for kcnt := 1 to npv do begin if auxopertabptr^.operptr^.dimensions <> 0 then error(35); (* non-scalar indices *) indice := auxopertabptr^.operptr^.firstvalue^.realval; if indice - 1.0*trunc(indice) <> 0.0 then error(37); (* non-integer indices *) if not (trunc(indice) in [1..auxdimeninfoptr^.dimenlength]) then error(38); (* out of range index *) sl := (sl*auxdimeninfoptr^.dimenlength) + trunc(indice) - 1; auxopertabptr := auxopertabptr^.lastoper; ridoper(opertabptr); opertabptr := auxopertabptr; auxdimeninfoptr := auxdimeninfoptr^.nextdimen end; valuesptr := parmptr^.firstvalue; while sl <> 0 do (* determine which value in *) (* pt[sval(sv)], pt[sval(sv-1)] ... pt[sval(sv-npv+1)] *) (* := sval(sv-npv) *) begin valuesptr := valuesptr^.nextvalue; sl := sl - 1 end end; {getarrayposition} procedure linkresults; var ptrtovalues: ^values; begin (* linkresults *) if npv = 0 then begin if not globordummy then if rarg then rparmptr^.ptrval := opertabptr^.operptr else lparmptr^.ptrval := opertabptr^.operptr else passedadj^.valtabptr := opertabptr^.operptr end else begin if globordummy then parmptr := passedadj^.valtabptr else parmptr := passedadj^.deferedvaltabptr^.ptrval; getarrayposition(ptrtovalues); if opertabptr^.operptr^.dimensions <> 0 then error(36); (* assigned expression not a scalar *) ptrtovalues^.realval := opertabptr^.operptr^.firstvalue^.realval end; auxopertabptr := opertabptr; opertabptr := opertabptr^.lastoper; ridoper(auxopertabptr); ptrlastoper := opertabptr end; {linkresults} procedure stackpointers; var auxptrtoda: ^valtab; ptrtovalues, auxvaluesptr: ^values; begin (* stackpointers *) if npv = 0 then begin auxopertabptr := opertabptr; getoper(opertabptr); opertabptr^.lastoper := auxopertabptr; opertabptr^.operptr := parmptr; ptrlastoper := opertabptr end else begin auxptrtoda := ptrtoda; getvalt(ptrtoda); ptrtoda^.nextvaltablink := auxptrtoda; ptrtoda^.intermedresult := true; ptrtoda^.dimensions := 0; ptrtoda^.firstdimen := nil; ptrtoda^.forwardorder := true; getvalu(auxvaluesptr); ptrtoda^.firstvalue := auxvaluesptr; getarrayposition(ptrtovalues); ptrtoda^.firstvalue^.realval := ptrtovalues^.realval; ptrtoda^.firstvalue^.nextvalue := nil; auxopertabptr := opertabptr; getoper(opertabptr); opertabptr^.lastoper := auxopertabptr; opertabptr^.operptr := ptrtoda; ptrlastoper := opertabptr end end; {stackpointers} function simplevariable: boolean; var validsv: boolean; begin (* simplevariable *) validsv := false; rarg := false; globordummy := false; if assign then begin if (tokentabptr^.noun = formres) or (tokentabptr^.noun = globvar) then begin globordummy := true; passedadj := tokentabptr^.vartabptr; hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; validsv := true end else if tokentabptr^.noun = formarg then begin if namesmatch(tokentabptr^.vartabptr^.functabptr^.leftarg, tokentabptr^.vartabptr^.varname) then rarg := true; passedadj := tokentabptr^.vartabptr end end else begin if (tokentabptr^.noun = formres) or (tokentabptr^.noun = globvar) then begin parmptr := tokentabptr^.vartabptr^.valtabptr; if parmptr <> nil then begin hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; validsv := true end end else begin if tokentabptr^.noun = formarg then begin if namesmatch(tokentabptr^.vartabptr^.functabptr^.leftarg, tokentabptr^.vartabptr^.varname) then parmptr := lparmptr^.ptrval else parmptr := rparmptr^.ptrval; hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; validsv := true end end end; simplevariable := validsv end; {simplevariable} procedure index(var validi: boolean); var valide1, valide2: boolean; begin (* index *) validi := false; expression(valide1); if valide1 then begin npv := 1; (* no. of index expressions *) while specsymbol(xsemicolsym) do begin npv := npv + 1; expression(valide2); if not valide2 then error(39) (* invalid index expression *) end; validi := true end end; {index} begin (* variable *) validvar := false; npv := 0; if not assign then if specsymbol(xquadsym) then begin inputval; validvar := true end else begin if specsymbol(xrightbracket) then begin index(validindex); if (not validindex) or (not specsymbol(xleftbracket)) then error(34) (* invalid index expression *) end; if simplevariable then begin stackpointers; validvar := true end end else if specsymbol(xquadsym) then begin outputval; validvar := true end else begin if specsymbol(xrightbracket) then begin index(validindex); if (not validindex) or (not specsymbol(xleftbracket)) then error(34) (* invalid index expression *) end; if simplevariable then begin linkresults; validvar := true end end; variable := validvar end; {variable} ======================================================================================== DOCUMENT :usus Folder:VOLUK04:aplparse2.text ======================================================================================== procedure primary(var valid: boolean); (* recursive entry *) var validx: boolean; assign: boolean; function vector: boolean; var vec: boolean; begin (* vector *) vec := false; if tokentabptr^.noun = constant then begin auxopertabptr := opertabptr; getoper(opertabptr); ptrlastoper := opertabptr; opertabptr^.lastoper := auxopertabptr; opertabptr^.operptr := tokentabptr^.valtabptr; hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; vec := true end; vector := vec end; {vector} begin (* primary *) valid := true; if not vector then begin assign := false; if not variable then if specsymbol(xrightpar) then begin expression(validx); if not validx then error(14) (* non-valid expression within parens *) else if not specsymbol(xleftpar) then error(15) (* right paren not balanced with left paren *) else valid := true end else if not functcall then valid := false else begin callsubr; primary(valid) end end end; {primary} procedure expression{var validexp: boolean}; (* recursive *) var donexp: boolean; validpri, validfunc, validassn: boolean; code: integer; procedure assignment(var valida: boolean); begin (* assignment *) valida := false; if specsymbol(xleftarrow) then begin assign := true; assign1 := true; if variable then valida := true else error(8); (* result of an assn not a valid variable *) valida := true; assign := false end end; {assignment} function mop: boolean; var validm: boolean; begin (* mop *) validm := false; if (tokentabptr^.noun = monadoper) or (tokentabptr^.noun = reductoper) then begin if tokentabptr^.noun = monadoper then code := moptab[tokentabptr^.monindx].opindex else code := redtab[tokentabptr^.redindx].opindex; hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; validm := true end; mop := validm end; {mop} function dop: boolean; var validd: boolean; begin (* dop *) validd := false; if tokentabptr^.noun = dyadoper then begin code := doptab[tokentabptr^.dopindx].opindex; hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; if (code > 80) then validd := true else if tokentabptr^.noun = specoper then if specsymbol(xperiod) then begin if tokentabptr^.noun = dyadoper then begin if doptab[tokentabptr^.dopindx].opindex <= 80 then begin code := code + 100*doptab[tokentabptr^.dopindx].opindex; hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; validd := true end else error(27) (* invalid inner product exp *) end else if tokentabptr^.noun = specoper then begin if specsymbol(xlittlecircle) then begin code := 10*code; validd := true end else error(26) (* inval outer prod exp *) end else error(26) (* same as above *) end else validd := true else validd := true end; dop := validd end; {dop} function itsboolean(test: real): boolean; begin if (test = 1.0) or (test = 0.0) then itsboolean := true else itsboolean := false end; {itsboolean} procedure dyadcomp(var sfloat: real; value: real; code: integer); begin (* compute result of dyadic operation *) case code of (* left codes - reduction ops / right code - dyadic ops *) 2, 52: sfloat := value + sfloat; (* addition *) 3, 53: sfloat := value - sfloat; (* subtraction *) 4, 54: sfloat := value * sfloat; (* multiplication *) 5, 55: if sfloat = 0.0 (* division *) then error(20) (* attempted division by zero *) else sfloat := value / sfloat; 6, 56: if value > 0.0 (* number raised to a power *) then sfloat := exp(sfloat * ln(value)) else sfloat := 1.0 / (exp(sfloat * ln(abs(value)))); 21, 71: if value = sfloat (* equality *) then sfloat := 1.0 else sfloat := 0.0; 22, 72: if value <> sfloat (* inequality *) then sfloat := 1.0 else sfloat := 0.0; 23, 73: if value < sfloat (* less than *) then sfloat := 1.0 else sfloat := 0.0; 24, 74: if value <= sfloat (* less than or equal to *) then sfloat := 1.0 else sfloat := 0.0; 25, 75: if value >= sfloat (* greater than or equal to *) then sfloat := 1.0 else sfloat := 0.0; 26, 76: if value > sfloat (* greater than *) then sfloat := 1.0 else sfloat := 0.0; 27, 77: if (itsboolean(value)) and (itsboolean(sfloat)) then (* and *) if (value = 1.0) and (sfloat = 1.0) then sfloat := 1.0 else sfloat := 0.0 else error(19); (* value not boolean *) 28, 78: if (itsboolean(value)) and (itsboolean(sfloat)) then (* or *) if (value = 1.0) or (sfloat = 1.0) then sfloat := 1.0 else sfloat := 0.0 else error(19); (* value not boolean *) 29: if value > sfloat (* maximum or ceiling *) then sfloat := value; 30: if value < sfloat (* minimum or floor *) then sfloat := value; 31: if (value*sfloat) < 0.0 (* log to a base *) then error(50) (* number and base of different sign *) else sfloat := (ln(abs(sfloat))) / (ln(abs(value))) end (* case *) end; {dyadcomp} procedure indexgenerator(arg: typevaltabptr); (* monadic iota generator *) var iotaindex: integer; topvalue: integer; begin if arg^.dimensions <> 0 then error(21) (* argument not a scalar *) else if arg^.firstvalue^.realval < 0.0 then error(22) (* argument is negative *) else if arg^.firstvalue^.realval <> trunc(arg^.firstvalue^.realval) then error(23) (* argument is not an integer *) else begin getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.forwardorder := true; newvaltablink^.intermedresult := true; newvaltablink^.dimensions := 1; (* result is a vector *) getdim(newdim); newvaltablink^.firstdimen := newdim; topvalue := trunc(arg^.firstvalue^.realval); (* last index generd *) newdim^.dimenlength := topvalue; newdim^.nextdimen := nil; iotaindex := 1; switch := true; while iotaindex <= topvalue do begin getvalu(newvalues); newvalues^.realval := iotaindex; if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalptr := newvalues; iotaindex := iotaindex + 1 end; if switch = true then newvaltablink^.firstvalue := nil (* result is a vector of length 0 *) else newvalues^.nextvalue := nil end end; {indexgenerator} procedure ravel(arg: typevaltabptr); (* monadic comma operator *) var elements: integer; begin getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; newvaltablink^.forwardorder := arg^.forwardorder; newvaltablink^.dimensions := 1; (* result is a vector *) getdim(newdim); newvaltablink^.firstdimen := newdim; newdim^.nextdimen := nil; switch := true; valptr := arg^.firstvalue; elements := 0; while valptr <> nil do begin (* duplicate values into result *) getvalu(newvalues); newvalues^.realval := valptr^.realval; elements := elements + 1; if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalptr := newvalues; valptr := valptr^.nextvalue end; newdim^.dimenlength := elements; if switch = true then newvaltablink^.firstvalue := nil else newvalues^.nextvalue := nil end; {ravel} procedure shapeof(arg: typevaltabptr); (* monadic rho operator *) begin getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; newvaltablink^.forwardorder := true; newvaltablink^.dimensions := 1; (* result is a vector *) getdim(newdim); newdim^.dimenlength := arg^.dimensions; newvaltablink^.firstdimen := newdim; newdim^.nextdimen := nil; switch := true; dimptr := arg^.firstdimen; while dimptr <> nil do begin (* argument dimensions become result values *) getvalu(newvalues); newvalues^.realval := dimptr^.dimenlength; if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalptr := newvalues; dimptr := dimptr^.nextdimen end; if switch = true then newvaltablink^.firstvalue := nil (* result is a vector of length 0 *) else newvalues^.nextvalue := nil end; {shapeof} procedure reduction(arg: typevaltabptr); var counter: integer; rowlength: integer; sfloat: real; begin if (arg^.dimensions = 0) or (arg^.firstvalue = nil) then error(24) (* argument is a scalar or vector of length zero *) else if (arg^.dimensions = 1) and (arg^.firstdimen^.dimenlength = 1) then error(51) (* argument is a vector of length one *) else begin getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; if arg^.forwardorder = true then reverselinklist(arg); newvaltablink^.forwardorder := false; newvaltablink^.dimensions := arg^.dimensions - 1; dimptr := arg^.firstdimen; switch := true; while dimptr^.nextdimen <> nil do begin (* build dimensions of result *) getdim(newdim); if switch = true then begin switch := false; newvaltablink^.firstdimen := newdim end else newptr^.nextdimen := newdim; newdim^.dimenlength := dimptr^.dimenlength; newptr := newdim; dimptr := dimptr^.nextdimen end; if switch = true then newvaltablink^.firstdimen := nil (* arg is a vector, result is scalar *) else newdim^.nextdimen := nil; rowlength := dimptr^.dimenlength; valptr := arg^.firstvalue; switch := true; while valptr <> nil do begin (* perform reduction *) sfloat := valptr^.realval; (* sfloat gets last value in row *) valptr := valptr^.nextvalue; for counter := 2 to rowlength do begin dyadcomp(sfloat, valptr^.realval, code); valptr := valptr^.nextvalue end; getvalu(newvalues); newvalues^.realval := sfloat; if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalptr := newvalues end; newvalues^.nextvalue := nil end end; {reduction} procedure roll(rollsize: real; var rollresult: real); const rollmult = -23571; rolladd = 7473; twotothe16 = 65536.0; var temprollnum: real; begin rollnum := rollnum*rollmult + rolladd; if rollnum < 0 then temprollnum := twotothe16 + rollnum else temprollnum := rollnum; rollresult := trunc(rollsize*(temprollnum/twotothe16) + 1.0) end; {roll} procedure monadic(arg: typevaltabptr; token: tokenptr); (* operations with codes between 1 and 31 *) begin if token^.noun = reductoper then reduction(arg) else if code > 20 then case code of 21: indexgenerator(arg); 22: shapeof(arg); 23: ravel(arg) end (* case *) else begin getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; newvaltablink^.forwardorder := arg^.forwardorder; newvaltablink^.dimensions := arg^.dimensions; switch := true; dimptr := arg^.firstdimen; while dimptr <> nil do begin (* duplicate dimensions of arg into result *) getdim(newdim); newdim^.dimenlength := dimptr^.dimenlength; if switch = true then begin switch := false; newvaltablink^.firstdimen := newdim end else newptr^.nextdimen := newdim; newptr := newdim; dimptr := dimptr^.nextdimen end; if switch = true then newvaltablink^.firstdimen := nil (* result is a scalar *) else newdim^.nextdimen := nil; switch := true; valptr := arg^.firstvalue; while valptr <> nil do begin getvalu(newvalues); if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalptr := newvalues; case code of 1: if itsboolean(valptr^.realval) (* logical negation *) then newvalues^.realval := 1.0 - valptr^.realval else error(19); (* value not boolean *) 2: newvalues^.realval := valptr^.realval; (* no-op *) 3: newvalues^.realval := 0.0 - valptr^.realval; (* negation *) 4: if valptr^.realval > 0.0 (* signum *) then newvalues^.realval := 1.0 else if valptr^.realval < 0.0 then newvalues^.realval := -1.0 else newvalues^.realval := 0.0; 5: if valptr^.realval = 0.0 (* reciprocal *) then error(54) (* attempted inverse of zero *) else newvalues^.realval := 1.0 / valptr^.realval; 6: newvalues^.realval := exp(valptr^.realval); (* exp *) 9: if valptr^.realval = trunc(valptr^.realval) (* ceiling *) then newvalues^.realval := valptr^.realval else newvalues^.realval := trunc(valptr^.realval + 1.0); 10: newvalues^.realval := trunc(valptr^.realval); (* floor *) 7: if trunc(valptr^.realval) <> valptr^.realval then error(23) (* argument is not an integer *) else if valptr^.realval < 0.0 then error(22) (* argument is negative *) else roll(valptr^.realval, newvalues^.realval) (* roll *) end; (* case *) valptr := valptr^.nextvalue end; if switch = true then newvaltablink^.firstvalue := nil else newvalues^.nextvalue := nil end end; {monadic} procedure catenate(leftarg, rightarg: typevaltabptr); (* dyadic comma operator - joins 2 arguments *) var resultlength: integer; begin (* catenate *) if (rightarg^.dimensions > 1) or (leftarg^.dimensions > 1) then error(53) (* argument(s) with rank greater than 1 *) else begin getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; if leftarg^.forwardorder = false then reverselinklist(leftarg); if rightarg^.forwardorder = false then reverselinklist(rightarg); newvaltablink^.forwardorder := true; newvaltablink^.dimensions := 1; (* result is a vector *) getdim(newdim); newvaltablink^.firstdimen := newdim; newdim^.nextdimen := nil; resultlength := 0; if leftarg^.dimensions = 0 then resultlength := resultlength + 1 (* leftarg is a scalar *) else resultlength := resultlength + leftarg^.firstdimen^.dimenlength; if rightarg^.dimensions = 0 then resultlength := resultlength + 1 (* rightarg is a scalar *) else resultlength := resultlength + rightarg^.firstdimen^.dimenlength; newdim^.dimenlength := resultlength; switch := true; if resultlength = 0 then newvaltablink^.firstvalue := nil (* result is vector of length 0 *) else begin (* transfer values to result *) leftvalptr := leftarg^.firstvalue; while leftvalptr <> nil do begin (* transfer left arg values (if any) *) getvalu(newvalues); if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalues^.realval := leftvalptr^.realval; newvalptr := newvalues; leftvalptr := leftvalptr^.nextvalue end; rightvalptr := rightarg^.firstvalue; while rightvalptr <> nil do begin (* transfer right arg values (if any) *) getvalu(newvalues); if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalues^.realval := rightvalptr^.realval; newvalptr := newvalues; rightvalptr := rightvalptr^.nextvalue end; newvalues^.nextvalue := nil end (* transfer of values *) end end; {catenate} procedure indexof(leftarg, rightarg: typevaltabptr); (* dyadic iota operator *) var mapindex, icount, testlength, onemore: integer; begin (* indexof *) if leftarg^.dimensions <> 1 then error(29) (* left argument is not a vector *) else begin getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; if leftarg^.forwardorder = false then reverselinklist(leftarg); newvaltablink^.forwardorder := rightarg^.forwardorder; newvaltablink^.dimensions := rightarg^.dimensions; if rightarg^.dimensions = 0 then newvaltablink^.firstdimen := nil (* right argument is a scalar *) else begin (* build dimensions of result *) switch := true; dimptr := rightarg^.firstdimen; while dimptr <> nil do begin getdim(newdim); if switch = true then begin switch := false; newvaltablink^.firstdimen := newdim end else newptr^.nextdimen := newdim; newdim^.dimenlength := dimptr^.dimenlength; newptr := newdim; dimptr := dimptr^.nextdimen end; newdim^.nextdimen := nil end; switch := true; rightvalptr := rightarg^.firstvalue; while rightvalptr <> nil do begin getvalu(newvalues); if switch = true then begin switch := false; newvaltablink^.firstvalues := newvalues end else newvalptr^.nextvalue := newvalues; icount := 1; leftvalptr := leftarg^.firstvalue; testlength := leftarg^.firstdimen^.dimenlength; (* length of left arg *) onemore := testlength + 1; (* length of left arg plus one !!! *) mapindex := onemore; while (icount <= testlength) and (mapindex = onemore) do begin (* try to match value in right arg with one in left arg *) if leftvalptr^.realval = rightvalptr^.realval then mapindex := icount; (*value match *) icount := icount + 1; leftvalptr := leftvalptr^.nextvalue end; newvalues^.realval := mapindex; newvalptr := newvalues; rightvalptr := rightvalptr^.nextvalue end; (* if no match, index becomes one more than length of left arg *) newvalues^.nextvalue := nil end end; {indexof} procedure reshape(leftarg, rightarg: typevaltabptr); (* dyadic rho operator - change dimensions of *) var resultlength, elements: integer; dimptr: ^dimeninfo; newptr: ^values; begin (* reshape *) if leftarg^.dimensions > 1 then error(56) (* left argument is not a vector or a scalar *) else begin getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; if leftarg^.forwardorder = false then reverselinklist(leftarg); if rightarg^.forwardorder = false then reverselinklist(rightarg); newvaltablink^.forwardorder := true; if leftarg^.firstdimen = nil then newvaltablink^.dimensions := 1 else newvaltablink^.dimensions := leftarg^.firstdimen^.dimenlength; resultlength := 1; leftvalptr := leftarg^.firstvalue; switch := true; while leftvalptr <> nil do (* left arg values are dimensions of result *) begin (* build result dimensions *) resultlength := resultlength*trunc(leftvalptr^.realval); getdim(newdim); newdim^.dimenlength := trunc(leftvalptr^.realval); leftvalptr := leftvalptr^.nextvalue; if switch = true then begin switch := false; newvaltablink^.firstdimen := newdim end else dimptr^.nextdimen := newdim; dimptr := newdim; end; newdim^.nextdimen := nil; rightvalptr := rightarg^.firstvalue; elements := 0; switch := true; while elements < resultlength do begin (* duplicate right arg values into result values *) elements := elements + 1; getvalu(newvalues); if rightvalptr = nil (* extend right argument if necessary *) then rightvalptr := rightarg^.firstvalue; newvalues^.realval := rightvalptr^.realval; if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newptr^.nextvalue := newvalues; newptr := newvalues; rightvalptr := rightvalptr^.nextvalue end; newvalues^.nextvalue := nil end end; {reshape} procedure innerproduct(leftarg, rightarg: typevaltabptr); var inpro1code, inpro2code: integer; leftskip, rightskip: integer; icount, jcount, kcount, lcount, mcount: integer; lastleftdim, firstrightdim, commonlength: integer; lptr: ^values; hold: real; sfloat: real; value: real; begin (* inner product is matrix multiplication *) dimptr := leftarg^.firstdimen; if leftarg^.firstdimen <> nil then while dimptr^.nextdimen <> nil do dimptr := dimptr^.nextdimen; (* get last dimen of left arg (if any) *) if (dimptr <> nil) and (rightarg^.firstdimen <> nil) then if dimptr^.dimenlength <> rightarg^.firstdimen^.dimenlength then error(52) (* last dim of left arg not = first dim of right arg *) else begin inpro1code := code div 100; (* seperate operators *) inpro2code := code mod 100; getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; if leftarg^.forwardorder = false then reverselinklist(leftarg); if rightarg^.forwardorder = false then reverselinklist(rightarg); newvaltablink^.forwardorder := true; newvaltablink^.dimensions := leftarg^.dimensions + rightarg^.dimensions - 2; if newvaltablink^.dimensions < 0 then newvaltablink^.dimensions := 0; switch := true; lastleftdim := 0; if leftarg^.firstdimen <> nil then begin (* copy all but last of left arg dims into result *) leftskip := 1; dimptr := leftarg^.firstdimen; while dimptr^.nextdimen <> nil do begin (* copy left arg dimensions *) getdim(newdim); newdim^.dimenlength := dimptr^.dimenlength; leftskip := leftskip*dimptr^.dimenlength; if switch = true then begin switch := false; newvaltablink^.firstdimen := newdim end else newptr^.nextdimen := newdim; newptr := newdim; dimptr := dimptr^.nextdimen end; lastleftdim := dimptr^.dimenlength end; if rightarg^.firstdimen <> nil then begin (* copy all but last of right arg dims into result *) rightskip := 1; dimptr := rightarg^.firstdimen^.nextdimen; while dimptr <> nil do begin (* copy right arg dimensions *) getdim(newdim); newdim^.dimenlength := dimptr^.dimenlength; rightskip := rightskip*dimptr^.dimenlength; if switch = true then begin switch := false; newvaltablink^.firstdimen := newdim end else newptr^.nextdimen := newdim; newptr := newdim; dimptr := dimptr^.nextdimen end end; if switch = true then newvaltablink^.firstdimen := nil else newdim^.nextdimen := nil; if leftarg^.firstvalue = nil then leftskip := 0; if rightarg^.firstvalue = nil then rightskip := 0; switch := true; if rightarg^.firstdimen <> nil then firstrightdim := rightarg^.firstdimen^.dimenlength else firstrightdim := 0; if firstrightdim > lastleftdim then commonlength := firstrightdim else commonlength := lastleftdim; icount := 0; leftvalptr := leftarg^.firstvalue; while icount < leftskip do begin (* loop for each row in left arg *) lptr := leftvalptr; (* hold start of row position *) jcount := 0; while jcount < rightskip do begin (* loop for each column in right arg *) leftvalptr := lptr; rightvalptr := rightarg^.firstvalue; lcount := 0; while lcount < jcount do begin (* skip to starting value in right arg *) rightvalptr := rightvalptr^.nextvalue; if rightvalptr = nil then rightvalptr := rightarg^.firstvalue; (* extend arg *) lcount := lcount + 1 end; kcount := 0; while kcount < commonlength do begin (* loop for each element in row/column *) sfloat := rightvalptr^.realval; dyadcomp(sfloat, leftvalptr^.realval, inpro2code); value := sfloat; if kcount = 0 then (* set identity value for first time through *) case inpro1code of 52, 53, 78: sfloat := 0.0; 54, 55, 56, 77: sfloat := 1.0; 71, 72, 73, 74, 75, 76: (* null case *) end (* case *) else sfloat := hold; dyadcomp(sfloat, value, inpro1code); hold := sfloat; (* save summer result *) leftvalptr := leftvalptr^.nextvalue; if leftvalptr = nil then leftvalptr := leftarg^.firstvalue; (* extend arg *) mcount := 0; while mcount < rightskip do begin (* skip to next value in right arg *) mcount := mcount + 1; rightvalptr := rightvalptr^.nextvalue; if rightvalptr = nil then rightvalptr := rightarg^.firstvalue end; kcount := kcount + 1 end; getvalu(newvalues); newvalues^.realval := sfloat; if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalptr := newvalues; jcount := jcount + 1 end; icount := icount + 1 end; if switch = true then newvaltablink^.firstvalue := nil else newvalues^.nextvalue := nil end end; {innerproduct} procedure outerproduct(leftarg, rightarg: typevaltabptr); var outprocode: integer; sfloat: real; begin outprocode := code div 10; getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; if leftarg^.forwardorder = false then reverselinklist(leftarg); if rightarg^.forwardorder = false then reverselinklist(rightarg); newvaltablink^.forwardorder := true; newvaltablink^.dimensions := leftarg^.dimensions + rightarg^.dimensions; switch := true; dimptr := leftarg^.firstdimen; while dimptr <> nil do begin (* copy left arg dimensions to result *) getdim(newdim); newdim^.dimenlength := dimptr^.dimenlength; if switch = true then begin switch := false; newvaltablink^.firstdimen := newdim end else newptr^.nextdimen := newdim; newptr := newdim; dimptr := dimptr^.nextdimen end; dimptr := rightarg^.firstdimen; while dimptr <> nil do begin (* copy right arg dimensions to result *) getdim(newdim); newdim^.dimenlength := dimptr^.dimenlength; if switch = true then begin switch := false; newvaltablink^.firstdimen := newdim end else newptr^.nextdimen := newdim; newptr := newdim; dimptr := dimptr^.nextdimen end; if switch = true then newvaltablink^.firstdimen := nil else newdim^.nextdimen := nil; switch := true; leftvalptr := leftarg^.firstvalue; while leftvalptr <> nil do begin rightvalptr := rightarg^.firstvalue; while rightvalptr <> nil do begin sfloat := rightvalptr^.realval; dyadcomp(sfloat, leftvalptr^.realval, outprocode); getvalu(newvalues); if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalues^.realval := sfloat; newvalptr := newvalues; rightvalptr := rightvalptr^.nextvalue end; leftvalptr := leftvalptr^.nextvalue end; if switch = true then newvaltablink^.firstvalue := nil else newvalues^.nextvalue := nil end; {outerproduct} procedure dyadic(leftarg, rightarg: typevaltabptr); (* operators with codes of 52 and higher *) var compatible: boolean; arg: typevaltabptr; sfloat: real; begin if code > 1000 then innerproduct(leftarg, rightarg) else if code > 100 then outerproduct(leftarg, rightarg) else if code > 80 then case code of 87: indexof(leftarg, rightarg); 88: reshape(leftarg, rightarg); 89: catenate(leftarg, rightarg) end (* case *) else begin (* simple dyadics *) compatible := true; if (leftarg^.dimensions >= 1) and (rightarg^.dimensions >= 1) then if leftarg^.dimensions <> rightarg^.dimensions then compatible := false (* different ranks/neither scalar *) else begin (* ranks match - check lengths *) leftdimptr := leftarg^.firstdimen; rightdimptr := rightarg^.firstdimen; while leftdimptr <> nil do begin if leftdimptr^.dimenlength <> rightdimptr^.dimenlength then compatible := false; (* different length(s) *) leftdimptr := leftdimptr^.nextdimen; rightdimptr := rightdimptr^.nextdimen end end; if compatible = true (* arguments suitable for dyadic operation *) then begin (* build dimensions of result *) if rightarg^.dimensions > leftarg^.dimensions then arg := rightarg else arg := leftarg; (* result has shape of larger arg *) getvalt(newvaltablink); oldvaltablink^.nextvaltablink := newvaltablink; newvaltablink^.nextvaltablink := nil; newvaltablink^.intermedresult := true; if leftarg^.forwardorder <> rightarg^.forwardorder then reverselinklist(leftarg); newvaltablink^.forwardorder := arg^.forwardorder; newvaltablink^.dimensions := arg^.dimensions; switch := true; dimptr := arg^.firstdimen; while dimptr <> nil do begin (* copy dimensions to result *) getdim(newdim); newdim^.dimenlength := dimptr^.dimenlength; if switch = true then begin switch := false; newvaltablink^.firstdimen := newdim end else newptr^.nextdimen := newdim; newptr := newdim; dimptr := dimptr^.nextdimen end; if switch = true then newvaltablink^.firstdimen := nil (* result is a scalar *) else newdim^.nextdimen := nil; switch := true; rightvalptr := rightarg^.firstvalue; leftvalptr := leftarg^.firstvalue; valptr := arg^.firstvalue; while valptr <> nil do begin (* perform operation *) getvalu(newvalues); sfloat := rightvalptr^.realval; dyadcomp(sfloat, leftvalptr^.realval, code); newvalues^.realval := sfloat; if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalptr := newvalues; valptr := valptr^.nextvalue; leftvalptr := leftvalptr^.nextvalue; rightvalptr := rightvalptr^.nextvalue; if leftvalptr = nil then leftvalptr := leftarg^.firstvalue; (* extend arg *) if rightvalptr = nil then rightvalptr := rightarg^.firstvalue (* extend *) end; if switch = true then newvaltablink^.firstvalue := nil (* vector of len 0 *) else newvalues^.nextvalue := nil end else error(55) (* arguments incompatible for dyadic operation *) end end; {dyadic} procedure funcall(var validfunk: boolean); var validpm: boolean; begin (* funcall *) validfunk := false; if functcall then begin if tokentabptr^.noun <> statend then begin subrtabptr^.tokencallingsubr := tokentabptr; primary(validpm); if not validpm then error(17) (* leftarg of dyadic func call not a primary *) end; callsubr; validfunk := true end end; {funcall} begin (* expression *) primary(validpri); if not validpri then begin if tokentabptr^.noun = statend then begin validexp := true; assign1 := true end else validexp := false end else begin donexp := false; while not donexp do begin funcall(validfunc); if validfunc then begin expression(validexp); donexp := true end else begin assignment(validassn); if validassn and (tokentabptr^.noun = statend) then begin donexp := true; validexp := true end; if not validassn then if mop then begin monadic(opertabptr^.operptr, hold); opertabptr^.operptr := newvaltablink end else if not dop then begin validexp := true; donexp := true end else begin primary(validpri); if not validpri then error(13) (* dyad oper not preceded by a pri *) else begin dyadic(opertabptr^.operptr, opertabptr^.lastoper^.operptr); auxopertabptr := opertabptr; opertabptr := opertabptr^.lastoper; ptrlastoper := opertabptr; ridoper(auxopertabptr); opertabptr^.operptr := newvaltablink end end end end end end; {expression} ======================================================================================== DOCUMENT :usus Folder:VOLUK04:aplparse3.text ======================================================================================== begin (* parser *) assign := false; assign1 := false; doneparse := false; repeat expression(validexp); (* check for valid expression *) if not validexp then error(10) (* invalid expression *) else if specsymbol(xrightarrow) then if not ((opertabptr^.operptr^.firstvalue = nil) and (opertabptr^.operptr^.dimensions > 0)) then (* branch *) (* result of expression is at opertabptr *) if opertabptr^.operptr^.firstvalue^.realval <> trunc(opertabptr^.operptr^.firstvalue^.realval) then error(12) (* stmt.num.to branch to not an integer *) else if subrtabptr = nil then begin (* interpretive *) tokentabptr := hold; doneparse := true end else (* function mode *) if trunc(opertabptr^.operptr^.firstvalue^.realval) in [1..(subrtabptr^.calledsubr^.numofstatements)] then begin vfunchold := subrtabptr^.calledsubr^.firstatement; for cnt := 1 to trunc(opertabptr^.operptr^.firstvalue^.realval) do begin vfuncptr := vfunchold; tokentabptr := vfuncptr^.nextstmnt; vfunchold := vfuncptr^.nextvfuncptr end; auxopertabptr := opertabptr; opertabptr := opertabptr^.lastoper; ridoper(auxopertabptr); ptrlastoper := opertabptr; tokentabptr := vfuncptr^.nextstmnt end else (* successor *) else (* successor *) else (* successor *) begin if not assign1 then outputval; assign1 := false; if subrtabptr = nil then begin (* interpretive *) hold := tokentabptr; tokentabptr := tokentabptr^.nextoken; doneparse := true end else (* function *) begin vfuncptr := vfuncptr^.nextvfuncptr; donesuccessor := false; repeat if vfuncptr <> nil then begin tokentabptr := vfuncptr^.nextstmnt; donesuccessor := true end else begin returntocallingsubr; if tokentabptr^.noun = statend then donesuccessor := true end until donesuccessor end end until doneparse; release (* release memory *) end; {parser} ======================================================================================== DOCUMENT :usus Folder:VOLUK04:aplprocs.text ======================================================================================== procedure printaplstatement; begin writeln(outfile, aplstatement) end; {printaplstatement} procedure serror(errorindex: integer); var msgcol: integer; begin tokenerror := true; writeln(outfile, errormsgs[errorindex]); printaplstatement; (* echo statement to user *) for msgcol := 1 to (position - 1) do write(outfile, ' '); writeln(outfile, character[uparrow]) (* print pointer to user error *) end; {serror} procedure skipspaces; begin while (aplstatement[position] = character[space]) and (position <= linelength) do position := position + 1 end; {skipspaces} procedure getaplstatement; var inputchars: string; begin (* blank out line *) fillchar(aplstatement, sizeof(aplstatement), character[space]); linelength := 0; position := 1; linetoolong := false; aplstatement[inputarraysize] := character[omega]; aplstatement[inputarraysize - 1] := character[space]; (* set end-of-line *) repeat begin write(outfile, character[quadrangle]); if funcmode then write(outfile, character[leftbracket], funcstatements + 1: 2, character[rightbracket], character[space]) else write(outfile, ' ', character[space]); readln(infile, inputchars); while (linelength < length(inputchars)) and (not linetoolong) do if linelength < maxinputline then begin linelength := linelength + 1; aplstatement[linelength] := inputchars[linelength] end else linetoolong := true end until linelength <> 0; (* reject null lines *) if linetoolong then serror(71) end; {getaplstatement} function itsadigit(testchar: char): boolean; var digitindex: aplcharset; begin (* test to see if input character is a digit *) itsadigit := true; for digitindex := onesymbol to zerosymbol do if testchar = character[digitindex] then exit(itsadigit); itsadigit := false end; {itsadigit} function itsaletter(testchar: char): boolean; var letterindex: aplcharset; begin (* test to see if input character is a letter *) itsaletter := true; for letterindex := asymbol to zsymbol do if testchar = character[letterindex] then exit(itsaletter); itsaletter := false end; {itsaletter} function chartonum(testchar: char): integer; var digitindex: aplcharset; begin (* change a character to a number *) for digitindex := onesymbol to zerosymbol do if testchar = character[digitindex] then begin chartonum := digits[digitindex]; exit(chartonum) end end; {chartonum} function namesmatch{nameone, nametwo: packedstring): boolean}; begin (* see if two names (identifiers) are the same *) namesmatch := nameone = nametwo end; {namesmatch} procedure tablelookup(testchar: char; tablelength: integer; table: optable; var tableindex: integer); var index: integer; begin (* check for membership in a given table *) tableindex := 0; for index := 1 to tablelength do if testchar = table[index].opsymbol then begin tableindex := index; exit(tablelookup) end end; {tablelookup} procedure identifier(var name: packedstring; var itsanidentifier: boolean); var namelength: integer; nametoolong: boolean; begin itsanidentifier := false; skipspaces; if itsaletter(aplstatement[position]) then begin nametoolong := false; itsanidentifier := true; for namelength := 1 to maxvarnamelength do (* blank out name *) name[namelength] := character[space]; namelength := 0; while (itsaletter(aplstatement[position])) or (itsadigit(aplstatement[position])) do begin (* build identifier *) namelength := namelength + 1; if namelength <= maxvarnamelength then name[namelength] := aplstatement[position] else nametoolong := true; position := position + 1 end; if nametoolong then serror(70) (* name greater than maxlength *) end end; {identifier} procedure makeanumber{var realnumber: real; var itsanumber: boolean}; var sign, digitcount: integer; begin (* convert character input string to numerical representation *) itsanumber := false; skipspaces; sign := 1; digitcount := 0; realnumber := 0.0; if (aplstatement[position] = character[negative]) or (itsadigit(aplstatement[position])) then begin itsanumber := true; if aplstatement[position] = character[negative] then begin sign := -1; position := position + 1 end; if not itsadigit(aplstatement[position]) then begin serror(1); (* digit must follow a minus sign *) itsanumber := false end else begin (* form whole number portion *) while itsadigit(aplstatement[position]) do begin realnumber := 10.0*realnumber + chartonum(aplstatement[position]); position := position + 1 end; if aplstatement[position] = character[period] then begin position := position + 1; while itsadigit(aplstatement[position]) do begin (* form fractional portion *) realnumber := realnumber + (chartonum(aplstatement[position]) / pwroften(digitcount + 1)); digitcount := digitcount + 1; position := position + 1 end; if digitcount = 0 then begin serror(2); (* digits must follow a decimal point *) itsanumber := false end end; realnumber := realnumber * sign end end end; {makeanumber} function monadicreference: boolean; var subposition, tableindex: integer; begin (* see if operator is monadic within context of input line *) monadicreference := false; if newtokenptr^.nextoken^.noun = statend then monadicreference := true else begin subposition := position - 1; while (subposition > 0) and (aplstatement[subposition] = character[space]) do subposition := subposition - 1; (* get last non-blank *) if subposition <> 0 then tablelookup(aplstatement[subposition], spectablength, spectab, tableindex); if (tableindex <> 0) or (subposition = 0) then monadicreference := true else if (newtokenptr^.nextoken^.noun <> formres) and (newtokenptr^.nextoken^.noun <> formarg) and (newtokenptr^.nextoken^.noun <> globvar) and (newtokenptr^.nextoken^.noun <> constant) and (aplstatement[subposition] <> character[period]) and (aplstatement[subposition] <> character[rightparen]) and (aplstatement[subposition] <> character[rightbracket]) then monadicreference := true end end; {monadicreference} procedure dyadicopcheck; var tableindex: integer; begin tablelookup(aplstatement[position], doptablength, doptab, tableindex); if tableindex = 0 then begin tablelookup(aplstatement[position], chartablength, chartab, tableindex); if tableindex = 0 then if aplstatement[position] = character[southcap] then begin oldtokenptr := savetokenptr; ridtoken(newtokenptr); newtokenptr := savetokenptr; position := linelength + 1 end (* this was a comment - ignore remainder of line *) else serror(4) (* invalid character encountered *) else begin (* special character encountered *) newtokenptr^.noun := specoper; newtokenptr^.charindx := tableindex end end else if monadicreference then serror(74) (* monadic reference to dyadic operator *) else begin (* operator is dyadic *) newtokenptr^.noun := dyadoper; newtokenptr^.dopindx := tableindex end end; {dyadicopcheck} procedure checkothertables; var tableindex: integer; chkindex: integer; function nextnonblank: char; begin chkindex := position + 1; while (chkindex < linelength) and (aplstatement[chkindex] = character[space]) do chkindex := chkindex + 1; nextnonblank := aplstatement[chkindex] end; {nextnonblank} begin if nextnonblank = character[forwardslash] then begin tablelookup(aplstatement[position], redtablength, redtab, tableindex); if tableindex = 0 then serror(72) (* invalid reduction operator *) else if not monadicreference then serror(73) (* dyadic reduction reference *) else begin (* operator is valid reduction operator *) newtokenptr^.noun := reductoper; newtokenptr^.redindx := tableindex end; position := chkindex + 1 end else begin tablelookup(aplstatement[position], moptablength, moptab, tableindex); if tableindex = 0 then dyadicopcheck else if not monadicreference then dyadicopcheck else begin (* operator is monadic *) newtokenptr^.noun := monadoper; newtokenptr^.monindx := tableindex end; position := position + 1 end end; {checkothertables} procedure trytogetanumber; var numbercount: integer; realnumber: real; itsanumber: boolean; begin numbercount := 0; makeanumber(realnumber, itsanumber); if not itsanumber then checkothertables else begin (* store values in value table *) getvalt(newvaltablink); newvaltablink^.nextvaltablink := oldvaltablink; oldvaltablink := newvaltablink; newvaltablink^.forwardorder := true; if funcmode then newvaltablink^.intermedresult := false else newvaltablink^.intermedresult := true; switch := true; while itsanumber do begin numbercount := numbercount + 1; getvalu(newvalues); if switch = true then begin switch := false; newvaltablink^.firstvalue := newvalues end else newvalptr^.nextvalue := newvalues; newvalues^.realval := realnumber; newvalptr := newvalues; makeanumber(realnumber, itsanumber) end; newvalues^.nextvalue := nil; if numbercount > 1 then begin newvaltablink^.dimensions := 1; (* number is a vector *) getdim(newdim); newvaltablink^.firstdimen := newdim; newdim^.dimenlength := numbercount; newdim^.nextdimen := nil end else begin newvaltablink^.dimensions := 0; newvaltablink^.firstdimen := nil end; newtokenptr^.noun := constant; newtokenptr^.valtabptr := newvaltablink end end; {trytogetanumber} function nameinvartable{name: packedstring; var varpointer: vartabptrtype; testfuncptr: ptrfunctab): boolean}; var found: boolean; begin found := false; varpointer := oldvartabptr; while (varpointer <> nil) and (found = false) do begin if (namesmatch(name, varpointer^.varname)) and (varpointer^.functabptr = testfuncptr) (* test for global var *) then found := true else varpointer := varpointer^.nextvartabptr end; nameinvartable := found end; {nameinvartable} procedure addnametovartable(name: packedstring); begin (* new variable name encountered *) getvarr(newvartabptr); newvartabptr^.nextvartabptr := oldvartabptr; oldvartabptr := newvartabptr; newvartabptr^.varname := name; newvartabptr^.valtabptr := nil; if newtokenptr <> nil then if (newtokenptr^.noun = formres) or (newtokenptr^.noun = formarg) then newvartabptr^.functabptr := newfunctabptr else newvartabptr^.functabptr := nil end; {addnametovartable} function funcalreadydefined{var newfuname: packedstring; var funcindex: ptrfunctab): boolean}; var found: boolean; begin found := false; funcindex := oldfunctabptr; while (funcindex <> nil) and (found = false) and (newfunctabptr <> nil) do if namesmatch(funcindex^.funcname, newfuname) then found := true else funcindex := funcindex^.nextfunctabptr; funcalreadydefined := found end; {funcalreadydefined} procedure maketokenlink; begin gettoken(newtokenptr); newtokenptr^.nextoken := oldtokenptr; savetokenptr := oldtokenptr; oldtokenptr := newtokenptr end; {maketokenlink} procedure processfunctionheader; var dummyptr: ^functab; name1, name2, name3: packedstring; itsanidentifier: boolean; funcheaderror: boolean; arityindex: integer; begin funcheaderror := false; funcmode := true; funcstatements := -1; if firstfunction then begin funcstatements := 0; firstfunction := false end; arityindex := 1; position := position + 1; identifier(name1, itsanidentifier); if not itsanidentifier then begin serror(7); (* unrecognizable function/argument name *) funcmode := false; (* exit function mode *) funcheaderror := true end else begin getfunc(newfunctabptr); skipspaces; if aplstatement[position] = character[leftarrow] then begin newfunctabptr^.result := true; (* explicit result *) newfunctabptr^.resultname := name1; position := position + 1; identifier(name1, itsanidentifier); if not itsanidentifier then begin serror(6); (* unrecognizable name to right of explicit result *) funcheaderror := true end end else newfunctabptr^.result := false; (* no explicit result *) skipspaces; if (position <= linelength) and (not funcheaderror) then begin identifier(name2, itsanidentifier); if not itsanidentifier then begin serror(7); (* invalid function/argument name *) funcheaderror := true end else arityindex := 2 end; skipspaces; if (position <= linelength) and (not funcheaderror) then begin identifier(name3, itsanidentifier); if not itsanidentifier then begin serror(9); (* invalid function right argument name *) funcheaderror := true end else arityindex := 3 end; skipspaces; if (position <= linelength) and (not funcheaderror) then begin serror(3); (* extraneous characters to right of function header *) funcheaderror := true end; case arityindex of 1: begin newfunctabptr^.arity := niladic; newfunctabptr^.funcname := name1 end; 2: begin newfunctabptr^.arity := monadic; newfunctabptr^.funcname := name1; newfunctabptr^.rightarg := name2; addnametovartable(name2); newvartabptr^.functabptr := newfunctabptr end; 3: begin newfunctabptr^.arity := dyadic; newfunctabptr^.leftarg := name1; newfunctabptr^.funcname := name2; newfunctabptr^.rightarg := name3; addnametovartable(name1); newvartabptr^.functabptr := newfunctabptr; addnametovartable(name3); newvartabptr^.functabptr := newfunctabptr end; end; {case} if funcalreadydefined(newfunctabptr^.funcname, dummyptr) then begin serror(5); (* function already defined *) funcheaderror := true end; if funcheaderror then begin ridfunc(newfunctabptr); (* header no good *) funcmode := false; (* exit function mode *) newfunctabptr := oldfunctabptr end end end; {processfunctionheader} procedure destroystatement; var dumtokenptr: ^tokentable; auxsubrtabptr: ^subrtab; begin if subrtabptr <> nil then begin while subrtabptr^.lastsubrptr <> nil do begin auxsubrtabptr := subrtabptr; subrtabptr := subrtabptr^.lastsubrptr; ridsubr(auxsubrtabptr) end; ridsubr(subrtabptr) end; dumtokenptr := oldtokenptr; while dumtokenptr <> holdtokenptr do begin oldtokenptr := oldtokenptr^.nextoken; ridtoken(dumtokenptr); dumtokenptr := oldtokenptr end; newtokenptr := holdtokenptr; oldtokenptr := holdtokenptr (* return pointer to end of last good line *) end; {destroystatement} procedure reverselinklist{var argptr: typevaltabptr}; var hold, temptr: ^values; begin valptr := argptr^.firstvalue; temptr := valptr^.nextvalue; while temptr <> nil do begin hold := temptr^.nextvalue; temptr^.nextvalue := valptr; valptr := temptr; temptr := hold end; argptr^.firstvalue^.nextvalue := nil; argptr^.firstvalue := valptr; if argptr^.forwardorder = true then argptr^.forwardorder := false else argptr^.forwardorder := true (* toggle list order switch *) end; {reverselinklist} ======================================================================================== DOCUMENT :usus Folder:VOLUK04:contents.text ======================================================================================== USUS(UK) SOFTWARE LIBRARY VOLUME 4 30-AUG-82 The following material was submitted by Chris Lee, INMOS 10-Feb-82 ---------------------------------------------------------------------- The APL program is an adaptation for UCSD pascal of a program by Alan M Kaniss that appears in the Byte Book Of Pascal. The changes made were very small, so it is still fairly inefficient. There are still probably a few typos in it as well as common or garden bugs. The APL subset that has been implemented so far is fairly small and limiting, such as no character strings, plus things like restictions on where generalised matrices may be used (bracketing them sometimes helps). If you find any bugs or write any enhancements I would be grateful if you could forward them on to me Greg Nunan either via USUS or Inmos Ltd., Whitefriars, Lewins Mead, Bristol BS1 2NP, England. APL.TEXT The APL Interpreter with its associated include files. APLPARSE1.TEXT APLPARSE2.TEXT APLPROCS.TEXT APLPARSE3.TEXT APLHEAP.TEXT APLINIT.TEXT APLCHERS.TEXT APLPARSE0.TEXT The following materail was submitted by Morton Ogilvie, ERCC 23-Aug-82 ----------------------------------------------------------------------- SORT/MERGE Package Release 1.3 SORT.DOC.TEXT - Full user documentation of the Package, for use under versions II.0, II.1 and IV.0 of the UCSD p-System; SORT.MERGE.TEXT - Pascal source of the main program supporting the primary SORT, MERGE and CHECK procedures: configured for use under version IV.0, but with comments indicating modifications required for use under versions II.0 and II.1; SORT.DUMUN.TEXT - Pascal source of the minimal User-provided Unit required in addition to the main program, to the define file and record structures and key comparison specifications of the SORT, MERGE and CHECK procedures, and to define intialisation and termination procedures: suitable for TEXT or FILE OF STRING files, with comments indicating modifications required for other file types; SORT.TXTUN.TEXT - Pascal source of a more generalised User-provided Unit defining file structures and specifications for SORT, MERGE and CHECK operations for TEXT or FILE OF STRING files, for use under version II.0, II.1 or IV.0; UK Volume 4 continued The following material was submitted by Jim McNicol, SCRI 23-Aug-82 ----------------------------------------------------------------------- SPBSSTUFF is an Intrinsic Unit of procedures and functions designed to ease the problems of error checking in conversational style programs. Including Screenops it adds 18 blocks of diskspace to the SYSTEM.LIBRARY. SPBSSTUFF.TEXT SPBSSTUFF.CODE SPBSSDOC1.TEXT SPBSSDOC2.TEXT The contents of SPBSSTUFF are:- Procedure PrintLine(x,y:integer;s:string); Function GetChar(okchars:setofchar):char; Function GetCHoice(options:setofchar):char; Procedure Goodbye; Procedure GetString(var s:string;maxlen:integer;okchars:setofchar); Procedure OpenNewFile (var nameoffile:string;s1,s2:string); Procedure OpenOldFile (var nameoffile:string;s1,s2:string); Procedure GetTextfileName(var s:string;s1,s2:string); Procedure IoError(ioresult:integer); Procedure WriteIoError(ioresult:integer); Procedure IntNum(var num:integer;var good:boolean;s:string); Procedure RealNum(var num:real;var good:boolean;s:string); Procedure GetRealNo(var num:real;termchars:setofchar); Procedure GetIntNo(var num:integer;var ok:boolean;maxlen : integer;termchars: setofchar); Function GetReal(x,y:integer;min,max:real):real; Function GetInt(x,y:integer;min,max:integer):integer; Procedure CheckPrinter; Procedure Continue (x,y:integer); Procedure Yes:boolean; Procedure Bell (times:integer); CONTENTS.TEXT This list. ======================================================================================== DOCUMENT :usus Folder:VOLUK04:sort.doc.text ======================================================================================== EDINBURGH REGIONAL COMPUTING CENTRE TRAINING UNIT User Specification for the ERCC UCSD p-System II.0 -IV.0 SORT/MERGE Package Introduction The ERCC UCSD p-System SORT/MERGE Package provides you with facilities for sorting, merging and checking the order of your files of TEXT or DATA type, with any record structure you may wish to define. Access You may use the Package under the UCSD p-System (Version II or IV) on any of the following micro-computers: Cromemco System Three Intertec Superbrain QD/DD Apple II Terak 8510 Sirius 1 All files referred to in this description as relating to the Package are obtainable from the United Kingdom UCSD System Users' Society {USUS(UK)} or from the Microcomputer Support Unit, Edinburgh Regional Computing Centre. These TEXT files are identified as follows: SORT.DOC.TEXT - the text of this User Specification for the Package; SORT.MERGE.TEXT - the Pascal source code of the main SORT/MERGE Program (configured for use under UCSD Version IV.0, comments indicating modifications for use under Version II.0); SORT.DUMUN.TEXT - a minimal User Unit required to complete the Package; SORT.TXTUN.TEXT - a general-purpose User Unit for sorting TEXT files or files of STRING (two versions, for use under UCSD Versions II.0/II.1 and IV.0.) General Description The Package performs the following primary procedures: Sort - Sort the contents of a file (TEXT or DATA) into order with respect to certain key information held in each line or record (as defined by you), placing the sorted records in another nominated file; Merge - Merge together into a single file the contents of two files of the same record structure, which you have already sorted into the required order, with respect to the same key information; Check - Check that the contents of a TEXT or DATA file are correctly ordered with respect to the key information you define. [N.B. If your file is of some size, the Sort procedure may need one or two temporary files, at least as large as your original file, for working space. These temporary files may, but need not, reside on the same volume as your original file. The Sort procedure can, in general, handle a file of up to half the capacity of a disk volume, while the Merge and Check procedures can handle a file occupying a full disk.] Secondary functions include invoking your own procedures to initialise information required for the primary procedures and to terminate the primary procedures as you wish (tidying up, listing or reformatting files, etc.) In the UCSD Version IV.0 implementation, you may invoke the FILER at any stage to assist you in managing your files, automatically returning to the Sort/Merge Package on leaving the Filer. File and Record Structures The file or files which you present to the Package may be any TEXT files, containing lines of text, or DATA files, containing structured records of your own specification. The ordered file produced by the Sort or Merge procedure need not be of the same structure as the file or files which you present. You may define it to be of whatever structure you wish. Further, the key information on which you wish to base the ordering may not be contained explicitly in the records of the file or files you present (e.g. you may wish to extract numerical data from lines of text or convert alphanumeric data from ISO to EBCDIC code, etc.) You may, therefore wish to define an intermediate record structure upon which comparisons are to be made. Any temporary files required by the Sort procedure will be of this intermediate structure. If you wish to change the structure of your records for either of these reasons, you will need to provide the necessary code to convert from one record type to the other. You might wish to include code to select certain records from the input file and ignore others. You will, in any case, need to provide additional code to define exactly what the key information is and how records are to be compared. The code provided in the additional User Unit files, referred to above, is likely to be suitable for these purposes, for certain common cases. You may, therefore, be able to avoid producing your own code or perhaps merely tailor the provided code to suit your own needs. The User-provided Unit You must specify the structures of your files and any additional file manipulation procedures you wish to make availabe to the Package, in the form of a UCSD Pascal Unit. This Unit must also define the way in which records are to be compared and must provide any other information necessary to the sorting, merging or checking procedures which you wish to be conducted. A minimal User Unit for sorting TEXT files (or DATA files of FILE OF STRING type) is provided in the text file: SORT.DUMUN.TEXT (q.v.) You should include any additional code you may need for any particular application within the framework defined by that Unit. First of all, the Unit must always be called 'SORTSPEC' and you must write the comment: (*$S++*) immediately before the UNIT SORTSPEC statement, as indicated in the sample Unit. The CONST item RUNLENGTH defines the maximum number of records, of intermediate (SORTTYPE) structure, which are processed in the initial phase of the Sort procedure, in which segments of the file are sorted into runs, and copied to a temporary file; these are later merged together into a single, sorted file. If your records are more than 80 bytes in length, you may have to reduce the value of RUNLENGTH to accommodate them in memory in smaller groups. Increasing the value of RUNLENGTH will increase the memory requirement of the procedure, and will prolong the initial phase, but will reduce the number of merging passes and may reduce the number of temporary files required. If RUNLENGTH is at least half the number of records to be sorted, only one temporary file will be required; if it equals or exceeds the number of records, the sort will be completed in a single pass, with no need of temporary files - subject to the availability of sufficient main storage. Values of 20480 DIV SIZEOF(SORTTYPE) and 10240 DIV SIZEOF(SORTTYPE) will normally be suitable for the RUNLENGTH parameter in the UCSD Version II and Version IV implementations, respectively. If a System Halt or Stack Overflow condition arises on attempting to execute the Package, you should reduce the value of RUNLENGTH and try again. You may require to replace the definitions of the TYPE identifiers INPUTTYPE, SORTTYPE and OUTPUTTYPE with the specifications of the record structures you want your input, intermediate (work files) and output files to have, respectively. [SORTTYPE is the record structure on which the comparison of key information is based in the Sort, Merge and Check procedures.] If you are defining different record structures for your files, you will next have to write, in the PROCEDURE USERIN, whatever Pascal statements are needed to convert a record of INPUTTYPE (INPUTREC) into one of SORTTYPE (SORTREC), and in the PROCEDURE USEROUT the code required to convert from SORTTYPE (SORTREC) to OUTPUTTYPE (OUTPUTREC). You may leave these procedures unchanged if your files are all of the same structure. [N.B. In the case of TEXT files, the INPUTTYPE and OUTPUTTYPE declarations are not used by the Package to define the input and output files; they are, however, used in the buffering mechanism on input. They should be defined as STRING (equivalent to STRING[80]), or STRING[maximum line length], which may also be a suitable definition for the intermediate SORTTYPE structure. You may still define a different SORTTYPE record structure if your key comparison procedure demands it. Text lines in the input file which are longer than the length specified by INPUTTYPE are truncated by the Package, to avoid failure.] In any case, you must include in the (BOOLEAN) FUNCTION COMPARE whatever code you require to compare two records (of SORTTYPE type) and indicate whether they are correctly ordered [all keys of the two records are equal or any key of the first record (SORTREC1) takes precedence over the corresponding key of the second (SORTREC2), all previous keys being equal.] If the code you have included in the PROCEDURES USERIN and USEROUT or the FUNCTION COMPARE requires any preliminary housekeeping (interactive requests for specifications of keys, etc.) you may include code to perform the operations you need in the PROCEDURE INITIALISE. You may leave this procedure empty if you have no such requirement - but it must still appear in the Unit. If you require the Package to perform any housekeeping on conclusion of the main procedures (e.g. listing the output files), you must include the required code in the PROCEDURE TERMINATE, in a similar fashion. You should insert any declarations of variables or other identifiers which you may need for any of these purposes immediately after the IMPLEMENTATION statement. Any file indentifiers should, however, be declared in the INTERFACE section, as 'PUBLIC' variables. If you intend to run the Package under Version II.0 of the UCSD p-System, you will require to remove the final 'BEGIN' statement from the Unit. If, however, you are using version II.1 or IV.0, you may insert after that 'BEGIN' statement any code you wish to pre-initialise variables used in the INITIALISE, USERIN, COMPARE, USEROUT and TERMINATE procedures. The code provided in the file SORT.TXTUN.TEXT (q.v.) illustrates a more generalised form of the User-provided Unit for sorting TEXT files (or DATA files of FILE OF STRING type), containing lines or records of not more than 80 characters in which up to 6 key fields (of STRING, INTEGER or REAL type) may be defined in each record or line of text. The keys are specified interactively, by invoking the PROCEDURE INITIALISE and the output file may be listed to the CONSOLE: automatically, by invoking the PROCEDURE TERMINATE. This Unit may be altered easily, by changing the values of the CONST items MAXRECL, MAXNOKEYS and RUNLENGTH, to specify respectively the maximum length of your records, the maximum number of keys you require and the number of records of intermediate type you estimate can be accommodated in memory during the initial sort phase. Compilation and Linkage of the Package Once you have produced your User Unit, you must next compile it. The Package demands that you must place the code generated by the Pascal Compiler in the CODE file: SORT.SPEC.CODE on the System (Boot) Disk. Once you have completed the compilation of your Unit, you must now prepare to compile the code of the main SORT/MERGE Package, in the file: SORT.MERGE.TEXT If you are using the UCSD Version IV.0 System and you wish to use the facility to enter the Filer and return to the Package, you must first arrange for the System Unit contained in the CODE file: COMMANDIO.CODE to be on the System (Boot) disk. Otherwise (if you are running under Version II.0 or II.1 or you do not wish to use the Filer entry facility) you will need to edit the file: SORT.MERGE.TEXT as indicated by the comments in the USES statement and the PROCEDURE ENTERFILER. If you are using UCSD Version II, you may place the compiled code in any file of your choice, say: SORT.MERGE.CODE If you are using the UCSD Version IV.0 System, you must place the compiled code in the CODE file: SORTMERGE.CODE on the System (Boot) disk. [N.B. no '.' in the name 'SORTMERGE' this time.] When you have successfully completed both compilations, you must next link the two code files together, as follows: If you are using the UCSD Version II System: Enter the Linker (Command L at UCSD System level); In response to the prompt: Host File? type: SORT.MERGE (or whatever you have called your code file compiled from the main Package, without '.CODE') and press RETURN; In response to the prompt: Lib file? type: SORT.SPEC (the name of the CODE file cotaining you Unit, without '.CODE') and press RETURN; In response to the second prompt: Lib file? and the prompt: Map file? press RETURN; In response to the prompt: Output file? type: SORTMERGE.CODE and press RETURN. [N.B. No '.' in the name 'SORTMERGE' this time, and '.CODE' is essential.] If you are using the UCSD Version IV System, link your code files as follows: Enter the Editor (Command E at UCSD System level); In response to the prompt: No workfile is present. File? press RETURN; In response to the Editor prompt line, type: I type the line: SORT.SPEC press RETURN and terminate with CONTROL and C together; then in response to the Editor prompt line, type: Q W and in response to the prompt: Name of output file -> type: USERLIB.TEXT and press RETURN; [The above creates a search list for automatic linking of your Unit.] This procedure will result in the production of a complete program which will conduct the sorting, merging and checking operations you have defined. Execution of the Package When you have produced the CODE file: SORTMERGE.CODE by the above compiling and linking operations, you can now execute it, as follows: Type the UCSD System command: X SORTMERGE The Package will introdue itself and offer the prompt: I(nit S(ort M(erge C(heck F(iler T(erm Q(uit: [If this does not appear and the system hangs, the most probable cause is STACK OVERFLOW due to excess memory requirements. In this case, reduce the value you have assigned to the RUNLENGTH item in your Unit, repeat the Compiling and Linking procedures and try again.] If you have included code in the PROCEDURE INITIALISE, you should type: I and that procedure will be invoked for you. Upon its conclusion, the Package will offer the above prompt again, to allow you to choose another procedure. If you want to Sort one of your TEXT or DATA files , type: S and the Sort procedure will be invoked. Proceed as follows: In response to the prompt: Sort which file? type the name of the file (of INPUTTYPE structure) you want to sort, including the disk identifier or drive number and '.TEXT' or '.DATA' as appropriate; In response to the prompt: Into which file? type the name of the (new) file (of OUTPUTTYPE structure) in which you wish the sorted records to be placed, including the disk identifier or drive number and '.TEXT' or '.DATA' as appropriate. This may be on the same disk as your unsorted input file, if you wish; In response to the prompt: Which work disk? type the disk identifier or drive number of a disk which the procedure may use to create any temporary work files it may need. This may be the same disk as that containing you unsorted and sorted files. [Space for at least two copies of your records in SORTTYPE format should be available.] In response to the prompt: Press SPACE or RETURN when ready, ESC to abort press the RETURN key, when you have loaded the disks you have nominated [pressing the ESC key will abort the Sort procedure and return to the prompt line: I(nit S(ort M(erge C(heck T(erm Q(uit? to allow you to chose another procedure.] The Sort procedure will then commence. Messages such as: Sort1 starts ... . . . ... Sort2 starts ... . . . ... . . . Merge1 starts ... . . . ... Merge2 starts ... . . . ... . . . etc. will be displayed at certain stages of the procedure to allow you to monitor its progress. The 'comfort dots' appearing during each phase indicate the number of lines or records transferred to the work files or output file. On conclusion, the Package will return to the original prompt, to enable you to choose a further procedure. If you type: M the Merge procedure will be entered. Proceed as follows: In response to the prompt: Merge which file? type the name of the first of the two files (of INPUTTYPE structure, already sorted) which you wish to merge together, including the disk identifier or drive number and '.TEXT' or '.DATA' as appropriate; In response to the prompt: With which file? type the name of the second file you wish to merge, including the disk identifier or drive number and '.TEXT or '.DATA'. This may be on the same disk as the first. The two files must be of the same type and structure, otherwise the procedure will terminate at this point; In response to the prompt: Into which file? type the name of the (new) file (of OUTPUTTYPE structure) into which you wish the resultant merged sequence of records to be placed, including the disk identifier or drive number and '.TEXT' or '.DATA' as appropriate. This file may be on the same disk as the input files, provided sufficient space is available; The Merging procedure will commence, 'comfort dots' appearing to indicate the number of lines or records transferred to the output file. Upon its conclusion, the Package will return to the original prompt, to allow you to choose a further procedure. If you type: C the Check procedure will be invoked. Proceed as follows: In response to the prompt: Check which file? type the name of the file (of INPUTTYPE strucutre) you wish to check for order against the key specification defined in your Unit, including the disk identifier or drive number and '.TEXT' or '.DATA' as appropriate. This file may be of OUTPUTTYPE as long as that is the same as INPUTTYPE; The Check procedure will commence, 'comfort dots' and asterisks indicating the lines or records which are found to be in and out of sequence, respectively. Upon conclusion, the procedure will print a report of the form: File FILENAME holds N records: M are out of order and will return the Package to the original prompt, to allow you to choose a further procedure. If you type: T the Package will enable you to conclude a Sort, Merge or Check procedure as you have defined in your PROCEDURE TERMINATE, by invoking that procedure. On its conclusion, the Package will return to the original prompt, to allow you to choose a further procedure. If you are using the UCSD Version IV System, you may type: F The Package will automatically invoke the UCSD System Filer. This will enable you to manipulate your files and disks between Sort, Merge and Check procedures without leaving the Sort/Merge Package. On quitting the Filer (Filer Command Q), the Package will return to its original prompt, to allow you to choose a further procedure. If you type: Q the Sort/Merge Package will terminate, returning you to main UCSD System Command level. Advice and Consultancy Any problems relating to the operation of the Sort/Merge Package should be related to the author, Mr D.D.M. Ogilvie, Training Unit Manager, ERCC, 59 George Square, Edinburgh EH8 9JU - telephone 031-667 1011 ext 2303. D.D.M. Ogilvie ERCC 23rd August, 1982 ======================================================================================== DOCUMENT :usus Folder:VOLUK04:sort.dumun.text ======================================================================================== (*$S++*) UNIT SORTSPEC; (* File type and key specicification template for SORT/MERGE Package *) INTERFACE CONST RUNLENGTH=256; (* Set to 20480 DIV SIZEOF(SORTTYPE) or less *) TYPE INPUTTYPE=STRING; (* Replace by RECORD TYPE of unsorted file *) SORTTYPE=INPUTTYPE; (* Replace by RECORD TYPE for key comparisons *) OUTPUTTYPE=INPUTTYPE; (* Replace by RECORD TYPE for sorted file *) PROCEDURE INITIALISE; PROCEDURE USERIN(INPUTREC: INPUTTYPE; VAR SORTREC: SORTTYPE); FUNCTION COMPARE(SORTREC1, SORTREC2: SORTTYPE): BOOLEAN; PROCEDURE USEROUT(SORTREC: SORTTYPE; VAR OUTPUTREC: OUTPUTTYPE); PROCEDURE TERMINATE; IMPLEMENTATION (* Insert declaration of any local variables, etc. required by PROCEDURES INITIALISE, USERIN, COMPARE, USEROUT and TERMINATE - these are optional *) PROCEDURE INITIALISE; BEGIN (* Insert any code required to initialise local variables required by the PROCEDURES USERIN, COMPARE, USEROUT and TERMINATE or to manipulate the file to be sorted, etc. - this is optional *) END; PROCEDURE USERIN; BEGIN SORTREC:=INPUTREC (* Replace by any code required to convert an INPUTTYPE RECORD into a SORTTYPE RECORD *) END; FUNCTION COMPARE; BEGIN COMPARE:=SORTREC1<=SORTREC2 (* Replace by code required to compare the key fields of two SORTTYPE RECORDS and return the result TRUE if they are correctly ordered relatively, FALSE if not *) END; PROCEDURE USEROUT; BEGIN OUTPUTREC:=SORTREC (* Replace by any code required to convert a SORTYPE RECORD into an OUTPUTTYPE RECORD *) END; PROCEDURE TERMINATE; BEGIN (* Insert any code required to manipulate the sorted file or otherwise conclude the SORT/MERGE Procedures - this is optional *) END; (* Remove the following BEGIN statement for use under UCSD Version II.0 *) BEGIN (* Version IV.0 only - Insert any code required to pre-intialise any variables defined in the INTERFACE or IMPLEMENTATION sections above. *) END. : ======================================================================================== DOCUMENT :usus Folder:VOLUK04:sort.merge.text ======================================================================================== (*$S++*) (*$R-*) (* ERCC UCSD p-System II.0-IV.0 SORT/MERGE Package Version 1.3 23-Aug-82 *) (* Please forward any comments, suggestions, bugs etc. to the author: Morton Ogilvie, Training Unit Manager, Edinburgh Regional Computing Centre, 59 George Square, Edinburgh EH14 5AW, Scotland *) PROGRAM SORTMERGE(INPUT,OUTPUT,F0,F1,F2,F3,F4,F5,F6,F7,F8); (* SORT, MERGE and CHECK for TEXT or DATA FILES *) USES (*$U COMMANDIO.CODE*) COMMANDIO, (*$U SORT.SPEC.CODE*) SORTSPEC; (* Remove the references to COMMANDIO above for Version II or if Filer entry not required under Version IV. SORTSPEC is Unit supplied by user to define file and record structures and sorting keys, etc. *) TYPE DATAARRAY=ARRAY[1..RUNLENGTH] OF SORTTYPE; INCHAN=0..5; OUTCHAN=6..8; FILETYPE=(TXT,INT,OUT); VAR F0,F1:TEXT; F2,F3:FILE OF INPUTTYPE; F4,F5,F6:FILE OF SORTTYPE; F7:FILE OF OUTPUTTYPE; F8:TEXT; SORTIN,SORTOUT,SINKFILE,TEMP1,TEMP2,TEMP:STRING[30]; REC1,REC2:SORTTYPE; BLOCK:DATAARRAY; RECSLEFT:ARRAY[4..5] OF INTEGER; MAXL,NODOTS,NORECS,NOOUT,BLOCKSIZE,SBLOCKS,MBLOCKS,MPASS:INTEGER; SOURCE,PSOURCE,SSOURCE:INCHAN; SINK:OUTCHAN; QUIT,TEXTIN,TEXTOUT,EXISTP,EXISTS,OK,GOTONE,GOTOTHER:BOOLEAN; BUFFER:RECORD CASE TIO:FILETYPE OF TXT: (LINE: STRING[255]); INT: (RECI: INPUTTYPE); OUT: (RECO:OUTPUTTYPE) END; COMMAND,CH:CHAR; PROCEDURE MONITOR(CH: CHAR); BEGIN IF NODOTS=0 THEN WRITELN; IF CH<>'.' THEN WRITE(CHR(7)); WRITE(CH); NODOTS:=NODOTS+1; IF NODOTS=80 THEN NODOTS:=0 END; PROCEDURE CONNECT(CHAN: INTEGER; FILENAME: STRING; VAR EXISTS: BOOLEAN); VAR MODE: STRING[4]; BEGIN IF CHAN IN [0..5] THEN MODE:='find' ELSE MODE:='make'; IF FILENAME='' THEN EXISTS:=FALSE ELSE BEGIN (*$I-*) CASE CHAN OF 0: RESET(F0,FILENAME); 1: RESET(F1,FILENAME); 2: RESET(F2,FILENAME); 3: RESET(F3,FILENAME); 4: RESET(F4,FILENAME); 5: RESET(F5,FILENAME); 6: REWRITE(F6,FILENAME); 7: REWRITE(F7,FILENAME); 8: REWRITE(F8,FILENAME) END; EXISTS:=IORESULT=0; (*$I+*) END; IF EXISTS THEN IF (CHAN>5) THEN SINKFILE:=FILENAME ELSE ELSE WRITELN('Sorry, cannot ',MODE,' your file ',FILENAME) END; PROCEDURE DISCONNECT(CHAN: OUTCHAN; VAR OK: BOOLEAN); BEGIN (*$I-*) CASE CHAN OF 6: CLOSE(F6,LOCK); 7: CLOSE(F7,LOCK); 8: CLOSE(F8,LOCK); END; OK:=IORESULT=0; (*$I+*) IF NOT OK THEN WRITELN('Sorry, cannot close file ',SINKFILE); END; FUNCTION ENDOF(SOURCE:INCHAN): BOOLEAN; BEGIN CASE SOURCE OF 0: ENDOF:=EOF(F0); 1: ENDOF:=EOF(F1); 2: ENDOF:=EOF(F2); 3: ENDOF:=EOF(F3); 4: ENDOF:=(RECSLEFT[4]=0) OR EOF(F4); 5: ENDOF:=(RECSLEFT[5]=0) OR EOF(F5); END END; PROCEDURE TAKE; BEGIN IF ENDOF(SOURCE) THEN GOTONE:=FALSE ELSE CASE SOURCE OF 0: BEGIN WHILE EOLN(F0) AND NOT EOF(F0) DO READLN(F0); IF EOF(F0) THEN GOTONE:=FALSE ELSE BEGIN READLN(F0,BUFFER.LINE); IF LENGTH(BUFFER.LINE)>MAXL THEN BUFFER.LINE:=COPY(BUFFER.LINE,1,MAXL); USERIN(BUFFER.RECI,REC1) END END; 1: BEGIN WHILE EOLN(F1) AND NOT EOF(F1) DO READLN(F1); IF EOF(F1) THEN GOTONE:=FALSE ELSE BEGIN READLN(F1,BUFFER.LINE); IF LENGTH(BUFFER.LINE)>MAXL THEN BUFFER.LINE:=COPY(BUFFER.LINE,1,MAXL); USERIN(BUFFER.RECI,REC2) END END; 2: BEGIN USERIN(F2^,REC1); GET(F2) END; 3: BEGIN USERIN(F3^,REC2); GET(F3) END; 4,5: END END; PROCEDURE GIVE; BEGIN CASE SINK OF 6: BEGIN CASE SOURCE OF 0,2: F6^:=REC1; 1,3: F6^:=REC2; 4: BEGIN F6^:=F4^; GET(F4); END; 5: BEGIN F6^:=F5^; GET(F5); END END; PUT(F6) END; 7: BEGIN CASE SOURCE OF 0,2: USEROUT(REC1,F7^); 1,3: USEROUT(REC2,F7^); 4: BEGIN USEROUT(F4^,F7^); GET(F4); END; 5: BEGIN USEROUT(F5^,F7^); GET(F5); END END; PUT(F7) END; 8: BEGIN CASE SOURCE OF 0,2: USEROUT(REC1,BUFFER.RECO); 1,3: USEROUT(REC2,BUFFER.RECO); 4: BEGIN USEROUT(F4^,BUFFER.RECO); GET(F4) END; 5: BEGIN USEROUT(F5^,BUFFER.RECO); GET(F5) END END; WRITELN(F8,BUFFER.LINE) END END; MONITOR('.') END; PROCEDURE SHSORT(VAR BLOCK:DATAARRAY;NORECS:INTEGER); VAR I,J,K,M:INTEGER; T:SORTTYPE; BEGIN M:=1; WHILE M<=NORECS DO M:=M+M; M:=M-1; WHILE M>1 DO BEGIN M:=M DIV 2; FOR I:= M+1 TO NORECS DO BEGIN K:=I; J:=K-M; T:=BLOCK[K]; WHILE J>0 DO IF COMPARE(BLOCK[J],T) THEN J:=0 ELSE BEGIN BLOCK[K]:=BLOCK[J]; K:=J; J:=K-M END; BLOCK[K]:=T END END END; PROCEDURE SORTPHASE; BEGIN IF TEXTIN THEN SOURCE:=0 ELSE SOURCE:=2; CONNECT(SOURCE,SORTIN,OK); IF OK THEN BEGIN BLOCKSIZE:=RUNLENGTH; SBLOCKS:=0; GOTONE:=TRUE; WHILE OK AND NOT ENDOF(SOURCE) DO BEGIN SBLOCKS:=SBLOCKS+1; WRITE(CHR(7),'Sort',SBLOCKS,' starts'); NORECS:=0; REPEAT TAKE; IF GOTONE THEN BEGIN NORECS:=NORECS+1; BLOCK[NORECS]:=REC1 END; UNTIL (NORECS=BLOCKSIZE) OR (NOT GOTONE); WRITE(CHR(7)); IF NORECS>0 THEN BEGIN SHSORT(BLOCK,NORECS); WRITE(CHR(7)); IF SBLOCKS=1 THEN IF ENDOF(SOURCE) THEN BEGIN IF TEXTOUT THEN SINK:=8 ELSE SINK:=7; CONNECT(SINK,SORTOUT,OK) END ELSE BEGIN SINK:=6; CONNECT(SINK,TEMP1,OK); END; NODOTS:=0; IF OK THEN FOR NOOUT:=1 TO NORECS DO BEGIN REC1:=BLOCK[NOOUT]; GIVE END; WRITELN END END; IF TEXTIN THEN CLOSE(F0) ELSE CLOSE(F2); IF OK THEN DISCONNECT(SINK,OK) END END; PROCEDURE MERGEBLOCKS; BEGIN SOURCE:=PSOURCE; GOTOTHER:=NOT ENDOF(SOURCE); SOURCE:=SSOURCE; NODOTS:=0; REPEAT GOTONE:=NOT ENDOF(SOURCE); IF GOTOTHER THEN BEGIN IF GOTONE THEN IF COMPARE(F4^,F5^) THEN SOURCE:=PSOURCE ELSE SOURCE:=SSOURCE ELSE SOURCE:=PSOURCE+SSOURCE-SOURCE; GOTOTHER:=GOTONE; GOTONE:=TRUE END; IF GOTONE THEN BEGIN GIVE; RECSLEFT[SOURCE]:=RECSLEFT[SOURCE]-1 END UNTIL NOT GOTONE; WRITELN END; PROCEDURE MERGEPHASE; BEGIN MPASS:=0; PSOURCE:=4; SSOURCE:=5; REPEAT MPASS:=MPASS+1; WRITE(CHR(7),'Merge',MPASS,' starts'); TEMP:=TEMP1; RESET(F4,TEMP1); RESET(F5,TEMP1); IF SBLOCKS>2 THEN BEGIN SINK:=6; CONNECT(SINK,TEMP2,OK) END ELSE BEGIN IF TEXTOUT THEN SINK:=8 ELSE SINK:=7; CONNECT(SINK,SORTOUT,OK) END; IF OK THEN BEGIN MBLOCKS:=0; REPEAT NORECS:=0; WHILE (NOT EOF(F5)) AND (NORECS''; REPEAT WRITE('Into which file?'); READLN(SORTOUT) UNTIL SORTOUT<>''; WRITE('Which work disk?'); READLN(TEMP); WRITELN('Press SPACE or RETURN when ready, ESC to abort'); REPEAT READ(KEYBOARD,CH) UNTIL CH IN [' ',CHR(27)]; IF CH<>CHR(27) THEN BEGIN IF TEMP<>'' THEN BEGIN IF TEMP[1] IN ['0'..'9'] THEN TEMP:=CONCAT('#',TEMP); IF TEMP[LENGTH(TEMP)]<>':' THEN TEMP:=CONCAT(TEMP,':') END; TEMP1:=CONCAT(TEMP,'SORTTEMP1.DATA'); TEMP2:=CONCAT(TEMP,'SORTTEMP2.DATA'); TEMP:=''; IF LENGTH(SORTIN)>5 THEN TEMP:=COPY(SORTIN,LENGTH(SORTIN)-4,5); TEXTIN:=(TEMP='.TEXT') OR (TEMP='.text'); TEMP:=''; IF LENGTH(SORTOUT)>5 THEN TEMP:=COPY(SORTOUT,LENGTH(SORTOUT)-4,5); TEXTOUT:=(TEMP='.TEXT') OR (TEMP='.text'); IF TEXTIN THEN SOURCE:=0 ELSE SOURCE:=2; SORTPHASE; IF OK THEN IF SINK=6 THEN MERGEPHASE; END; WRITELN(CHR(7),'Sortfile ends') END; PROCEDURE MERGE; BEGIN SOURCE:=PSOURCE; GOTONE:=TRUE; TAKE; GOTOTHER:=GOTONE; SOURCE:=SSOURCE; NODOTS:=0; REPEAT TAKE; IF GOTOTHER THEN BEGIN IF GOTONE THEN IF COMPARE(REC1,REC2) THEN SOURCE:=PSOURCE ELSE SOURCE:=SSOURCE ELSE SOURCE:=PSOURCE+SSOURCE-SOURCE; GOTOTHER:=GOTONE; GOTONE:=TRUE END; IF GOTONE THEN GIVE UNTIL NOT GOTONE; WRITELN END; PROCEDURE MERGEFILES; VAR MERGIN1,MERGIN2,MERGOUT:STRING[30]; BEGIN WRITELN('Mergefiles entered'); WRITELN; REPEAT WRITE('Merge which file?'); READLN(MERGIN1) UNTIL MERGIN1<>''; REPEAT WRITE('With which file?'); READLN(MERGIN2) UNTIL MERGIN2<>''; REPEAT WRITE('Into which file?'); READLN(MERGOUT) UNTIL MERGOUT<>''; TEMP:=''; IF LENGTH(MERGIN1)>5 THEN TEMP:=COPY(MERGIN1,LENGTH(MERGIN1)-4,5); TEXTIN:=(TEMP='.TEXT') OR (TEMP='.text'); TEMP:=''; IF LENGTH(MERGIN2)>5 THEN TEMP:=COPY(MERGIN1,LENGTH(MERGIN2)-4,5); IF TEXTIN<>((TEMP='.TEXT') OR (TEMP='.text')) THEN WRITELN('Sorry, your input files must be of same TYPE') ELSE BEGIN TEMP:=''; IF LENGTH(MERGOUT)>5 THEN TEMP:=COPY(MERGOUT,LENGTH(MERGOUT)-4,5); TEXTOUT:=(TEMP='.TEXT') OR (TEMP='.text'); IF TEXTIN THEN BEGIN PSOURCE:=0; SSOURCE:=1; END ELSE BEGIN PSOURCE:=2; SSOURCE:=3; END; CONNECT(PSOURCE,MERGIN1,EXISTP); CONNECT(SSOURCE,MERGIN2,EXISTS); IF EXISTP AND EXISTS THEN BEGIN IF TEXTOUT THEN SINK:=8 ELSE SINK:=7; CONNECT(SINK,MERGOUT,OK); IF OK THEN BEGIN MERGE; DISCONNECT(SINK,OK) END; IF TEXTIN THEN BEGIN CLOSE(F0); CLOSE(F1) END ELSE BEGIN CLOSE(F2); CLOSE(F3) END END END; WRITELN(CHR(7),'Mergefiles ends') END; PROCEDURE CHECKFILE; VAR CHECKIN:STRING[30]; CH:CHAR; BEGIN WRITELN('Checkfile entered'); WRITELN; REPEAT WRITE('Check which file?'); READLN(CHECKIN) UNTIL CHECKIN<>''; TEMP:=''; IF LENGTH(CHECKIN)>5 THEN TEMP:=COPY(CHECKIN,LENGTH(CHECKIN)-4,5); TEXTIN:=(TEMP='.TEXT') OR (TEMP='.text'); IF TEXTIN THEN SOURCE:=1 ELSE SOURCE:=3; CONNECT(SOURCE,CHECKIN,EXISTS); IF EXISTS THEN BEGIN GOTOTHER:=FALSE; GOTONE:=TRUE; NORECS:=0; NOOUT:=0; NODOTS:=0; REPEAT TAKE; IF GOTONE THEN BEGIN CH:='.'; IF GOTOTHER THEN IF NOT COMPARE(REC1,REC2) THEN BEGIN NOOUT:=NOOUT+1; CH:='*' END; NORECS:=NORECS+1; MONITOR(CH); REC1:=REC2 END; GOTOTHER:=GOTONE UNTIL NOT GOTONE; WRITELN; IF TEXTIN THEN CLOSE(F1) ELSE CLOSE(F3); WRITELN('File ',CHECKIN,' holds ',NORECS,' records: ', NOOUT,' are out of order'); END; WRITELN(CHR(7),'Checkfile ends') END; PROCEDURE ENTERFILER; BEGIN CHAIN('I="F"'); CHAIN('*SORTMERGE'); QUIT:=TRUE (* Remove the above three statements for Version II or if Filer entry not required under Version IV. Substitute the following: WRITELN('Filer entry not implemented.'); WRITELN('Sorry!') *) END; BEGIN WRITELN; WRITELN; WRITELN('-----------------------------------------------------------------'); WRITELN('ERCC UCSD p-System II-IV Sort/Merge Package Version 1.3 23-Aug-82'); WRITELN('-----------------------------------------------------------------'); WRITELN; QUIT:=FALSE; REPEAT MAXL:=SIZEOF(INPUTTYPE)-2; WRITELN; WRITE('I(nit S(ort M(erge C(heck T(erm F(iler Q(uit: '); READ(KEYBOARD,COMMAND); IF COMMAND IN ['I','S','M','C','T','F','Q','i','s','m','c','t','f','q'] THEN CASE COMMAND OF 'I','i': INITIALISE; 'S','s': SORTFILE; 'M','m': MERGEFILES; 'C','c': CHECKFILE; 'T','t': TERMINATE; 'F','f': ENTERFILER; 'Q','q': QUIT:=TRUE END ELSE BEGIN WRITE(COMMAND); READLN; WRITELN('Pardon me?') END UNTIL QUIT END. ======================================================================================== DOCUMENT :usus Folder:VOLUK04:sort.read.text ======================================================================================== ERCC UCSD p-System II.0-IV.0 SORT/MERGE Package Release 1.3 - 23-Aug-82 This disk contains the following TEXT files, comprising the source code (Pascal) and documentation of the ERCC SORT/MERGE Package. SORT.DOC.TEXT - Full user documentation of the Package, for use under versions II.0, II.1 and IV.0 of the UCSD p-System; SORT.MERGE.TEXT - Pascal source of the main program supporting the primary SORT, MERGE and CHECK procedures: configured for use under version IV.0, but with comments indicating modifications required for use under versions II.0 and II.1; SORT.DUMUN.TEXT - Pascal source of the minimal User-provided Unit required in addition to the main program, to the define file and record structures and key comparison specifications of the SORT, MERGE and CHECK procedures, and to define intialisation and termination procedures: suitable for TEXT or FILE OF STRING files, with comments indicating modifications required for other file types; SORT.TXTUN.TEXT - Pascal source of a more generalised User-provided Unit defining file structures and specifications for SORT, MERGE and CHECK operations for TEXT or FILE OF STRING files, for use under version II.0, II.1 or IV.0; ======================================================================================== DOCUMENT :usus Folder:VOLUK04:sort.txtun.text ======================================================================================== (*$S++*) (*$R-*) (*$V-*) (* ERCC UCSD p-System II.0-IV.0 SORT/MERGE Package Release 1.3 23-Aug-82 *) (* Suggested file and key specs for sorting TEXT or FILE OF STRING files *) UNIT SORTSPEC; INTERFACE CONST RUNLENGTH=172; (* Set smaller if your records are large *) MAXNOKEYS=6; (* Set to number of sorting keys to be defined *) MAXRECL=80; (* Set to max length of line for TEXT files *) TYPE INPUTTYPE=STRING[MAXRECL]; SORTTYPE=PACKED RECORD MAINPART: INPUTTYPE; KEYPART: PACKED ARRAY[1..MAXNOKEYS] OF PACKED RECORD CASE KEYTYPE: CHAR OF 'I': (IKEY: INTEGER); 'R': (RKEY: REAL); 'S': () END END; OUTPUTTYPE=INPUTTYPE; VAR TXTFILE: TEXT; (* Needed locally by PROCEDURE TERMINATE below *) DATFILE: FILE OF INPUTTYPE; (* Ditto *) PROCEDURE INITIALISE; PROCEDURE USERIN(INPUTREC: INPUTTYPE; VAR SORTREC: SORTTYPE); FUNCTION COMPARE(SORTREC1, SORTREC2: SORTTYPE): BOOLEAN; PROCEDURE USEROUT(SORTREC: SORTTYPE; VAR OUTPUTREC: OUTPUTTYPE); PROCEDURE TERMINATE; IMPLEMENTATION (* Declarations of key specification lists *) TYPE KEYLIST=1..MAXNOKEYS; VAR NOOFKEYS: 0..MAXNOKEYS; KEYNO: KEYLIST; KPOS,KLEN: ARRAY [KEYLIST] OF 1..256; KTYP: ARRAY[KEYLIST] OF CHAR; KORD: ARRAY[KEYLIST] OF BOOLEAN; (* ***** Additional PROCEDURES required by PROCEDURE USERIN ***** *) PROCEDURE STOI(LINE:STRING;FIRST,WIDTH:INTEGER;VAR RESULT:INTEGER; VAR ERROR:BOOLEAN); (* Decode numeric field of STRING into INTEGER value *) VAR NO,SIGN,COL,LAST,DIGIT: INTEGER; SYMBOL: CHAR; BEGIN NO:=0; SIGN:=0; ERROR:=FALSE; LAST:=FIRST+WIDTH-1; IF LAST>LENGTH(LINE) THEN ERROR:=TRUE ELSE BEGIN FOR COL:=FIRST TO LAST DO BEGIN SYMBOL:=LINE[COL]; IF (SYMBOL='+') THEN IF (SIGN=0) THEN SIGN:=1 ELSE ERROR:=TRUE ELSE IF (SYMBOL='-') THEN IF (SIGN=0) THEN SIGN:=-1 ELSE ERROR:=TRUE ELSE IF SYMBOL IN [' ','0'..'9'] THEN BEGIN IF SYMBOL=' ' THEN DIGIT:=0 ELSE BEGIN IF SIGN=0 THEN SIGN:=1; DIGIT:=ORD(SYMBOL)-ORD('0') END; IF (NO>3276) OR ((NO=3276) AND (DIGIT>7)) THEN ERROR:=TRUE ELSE NO:=10*NO+DIGIT END ELSE ERROR:=TRUE END END; IF ERROR THEN BEGIN WRITELN(CHR(7),'Illegal INTEGER in cols',FIRST,'-',LAST); RESULT:=0; END ELSE RESULT:=NO*SIGN END; PROCEDURE STOR(LINE:STRING;FIRST,WIDTH:INTEGER;VAR RESULT:REAL; VAR ERROR: BOOLEAN); (* Decode numeric field of STRING into REAL value *) VAR NO: REAL; IEXP,PLACES,SIGN,COL,LAST,DIGIT: INTEGER; POINT,EXPT: BOOLEAN; SYMBOL: CHAR; BEGIN NO:=0; SIGN:=0; PLACES:=0; POINT:=FALSE; EXPT:=FALSE; ERROR:=FALSE; LAST:=FIRST+WIDTH-1; IF LAST>LENGTH(LINE) THEN ERROR:=TRUE ELSE BEGIN FOR COL:=FIRST TO LAST DO BEGIN SYMBOL:=LINE[COL]; IF SYMBOL='+' THEN IF SIGN=0 THEN SIGN:=1 ELSE ERROR:=TRUE ELSE IF SYMBOL='-' THEN IF SIGN=0 THEN SIGN:=-1 ELSE ERROR:=TRUE ELSE IF SYMBOL='.' THEN IF POINT THEN ERROR:=TRUE ELSE POINT:=TRUE ELSE IF SYMBOL='E' THEN IF EXPT THEN ERROR:=TRUE ELSE BEGIN EXPT:=TRUE; IF COL=LAST THEN ERROR:=TRUE ELSE BEGIN COL:=COL+1; STOI(LINE,COL,LAST+1-COL,IEXP,ERROR); IF (IEXP<-38) OR (IEXP>37) THEN ERROR:=TRUE ELSE PLACES:=TRUNC(IEXP)+PLACES; COL:=LAST END END ELSE IF SYMBOL IN [' ','0'..'9'] THEN BEGIN IF SYMBOL=' ' THEN DIGIT:=0 ELSE BEGIN IF SIGN=0 THEN SIGN:=1; DIGIT:=ORD(SYMBOL)-ORD('0') END; NO:=10*NO+DIGIT; IF POINT THEN PLACES:=PLACES-1; END ELSE ERROR:=TRUE END END; IF ERROR THEN BEGIN WRITELN(CHR(7),'Illegal REAL in cols',FIRST,'-',LAST); RESULT:=0; END ELSE BEGIN WHILE PLACES<>0 DO IF PLACES>0 THEN BEGIN NO:=NO*10; PLACES:=PLACES-1 END ELSE BEGIN NO:=NO/10; PLACES:=PLACES+1 END; RESULT:=NO*SIGN END END; (* PROCEDURES and FUNCTION required SORT/MERGE Package Main Program *) PROCEDURE INITIALISE; VAR CH: CHAR; LINE: STRING; ERROR: BOOLEAN; NO: INTEGER; BEGIN WRITELN('Initialise entered'); WRITELN; REPEAT WRITE('How many keys?'); READLN(LINE); STOI(LINE,1,LENGTH(LINE),NO,ERROR) UNTIL (NOT ERROR) AND (0<=NO) AND (NO<=MAXNOKEYS); NOOFKEYS:=NO; FOR KEYNO:= 1 TO NOOFKEYS DO BEGIN REPEAT WRITE('Key',KEYNO,' Position (col no.)?'); READLN(LINE); STOI(LINE,1,LENGTH(LINE),NO,ERROR) UNTIL (NOT ERROR) AND (1<=NO) AND (NO<=MAXRECL); KPOS[KEYNO]:=NO; REPEAT WRITE(' Length (cols or bytes)?'); READLN(LINE); STOI(LINE,1,LENGTH(LINE),NO,ERROR) UNTIL (NOT ERROR) AND (1<=NO) AND (NO<=MAXRECL); KLEN[KEYNO]:=NO; WRITE(' Type I)nteger R)eal S)tring?'); REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['I','R','S','i','r','s']; CASE CH OF 'i','I': CH:='I'; 'r','R': CH:='R'; 's','S': CH:='S' END; WRITE(CH); READLN; KTYP[KEYNO]:=CH; WRITE(' Order A)scending D)escending?'); REPEAT READ(KEYBOARD,CH) UNTIL CH IN ['A','a','D','d']; WRITE(CH); READLN; KORD[KEYNO]:=(CH='a') OR (CH='A') END; WRITELN('Initialise ends') END; PROCEDURE USERIN; VAR ERROR: BOOLEAN; BEGIN ERROR:=FALSE; WITH SORTREC DO BEGIN MAINPART:=INPUTREC; FOR KEYNO:= 1 TO NOOFKEYS DO BEGIN CASE KTYP[KEYNO] OF 'I': STOI(INPUTREC,KPOS[KEYNO],KLEN[KEYNO],KEYPART[KEYNO].IKEY, ERROR); 'R': STOR(INPUTREC,KPOS[KEYNO],KLEN[KEYNO],KEYPART[KEYNO].RKEY, ERROR); 'S': END; IF ERROR THEN BEGIN WRITELN('USERIN Fails - Illegal Key in this record:'); WRITELN(INPUTREC) END END END END; FUNCTION COMPARE; VAR S1,S2: STRING; I1,I2: INTEGER; R1,R2: REAL; BEGIN COMPARE:=TRUE; FOR KEYNO:= 1 TO NOOFKEYS DO BEGIN CASE KTYP[KEYNO] OF 'I': BEGIN I1:=SORTREC1.KEYPART[KEYNO].IKEY; I2:=SORTREC2.KEYPART[KEYNO].IKEY; IF I1<>I2 THEN BEGIN COMPARE:=(I1R2 THEN BEGIN COMPARE:=(R1S2 THEN BEGIN COMPARE:=(S15 THEN FTYPE:=COPY(FILENAME,LENGTH(FILENAME)-4,5); IF (FTYPE='.TEXT') OR (FTYPE='.text') THEN BEGIN (*$I-*) RESET(TXTFILE,FILENAME); EXISTS:=IORESULT=0; (*$I+*) IF EXISTS THEN BEGIN WHILE NOT EOF(TXTFILE) DO BEGIN READLN(TXTFILE,LINE); WRITELN(LINE) END; CLOSE(TXTFILE) END END ELSE BEGIN (*$I-*) RESET(DATFILE,FILENAME); EXISTS:=IORESULT=0; (*$I+*) IF EXISTS THEN BEGIN WHILE NOT EOF(DATFILE) DO BEGIN LINE:=DATFILE^; GET(DATFILE); WRITELN(LINE) END; CLOSE(DATFILE) END END; IF NOT EXISTS THEN WRITELN('Sorry, cannot find your file ',FILENAME); WRITELN(CHR(7),'Terminate ends') END; (* Remove the following two lines for use under UCSD Version II.0 *) BEGIN NOOFKEYS:=0 (* Avoids catastrophy if user fails to call INITIALISE *) END. ======================================================================================== DOCUMENT :usus Folder:VOLUK04:spbssdoc1.text ======================================================================================== *** SPBSSTUFF *** SPBSSTUFF is an Intrinsic Unit of procedures and functions designed to ease the problems of error checking in conversational style programs. Including Screenops it adds 18 blocks of diskspace to the SYSTEM.LIBRARY. The INTERFACE section of the Unit declares PR and F to be of type 'TEXT' and SETOFCHAR to be of type 'SET OF CHAR'. PR is always used to denote PRINTER:. Therefore any programs using SPBSSTUFF must use PR to denote PRINTER: unless another channel name is declared. F is used in OpenOldfile & OpenNewfile. F must be closed when these two procedures are called. This implies that if the user whishes two or more text files to be open simultaneously OpenNewfile & OpenOldfile can be used only for that file denoted by F. As some of the SPBSSTUFF pocedures use CHAINSTUFF & SCREENOPS, these are also declared in the INTERFACE. The version of Screenops used is a subset of that availabe in USUS UK Vol 2, containing only: ScclrLine, ScclrScreen, ScErasetoEOL. The example below illustrates how SPBSSTUFF must be incorporated in a program:- (*$S+,V-*) Program Dummy; uses chainstuff,screenops,spbsstuff; begin . . . end. The compiler option S+ is needed for compilation, and V- is needed to avoid string lengths being checked as they are being passed to and from the main program and SPBSSTUFF. The contents of SPBSSTUFF are:- Procedure PrintLine(x,y:integer;s:string); Function GetChar(okchars:setofchar):char; Function GetCHoice(options:setofchar):char; Procedure Goodbye; Procedure GetString(var s:string;maxlen:integer;okchars:setofchar); Procedure OpenNewFile (var nameoffile:string;s1,s2:string); Procedure OpenOldFile (var nameoffile:string;s1,s2:string); Procedure GetTextfileName(var s:string;s1,s2:string); Procedure IoError(ioresult:integer); Procedure WriteIoError(ioresult:integer); Procedure IntNum(var num:integer;var good:boolean;s:string); Procedure RealNum(var num:real;var good:boolean;s:string); Procedure GetRealNo(var num:real;termchars:setofchar); Procedure GetIntNo(var num:integer;var ok:boolean;maxlen : integer;termchars: setofchar); Function GetReal(x,y:integer;min,max:real):real; Function GetInt(x,y:integer;min,max:integer):integer; Procedure CheckPrinter; Procedure Continue (x,y:integer); Procedure Yes:boolean; Procedure Bell (times:integer); Updated May 1982 to make all procedures & functions screen orientated. Procedure GetString (VAR S:STRING;MAXLEN:INTEGER;OKCHARS:SETOFCHAR) ================================================================== Local vars 61 words ---------- Code 216 bytes ---- Other routines used GetChar ------------------- Special features 1. The variable OKCHARS is of type ---------------- SETOFCHAR which must be declared as a new type SETOFCHAR=SET OF CHAR; either in the INTERFACE section of the UNIT or at the start of the program, whichever is appropriate. General Description ------------------- GetString returns the string S entered from the keyboard. S is allowed a maximum of MAXLEN characters. These characters are read individually using GetChar. Any character which does not belong to OKCHARS is not accepted and the bell is rung to warn the user. Backspacing is permitted to allow corrections. After MAXLEN characters have been entered, no further characters except BACKSPACE and corresponding replacement characters are accepted. The user denotes the end of the string by pressing RETURN. If a null string is read i.e. the RETURN key is pressed first, S retains its value prior to the procedure call. Applications ------------ GetString can be used to read any string being entered from the keyboard. Procedure IoError (IORESULT:INTEGER) ==================================== Local vars 3 words ---------- Code 66 bytes ---- Other routines used PrintLine,WriteIoError,Goodbye,Continue ------------------- Special features None ---------------- General Description ------------------- IoError, starting at position (3,18) on the screen, lists a full I/O error message. The fault description itself is obtained from WRITEIOERROR. If IORESULT is greater than 18 and not equal to 64 IoError will terminate the program, using GOODBYE If IORESULT does not exceed 18 or equal 64, the message 'Press to Continue' is listed on line 23. When RETURN has been pressed, control is returned to the calling procedure. Applications ------------ IoError in conjunction with the compiler option I-, can be used to describe I/0 errors during program execution without the program necessarily being terminated by the system. Procedure Continue(X,Y:INTEGER) =============================== Local vars 4 words ---------- Code 68 bytes ---- Other routines used GetChar ------------------- Special features NONE ---------------- General description ------------------- Continue writes the message 'Press to continue..' at position x,y on the screen: When is pressed, control is passed to the next statement in the program. Applications ------------ Continue enables the user to control the pace at which the program moves from one section to the next, for example to ensure that error messages do not disappear too quickly from the screen. Function GetCHoice(OPTIONS:SETOFCHAR):CHAR ========================================== Local vars 22 words ---------- Code 168 bytes ---- Other routines used GetChar ------------------- Special features 1. The variable OPTIONS is of type ---------------- SETOFCHAR which must be declared as a new type SETOFCHAR=SET OF CHAR; either in the INTERFACE section of the UNIT or at the start of the program, whichever is appropriate. 2. Program text files must hold the OPTIONS in upper case. Lower case responses by the user will automatically be converted to upper case before being checked for inclusion in OPTIONS. General Description ------------------- GetCHoice returns a single character selected by the user via the keyboard from a set of single character OPTIONS. These options will usually be listed on the screen in menu form. The choice is made by typing the appropriate key followed by RETURN. The user can backspace over his choice before pressing RETURN. Lower and upper case alphabetic characters are treated as equivalent. If a character is entered which does not belong to OPTIONS the bell is rung and that character is not accepted. Applications ------------ GetCHoice can be used whenever the user is asked to select from several options. Procedure GetRealNo(VAR NUM:REAL;TERMCHARS:SETOFCHAR) ===================================================== Local vars 100 words ---------- Code 442 bytes ---- Other routines used GetChar,RealNum ------------------- Special features The variable TERMCHARS is of type SETOFCHAR which ---------------- must be declared as a new type SETOFCHAR=SET OF CHAR; either in the INTERFACE section of the UNIT or at the start of the program, whichever is appropriate. General Description ------------------- GetRealNo gets one real number from the keyboard. Exponential format is not allowed. Leading spaces are ignored. The real number is terminated by any one of the characters belonging to TERMCHARS. Backspacing to correct errors is possible until a terminating character has been entered. Illegal characters, e.g.'A', are not accepted, and the bell is rung as a warning. Characters which would cause illegal format, e.g. a second '+', are not accepted, and the bell is rung as a warning. A maximum of 21 characters may be entered, excluding leading spaces. Applications ------------ GetRealNo can be used to read a single real number from the keyboard, using any sensible characters as terminators. Procedure PrintLine(I,J:INTEGER;S:STRING) ========================================= Local vars 46 words ---------- Code 54 bytes ---- other routines used none ------------------- Special features none ---------------- General Description ------------------- PrintLine prints the string S on the screen starting at position (I,J). If I is greater than 79 the screen is cleared and S starts at position (I-80,J). The cursor remains at the end of the string after printing. Applications ------------ PrintLine allows listing of text at specific locations on the screen. Function OpenOldFile(VAR NAMEOFFILE:STRING;S1,S2:STRING); ========================================================= Local vars 87 ---------- Code 80 ---- Other routines used GetTextfileName,IOERROR. ------------------- Special features The variable F of type TEXT is used to denote the ---------------- channel to the specified file. It is assumed that F has been declared earlier in the INTERFACE section of a unit, or as a global variable in the program. General features ---------------- OpenOldFile, uses GetTextfilename to get a legal filename from the keyboard. It then checks to see if the file does exist, and if so opens the file with a reset command and leaves the file open. If it does not exist or there is another IOERROR then the appropriate IOERROR message is displayed, and the user will be prompted for another filename until an existing file is opened successfully. Applications ------------ Can be used wherever a program has to access an existing file. Function GetChar(OKCHAR:SETOFCHAR):CHAR ======================================= Local vars 21 words ---------- Code 88 bytes ---- Other routines used NONE ------------------- Special features 1. The variable OKCHARS is of type SETOFCHAR ---------------- which must be declared as a new type SETOFCHAR=SET OF CHAR; either in the INTERFACE section of the UNIT or at the start of the program, whichever is appropriate. General Description ------------------- Immediately it is called GetChar clears the keyboard buffer, then waits for a single character to be typed in from the keyboard. If this character belongs to OKCHARS it is returned as CHAR, and is echoed to the screen if it is a 'visible' character. Return is not echoed. If the character which is read does not belong to OKCHARS the bell will ring and the character will not be echoed. GetChar then waits until another character is entered, and the entire process is repeated. Applications ------------ GetChar is used in every SPBSSTUFF routine which reads from the keyboard. Procedure GetTextfileName (VAR NAMEOFFILE STRING; S1,S2:STRING) =================================================== Local vars 205 words ---------- Code 692 bytes ---- Other routines used Continue,PrintLine, GetString,GetChar ------------------- Special features None ---------------- General Description ------------------- GetTextfileName gets a text file name from the keyboard. If the user omits 'TEXT', the procedure will automatically append it. The diskname must also be included as part of the file name. Device names, such as #4, are not permitted. The procedure begins by sending the text 'Insert other disk now if relevant' to the top line of a cleared screen. Starting at positions (2,3) and (2,5) it then lists the strings S1 and S2. These strings can be used to prompt the user and describe the type of file name needed e.g. S1:='ENTER THE DESIGN FILE NAME'. S1 and S2 can be null. They should not be more than 37 characters as any more characters will appear on the second half of the screen. No check is made on the lengths of S1 and S2. They are the default string length. Illegal file name characters are rejected as they are being typed in (see Apple Pascal Operating System Manual, p30) Illegal names are rejected. The appropriate error message is listed on lines 13 and 15 of the screen. 'Press to Continue' is listed on line 22. After RETURN has been pressed GetTextfilenName is executed again. Illegal names are those with two or more colons, disk names with 0 or more than 7 characters, and filenames with 0 or more than 10 characters. Applications ------------ GetTextfileName can be used whenever a file name has to be entered from the keyboard. Procedure RealNum (VAR NUM:REAL;VAR GOOD:BOOLEAN;S:STRING) ========================================================== Local vars 159 words ---------- Code ---- 400 bytes Other routines used None ------------------- Special features None ---------------- General Description ------------------- RealNum converts the string S to a real number NUM if this is possible. GOOD is set to 'true if the conversion is successful. Otherwise GOOD is set to 'false'. The conversion will not be successful if S is in exponential format. Leading and trailing spaces (ASCII dec 32) in S are ignored. the number in S is terminated by the first space following a digit. Conversion to a real number will be unsuccessful if any of the following occur: 1) S contains characters other than '+','-','.',' ','0'..'9' 2) '+' or '-' appear in any position except the first (ignoring leading spaces) 3) More than one decimal point 4) Any characters other than 'space' follow the terminating space Applications ------------ RealNum can be used together with the compiler option I- to read real data without the risk of a program crash should the data contain any errors. Such data might be read from disk, from the terminal keyboard, or from an external device such as an electronic balance. ======================================================================================== DOCUMENT :usus Folder:VOLUK04:spbssdoc2.text ======================================================================================== Procedure IntNum(VAR NUM:INTEGER;VAR GOOD:BOOLEAN;S:STRING) ============================================================ Local vars 75 words ---------- Code 402 bytes ---- Other routines used None ------------------- Special features None ---------------- General Description ------------------- IntNum converts the string S to the integer NUM if this is possible. GOOD is set to 'true' if the conversion is successful. Otherwise GOOD is set to 'false' and NUM is returned as -32767. Leading and trailing spaces (ASCII dec 32) in S are ignored. the number in S is assumed to be terminated by the first space following a digit. Conversion to integer form will be unsuccessful if any of the following occur: 1) S contains characters other than '+','-',' ','0'..'9' 2) '+'or '-' appear in any position except the first (ignoring leading spaces) 3) Any characters other than 'space' follow the terminating space 4) The value of the converted integer lies outside the range (-32767 .. +32767) inclusive. Applications ------------ IntNum can be used together with the compiler option I- to read integer data without the risk of a program crash should the data contain any errors. Such data might be read from disk, from the terminal keyboard, or from an external device. It is also used in GetInt and GetIntNo where the integer is, in fact, read from the keyboard as a string, then converted to an integer, using IntNum. Function Yes:BOOLEAN; ===================== Local vars ---------- Code 38 bytes ---- Other routines GetCHoice -------------- Special features NONE ---------------- General description ------------------- Yes returns true if 'y' or 'Y' is entered at the keyboard and false if 'n' of 'N' is entered. Will not accept any other characters. Applications ------------ Can be used whenever a true/false answer is required. Procedure OpenNewFile(VAR NAMEOFFILE:STRING;S1,S2:STRING); ========================================================== Local vars 87 words ---------- Code 294 bytes ---- Other routines used GetTextfileName,Goodbye,PrintLine, ------------------- Bell,Yes,IoError Special features The variable F, of type TEXT is used to denote the channel to the specified file. It is assummed that F has been declared earlier in the INTERFACE section of a UNIT. General description ------------------- OpenNewFile uses GetTextfileName to get a legal filename from the keyboard. It then checks to see if this file already exists, and if it does, the message 'This file already exists!' 'Do you wish to overwrite it (y/n)?' appears on lines 11 & 14 respectively. If the reply is 'N' then the screen is cleared and the user prompted for another filename. If the reply is 'Y' then the file is opened with a 'rewrite' command, and left open (the contents of the original version will be lost) If the file does not already exist a new file is opened with the 'rewrite' command and left open. If there is a fault during the opening of the file, then appropriate IOERROR message is displayed and the user prompted for another filename, until a new file is successfully opened. As OpenNewfile uses the text variable f,f must be closed when OpenNewfile is called. If this is not the case the message 'Not closed; attempt to open an open file' 'Program needs altering to rectify' 'this problem' will appear and the program will be terminated using Goodbye. Applications ------------ Can be used in virtually every program when a new file has to be created. Procedure WriteIoError (IORESULT : INTEGER) =========================================== Local vars 0 words ---------- Code 972 bytes ---- Other routines used None ------------------- Special features None ---------------- General Description ------------------- WriteIoError lists the I/O fault description to the current cursor position on the screen. These fault descriptions are given in the appropriate UCSD Manuals. If IORESULT is not in the range 1..18, or 64, the message 'Report this fault' is listed. Applications ------------ WriteIoError is used in IOERROR to list the formal I/0 error description, and can be incorporated in any procedures which fulfill a similar role. Procedure GetIntNo (VAR NUM:INTEGER;VAR OK:BOOLEAN;MAXLEN:INTEGER TERMCHARS:SETOFCHAR) ==================================================================== Local vars 110 words ---------- Code 374 bytes ---- Other routines used GetChar,IntNum ------------------- Special features 1. The variable TERMCHARS is of type SETOFCHAR ---------------- which must be declared as a new type SETCHAR=SET OF CHAR; either in the INTERFACE section of the UNIT or at the start of the program, whichever is appropriate. General Description ------------------- GetIntNo returns one integer from the keyboard. Leading spaces are ignored. The integer is terminated by any one of the charcters in TERMCHARS. If the integer entered from the keyboard is a short integer, that is in the range (-32767 .. +32767), OK is set to 'true'. Otherwise OK is set to 'false', and NUM is set to -32767. Backspacing to correct errors is permissible until a terminating character has been entered. The maximum number of digits which a user is allowed to enter from the keyboard, ignoring leading spaces, is MAXLEN. After MAXLEN characters have been entered, the only acceptable characters are TERMCHARS and BACKSPACE. Illegal characters, that is all characters except '+','-',' ', '0'..'9',are not accepted, and the bell is rung as a warning. Characters which would cause illegal format, e.g. a second '+', are not accepted, and the bell is rung as a warning. Applications ------------ GetIntNo can be used to read an integer from the keyboard, using any (sensible) terminating characters. A check is made to ensure that the integer entered is not a 'long integer'. Procedure Bell (TIMES:INTEGER); =============================== Local vars 4 words ---------- Code 74 bytes ---- Other routines used NONE ------------------- Special features NONE ---------------- General Description ------------------- Bell sends the ASCII code 13 the requested number of times. This rings the bell in the Apple (or external terminal) each time the code is sent. Applications ------------ Obvious. In general the Computing & Statistics staff at SCRIP use Bell(3) to give an error warning & Bell(1) to give an audio prompt that some routine has just been started/ completed. Function GetReal (X,X:INTEGER;MIN,MAX:REAL):REAL ================================================ Local vars 13 words ---------- Code 258 bytes ---- Other routines used GetRealNo,Screenops ------------------- Special features None ---------------- GENERAL DESCRIPTION ------------------- GetReal obtains a real number from the keyboard. The real number must be terminated by a RETURN. The number entered is echoed to the screen starting at position x,y. If the value of this real number does not lie in the range MIN .. MAX, the bell is rung and at line y+2, & y+3 respectively, the message 'Error! min is 'press to try again..' is listed (similarly for MAX). The user must then enter another real number. When return is pressed the message & the number entered are cleared from the screen & the cursor is returned to position x,y waiting for another attempt. As the function uses GetRealNo, any illegal characters or formats will not be accepted. APPLICATIONS ------------ GetReal can be used to read a single real number from the keyboard, Where that real number must lie within a given range. Procedure Goodbye ================= Local vars 5 words ---------- code 290 bytes ---- Other routines used PrintLine,chainstuff ------------------- Special features 1. Goodbye uses F, of type text, declared in the interface section of the Unit, and will work successfully only if F is closed when Goodbye is called. As Goodbye is called by several other procedures, particularly I/O checking routines, care must be taken to ensure that F is never left open unnecessarily. General Description ------------------- Goodbye is a elaborate version of the UCSD intrinsic EXIT. The Statement 'End of program' is listed, on the screen starting at position (0,22). Goodbye then checks to see if SYSTEM.PASCAL is on-line in the boot disk drive (#4).If this file is not on-line the bell is rung several times and the message 'Put system disc in #4 and press ' is sent to line 23 of the screen. If SYSTEM.PASCAL is present Goodbye then checks to see if the boot disc is a 'Turnkey disc' by checking to see if SYSTEM.STARTUP is also on the boot disc. If the boot disc is a 'turnkey disc' Goodbye then looks to see if STARTUP.CODE (*) is present and if it is PLEASE PRESS TO CONTINUE sent to line 23. When RETURN is pressed,STARTUP.CODE is executed,putting the user back into the original program (thus the user is never in the Outer Command Level). If SYSTEM.PASCAL is present and SYSTEM.STARTUP or STARTUP.CODE is not then Goodbye leaves the user in the outer command level. (NOTE:Goodbye only works to its full usefulness if the 'original' system disc is in drive 4. If another system disc is in drive 4 then Goodbye will find SYSTEM.PASCAL (and maybe SYSTEM.STARTUP) and therefore think that the correct disc is in drive 4,but the operating system demands that the disc HAS to be the disc that the system was booted with, and it will take over from Goodbye and promt the user for the original boot disc) Applications ------------ Goodbye forces the program to end immediately, and, if the original boot disc is in drive 4, returns the user safely to the Outer Command Level of the UCSD System unless the boot disc is a 'turnkey disc' in which case he user will be left in the startup program (which means that the inexperienced user, assuming the programs lead the user, needs only to know how to turn the APPLE on and how to read!). (*) Note STARTUP.CODE is a feature used by the Statistics and Computing staff at the Scottish Crop Research Institute (Pentlandfield). It is used to make development and updating of turnkey discs simpler. Our SYSTEM.STARTUP programs are very short and just execute STARTUP.CODE programs, which will usually contain the initial MENU. Also SYSTEM.STARTUP cannot be used as a paramter in SETCHAIN. Function GetInt(X,Y,MIN,MAX:INTEGER):INTEGER ======================================== Local vars 10 words ---------- Code 226 bytes ---- Other routines used GetIntNo,Screenops ------------------- Special features ---------------- GENERAL DESCRIPTION ------------------- GetInt reads an integer from the keyboard. This integer must be terminated by the RETURN key. The integer is echoed to the screen starting at position (x,y). If this integer lies outside the range MIN..MAX, where MIN and MAX must not be long integers, the bell is rung and at lines y+2,Y+3 respectively, the message 'Range error min is MIN max is MAX Press to try again..' is listed. The user must then enter another number. When RETURN is pressed the message and number entered are cleared from the screen and the cursor returns to position X,Y waiting for another attempt. This function uses GetIntNo, which protects the user from entering illegal characters or formats. APPLICATIONS ------------ If the integer entered is a long integer then the value of the integer will be changed to -32767, so -32767 sould never be used as the MIN value in the range. Procedure CheckPrinter ====================== Local vars 5 words ---------- Code 320 bytes ---- Other routines used PrintLine, GetChar. Special features 1. The variable PR, of type TEXT, is used to ---------------- denote PRINTER: within Checkprinter. It is assumed that PR has been declared earlier in THE INTERFACE section of a UNIT General Description ------------------- CheckPrinter does three things. Firstly it sends the folling message to the screen. 'Please check that the printer is switched on and is "online" Press the spacebar to align the printer. to start listing press ' Secondly it opens the output file PRINTER:. Note that this is done with I/O checking off so that if PRINTER: has already been 'opened' in the main program, no error will occur. Thirdly it moves the paper in the printer forward one line every time the spacebar is pressed. Thus by holding down both the spacebar and the repeat keys, the paper can be easily be moved to the top of a page. Program control is returned to the main program once the RETURN key is pressed. Applications ------------ CheckPrinter can be used to ensure the printer is online before any printing is done. ======================================================================================== DOCUMENT :usus Folder:VOLUK04:spbsstuff.code ======================================================================================== < binary file -- not listed > ======================================================================================== DOCUMENT :usus Folder:VOLUK04:spbsstuff.text ======================================================================================== (*$s+,v-,L printer:*) (************************************************************************) (* *) (* program :- spbsstuff (intrinsic unit Procedures and Functions *) (* *) (* update :- May 1982 *) (* *) (************************************************************************) Unit SpbsStuff;intrinsic code 25 data 24; interface uses chainstuff,screenops; type setofchar=set of char; var f,pr:text; Procedure Bell(times:integer); Procedure Printline(x,y:integer;s:string); Function GetChar(okchars:setofchar):char; Function GetCHoice(options:setofchar):char; Function Yes:boolean; Procedure Continue(x,y:integer); Procedure Goodbye; Procedure GetString(var s:string;maxlen:integer;okchars:setofchar); Procedure GetTextfileName(var nameoffile:string;s1,s2:string); Procedure IoError(fault:integer); Procedure WriteIoError(fault:integer); Procedure OpenNewFile(var nameoffile:string;s1,s2:string); Procedure OpenOldFile(var nameoffile:string;s1,s2:string); Procedure IntNum(var num:integer;var good:boolean;s:string); Procedure RealNum(var num:real;var good:boolean;s:string); Procedure GetRealNo(var num:real;termchars:setofchar); Procedure GetIntNo(var num:integer;var ok:boolean;maxlen : integer; termchars: setofchar); Function GetReal(x,y:integer;min,max:real):real; Function GetInt(x,y,min,max:integer):integer; Procedure CheckPrinter; implementation (**********************************************************************) Procedure Bell; (* rings the buzzer the required number of times *) var loop2,loop:integer; begin for loop:=1 to times do begin for loop2:=1 to 40 do write(''); write(chr(7)) end end; (* of Bell *) (**********************************************************************) Procedure Printline; (* prints s on the screen, starting at position x,y. *) (* if x>79 clears screen, and starts at x-80,y *) begin if x>79 then begin ScClrScreen; x:=x-80 end; gotoxy(x,y); write(s) end; (* of Printline *) (**********************************************************************) (* reads one char from the console. *) (* accepts if in okchars and echoes if possible. *) (* if not in okchars rings bell and reads again. *) (* doesnot echo return *) Function GetChar; var ch:char; good:boolean; begin unitclear(1); (* clear type-ahead buffer *) repeat read(keyboard,ch); if eoln(keyboard) then ch:=chr(13); good:=ch in okchars; if not good then Bell(3) else if ch in [' '..chr(125)] then write(ch) until good; GetChar:=ch end; (* of GetChar *) (**********************************************************************) (* gets the choice from a set of single char options *) (* The option set needs to be in UPPER case *) Function GetChoice; var chdum,ch:char; good:boolean; begin unitclear(1); (* clear type-ahead buffer *) repeat repeat read(keyboard,chdum); if chdum in ['a'..'z'] then ch:=chr(ord(chdum)-32) else ch:=chdum; good:=ch in options; if not good then Bell(3) else if ch in [' '..chr(125)] then write(chdum) until good; GetChoice:=ch; ch:=GetChar([chr(8),chr(13)]); if ch=chr(8) then write(chr(8),' ',chr(8)) until ch=chr(13) end; (* of GetChoice *) (**********************************************************************) Function yes; (* reads a y/n reply only in either upper or lower case *) begin yes:=GetChoice(['Y','N'])='Y' end; (**********************************************************************) Procedure Continue; (* prints continue message in required position *) var ch:char; begin gotoxy(x,y); write('Press to continue..'); ch:=GetChar([chr(13)]) end; (**********************************************************************) (* print 'end of program' at position 0,22 and quit *) (* If Turnkey disc will restart at the beginning *) Procedure Goodbye; var nioresult,i:integer; ch:char; ok:boolean; begin ScClrLine(22); Printline(0,22,'End of program'); repeat (*$i-*) reset(f,'#4:system.pascal'); (*$i+*) ok:=(ioresult=0); if ok then begin (*$i-*) close(f,normal); reset(f,'#4:system.startup'); nioresult:=ioresult; if (nioresult=0) then begin close(f,normal); reset(f,'#4:startup.code'); nioresult:=ioresult; if (nioresult=0) then begin close(f,normal); (*$i+*) Continue(0,23); setchain('#4:startup'); exit(program) end end end else begin (*$i+*) Bell(6); Printline(0,23,'Put system disk in #4 and press '); if GetChar([chr(13)])=chr(13) then ScClrLine(23) end until ok; exit(program) end; (* of Goodbye *) (**********************************************************************) (* reads, char by char, string s of max length maxlen. *) (* each char must belong to okchars. *) (* if a nul string is read, s retains its value prior *) (* to the Procedure call. *) Procedure GetString; var s1:string[1]; str:string[80]; begin s1:=' '; str:=''; repeat if length(str)=0 then s1[1]:=GetChar(okchars+[chr(13)]) else if length(str)=maxlen then s1[1]:=GetChar([chr(13),chr(8)]) else s1[1]:=GetChar(okchars+[chr(13),chr(8)]); if s1[1] in okchars then str:=concat(str,s1) else if s1[1]=chr(8) then begin write(chr(8),' ',chr(8)); delete(str,length(str),1) end until s1[1]=chr(13); if length(str)<>0 then s:=str end; (* of GetString *) (**********************************************************************) (* gets text file name. allows only those chars defined by *) (* local variable okchars. .text is added if necessary *) (* checks for bad names (see below). *) Procedure GetTextfileName; var ok:boolean; name:string[23]; lpdottext,updottext,pc,lfullname,lname:integer; okchars:setofchar; filename:string; Procedure txtflerror(error:integer); (* prints text file name error, starting at line 12 *) var s:string; ch:char; begin (* of txtflerror *) case error of 1: s:='no disk name (no chars before '':'')'; 2: s:='disk name exceeds 7 chars'; 3: s:='no file name (no chars after '':'')'; 4: s:='no '':'' allowed in file name'; 5: s:='file name exceeds 10 chars' end; (* of case *) Bell(3); Printline(2,12,'fault in text file name'); Printline(2,15,s); Continue(2,22) end; (* of txtflerror *) begin (* of GetTextfileName *) okchars:=['%'..')','+','-'..'<','>','@'..'z','^',chr(97)..chr(122)]; repeat repeat repeat repeat repeat (* check at least one char before colon *) ok:=true; Printline(82,0,'(Insert other disk now if relevant)'); Printline(2,3,s1); Printline(2,5,s2); Printline(2,7,''); GetString(filename,23,okchars); gotoxy(2,8); pc:=pos(':',filename); if(pc=0)or (pc=1) then begin ok:=not(ok); txtflerror(1) end until ok; (* check max 7 chars before colon *) if pos(':',filename)>8 then begin ok:=not(ok); txtflerror(2) end until ok; (* check at least one char (excluding .text) after colon *) lfullname:=length(filename); name:=copy(filename,pc+1,lfullname-pc); updottext:=pos('.TEXT',name); lpdottext:=pos('.text',name); if ((length(name)=0) or (updottext=1) or (lpdottext=1)) then begin ok:=not ok; txtflerror(3) end until ok; (* check only one colon altogether *) if pos(':',name) <> 0 then begin ok:=not ok; txtflerror(4) end until ok; (* check max 10 chars (excluding .text) after colon *) if ((updottext>0) or (lpdottext>0)) then lname:=length(name)-5 else lname:=length(name); if lname>10 then begin ok:=not ok; txtflerror(5) end until ok; if ((updottext=0) and (lpdottext=0)) then nameoffile:=concat(filename,'.text') else nameoffile:=filename end; (* GetTextfileName *) (**********************************************************************) Procedure writeIoError; (* writes the appropriate ioerror to the screen *) begin if ((fault<=18)or(fault=64)) then case fault of 1: write('bad block, parity error'); 2: write('bad device (volume) number'); 3: write('illegal I/O request'); 4: write('data-com timeout'); 5: write('lost device; device is no longer online'); 6: write('lost file, no longer in directory'); 7: write('bad title; illegal file name'); 8: write('no room; insufficient space'); 9: write('no such volume online'); 10:write('no file; no such file on volume'); 11:write('duplicate directory entry'); 12:write('not closed; attempt to open an open file'); 13:write('not open; attempt to access a closed file'); 14:write('bad format; error in reading real or integer'); 15:write('ring buffer overflow'); 16:write('disk is write protected'); 17:write('illegal block number'); 18:write('illegal buffer'); 64:write('device error') end else write('please report this fault') end; (* writeIoError *) (**********************************************************************) (* prints IoError starting at position 3,17 *) Procedure IoError; begin Bell(3); Printline(2,18,'i/o error '); write(fault); gotoxy(2,20); writeIoError(fault); if ((fault>18) and (fault<>64)) then Goodbye; Continue(2,23) end; (* of IoError *) (**********************************************************************) Procedure OpenNewFile; (* opens a new file, first checks to see if a file with this name already exists, if it does then asks if it is to be overwritten *) var openok,goodname:boolean; fault:integer; begin repeat repeat goodname:=true; GetTextfileName(nameoffile,s1,s2); (*$i-*) reset(f,nameoffile); (*$i+*) fault:=ioresult; if fault=12 then begin ioerror(fault); PrintLine(2,11,'Program needs altering to recitify'); PrintLine(2,14,'this problem '); close(f,normal); goodbye end; if fault=0 then begin Bell(3); Printline(2,11,'this file already exists!'); Printline(2,14,'do you wish to overwrite it (y/n) ?'); goodname:=Yes; gotoxy(2,16) end; (*$i-*) close(f,normal) (*$i+*) until goodname; (*$i-*) rewrite(f,nameoffile); (*$i+*) fault:=ioresult; openok:=fault=0; if not openok then begin (*$i-*) close(f,normal); (*$i+*) IoError(fault) end until openok end; (**********************************************************************) Procedure OpenOldFile; (* opens an existing file *) var fault:integer; begin repeat GetTextfileName(nameoffile,s1,s2); (*$i-*) reset(f,nameoffile); (*$i+*) fault:=ioresult; (*$i-*) close(f,normal); (*$i+*) if fault<>0 then IoError(fault); until fault=0; (*$i-*) reset(f,nameoffile); (*$i+*) end; (**********************************************************************) (* gonverts string 's' to short integer num *) (* good set to true if conversion successful*) Procedure IntNum; var ok,neg:boolean; okchars:setofchar; l:integer[36]; i,n:integer; begin good:=false; n:=length(s); l:=0; i:=0; neg:=false; ok:=false; okchars:=['0'..'9']; num:=0; if n=0 then begin num:=-32767; exit(IntNum) end; i:=i+1; if not (s[i] in okchars) then begin repeat if (s[i]='-') then begin neg:=true; ok:=true end else if (s[i]='+') then ok:=true else if ((s[i]<>' ') or (i=n)) then begin num:=-32767; exit(IntNum) end; i:=i+1 until( ok or (s[i] in okchars)) end; ok:=true; repeat if (s[i] in okchars) then l:=l*10+ord(s[i])-48 else ok:=false; i:=i+1 until ((i-1=n) or not ok); if i>n then i:=n; if not ok then begin repeat if s[i]<>' ' then begin num:=-32767; exit(IntNum) end; i:=i+1 until (i>n) end; if l>32767 then begin num:=-32767; exit(IntNum) end; good:=true; str(l,s); for i:=1 to length(s) do num:=num*10+ord(s[i])-48; if neg then num:=-num end; (* of IntNum *) (**********************************************************************) (* converts string 's' to real num *) (* not valid if string in exp. format *) (* good set to true if conversion successful *) Procedure RealNum; var ok,dec,neg:boolean; okchars:setofchar; l:integer[36]; dnum,i,n:integer; s1,s2:string; begin good:=false; n:=length(s); dnum:=0; dec:=false; l:=0; i:=0; neg:=false; ok:=false; okchars:=['0'..'9','.']; num:=0.0; if n=0 then exit(RealNum); i:=i+1; if not (s[i] in okchars) then begin repeat if (s[i]='-') then begin neg:=true; ok:=true end else if(s[i]='+') then ok:=true else if((s[i]<>' ')or(i=n)) then exit(RealNum); i:=i+1 until (ok or (s[i] in okchars)) end; ok:=true; repeat if (s[i] in okchars) then begin if s[i]<>'.' then begin num:=num*10.0 + ord(s[i])-48.0; if dec then dnum:=dnum+1 end else begin if not dec then dec:=true else exit(RealNum); end end else ok:=false; i:=i+1 until ((i-1=n) or not ok); if i>n then i:=n; if not ok then repeat if s[i]<>' ' then exit(RealNum); i:=i+1 until (i>n); if dnum>0 then for i:=1 to dnum do num:=num/10; if neg then num:=-num; good:=true end; (* of RealNum *) (**********************************************************************) (* gets one real no from console *) (* exp. format not allowed *) (* leading spaces ignored *) (* terminating character(s) defined by user in termchars *) Procedure GetRealNo; var s :string[36]; ok:boolean; okchars:setofchar; maxlen,i,n,k:integer; s1:string[1]; str:string[80]; begin s1:=' '; maxlen:=21; okchars:=['0'..'9','.']; str:=''; repeat if length(str)=0 then begin s1[1]:=GetChar(okchars+['+','-',' ']); if s1[1]=' ' then str:='' end else if ((str[1] in ['+','-'])and(maxlen=(length(str)))) then s1[1]:=GetChar(termchars+[chr(8)]) else if ((not(str[1] in ['+','-']))and(maxlen=(length(str)-1))) then s1[1]:=GetChar(termchars+[chr(8)]) else if str[length(str)] in ['0'..'9'] then s1[1]:=GetChar(okchars+termchars+[chr(8)]) else s1[1]:=GetChar(okchars+[chr(8)]); if s1[1] in ['0'..'9','+','-','.'] then str:=concat(str,s1) else if s1[1]=chr(8) then begin write(chr(8),' ',chr(8)); delete(str,length(str),1) end; if pos('.',str)>0 then okchars:=['0'..'9'] else okchars:=['0'..'9','.']; until (str<>'')and(s1[1] in termchars); RealNum(num,ok,str) end; (* of GetRealNo *) (**********************************************************************) (* gets one integer from console *) (* leading spaces ignored *) (* terminating character(s) defined by user in termchars *) Procedure GetIntNo; var s :string[36]; l :integer[36]; okchars:setofchar; i,n,k:integer; s1:string[1]; str:string[80]; begin s1:=' '; okchars:=['0'..'9']; str:=''; repeat if length(str)=0 then begin s1[1]:=GetChar(okchars+['+','-',' ']); if s1[1]=' ' then str:='' end else if str[length(str)] in okchars then begin if ((str[1] in okchars)and(maxlen=(length(str)))) then s1[1]:=GetChar(termchars+[chr(8)]) else if ((not(str[1] in okchars))and(maxlen=(length(str)-1))) then s1[1]:=GetChar(termchars+[chr(8)]) else s1[1]:=GetChar(okchars+termchars+[chr(8)]) end else s1[1]:=GetChar(okchars+[chr(8)]); if s1[1] in ['0'..'9','+','-'] then str:=concat(str,s1) else if s1[1]=chr(8) then begin write(chr(8),' ',chr(8)); delete(str,length(str),1) end until (str<>'')and(s1[1] in termchars); IntNum(num,ok,str) end; (* of GetIntNo *) (**********************************************************************) (* gets one real no from console *) (* leading spaces ignoed *) (* 'ret' is only valid terminator *) Function GetReal; var ok:boolean; num:real; ch:char; begin repeat ok:=true; gotoxy(x,y); GetRealNo(num,[chr(13)]); if (nummax) then ok:=false; if not ok then begin Bell(3); gotoxy(2,y+2); write('error! '); if (num to try again..'); ch:=GetChar([chr(13)]); SCClrLine(y+3); SCClrLine(y+2); SCErasetoEOL(x,y) end until ok; GetReal:=num end; (* of GetReal *) (**********************************************************************) (* get one integer from console *) (* 'ret' is only valid terminator *) (* checks that integer lies in range min..max *) Function GetInt; var ok:boolean; n:integer; ch:char; begin repeat gotoxy(x,y); GetIntNo(n,ok,5,[chr(13)]); if ok then if ((nmax)) then ok:=false; if not ok then begin Bell(3); gotoxy(2,y+2); write('Range error min is ',min,' max is ',max); gotoxy(2,y+3); write('Press to try again..'); ch:=GetChar([chr(13)]); SCClrLine(y+3); SCClrLine(y+2); SCErasetoEOL(x,y) end until ok; GetInt:=n end; (* of GetInt *) (**********************************************************************) (* check the printer*) Procedure CheckPrinter; var ok:boolean; string1:string[1]; begin (* sends the message to the screen. *) string1:=' '; Printline(82,5,'Please check that the printer is'); Printline(2,7,'switched on and is "online"'); Printline(2,10,'Press the spacebar to align the'); Printline(2,12,'printer.'); Printline(2,17,'To start listing press ..'); (*$i-*) rewrite(pr,'printer:'); (* opens the output file printer with i/o checking off *) (*$i+*) repeat string1[1]:=GetChar([chr(13),chr(32)]); if (string1[1]=chr(32)) then begin write(chr(8)); writeln(pr) end; until (string1[1]=chr(13)) end; (* of CheckPrinter *) begin (* dummy main *) end. ======================================================================================== DOCUMENT :usus Folder:VOLUK04:voluk4.doc.text ======================================================================================== USUS Library Volume UK4 An APL Interpreter and other stuff Submitted by USUS(UK) UKVOL4: APL.TEXT 32 The APL Interpreter APLPARSE1.TEXT 18 an include file APLPARSE2.TEXT 66 ditto APLPROCS.TEXT 34 ditto APLPARSE3.TEXT 6 ditto APLHEAP.TEXT 12 ditto APLINIT.TEXT 16 ditto APLCHERS.TEXT 6 ditto APLPARSE0.TEXT 16 ditto SORT.DOC.TEXT 42 Documentation of the Sort/Merge Utility SORT.MERGE.TEXT 26 The main Sort/Merge program SORT.READ.TEXT 6 Some more notes on the Sort/Merge files SORT.DUMUN.TEXT 8 A example of the required user-supplied for Sort/Merge SORT.TXTUN.TEXT 18 A more general example of SORT.DUMUN.TEXT SPBSSTUFF.TEXT 40 A unit full of useful goodies SPBSSDOC1.TEXT 32 Documentation for SPBSSTUFF SPBSSDOC2.TEXT 32 Documentation for SPBSSTUFF SPBSSTUFF.CODE 16 A code file for IV.0 of SBBSSTUFF CONTENTS.TEXT 10 The UK's file of the contents of this disk, there's more detail in this one about this disk. VOLUK4.DOC.TEXT 6 You're reading it. __________________________________________________________________________ Please transfer the text below to a disk label if you copy this volume. USUS Volume UK4 -***- USUS Software Library For not-for-profit use by USUS members only. May be used and distributed only according to stated policy and the author's wishes. This volume was assembled by USUS(UK) from material collected by their Library committee. __________________________________________________________________________ DTCCatTextDocsRecursive Recursive Text File Concatenator 1.0 [18 September 2000] Written by David T. Craig Processing document "Jefferson Computer Museum - UCS" [TEXT/ttxt] ... Processing FOLDER "usus Folder" ... Processing document ":usus Folder:readme.doc.txt" [TEXT/MSWD] ... Processing FOLDER ":usus Folder:VOL01" ... Processing document ":usus Folder:VOL01:catalog1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:combine.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:cpm.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:cpmcopy.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:crc16.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:crt.i.o.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:diskread.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:format.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:format.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:format1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:format2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:getcpm.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:getcpm2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:gotcha.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:initvar.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:inoutready.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:introductn.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:l.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:modem.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:modem1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:pretty.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:pretty.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:readcpm.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:rwcpm.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:simp.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:typeset.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:units.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL01:volume1.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL03" ... Processing document ":usus Folder:VOL03:blackjack.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:catalog.3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:chase.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:debts.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:othell1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:othell2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:othellinit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:othello.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:policy.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:requests.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:snoopy.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:store.data" [TEXT/ttxt] ... Processing document ":usus Folder:VOL03:universal.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL04" ... Processing document ":usus Folder:VOL04:catalog.4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:compare.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:compress.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:dbbuilder.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:dbunit.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:dbunit.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:dbunit.3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:dbunit.4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:dbunit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:index.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:kb.dbdemo.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:kb.scunit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:kb.starter.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:kb.testdb" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:teach.wumpus" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:usus.news.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:volume.4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:wump.cave0.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:wump.cave1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:wump.cave2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:wump.cave3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:wump.cave4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:wump.cave5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL04:wumpus.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL05" ... Processing document ":usus Folder:VOL05:addrs.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:catalog.5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:crtinput.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:dir.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:diskread.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:fmt.1.5.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:fmt.2.0.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:fmt.examp.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:getnumber.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:getsort.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:hexdecoct.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:id2id.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:makemasks.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:monaco.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:peek.poke.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:quicksort.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:read.diskr.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:read.fmt.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:screencntl.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:sp.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:struct.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:unit.good.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL05:update.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL06" ... Processing document ":usus Folder:VOL06:banner.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:baud.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:catalog.6.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:cts.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:dialer.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:dtonedet.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:dtron.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:fmt.64mask.data" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:fmt.64menu.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:fmt.mask.data" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:fmt.menu.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:fmt.newdoc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:format.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:format.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:format.3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:format.4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:format.5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:format.6.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:format.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:format.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:hangup.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:kbstat.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:modemini.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:mread.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:mrecstat.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:mwrite.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:ptp-files.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:ptp-inst.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:ptp-use.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:ptp.bush.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:ri.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:ringing.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:sh.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL06:sysname.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL07" ... Processing document ":usus Folder:VOL07:catalog.7.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:fastread.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:keyhit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:map-a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:map-b.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:map.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:map.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:proc.ref1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:proc.ref2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:prx.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:prxref.ini.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:prxref.opt.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:prxref.pfi.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:prxref.tbl.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:prxref.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL07:prxref.utl.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL08" ... Processing document ":usus Folder:VOL08:archiver.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:catalog.8.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:chain.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:chain.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:chain.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:copyblocks.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:crmblev1.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:d.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:disksort.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:error.data.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:exhalev2.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:fast.seek.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:fileunit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:global.ii0.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:global.iii.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:linecount.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:lisp.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:lister.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:mailer.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:mailer.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:modemv2.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:muldiv.z80.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:perusev4.6.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:recover.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:rem.term.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:rem.unit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:screen.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:screenunit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:units.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:volume.8.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL08:writerv7.2.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL09" ... Processing document ":usus Folder:VOL09:adv.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:adv.miscinfo" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:adv.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advinit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs10.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs11.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs6.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs7.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs8.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advs9.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advsubs.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:advverb.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:castles.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:catalog.9.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:spacewar.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:star.part1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:star.part2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:star.part3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:startrek.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL09:volume.9.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL10" ... Processing document ":usus Folder:VOL10:benchmark.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:benchmark1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btre.file.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btre.find1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btre.find2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btree.data" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btree.dclr.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btree.del1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btree.del2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btree.doit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btree.get.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btree.init.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btree.prnt.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:btree.std.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:catalog.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:catalog.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:catalog.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:kruskal.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:kruskal.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:new.bfs.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:person.data" [TEXT/ttxt] ... Processing document ":usus Folder:VOL10:vol10.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL11" ... Processing document ":usus Folder:VOL11:bjack.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:blackjack.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:chase.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:contents.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail.e.g.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail.form.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail.info.data" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail.init.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail.lett.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail.read.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail2a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail2b.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail6.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail7.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail8.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mail9.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:mailiniteg.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:screenopsa.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:screenopsx.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL11:vol11.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL12" ... Processing document ":usus Folder:VOL12:analyze.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:augment.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:bench.byte.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:bench.pcw.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:bench.swap.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:bench.usus.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:contents.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:cproc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:disk_copy.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:help.disk.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:help.keys.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:help.off.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:help.util.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:lmformat.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:make.page.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:new.page.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:new.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:off.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:off.info.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:off.read.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:off.start.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:offload.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:param.info.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:print.heap.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:print.mem.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:r.analyze.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:startup.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:vol12.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:vols.smac" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:w.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:w.impln.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:w.io.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:w.segs.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:wfiler.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL12:windows.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL13" ... Processing document ":usus Folder:VOL13:declare.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:defalt_doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:dopage.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:dot_doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:errordata" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:err_doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:fit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:howto_doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:initc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:intro_doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:main.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:pdate.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:readln.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:readnu.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:runon_doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:scredit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:scrgen.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:spec_doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:startup.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:sysgen.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:taxcalc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:taxedit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:taxnames.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:taxprint.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:taxrw.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:taxstart.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:taxtable.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:tech_doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:types.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL13:vol13.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL14" ... Processing document ":usus Folder:VOL14:8080conv.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:banner.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:bondystuff.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:calendar.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:compfile.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:copfile.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:copver.asm.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:copvol.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:crosses.gpat" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:dayofwk.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:default.gpat" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:fastread.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:game.assem.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:game.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:game1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:hexdump.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:home_loan.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:kbstat.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:listinfo.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:look.up.table" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:refer.inc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:reference.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:reform.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:roman.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:scanner.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:sorts1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:sorts2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:sorts3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:sorts4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:sparse.gpat" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:srccom.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:stock.data.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:stock.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:stock.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:table.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL14:vol14.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL15" ... Processing document ":usus Folder:VOL15:a.___.remu.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:clr_break.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:comm.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:contents.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:hsm.uinc1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:hsm.uinc2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:hsm.uroot.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:iounit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:remtalk.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:remunit.l3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:set_break.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:smtremv5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:std.unit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:teletalker.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:term.emul.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:term.init.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:term.log.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:term.main.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:term.util.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:tomus3.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:tomus3.c1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:tomus4.c2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL15:vol15.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL16" ... Processing document ":usus Folder:VOL16:8.inch.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:add.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:apple.labl.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:ase.header.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:basproc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:basproc2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bdebug.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bdoc1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bdoc2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bdoc3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bdriver.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bhkeep.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bintern.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bio.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bmain.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:bunit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:checkbook.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:crtinput.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:getnumber.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:horton.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:inv.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:inv.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:invcs.mask.data" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:issue.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:p.inc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:p.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:report.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:usus.inv.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:vol16.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL16:z80.seek.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL17" ... Processing document ":usus Folder:VOL17:booter.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:comp.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:comp.b.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:comp.c.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:comp.d.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:comp.e.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:comp.f.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:filer.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:globals.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:linker.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:system.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:system.b.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:vol17.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:xfer.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL17:yaloe.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL18" ... Processing document ":usus Folder:VOL18:8queens.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:ancest.s.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:bench.usus.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:benchmarks.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:black.doc1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:black.doc2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:blackbox.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:bondy_form.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:compkiller.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:debug.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:debug.b.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:intrinsics.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:life.inc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:life.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:long_int.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:numberio.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:odmscu.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:primes.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:pwrof2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:quicksort.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:qur.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:report.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:reportform.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:segmap.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:segmap.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:segmasher.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:sieve.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:sort2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:sortunit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:stars.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:tele.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:vol18.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:whet.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL18:whetstone.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL19" ... Processing document ":usus Folder:VOL19:2k.key.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:booter.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:dec.index.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:eis.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:lp11.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:macros.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:mainop.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:make_i.3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:modem.pas.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:patch.cont.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:patches.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:procop.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:pvm.mac.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:rx11.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:setup.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:system.interp" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:system.pascal" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:traps.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:vol19.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:xfer.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL19:zapram.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL20" ... Processing document ":usus Folder:VOL20:autopsy.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:base.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:bios.const.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:bios.data.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:bios.disks.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:bios.phone.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:bios.serpt.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:boot.write.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:bootmaker.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:bootr-genr.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:e.boot.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:e.load.bios" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:e.load.boot" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:ebios-genr.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:ebios.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:eboot-genr.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:escort.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:fastread.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:fmt-genr.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:formatter.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:h19util.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:home_loan.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:lwrcase.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:number2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:othello.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:othello.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:screen.h19.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:screen.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:sigfig.19.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:sxfr.svcs.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:trans-genr.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:transportr.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:unlpatch.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:unlpatch.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:unlpch.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:uprcase.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL20:vol20.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL22" ... Processing document ":usus Folder:VOL22:contour.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:curve_fit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:distrib.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:fact_stuff.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:func.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:graph.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:graphics.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:histogram.data" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:histogram.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:ivp.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:plotter.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:polar.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:post.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:post_entry.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:real_input.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:review.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:scrn_stuff.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:sines.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:traverse.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:triangle.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL22:vol22.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL23" ... Processing document ":usus Folder:VOL23:df.docum.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:df.iv.0.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:df.iv.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:dict.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:iodoc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:iotest.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:iounit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:rnddoc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:rndtest.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:spelldoc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:speller.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:stargame.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL23:vol23.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL24" ... Processing document ":usus Folder:VOL24:adv.miscinfo" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx10.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx11.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx2.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx4.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx6.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx7.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx8.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advx9.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advxcons.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advxinit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advxinit2.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advxinit4.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advxsegs.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advxsubs.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:advxverb.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL24:vol24.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL25" ... Processing document ":usus Folder:VOL25:readme.1st.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:sd.define.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:sh.calc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:sh.display.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:sh.field.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:sh.init.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:sh.save.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:sh.screen.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:ud.copy.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:ud.list.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:ud.maint.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:ud.sort.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:ud.ude.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:ud.udelst.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL25:vol25.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL26" ... Processing document ":usus Folder:VOL26:readme.1st.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:sd_define.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:sh.screen.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:sh_screen.unit" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ud.intrdoc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ud.sort.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ude.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ude.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ude.3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ude.4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ude.5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ude.6.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ud_copy.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ud_list.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ud_list.scrn" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ud_maint.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ud_sort.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ud_sort.scrn" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:ud_ude.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:userlib.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL26:vol26.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL27" ... Processing document ":usus Folder:VOL27:ff.basics1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.basics2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.basics3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.copy1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.copy2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.data1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.data2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.data3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.data4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.data5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.forms1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.forms2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.forms3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.forms4.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.forms5.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.freefrm.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.misc1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:ff.misc2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:readme.1st.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL27:vol27.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL28" ... Processing document ":usus Folder:VOL28:ff.2word.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.4word.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.b.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.c.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.d.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.e.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.f.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.g.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.h.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.i.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.j.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:ff.k.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:readme.1st.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL28:vol28.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL29" ... Processing document ":usus Folder:VOL29:convdoc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:convers.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:conv_test.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:draw4a.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:draw4a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:draw8a.1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:draw8a.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:drawdn.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:install.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:osmisc_ii0.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:osmisc_iv.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:scrnop_ii0.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:terminal.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:textio_ii0.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:textio_iv.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL29:vol29.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOL2A" ... Processing document ":usus Folder:VOL2A:512.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:acoustic.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:bootasm.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:bootcpm.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:catalog.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:cpmio.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:dchayes.io.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:delete.lf.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:dfoco.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:h14.driver.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:h19.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:h19.gotoxy" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:h19.miscinfo" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:hazel.miscinfo" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:hexout.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:kbstat.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:linecountr.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:movram.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:new.gotoxy.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:pe1100.gotoxy" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:peruse.pg.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:policy.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:prime1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:prime2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:ptp.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:ptp.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:punch.tape.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:randombyte.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:read.tape.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:shellmsort.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:smartremot.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:timing.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:tvi912c.gotoxy" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:update.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:vol.2b.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:volume.2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:writer.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOL2A:writer.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOLUK03" ... Processing document ":usus Folder:VOLUK03:ada.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:ada.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:adadoc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:adatest.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:coint.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:contents.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:filecheck.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:gendat.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:gendat.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:lainit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:lanext.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:luerror.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:luinit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:newadatest.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:parser.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:stget.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:textdat.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:types.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK03:voluk3.doc.text" [TEXT/ttxt] ... Processing FOLDER ":usus Folder:VOLUK04" ... Processing document ":usus Folder:VOLUK04:apl.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:aplchers.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:aplheap.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:aplinit.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:aplparse0.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:aplparse1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:aplparse2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:aplparse3.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:aplprocs.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:contents.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:sort.doc.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:sort.dumun.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:sort.merge.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:sort.read.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:sort.txtun.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:spbssdoc1.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:spbssdoc2.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:spbsstuff.code" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:spbsstuff.text" [TEXT/ttxt] ... Processing document ":usus Folder:VOLUK04:voluk4.doc.text" [TEXT/ttxt] ... Text documents have been concatenated to document "BigTextDocument" That's all, Folks!