C ACM ALGORITHM 568 C C PDS - A PORTABLE FILE DIRECTORY SYSTEM C C BY DAVID HANSON C C ACM TRANSACTIONS ON PROGRAMMING LANGUAGES AND SYSTEMS, APRIL 1981 C #========== TAPE INFORMATION ========== # # THIS TAPE CONTAINS ONE FILE SEGMENTED INTO SEVERAL PIECES. EACH # SEGMENT IS PRECEDED BY A LINE BEGINNING WITH #==========. WITHIN EACH # SEGMENT, INDIVIDUAL FILES BEGIN WITH A HEADER LINE OF THE FORM # # #-H- NAME # # WHERE "NAME" IS THE FILE NAME USED ON THE DEC-10. OTHER INFORMATION ON # THE HEADER LINE INCLUDES FILE SIZE AND DATE AND TIME INDICATORS, BUT IS # NOT REQUIRED FOR THE USE OF THE FILES. # # THE FOLLOWING SEQMENTS ARE INCLUDED. # # PDS IN RATFOR AND FORTRAN # RATFOR PREPROCESSOR AND I/O SYSTEM IN RATFOR AND FORTRAN # DEC-10 I/O SYSTEM # CYBER I/O SYSTEM # LIBRARY OF USEFUL RATFOR ROUTINES # #========== PDS IN RATFOR AND FORTRAN ========== #-H- PDS.DOC 12610 1980 103 2200 # NAME # PDS - PORTABLE FILE DIRECTORY SYSTEM # # FILES # C* LABELED COMMONS # PDSDEF DEFINITIONS # RATDEF STANDARD RATFOR DEFINITIONS # PDS[1-6].RAT PDS CODE IN RATFOR # PDS.FOR PDS CODE IN FORTRAN # # DESCRIPTION # THE PDS IS A SET OF SUBROUTINES AND FUNCTIONS THAT PROVIDE A # MACHINE-INDEPENDENT DIRECTORY STRUCTURE FOR ACCESSING # MACHINE-DEPENDENT FILES. IN THE SIMPLEST TERMS, THE PDS PROVIDES # A MAPPING FROM MACHINE-INDEPENDENT FILE NAMES TO MACHINE-DEPENDENT # NAMES. # # THE BASIC TECHNIQUE USED IN THE PDS IS THE SEPARATION OF THE # INFORMATION DESCRIBING A FILE FROM THE FILE ITSELF. THE PDS DEALS # ONLY WITH THE FORMER; IT DOES NOT USE OR MANIPULATE, IN ANY WAY, # THE ACTUAL FILES. THE PDS IS USED TO SPECIFY A FILE BUT DOES NOT # PARTICIPATE IN THE ACTUAL I/O TO THAT FILE. AS A RESULT, THERE IS # NO IMPACT ON I/O EFFICIENCY WHEN THE PDS IS USED. USE OF THE PDS # IMPLIES USE OF A MACHINE-INDEPENDENT DIRECTORY SYSTEM TO LOCATE # FILES, AND A MACHINE-DEPENDENT I/O SYSTEM TO ACCESS THEM. # # THE DIRECTORY STRUCTURE PROVIDED BY THE PDS IS ESSENTIALLY THE # ROOTED TREE SYSTEM FOUND IN UNIX. PDS NAMES SPECIFY A "PATH" TO # THE INDICATED FILE. A PATH NAMES SPECIFIES THE PATH IN TERMS OF # DIRECTORIES, AND ENDS IN THE NAME OF THE FILE. COMPONENTS ARE # SEPARATED BY SLASHES. FOR EXAMPLE, "/USER/SOURCE/PDS.RAT" MIGHT # BE USED TO SPECIFY A FILE NAMED "PDS.RAT" IN THE DIRECTORY # "SOURCE", WHICH RESIDES IN "USER", WHICH RESIDES THE ROOT (DENOTED # "/"). IN THE SUBROUTINES AND FUNCTIONS DESCRIBED BELOW, THE TERM # "PATH" REFERS TO A PDS PATH SPECIFICATION AND THE TERM "HOST NAME" # REFERS TO A NAME FOR A FILE ON THE HOST SYSTEM. THE PRIMARY # FUNCTION OF THE PDS IS TO MAP PATH NAMES TO HOST NAMES. # # THE NOTION OF A "WORKING DIRECTORY" IS ALSO SUPPORTED. IF A PATH # NAME DOES NOT BEGIN WITH A "/", IT IS TAKEN TO BE ROOTED AT THE # CURRENT WORKING DIRECTORY. INITIALLY, THE WORKING DIRECTORY IS # "/". # # THE NAMES "." AND ".." REFER TO THE CURRENT DIRECTORY AND TO THE # IMMEDIATE ANCESTOR OF THE CURRENT DIRECTORY, RESPECTIVELY. THESE # NAMES MAY BE USED AS COMPONENTS OF A PATH NAME, E.G. "../FOO". # # INTEGER CHDIR # CHARACTER PATH(ARB) # INTEGER STATUS # STATUS = CHDIR(PATH) # CHDIR CHANGES THE CURRENT WORKING DIRECTORY TO THE DIRECTORY # SPECIFIED IN "PATH". IF SUCCESSFUL, CHDIR RETURNS NOERR. IF # THE SPECIFIED PATH CANNOT BE FOUND, OR DOES NOT REFER TO A # DIRECTORY, CHDIR RETURNS ERR. # # INTEGER CHDS # CHARACTER ROOT(ARB), ILIST(ARB) # INTEGER STATUS # STATUS = CHDS(ROOT, ILIST) # CHDS IS USED TO DIRECT THE ATTENTION OF THE PDS TO A COMPLETELY # DIFFERENT DIRECTORY SYSTEM. THE ARGUMENTS SPECIFY THE HOST # NAMES OF THE TWO FILES THAT CHARACTERIZE A DIRECTORY SYSTEM # (KNOWN AS THE ROOT AND ILIST). THESE FILES MUST EXIST; SEE # MKDS. IF THE CHANGE WAS SUCCESSFUL, CHDS RETURNS NOERR. IF # EITHER OF THE FILES COULD NOT BE OPENED, NO CHANGE OF ATTENTION # IS MADE AND CHDS RETURNS ERR. INITIALLY, THE PDS ATTEMPTS TO # ACCESS THE DIRECTORY SYSTEM WHOSE ROOT AND ILIST FILES ARE # GIVEN BY THE HOST NAMES "ROOT" AND "ILIST". # # INTEGER CREATF # CHARACTER PATH(ARB) # INTEGER FD, MODE # FD = CREATF(PATH, MODE) # CREATF CREATES THE FILE INDICATED BY THE CONTENTS OF "PATH" AND # OPENS IT FOR I/O ACCORDING TO THE VALUE OF "MODE". A HOST NAME # FOR THE FILE IS GENERATED AND THAT FILE IS CREATED. THE VALUE # OF "MODE" IS WHATEVER IS APPROPRIATE FOR OPENING A FILE ON THE # HOST SYSTEM; SEE OPENF. IF THE FILE CREATION AND OPENING WAS # SUCCESSFUL, CREATF RETURNS A "FILE DESCRIPTOR", WHICH IS # WHATEVER IS APPROPRIATE AS AN ARGUMENT TO I/O FUNCTIONS (E.G. A # FORTRAN UNIT NUMBER). IF THE CREATION WAS UNSUCCESSFUL, CREATF # RETURNS ERR. # # INTEGER LINK # CHARACTER PATH1(ARB), PATH2(ARB) # INTEGER STATUS # STATUS = LINK(PATH1, PATH2) # LINK MAKES THE PATH SPECIFIED BY THE CONTENTS OF "PATH1" REFER # TO THE SAME FILE SPECIFIED BY THE CONTENTS OF "PATH2". THE # FILE SPECIFIED BY "PATH2" MUST EXIST AND MUST NOT BE A # DIRECTORY. THE PATH GIVEN IN "PATH1" MUST NOT EXIST. IF ANY # OF THESE CONDITIONS ARE NOT MET, LINK RETURNS ERR. IF THE # LINKING WAS SUCCESSFUL, LINK RETURNS NOERR. # # INTEGER MKDIR # CHARACTER PATH(ARB) # INTEGER STATUS # STATUS = MKDIR(PATH) # MKDIR IS USED TO MAKE DIRECTORIES. THE ARGUMENT SPECIFIES THE # NAME OF THE DIRECTORY TO BE CREATED. IF THE SPECIFIED FILE # ALREADY EXISTS, MKDIR RETURNS ERR. IF THE DIRECTORY CREATION # WAS SUCCESSFUL, MKDIR RETURNS THE "I-NUMBER" OF THE NEW # DIRECTORY. # # INTEGER MKDS # CHARACTER ROOT(ARB), ILIST(ARB) # INTEGER STATUS # STATUS = MKDS(ROOT, ILIST) # MKDS IS USED TO MAKE DIRECTORY SYSTEMS. THE ARGUMENTS SPECIFY # THE HOST FILE NAMES TO BE USED AS THE ROOT AND ILIST, # RESPECTIVELY. IF EITHER THE ROOT OR ILIST CANNOT BE # INITIALIZED, MKDS RETURNS ERR. IF THE DIRECTORY SYSTEM WAS # SUCCESSFULLY CREATED, MKDS RETURNS NOERR. # # INTEGER MKFILE # CHARACTER PATH(ARB), HNAME(ARB) # INTEGER STATUS # STATUS = MKFILE(PATH, HNAME) # MKFILE MAKES AN ENTRY THE DIRECTORY SYSTEM WHOSE PATH IS # DESCRIBED BY THE CONTENTS OF "PATH" AND THAT CORRESPONDS TO THE # HOST NAME GIVEN BY THE CONTENTS OF "HNAME". SUBSEQUENT # REFERENCES TO THE GIVEN PATH ARE MAPPED INTO THE HOST NAME. IF # THE HOST NAME IS NULL, ONE IS GENERATED. IF THE SPECIFIED PATH # ALREADY EXISTS, MKFILE RETURNS ERR. IF THE PATH WAS ENTERED # SUCCESSFULLY, MKFILE RETURNS THE I-NUMBER OF THE NEW FILE. # MKFILE IS CALLED DIRECTLY BY THE USED RARELY; CALLS TO CREATF # OR MKDIR ARE THE USUAL MEANS OF ESTABLISHING NEW FILES. # # INTEGER OPENF # CHARACTER PATH(ARB) # INTEGER FD, MODE # FD = OPENF(PATH, MODE) # OPENF OPENS AN EXISTING FILE REFERRED BY THE PATH CONTAINED IN # "PATH" FOR I/O ACCORDING TO THE VALUE OF "MODE". THE VALUE OF # "MODE" IS WHATEVER IS APPROPRIATE FOR OPENING A FILE ON THE # HOST SYSTEM. IF THE INDICATED FILE CAN BE OPENED, OPENF # RETURNS A "FILE DESCRIPTOR", WHICH IS WHATEVER IS APPROPRIATE # AS AN ARGUMENT TO I/O FUNCTIONS (E.G. A FORTRAN UNIT NUMBER). # IF THE FILE CANNOT BE OPENED ACCORDING TO "MODE", OPENF RETURNS # ERR. # # INTEGER STAT # CHARACTER PATH(ARB) # INTEGER STATUS, ARRAY(37) # STATUS = STAT(PATH, ARRAY) # STAT IS USED TO OBTAIN INFORMATION CONCERNING THE FILE WHOSE # PATH IS THE CONTENTS OF "PATH". THE INFORMATION RETURNED IN # "ARRAY" IS THE CONTENTS OF THE "I-NODE" FOR THAT FILE. IF THE # INDICATED FILE EXISTS, STAT RETURNS ERR AND FILLS "ARRAY" WITH # THE FOLLOWING INFORMATION. # # ARRAY(1) SYSTEM INFORMATION # ARRAY(2) I-NUMBER OF THIS FILE # ARRAY(3) FILE TYPE: "D" IF DIRECTORY, "P" IF PLAIN FILE # ARRAY(4) NUMBER OF LINKS # ARRAY(5) CREATION TIME (INTEGER OF FORM HHMM) # ARRAY(6) CREATION DATE (INTEGER OF FORM MMDD) # ARRAY(7) CREATION YEAR (INTEGER OF FORM YYYY) # ARRAY(8) TIME OF LAST ACCESS (INTEGER OF FORM HHMM) # ARRAY(9) DATE OF LAST ACCESS (INTEGER OF FORM MMDD) # ARRAY(10) YEAR OF LAST ACCESS (INTEGER OF FORM YYYY) # ARRAY(11..37) HOST NAME AS RIGHT-JUSTIFIED ASCII STRING # TERMINATED BY AN EOS # # IF THE FILE DOES NOT EXIST, STAT RETURNS ERR. # # INTEGER SYNC # INTEGER JUNK, STATUS # STATUS = SYNC(JUNK) # SYNC CAUSES VARIOUS TABLES INTERNAL TO THE PDS TO BE WRITTEN TO # THE APPROPRIATE FILES. SYNC ALWAYS RETURNS NOERR. # # INTEGER UNLINK # CHARACTER PATH(ARB) # INTEGER STATUS # STATUS = UNLINK(PATH) # UNLINK REMOVES THE PATH NAME GIVEN BY THE CONTENTS OF "PATH" # AND DECREMENTS THE LINK CODE OF THE ASSOCIATED I-NODE. IF THE # RESULTING COUNT IS 0, THE I-NODE IS MADE AVAILABLE FOR REUSE. # IF THE FILE INDICATED BY "PATH" IS A DIRECTORY, IT MUST BE # EMPTY. IF THE FILE DOES NOT EXIST, OR IS A NON-EMPTY # DIRECTORY, UNLINK RETURNS ERR. IF THE FILE WAS SUCCESSFULLY # UNLINKED, UNLINK RETURNS NOERR. # # SEE ALSO # DAVID R. HANSON, "A PORTABLE FILE DIRECTORY SYSTEM", TECH. REP. # TR79-3A, DEPT. OF COMPUTER SCIENCE, UNIV. ARIZONA, TUCSON, SEP. # 1979. # # DIAGNOSTICS # ALL OF THE FOLLOWING ERRORS INDICATE AN INTERNAL INCONSISTENCY # WITHIN THE PDS OR ARE THE RESULT OF EXCEEDING A LIMIT. # # UNLINK: ILL-FORMED DIRECTORY # ENTER: OUT OF DIRECTORY SPACE # RDDIR: NOT A DIRECTORY # RDDIR: CAN'T READ DIRECTORY # WRDIR: CAN'T CREATE DIRECTORY # IALLOC: CAN'T READ ILIST # IGET: CAN'T READ ILIST # IGET: BAD INUMBER # IGET: FREE INODE # IREAD: BAD INUMBER # IUPDAT: CAN'T READ ILIST # IUPDAT: CAN'T CREATE TEMPORARY ILIST # # INSTALLATION # THE INSTALLATION OF PDS IS STRAIGHTFORWARD, PROVIDING THAT RATFOR # AND A RATFOR I/O SYSTEM HAS BEEN INSTALLED. A TYPICAL APPROACH IS # TO SET THE VARIOUS PARAMETERS IN PDS TO THE DESIRED VALUES, # COMPILE THE RATFOR CODE, AND PLACE THE OBJECT IN A LIBRARY THAT # CAN BE SEARCHED WHEN THE PDS IS TO BE USED. # # THE PARAMETERS ARE DEFINED IN THE DEFINITIONS FILE PDSDEF AND CONSIST # MAINLY OF VARIOUS SIZES. THE IMPORTANT PARAMETERS ARE AS FOLLOWS; # THE DEFAULT SIZES ARE GIVEN IN PARENTHESES. # # MAXINODES (30) # IS THE SIZE OF THE I-NODE CACHE. IT SHOULD BE LARGE ENOUGH SO # THAT READING THE ILIST CAN BE KEPT TO A MINIMUM. IF MAXINODES # IS CHANGED, INODESSIZE MUST ALSO BE CHANGED SINCE IT IS THE # PRODUCT OF I_SIZE AND MAXINODES (SEE PDSDEF). # # MAXINUM (15) # IS THE SIZE OF THE I-NODE FREE LIST. WHEN THE FREE LIST IS # EXHAUSTED, THE ENTIRE ILIST IS READ, SO MAXINUM SHOULD NOT BE # SMALL. # # MAXDENTRY (250) # IS THE MAXIMUM SIZE OF A DIRECTORY IN FILES. THE PDS HANDLES # DIRECTORIES BY READING THEM INTO MEMORY ON THE ASSUMPTION THAT # DIRECTORIES ARE NOT VERY LARGE. THIS PARAMETER MUST BE # INCREASED TO HANDLE LARGER DIRECTORIES. IF MAXDENTRY IS # CHANGED, WDIRSIZE MUST BE CHANGED SINCE IT IS THE PRODUCT OF # D_SIZE AND MAXDENTRY (SEE PDSDEF). # # MAXFNAME (20) # IS THE MAXIMUM SIZE PLUS ONE OF A PATH COMPONENT IN # CHARACTERS. # # MAXPATH (80) # IS THE MAXIMUM SIZE PLUS ONE OF A PATH. # # MAXTNAME (26) # IS THE MAXIMUM SIZE PLUS ONE OF A HOST FILE NAME. IT THIS IS # CHANGED, THE SIZE OF THE I-NODE, GIVEN BY I_SIZE, MUST BE # CHANGED AS MUST INODESSIZE (SEE PDSDEF). # # THERE ARE OTHER PARAMETERS; SEE PDSDEF. # # PDS RELIES ON THE STANDARD RATFOR I/O ROUTINES OPEN, CREATE, # GETCH, PUTCH, AND CLOSE. A FORTRAN VERSION OF THESE ROUTINES IS # SUPPLIED WITH RATFOR. # # THE FILE PDS6.RAT CONTAINS A NUMBER OF SUPPORT ROUTINES. SOME OF # THESE MAY BE REPLACED BY INSTALLATION-DEPENDENT VERSIONS IF # DESIRED. IN PARTICULAR, AMOVE IS USED TO MOVE A FILE. THIS IS # DONE BY COPYING IT, BUT COULD BE DONE BY A RENAME OPERATION IF # THAT IS SUPPORTED ON THE LOCAL SYSTEM. # # BEFORE PDS CAN BE RUN, A STANDARD RATFOR DATE FUNCTION MUST BE # PROVIDED. THE CALL IS # # INTEGER DATE, YEAR, TIME, SECS # # CALL DATE4(DATE, YEAR, TIME, SECS) # # DATE4 RETURNS THE CURRENT DATE AND TIME. THE CURRENT DATE IS # RETURNED IN "DATE" AS AN INTEGER OF THE FORM MMDD (E.G. 1022). # THE CURRENT YEAR IS RETURNED IN "YEAR" AS AN INTEGER OF THE FORM # YYYY (E.G. 1979). THE CURRENT TIME IS RETURNED IN "TIME" AS AN # INTEGER OF THE FORM HHMM (E.G. 1525, 24-HOUR TIME). THE NUMBER OF # SECONDS PAST THE CURRENT MINUTE IS RETURNED IN "SECS" AS AN # INTEGER OF THE FORM SS (E.G. 31). # # FINALLY, THE GENERATION OF HOST NAMES MAY NEED TO BE MODIFIED TO # CONFORM TO LOCAL USAGE. THE DEFAULT NAME IS ILIST.N, WHERE # "ILIST" IS THE HOST NAME OF THE ILIST FILE, AND "N" IS THE INUMBER # OF THE FILE. IF THIS CONVENTION IS UNSATISFACTORY, CHANGE THE # LAST FEW LINES IN THE FUNCTION IALLOC, WHICH IS IN PDS4.RAT. # #-H- PDSDEF 1651 1980 103 2058 INCLUDE RATDEF # PDSDEF: GLOBAL PDS DEFINITIONS # INODE STRUCTURE; I_MOD AND I_INUM ARE ONLY USED FOR IN-CORE COPIES DEFINE(I_MOD,1)%%# 1 IF MODIFIED DEFINE(I_INUM,2)%# I-NUMBER OF THIS INODE DEFINE(I_TYPE,3)%# F FILE TYPE: 0=FREE, D=DIRECTORY, P=PLAIN FILE DEFINE(I_NLINK,4)%# NUMBER OF LINKS DEFINE(I_CTIME,5)%# CREATION TIME (INTEGER OF THE FORM HHMM) DEFINE(I_CDATE,6)%# CREATION DATE (INTEGER OF THE FORM MMDD) DEFINE(I_CYEAR,7)%# CREATION YEAR (INTEGER OF THE FORM YYYY) DEFINE(I_ATIME,8)%# LAST ACCESS TIME (INTEGER OF THE FORM HHMM) DEFINE(I_ADATE,9)%# LAST ACCESS DATE (INTEGER OF THE FORM MMDD) DEFINE(I_AYEAR,10)%# LAST ACCESS YEAR (INTEGER OF THE FORM YYYY) DEFINE(I_TNAME,11)%# FILE NAME ON TARGET SYSTEM DEFINE(I_SIZE,37)%# SIZE OF INODE DEFINE(I_SAVE,10)%# NUMBER OF ILIST MODIFICATIONS BEFORE UPDATE # DIRECTORY STRUCTURE DEFINE(D_INUM,1)%# I-NUMBER DEFINE(D_NAME,2)%# START OF NAME DEFINE(D_SIZE,21)%# SIZE OF DIRECTORY ENTRY DEFINE(D_SAVE,10)%# NUMBER OF WDIR MODIFICATIONS BEFORE UPDATE # FLAGS DEFINE(PLAIN,LETP)%# FILE IS A "PLAIN OLD FILE" DEFINE(DIRECTORY,LETD)%# FILE IS A DIRECTORY DEFINE(UNUSED,DIG0)%# INODE IS FREE # CONSTANTS DEFINE(ROOTDIR,1)%# INODE NUMBER OF THE ROOT DIRECTORY # SIZES DEFINE(MAXINODES,30)%# NUMBER OF IN-CORE INODES (MUST BE >= 4) DEFINE(MAXINUM,15)%# SIZE OF INODE FREE LIST DEFINE(MAXDENTRY,250)%# NUMBER OF ENTRIES IN A DIRECTORY DEFINE(MAXFNAME,20)%# MAXIMUM SIZE OF A PDS FILE NAME DEFINE(MAXPATH,80)%# MAXIMUM LENGTH OF A PATH NAME DEFINE(MAXTNAME,26)%# MAXIMUM LENGTH OF A HOST FILE NAME DEFINE(WDIRSIZE,5250)%# MUST BE D_SIZE*MAXDENTRY DEFINE(INODESSIZE,1110)%# MUST BE I_SIZE*MAXINODES #-H- CINODE 584 1980 103 2058 COMMON /CINODE/ NINODE, INUM(MAXINUM), INODES(INODESSIZE), IMOD, INAME(MAXTNAME), RNAME(MAXTNAME), IBUF(MAXLINE), IFD, IPOS INTEGER NINODE%# NUMBER OF FREE INODES, INIT = 0 INTEGER INUM%%# CONTAINS FREE INODE NUMBERS CHARACTER INODES%# IN-CORE INODES INTEGER IMOD%%# TIMES ILIST HAS BEEN MODIFIED, INIT = 0 CHARACTER INAME%# NAME OF THE ILIST FILE CHARACTER RNAME%# NAME OF THE ROOT FILE CHARACTER IBUF%# USED TO READ ILIST FILE INTEGER IFD%%# FILE DESCRIPTOR FOR READING ILIST, INIT = EOF INTEGER IPOS%%# CURRENT POSITION IN OPENED ILIST FILE, INIT = 0 #-H- CUWDIR 95 1980 103 2058 COMMON /CUWDIR/ IUWDIR INTEGER IUWDIR%# INUMBER OF USER'S WORKING DIRECTORY, INIT = ROOTDIR #-H- CWDIR 269 1980 103 2058 COMMON /CWDIR/ IWDIR, WSIZE, WDIR(WDIRSIZE), WMOD INTEGER IWDIR%# INODE NUMBER FOR WORKING DIRECTORY, INIT = 0 INTEGER WSIZE%# LENGTH OF WORKING DIRECTORY CHARACTER WDIR%# CONTENTS OF WORKING DIRECTORY INTEGER WMOD%%# TIMES WDIR HAS BEEN MODIFIED, INIT = 0 #-H- PDS1.RAT 808 1980 103 2058 # PDS1: DATA INITIALIZATION INCLUDE PDSDEF BLOCK DATA INCLUDE CINODE INCLUDE CWDIR INCLUDE CUWDIR # INODE STRUCTURE DATA NINODE /0/%# NO FREE INODES INITIALLY DATA INODES /INODESSIZE*0/ # EMPTY CACHE INITIALLY DATA IMOD /0/%# NO MODIFICATIONS INITIALLY DATA INAME(1), INAME(2), INAME(3), INAME(4), INAME(5), INAME(6) /_ LETI, LETL, LETI, LETS, LETT, EOS/%# DEFAULT ILIST NAME DATA RNAME(1), RNAME(2), RNAME(3), RNAME(4), RNAME(5) /_ LETR, LETO, LETO, LETT, EOS/ DATA IFD /EOF/%# ILIST NOT OPENED INITIALLY DATA IPOS /0/%# " # WORKING DIRECTORY STRUCTURE DATA IWDIR /0/%# NO WORKING DIRECTORY INITIALLY DATA WMOD /0/%# NO MODIFICATIONS INITIALLY # USER'S WORKING DIRECTORY STRUCTURE DATA IUWDIR /ROOTDIR/%# / IS INITIAL DIRECTORY END #-H- PDS2.RAT 6413 1980 103 2058 # PDS2: PDS USER PRIMITIVES INCLUDE PDSDEF # CHDIR(PATH) - CHANGE USER'S WORKING DIRECTORY TO PATH INTEGER FUNCTION CHDIR(PATH) CHARACTER PATH(MAXPATH) INTEGER IP, ISCAN, INODE(I_SIZE) INCLUDE CUWDIR IF (ISCAN(PATH, IP) == ERR) RETURN(ERR) CALL IGET(IP, INODE) IF (INODE(I_TYPE) ^= DIRECTORY) RETURN(ERR) IUWDIR = IP # SET NEW WORKING DIRECTORY RETURN(NOERR) END # CHDS(ROOT, ILST) - CHANGE TO ANOTHER DIRECTORY SYSTEM INTEGER FUNCTION CHDS(ROOT, ILST) CHARACTER ROOT(MAXTNAME), ILST(MAXTNAME) INTEGER FD INTEGER OPEN INCLUDE CINODE IF (ILST(1) ^= EOS) < FD = OPEN(ILST, READ) IF (FD == ERR) RETURN(ERR) CALL CLOSE(FD) ! IF (ROOT(1) ^= EOS) < FD = OPEN(ROOT, READ) IF (FD == ERR) RETURN(ERR) CALL CLOSE(FD) ! CALL NEWDIR(0)%# SAVE CURRENT SYSTEM AND CLEAR FOR NEW ONE CALL ICLEAR(YES) IF (ROOT(1) ^= EOS) CALL SCOPY(ROOT, 1, RNAME, 1) # UPDATE NAMES OF ROOT AND ILIST IF (ILST(1) ^= EOS) CALL SCOPY(ILST, 1, INAME, 1) RETURN(NOERR) END # CREATF(PATH, MODE) - CREATE FILE PATH AND OPEN IT ACCORDING TO MODE INTEGER FUNCTION CREATF(PATH, MODE) CHARACTER PATH(MAXPATH) INTEGER MODE CHARACTER INODE(I_SIZE) INTEGER IP, FD, MKFILE, CREATE STRING EOSS "" IP = MKFILE(PATH, EOSS) IF (IP == ERR) RETURN(ERR) CALL IGET(IP, INODE) # NEED TO GET TARGET NAME FD = CREATE(INODE(I_TNAME), MODE) IF (FD == ERR) CALL IFREE(IP) # DON'T NEED INODE ANYMORE RETURN(FD) END # LINK(PATH1, PATH2) - LINK PATH1 TO PATH2 INTEGER FUNCTION LINK(PATH1, PATH2) CHARACTER PATH1(MAXPATH), PATH2(MAXPATH) CHARACTER INODE(I_SIZE) INTEGER I, J, IP, ISCAN, CSCAN, CTOI, ITOC IF (ISCAN(PATH2, IP) == ERR) RETURN(ERR) CALL IGET(IP, INODE) IF (INODE(I_TYPE) == DIRECTORY) # CAN'T LINK TO DIRECTORIES RETURN(ERR) I = 1 IF (CSCAN(PATH1, I) == ERR) # CAN'T EXIST ALREADY RETURN(ERR) CALL ENTER(PATH1(I), IP) # MAKE ENTRY TO PATH2'S INODE INODE(I_NLINK) = INODE(I_NLINK) + 1 # INCREMENT PATH2'S LINK COUNT CALL IPUT(IP, INODE) RETURN(NOERR) END # MKDIR(PATH) - MAKE A NEW DIRECTORY INTEGER FUNCTION MKDIR(PATH) CHARACTER PATH(MAXPATH) INTEGER IP, IIP, MKFILE, INODE(I_SIZE) INCLUDE CWDIR STRING DOTDOT ".." STRING EOSS "" IP = MKFILE(PATH, EOSS) # MAKE A FILE IF (IP == ERR) RETURN(ERR) IIP = IWDIR # SAVE INUMBER OF PARENT CALL IGET(IP, INODE) INODE(I_TYPE) = DIRECTORY # THIS IS A DIRECTORY INODE(I_NLINK) = INODE(I_NLINK) + 1%# FOR . CALL IPUT(IP, INODE) CALL NEWDIR(IP) # PREPARE TO MAKE A NEW DIRECTORY CALL ENTER(DOTDOT(2), IP) # ENTER . AND .. CALL ENTER(DOTDOT(1), IIP) CALL WRDIR # MAKE SURE IT GETS WRITTEN CALL IGET(IIP, INODE)%# INCREMENT LINK COUNT OF PARENT INODE(I_NLINK) = INODE(I_NLINK) + 1 CALL IPUT(IIP, INODE) RETURN(IP) END # MKDS(ROOT, ILST) - MAKE A DIRECTORY SYSTEM INTEGER FUNCTION MKDS(ROOT, ILST) CHARACTER ROOT(MAXTNAME), ILST(MAXTNAME) INTEGER JUNK, FD, CREATE CHARACTER INODE(I_SIZE) STRING DOTDOT ".." STRING RNAME "ROOT" STRING INAME "ILIST" INODE(I_MOD) = 1%# BUILD AN INODE FOR THE ROOT INODE(I_INUM) = 1 INODE(I_TYPE) = DIRECTORY INODE(I_NLINK) = 2 CALL DATE4(INODE(I_CDATE), INODE(I_CYEAR), INODE(I_CTIME), JUNK) CALL DATE4(INODE(I_ADATE), INODE(I_AYEAR), INODE(I_ATIME), JUNK) INODE(I_TNAME) = EOS IF (ROOT(1) ^= EOS) CALL SCOPY(ROOT, 1, INODE, I_TNAME) ELSE CALL SCOPY(RNAME, 1, INODE, I_TNAME) IF (ILST(1) ^= EOS) FD = CREATE(ILST, WRITE) ELSE FD = CREATE(INAME, WRITE) IF (FD == ERR) RETURN(ERR) CALL IWRITE(INODE, FD) CALL CLOSE(FD) FD = CREATE(INODE(I_TNAME), WRITE) IF (FD == ERR) RETURN(ERR) CALL PUTINT(ROOTDIR, 5, FD) CALL PUTCH(BLANK, FD) CALL PUTLIN(DOTDOT(2), FD) CALL PUTCH(NEWLINE, FD) CALL PUTINT(ROOTDIR, 5, FD) CALL PUTCH(BLANK, FD) CALL PUTLIN(DOTDOT(1), FD) CALL PUTCH(NEWLINE, FD) CALL CLOSE(FD) RETURN(NOERR) END # MKFILE(PATH, TNAME) - MAKE A FILE POINTING TO TNAME INTEGER FUNCTION MKFILE(PATH, TNAME) CHARACTER PATH(MAXPATH), TNAME(MAXTNAME) INTEGER I, IP, CSCAN, IALLOC, INODE(I_SIZE), JUNK I = 1 IF (CSCAN(PATH, I) == ERR) # CHECK PATH, MUST NOT EXIST RETURN(ERR) IP = IALLOC(INODE) IF (TNAME(1) ^= EOS) CALL SCOPY(TNAME, 1, INODE, I_TNAME) CALL IPUT(IP, INODE) CALL ENTER(PATH(I), IP) RETURN(IP) END # OPENF(PATH, MODE) - OPEN PATH FOR READING OR WRITING INTEGER FUNCTION OPENF(PATH, MODE) CHARACTER PATH(MAXPATH) INTEGER MODE INTEGER IP, ISCAN, OPEN, INODE(I_SIZE) IF (ISCAN(PATH, IP) == ERR) RETURN(ERR) CALL IGET(IP, INODE) RETURN(OPEN(INODE(I_TNAME), MODE)) END # STAT(PATH, ARRAY) - GET INFO CONCERNING PATH INTO ARRAY INTEGER FUNCTION STAT(PATH, ARRAY) CHARACTER PATH(MAXPATH) INTEGER ARRAY(I_SIZE) INTEGER IP, ISCAN IF (ISCAN(PATH, IP) == ERR) RETURN(ERR) CALL IGET(IP, ARRAY) RETURN(NOERR) END # SYNC - UPDATE DISK COPIES OF ILIST AND WORKING DIRECTORY INTEGER FUNCTION SYNC(JUNK) INTEGER JUNK CALL IUPDAT CALL WRDIR RETURN(NOERR) END # UNLINK(PATH) - UNLINK PATH FROM ITS INODE INTEGER FUNCTION UNLINK(PATH) CHARACTER PATH(MAXPATH) CHARACTER INODE(I_SIZE) INTEGER I, IP, N, SCAN, LOOKUP INCLUDE CUWDIR INCLUDE CWDIR STRING DOT ".." I = 1 IF (SCAN(PATH, I) == ERR) RETURN(ERR) IF (LOOKUP(PATH(I), IP) == ERR) RETURN(ERR) CALL IGET(IP, INODE) IF (INODE(I_TYPE) == DIRECTORY) < # DIRECTORY IF (IP == IUWDIR) RETURN(ERR)%# CAN'T DELETE WORKING DIRECTORY N = IWDIR CALL RDDIR(IP) IF (WSIZE ^= 2*D_SIZE) # MUST BE EMPTY RETURN(ERR) IF (INODE(I_NLINK) ^= 2 \ LOOKUP(DOT, IIP) == ERR) CALL ERROR("UNLINK: ILL-FORMED DIRECTORY.") CALL IGET(IIP, INODE) INODE(I_NLINK) = INODE(I_NLINK) - 1 CALL IPUT(IIP, INODE) CALL RDDIR(N) CALL DELETE(PATH(I)) CALL IFREE(IP) RETURN(NOERR) ! CALL DELETE(PATH(I)) INODE(I_NLINK) = INODE(I_NLINK) - 1 IF (INODE(I_NLINK) > 0) CALL IPUT(IP, INODE) ELSE # LINK COUNT = 0, FREE INODE CALL IFREE(IP) RETURN(NOERR) END #-H- PDS3.RAT 3369 1980 103 2058 # PDS3: DIRECTORY HANDLING INCLUDE PDSDEF # DELETE - DELETE NAME FROM CURRENT DIRECTORY SUBROUTINE DELETE(NAME) CHARACTER NAME(MAXFNAME) INTEGER I, EQUAL INCLUDE CWDIR IF (IWDIR == 0) CALL RDDIR(ROOTDIR) # GET ROOT FOR (I = 0; I < WSIZE; I = I + D_SIZE) IF (EQUAL(NAME, WDIR(I+D_NAME)) == YES) < WDIR(I+D_INUM) = 0%# MARK ENTRY AS EMPTY WDIR(I+D_NAME) = EOS WMOD = WMOD + 1 IF (WMOD >= D_SAVE) CALL WRDIR RETURN ! RETURN END # ENTER - INSERT NAME INTO WORKING DIRECTORY WITH I-NUMBER N. SUBROUTINE ENTER(NAME, N) CHARACTER NAME(MAXTNAME) INTEGER N INTEGER I INCLUDE CWDIR IF (IWDIR == 0) CALL RDDIR(ROOTDIR) # GET ROOT FOR (I = 0; I < WSIZE; I = I + D_SIZE) IF (WDIR(I+D_INUM) == 0) # FOUND EMPTY ENTRY BREAK IF (I >= WSIZE) < # NEED TO EXPAND WORKING DIRECTORY SIZE IF (I + D_SIZE > MAXDENTRY*D_SIZE) CALL ERROR("ENTER: OUT OF DIRECTORY SPACE.") WSIZE = I + D_SIZE ! WDIR(I+D_INUM) = N CALL SCOPY(NAME, 1, WDIR, I + D_NAME) WMOD = WMOD + 1 IF (WMOD >= D_SAVE) CALL WRDIR RETURN END # LOOKUP - GET I-NUMBER FOR NAME IN N. INTEGER FUNCTION LOOKUP(NAME, N) CHARACTER NAME(MAXFNAME) INTEGER N INTEGER I, EQUAL INCLUDE CWDIR IF (IWDIR == 0) CALL RDDIR(ROOTDIR) # GET ROOT FOR (I = 0; I < WSIZE; I = I + D_SIZE) IF (WDIR(I+D_INUM) ^= 0 & EQUAL(NAME, WDIR(I+D_NAME)) == YES) < N = WDIR(I+D_INUM) RETURN(NOERR) ! RETURN(ERR) END # NEWDIR - CHANGE WORKING DIRECTORY TO AN EMPTY DIRECTORY WITH INODE N SUBROUTINE NEWDIR(N) INTEGER N INCLUDE CWDIR INCLUDE CUWDIR CALL WRDIR # FLUSH CURRENT DIRECTORY IWDIR = N WSIZE = 0 # DIRECTORY IS EMPTY IF (N == 0) # RESET USER'S WORKING DIRECTORY IUWDIR = ROOTDIR RETURN END # RDDIR - READ DIRECTORY ASSOCIATED WITH INODE N. SUBROUTINE RDDIR(N) INTEGER N INTEGER I, FD, OPEN, INODE(I_SIZE), CTOI, GETLIN, WBUF(MAXLINE), LENGTH INCLUDE CWDIR IF (N == IWDIR) # MAY ALREADY HAVE IT RETURN IF (WMOD > 0) CALL WRDIR # WRITE OUT CURRENT DIRECTORY CALL IGET(N, INODE) IF (INODE(I_TYPE) ^= DIRECTORY) CALL ERROR("RDDIR: NOT A DIRECTORY.") FD = OPEN(INODE(I_TNAME), READ) IF (FD == ERR) CALL ERROR("RDDIR: CAN'T READ DIRECTORY.") FOR (WSIZE = 0; GETLIN(WBUF, FD) ^= EOF; WSIZE = WSIZE + D_SIZE) < I = LENGTH(WBUF) IF (WBUF(I) == NEWLINE) WBUF(I) = EOS I = 1 WDIR(WSIZE+D_INUM) = CTOI(WBUF, I) CALL SCOPY(WBUF, I + 1, WDIR, WSIZE + D_NAME) ! CALL CLOSE(FD) IWDIR = N WMOD = 0 RETURN END # WRDIR - WRITE OUT CURRENT DIRECTORY; SET WMOD = 0 SUBROUTINE WRDIR INTEGER I, FD, CREATE, INODE(I_SIZE) INCLUDE CWDIR IF (WMOD == 0) # DON'T WRITE IF WE DON'T HAVE TO RETURN CALL IGET(IWDIR, INODE) FD = CREATE(INODE(I_TNAME), WRITE) IF (FD == ERR) CALL ERROR("WRDIR: CAN'T CREATE DIRECTORY.") FOR (I = 0; I < WSIZE; I = I + D_SIZE) IF (WDIR(I+D_INUM) ^= 0) < CALL PUTINT(WDIR(I+D_INUM), 5, FD) CALL PUTCH(BLANK, FD) CALL PUTLIN(WDIR(I+D_NAME), FD) CALL PUTCH(NEWLINE, FD) ! CALL CLOSE(FD) WMOD = 0 RETURN END #-H- PDS4.RAT 6690 1980 103 2058 # PDS4: INODE HANDLING INCLUDE PDSDEF # IALLOC - ALLOCATE AN INODE AND COPY INITIAL VALUE INTO ARRAY INTEGER FUNCTION IALLOC(ARRAY) CHARACTER ARRAY(I_SIZE) INTEGER I, J, FD INTEGER OPEN, GETLIN, UALLOC, LENGTH INCLUDE CINODE IF (NINODE == 0) < # SWEEP ILIST LOOKING FOR MORE FREE INODES CALL IUPDAT # INSURE UP TO DATE ILIST FD = OPEN(INAME, READ) IF (FD == ERR) CALL ERROR("IALLOC: CAN'T READ ILIST.") NINODE = MAXINUM FOR (I = 1; GETLIN(IBUF, FD) ^= EOF; I = I + 1) IF (IBUF(1) == UNUSED) < # FOUND ONE INUM(NINODE) = I NINODE = NINODE - 1 IF (NINODE == 0)%# QUIT IF WE HAVE ENOUGH BREAK ! WHILE (NINODE > 0) < INUM(NINODE) = I I = I + 1 NINODE = NINODE - 1 ! NINODE = MAXINUM CALL CLOSE(FD) ! IALLOC = INUM(NINODE) NINODE = NINODE - 1 I = UALLOC(I) INODES(I+I_MOD) = 0 INODES(I+I_INUM) = IALLOC INODES(I+I_TYPE) = PLAIN INODES(I+I_NLINK) = 1 CALL DATE4(INODES(I+I_CDATE), INODES(I+I_CYEAR), INODES(I+I_CTIME), JUNK) CALL DATE4(INODES(I+I_ADATE), INODES(I+I_AYEAR), INODES(I+I_ATIME), JUNK) CALL SCOPY(INAME, 1, INODES(I+I_TNAME), 1) # MAKE DEFAULT HOST NAME J = LENGTH(INAME) # (DEC-10 VERSION) KK = I + I_TNAME + J INODES(KK) = PERIOD J = ITOC(IALLOC, INODES(KK+1), I_SIZE-I_TNAME-J-1) CALL SCOPY(INODES, I + 1, ARRAY, 1) RETURN END # ICLEAR - CLEAR INODE DATA STRUCTURE; UPDATE IF FLAG == YES SUBROUTINE ICLEAR(FLAG) INTEGER FLAG INTEGER I INCLUDE CINODE IF (FLAG == YES) CALL IUPDAT NINODE = 0 # SET NO INODES AND CLEAR THE CACHE FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE) INODES(I+I_INUM) = 0 RETURN END # ICMP - COMPARE I-NUMBERS OF TWO INODES; CALLED BY QSORT INTEGER FUNCTION ICMP(X, Y) INTEGER X, Y INCLUDE CINODE RETURN (INODES(X+I_INUM) - INODES(Y+I_INUM)) END # IFREE - FREE INODE N. SUBROUTINE IFREE(N) INTEGER N INTEGER INODE(I_SIZE) INCLUDE CINODE IF (NINODE < MAXINUM) < NINODE = NINODE + 1 INUM(NINODE) = N ! INODE(I_INUM) = N # MAKE A FREE INODE AND PUT IT OUT INODE(I_TYPE) = UNUSED CALL IPUT(N, INODE) RETURN END # IGET - COPY INODE N INTO ARRAY. SUBROUTINE IGET(N, ARRAY) INTEGER N CHARACTER ARRAY(I_SIZE) INTEGER I, J, OPEN, UALLOC, GETLIN INCLUDE CINODE FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE) IF (INODES(I+I_INUM) == N) BREAK IF (I >= MAXINODES*I_SIZE) <%# GET INODE FROM ILIST FILE I = UALLOC(I) IF (IFD ^= EOF & N < IPOS) < # NEED TO REREAD ILIST CALL CLOSE(IFD) IFD = EOF ! IF (IFD == EOF) < IFD = OPEN(INAME, READ) IPOS = 0 ! IF (IFD == ERR) CALL ERROR("IGET: CAN'T READ ILIST.") FOR ( ; IPOS < N; IPOS = IPOS + 1) IF (GETLIN(IBUF, IFD) == EOF) CALL ERROR("IGET: BAD INUMBER.") CALL IREAD(INODES(I+I_MOD)) INODES(I+I_INUM) = N ! IF (INODES(I+I_TYPE) == UNUSED) CALL ERROR("IGET: FREE INODE.") CALL SCOPY(INODES, I + 1, ARRAY, 1) RETURN END # IPUT - COPY ARRAY TO INODE N AND UPDATE INODE FILE IF NECESSARY. SUBROUTINE IPUT(N, ARRAY) INTEGER N CHARACTER ARRAY(I_SIZE) INTEGER I, UALLOC INCLUDE CINODE FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE) IF (INODES(I+I_INUM) == N) BREAK IF (I >= MAXINODES*I_SIZE) # NEED A SLOT I = UALLOC(I) CALL SCOPY(ARRAY, 1, INODES, I + I_MOD) INODES(I+I_MOD) = 1 IMOD = IMOD + 1 IF (IMOD >= I_SAVE) CALL IUPDAT RETURN END # IREAD - CONVERT DATA IN IBUF TO INTERNAL INODE IN INODE SUBROUTINE IREAD(INODE) INTEGER INODE(I_SIZE) INTEGER I, LENGTH, CTOI INCLUDE CINODE I = LENGTH(IBUF) IF (IBUF(I) == NEWLINE)%# ZAP THE NEWLINE IBUF(I) = EOS INODE(I_MOD) = 0 INODE(I_INUM) = 0 INODE(I_TYPE) = IBUF(1) I = 3 INODE(I_NLINK) = CTOI(IBUF, I) INODE(I_CTIME) = CTOI(IBUF, I) INODE(I_CDATE) = CTOI(IBUF, I) INODE(I_CYEAR) = CTOI(IBUF, I) INODE(I_ATIME) = CTOI(IBUF, I) INODE(I_ADATE) = CTOI(IBUF, I) INODE(I_AYEAR) = CTOI(IBUF, I) CALL SCOPY(IBUF, I+1, INODE, I_TNAME) RETURN END # IUPDAT - UPDATE THE ILIST FILE IF MODIFIED; SET IMOD = 0 SUBROUTINE IUPDAT INTEGER I, J, N, FDI, FDO, IP(MAXINODES), JUNK, CREATE, OPEN, GETLIN EXTERNAL ICMP INCLUDE CINODE STRING TMPNAM "I.TMP" IF (IFD ^= EOF) < CALL CLOSE(IFD) IFD = EOF ! IF (IMOD == 0) RETURN IMOD = 0 J = 0 FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE) IF (INODES(I+I_INUM) > 0 & INODES(I+I_MOD) ^= 0) < INODES(I+I_MOD) = 0 J = J + 1 IP(J) = I ! IF (J == 0) RETURN IP(J+1) = -1 CALL QSORT(J, IP, ICMP) FDI = OPEN(INAME, READ) IF (FDI == ERR) CALL ERROR("IUPDAT: CAN'T READ ILIST.") FDO = CREATE(TMPNAM, WRITE) IF (FDO == ERR) CALL ERROR("IUPDAT: CAN'T CREATE TEMPORARY ILIST.") I = 0 FOR (J = 1; IP(J) >= 0; J = J + 1) < N = IP(J) N = INODES(N+I_INUM) FOR (I = I + 1; I < N; I = I + 1) IF (GETLIN(IBUF, FDI) ^= EOF) CALL PUTLIN(IBUF, FDO) JUNK = GETLIN(IBUF, FDI)%# THROW AWAY DISK COPY N = IP(J) CALL IWRITE(INODES(N+I_MOD), FDO) ! WHILE (GETLIN(IBUF, FDI) ^= EOF) CALL PUTLIN(IBUF, FDO) CALL CLOSE(FDI) CALL CLOSE(FDO) CALL AMOVE(TMPNAM, INAME) RETURN END # IWRITE - WRITE INODE TO FD IN PROPER FORMAT SUBROUTINE IWRITE(INODE, FD) INTEGER INODE(I_SIZE), FD CALL PUTCH(INODE(I_TYPE), FD) IF (INODE(I_TYPE) ^= UNUSED) < CALL PUTINT(INODE(I_NLINK), 4, FD) CALL PUTINT(INODE(I_CTIME), 5, FD) CALL PUTINT(INODE(I_CDATE), 5, FD) CALL PUTINT(INODE(I_CYEAR), 5, FD) CALL PUTINT(INODE(I_ATIME), 5, FD) CALL PUTINT(INODE(I_ADATE), 5, FD) CALL PUTINT(INODE(I_AYEAR), 5, FD) CALL PUTCH(BLANK, FD) CALL PUTLIN(INODE(I_TNAME), FD) ! CALL PUTCH(NEWLINE, FD) RETURN END # UALLOC - ALLOCATE A SLOT IN INODES INTEGER FUNCTION UALLOC(I) INTEGER I INTEGER LAST INCLUDE CINODE REPEAT < LAST = 0 FOR (I = 0; I < MAXINODES*I_SIZE; I = I + I_SIZE) IF (INODES(I+I_INUM) == 0) RETURN (I) ELSE IF (INODES(I+I_MOD) == 0) LAST = I + 1 IF (LAST ^= 0) < I = LAST - 1 RETURN (I) ! CALL IUPDAT%# DUMP THE CURRENT ILIST ! RETURN END #-H- PDS5.RAT 1834 1980 103 2058 # PDS5: PATH SCANNING INCLUDE PDSDEF # CSCAN - SEARCH DIRECTORY HIERARCHY FOR CREATION OF PATH(I), INCREMENT I INTEGER FUNCTION CSCAN(PATH, I) CHARACTER PATH(MAXPATH) INTEGER I INTEGER N, SCAN I = 1 IF (SCAN(PATH, I) == ERR) RETURN(ERR) IF (PATH(1) == SLASH & PATH(2) == EOS) # SPECIAL CASE THE ROOT RETURN(ERR) IF (LOOKUP(PATH(I), JUNK) == NOERR) RETURN(ERR)%# MUST NOT EXIST RETURN(NOERR) END # ISCAN - SEARCH DIRECTORY HIERARCHY FOR INPUT FILE PATH, RETURN INODE N INTEGER FUNCTION ISCAN(PATH, N) CHARACTER PATH(MAXPATH) INTEGER N INTEGER I, SCAN, LOOKUP I = 1 IF (SCAN(PATH, I) == ERR) RETURN(ERR) IF (PATH(1) == SLASH & PATH(2) == EOS) < # SPECIAL CASE THE ROOT N = ROOTDIR RETURN(NOERR) ! ELSE RETURN(LOOKUP(PATH(I), N)) RETURN END # SCAN - SEARCH DIRECTORY HIERARCHY ACCORDING TO PATH(I), INCREMENT I INTEGER FUNCTION SCAN(PATH, I) CHARACTER PATH(MAXPATH) INTEGER I CHARACTER INODE(I_SIZE), NAME(MAXFNAME) INTEGER IP, J, LENGTH, LOOKUP INCLUDE CWDIR INCLUDE CUWDIR IF (PATH(I) == SLASH \ IWDIR == 0) IP = ROOTDIR # START AT ROOT ELSE IP = IUWDIR REPEAT < WHILE (PATH(I) == SLASH) # GET OVER SLASHES I = I + 1 CALL IGET(IP, INODE) IF (INODE(I_TYPE) ^= DIRECTORY) # MUST BE A DIRECTORY RETURN(ERR) CALL RDDIR(IP) FOR (J = 1; PATH(I) ^= SLASH & PATH(I) ^= EOS; I = I + 1) IF (J < MAXFNAME) < NAME(J) = PATH(I) J = J + 1 ! NAME(J) = EOS IF (PATH(I) == EOS) < # FOUND THE END I = I - LENGTH(NAME) # BACKUP I RETURN(IP) ! IF (LOOKUP(NAME, IP) == ERR) # SEARCH FOR NEXT COMPONENT RETURN(ERR) ! RETURN END #-H- PDS6.RAT 5298 1980 103 2058 # PDS6: SUPPORT ROUTINES INCLUDE RATDEF # AMOVE - MOVE NAME1 TO NAME2 SUBROUTINE AMOVE(NAME1, NAME2) CHARACTER NAME1(ARB), NAME2(ARB) INTEGER CREATE, OPEN CHARACTER GETCH, C INTEGER FD1, FD2 FD1 = OPEN(NAME1, READ) IF (FD1 == ERR) CALL CANT(NAME1) FD2 = CREATE(NAME2, WRITE) IF (FD2 == ERR) CALL CANT(NAME2) WHILE (GETCH(C, FD1) ^= EOF) CALL PUTCH(C, FD2) CALL CLOSE(FD1) CALL CLOSE(FD2) RETURN END # CANT - PRINT CANT OPEN FILE MESSAGE AND DIE SUBROUTINE CANT(BUF) INTEGER BUF(MAXLINE) CALL PUTLIN(BUF, ERROUT) CALL REMARK(": CAN'T OPEN.") STOP RETURN END # CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I INTEGER FUNCTION CTOI(IN, I) CHARACTER IN(ARB) INTEGER I, S WHILE (IN(I) == BLANK \ IN(I) == TAB) I = I + 1 IF (IN(I) == MINUS \ IN(I) == PLUS) < S = IN(I) I = I + 1 ! ELSE S = NO FOR (CTOI = 0; IN(I) ^= EOS; I = I + 1) < IF (IN(I) < DIG0 \ IN(I) > DIG9) # NON-DIGIT BREAK CTOI = 10 * CTOI + IN(I) - DIG0 ! IF (S == MINUS) CTOI = -CTOI RETURN END # EQUAL - COMPARE STR1 TO STR2; RETURN YES IF EQUAL, NO IF NOT INTEGER FUNCTION EQUAL(STR1, STR2) CHARACTER STR1(ARB), STR2(ARB) INTEGER I FOR (I = 1; STR1(I) == STR2(I); I = I + 1) IF (STR1(I) == EOS) < EQUAL = YES RETURN ! EQUAL = NO RETURN END # GETLIN - GET NEXT LINE FROM F INTO LINE INTEGER FUNCTION GETLIN(LINE, F) CHARACTER LINE(MAXLINE), C, GETCH INTEGER F FOR (GETLIN = 0; GETCH(C, F) ^= EOF; ) < IF (GETLIN < MAXLINE - 1) < GETLIN = GETLIN + 1 LINE(GETLIN) = C ! IF (C == NEWLINE) BREAK ! LINE(GETLIN+1) = EOS IF (GETLIN == 0 & C == EOF) GETLIN = EOF RETURN END DEFINE(ABS,IABS) # ITOC - CONVERT INTEGER INT TO CHAR STRING IN STR INTEGER FUNCTION ITOC(INT, STR, SIZE) INTEGER ABS, MOD INTEGER I, INT, INTVAL, J, K, SIZE CHARACTER STR(ARB) INTVAL = ABS(INT) STR(1) = EOS I = 1 REPEAT < # GENERATE DIGITS I = I + 1 STR(I) = DIG0 + MOD(INTVAL,10) INTVAL = INTVAL / 10 ! UNTIL (INTVAL == 0 \ I >= SIZE) IF (INT < 0 & I < SIZE) < # THEN SIGN I = I + 1 STR(I) = MINUS ! ITOC = I - 1 FOR (J = 1; J < I; J = J + 1) < # THEN REVERSE K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 ! RETURN END # LENGTH - COMPUTE LENGTH OF STRING INTEGER FUNCTION LENGTH(STR) INTEGER STR(ARB) FOR (LENGTH = 0; STR(LENGTH+1) ^= EOS; LENGTH = LENGTH + 1) ; RETURN END # PUTINT - WRITE DECIMAL INTEGER N IN FIELD WIDTH >= W TO F SUBROUTINE PUTINT(N, W, F) INTEGER N, W, F CHARACTER CHARS(MAXCHARS) INTEGER ITOC INTEGER JUNK JUNK = ITOC(N, CHARS, MAXCHARS) CALL PUTSTR(CHARS, W, F) RETURN END # PUTLIN - WRITE STRING LINE TO FILE F SUBROUTINE PUTLIN(LINE, F) CHARACTER LINE(MAXLINE) INTEGER F, I FOR (I = 1; LINE(I) ^= EOS; I = I + 1) CALL PUTCH(LINE(I), F) RETURN END # PUTSTR - WRITE STRING STR TO FILE F IN FIELD WIDTH >= W SUBROUTINE PUTSTR(STR, W, F) CHARACTER STR(MAXLINE) INTEGER W, F, LEN, I, LENGTH, NW LEN = LENGTH(STR) FOR (I = LEN; I < W; I = I + 1)%# OUTPUT LEFT PADDING CALL PUTCH(BLANK, F) FOR (I = 1; STR(I) ^= EOS; I = I + 1) CALL PUTCH(STR(I), F) NW = -W FOR (I = LEN; I < NW; I = I + 1)%# OUTPUT RIGHT PADDING CALL PUTCH(BLANK, F) RETURN END # QSORT - SORTS A INTO ASCENDING ORDER; COMPARISONS ARE DONE BY COMPAR # COMPAR(X,Y) MUST RETURN <0 IF X < Y, 0 IF X == Y, AND >0 IF X > Y. SUBROUTINE QSORT(N, A, COMPAR) INTEGER N, A(ARB) EXTERNAL COMPAR INTEGER COMPAR INTEGER I, J, LV(20), P, PIVOT, UV(20), T LV(1) = 1 UV(1) = N P = 1 WHILE (P > 0) IF (LV(P) >= UV(P)) # ONLY ONE ELEMENT IN THIS SUBSET P = P - 1 # POP STACK ELSE < I = LV(P) - 1 J = UV(P) PIVOT = A(J) # PIVOT ELEMENT WHILE (I < J) < FOR (I=I+1; COMPAR(A(I), PIVOT) < 0; I=I+1) ; FOR (J = J - 1; J > I; J = J - 1) IF (COMPAR(A(J), PIVOT) <= 0) BREAK IF (I < J) < # OUT OF ORDER PAIR T = A(I)%%# EXCHANGE A(I) AND A(J) A(I) = A(J) A(J) = T ! ! J = UV(P) # MOVE PIVOT TO POSITION I T = A(I)%# EXCHANGE A(I) AND A(J) A(I) = A(J) A(J) = T IF (I-LV(P) < UV(P)-I) < # STACK SO SHORTER DONE FIRST LV(P+1) = LV(P) UV(P+1) = I - 1 LV(P) = I + 1 ! ELSE < LV(P+1) = I + 1 UV(P+1) = UV(P) UV(P) = I - 1 ! P = P + 1 # PUSH ONTO STACK ! RETURN END # SCOPY - COPY STRING AT FROM(I) TO TO(J) SUBROUTINE SCOPY(FROM, I, TO, J) CHARACTER FROM(ARB), TO(ARB) INTEGER I, J, K1, K2 K2 = J FOR (K1 = I; FROM(K1) ^= EOS; K1 = K1 + 1) < TO(K2) = FROM(K1) K2 = K2 + 1 ! TO(K2) = EOS RETURN END #-H- PDS.FOR 29930 1980 103 2201 BLOCK DATA COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD COMMON /CUWDIR/ IUWDIR INTEGER IUWDIR DATA NINODE /0/ DATA INODES /1110*0/ DATA IMOD /0/ DATA INAME(1), INAME(2), INAME(3), INAME(4), INAME(5), INAME(6) / *105, 108, 105, 115, 116, 10002/ DATA RNAME(1), RNAME(2), RNAME(3), RNAME(4), RNAME(5) / 114, 111, *111, 116, 10002/ DATA IFD /10003/ DATA IPOS /0/ DATA IWDIR /0/ DATA WMOD /0/ DATA IUWDIR /1/ END INTEGER FUNCTION CHDIR(PATH) INTEGER PATH(80) INTEGER IP, ISCAN, INODE(37) COMMON /CUWDIR/ IUWDIR INTEGER IUWDIR IF(.NOT.(ISCAN(PATH, IP) .EQ. 10001))GOTO 23000 CHDIR=(10001) RETURN 23000 CONTINUE CALL IGET(IP, INODE) IF(.NOT.(INODE(3) .NE. 100))GOTO 23002 CHDIR=(10001) RETURN 23002 CONTINUE IUWDIR = IP CHDIR=(0) RETURN END INTEGER FUNCTION CHDS(ROOT, ILST) INTEGER ROOT(26), ILST(26) INTEGER FD INTEGER OPEN COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS IF(.NOT.(ILST(1) .NE. 10002))GOTO 23004 FD = OPEN(ILST, 0) IF(.NOT.(FD .EQ. 10001))GOTO 23006 CHDS=(10001) RETURN 23006 CONTINUE CALL CLOSE(FD) 23004 CONTINUE IF(.NOT.(ROOT(1) .NE. 10002))GOTO 23008 FD = OPEN(ROOT, 0) IF(.NOT.(FD .EQ. 10001))GOTO 23010 CHDS=(10001) RETURN 23010 CONTINUE CALL CLOSE(FD) 23008 CONTINUE CALL NEWDIR(0) CALL ICLEAR(1) IF(.NOT.(ROOT(1) .NE. 10002))GOTO 23012 CALL SCOPY(ROOT, 1, RNAME, 1) 23012 CONTINUE IF(.NOT.(ILST(1) .NE. 10002))GOTO 23014 CALL SCOPY(ILST, 1, INAME, 1) 23014 CONTINUE CHDS=(0) RETURN END INTEGER FUNCTION CREATF(PATH, MODE) INTEGER PATH(80) INTEGER MODE INTEGER INODE(37) INTEGER IP, FD, MKFILE, CREATE INTEGER EOSS(1) DATA EOSS(1)/10002/ IP = MKFILE(PATH, EOSS) IF(.NOT.(IP .EQ. 10001))GOTO 23016 CREATF=(10001) RETURN 23016 CONTINUE CALL IGET(IP, INODE) FD = CREATE(INODE(11), MODE) IF(.NOT.(FD .EQ. 10001))GOTO 23018 CALL IFREE(IP) 23018 CONTINUE CREATF=(FD) RETURN END INTEGER FUNCTION LINK(PATH1, PATH2) INTEGER PATH1(80), PATH2(80) INTEGER INODE(37) INTEGER I, J, IP, ISCAN, CSCAN, CTOI, ITOC IF(.NOT.(ISCAN(PATH2, IP) .EQ. 10001))GOTO 23020 LINK=(10001) RETURN 23020 CONTINUE CALL IGET(IP, INODE) IF(.NOT.(INODE(3) .EQ. 100))GOTO 23022 LINK=(10001) RETURN 23022 CONTINUE I = 1 IF(.NOT.(CSCAN(PATH1, I) .EQ. 10001))GOTO 23024 LINK=(10001) RETURN 23024 CONTINUE CALL ENTER(PATH1(I), IP) INODE(4) = INODE(4) + 1 CALL IPUT(IP, INODE) LINK=(0) RETURN END INTEGER FUNCTION MKDIR(PATH) INTEGER PATH(80) INTEGER IP, IIP, MKFILE, INODE(37) COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD INTEGER DOTDOT(3) INTEGER EOSS(1) DATA DOTDOT(1)/46/,DOTDOT(2)/46/,DOTDOT(3)/10002/ DATA EOSS(1)/10002/ IP = MKFILE(PATH, EOSS) IF(.NOT.(IP .EQ. 10001))GOTO 23026 MKDIR=(10001) RETURN 23026 CONTINUE IIP = IWDIR CALL IGET(IP, INODE) INODE(3) = 100 INODE(4) = INODE(4) + 1 CALL IPUT(IP, INODE) CALL NEWDIR(IP) CALL ENTER(DOTDOT(2), IP) CALL ENTER(DOTDOT(1), IIP) CALL WRDIR CALL IGET(IIP, INODE) INODE(4) = INODE(4) + 1 CALL IPUT(IIP, INODE) MKDIR=(IP) RETURN END INTEGER FUNCTION MKDS(ROOT, ILST) INTEGER ROOT(26), ILST(26) INTEGER JUNK, FD, CREATE INTEGER INODE(37) INTEGER DOTDOT(3) INTEGER RNAME(5) INTEGER INAME(6) DATA DOTDOT(1)/46/,DOTDOT(2)/46/,DOTDOT(3)/10002/ DATA RNAME(1)/114/,RNAME(2)/111/,RNAME(3)/111/,RNAME(4)/116/,RNAME *(5)/10002/ DATA INAME(1)/105/,INAME(2)/108/,INAME(3)/105/,INAME(4)/115/,INAME *(5)/116/,INAME(6)/10002/ INODE(1) = 1 INODE(2) = 1 INODE(3) = 100 INODE(4) = 2 CALL DATE4(INODE(6), INODE(7), INODE(5), JUNK) CALL DATE4(INODE(9), INODE(10), INODE(8), JUNK) INODE(11) = 10002 IF(.NOT.(ROOT(1) .NE. 10002))GOTO 23028 CALL SCOPY(ROOT, 1, INODE, 11) GOTO 23029 23028 CONTINUE CALL SCOPY(RNAME, 1, INODE, 11) 23029 CONTINUE IF(.NOT.(ILST(1) .NE. 10002))GOTO 23030 FD = CREATE(ILST, 1) GOTO 23031 23030 CONTINUE FD = CREATE(INAME, 1) 23031 CONTINUE IF(.NOT.(FD .EQ. 10001))GOTO 23032 MKDS=(10001) RETURN 23032 CONTINUE CALL IWRITE(INODE, FD) CALL CLOSE(FD) FD = CREATE(INODE(11), 1) IF(.NOT.(FD .EQ. 10001))GOTO 23034 MKDS=(10001) RETURN 23034 CONTINUE CALL PUTINT(1, 5, FD) CALL PUTCH(32, FD) CALL PUTLIN(DOTDOT(2), FD) CALL PUTCH(10, FD) CALL PUTINT(1, 5, FD) CALL PUTCH(32, FD) CALL PUTLIN(DOTDOT(1), FD) CALL PUTCH(10, FD) CALL CLOSE(FD) MKDS=(0) RETURN END INTEGER FUNCTION MKFILE(PATH, TNAME) INTEGER PATH(80), TNAME(26) INTEGER I, IP, CSCAN, IALLOC, INODE(37), JUNK I = 1 IF(.NOT.(CSCAN(PATH, I) .EQ. 10001))GOTO 23036 MKFILE=(10001) RETURN 23036 CONTINUE IP = IALLOC(INODE) IF(.NOT.(TNAME(1) .NE. 10002))GOTO 23038 CALL SCOPY(TNAME, 1, INODE, 11) 23038 CONTINUE CALL IPUT(IP, INODE) CALL ENTER(PATH(I), IP) MKFILE=(IP) RETURN END INTEGER FUNCTION OPENF(PATH, MODE) INTEGER PATH(80) INTEGER MODE INTEGER IP, ISCAN, OPEN, INODE(37) IF(.NOT.(ISCAN(PATH, IP) .EQ. 10001))GOTO 23040 OPENF=(10001) RETURN 23040 CONTINUE CALL IGET(IP, INODE) OPENF=(OPEN(INODE(11), MODE)) RETURN END INTEGER FUNCTION STAT(PATH, ARRAY) INTEGER PATH(80) INTEGER ARRAY(37) INTEGER IP, ISCAN IF(.NOT.(ISCAN(PATH, IP) .EQ. 10001))GOTO 23042 STAT=(10001) RETURN 23042 CONTINUE CALL IGET(IP, ARRAY) STAT=(0) RETURN END INTEGER FUNCTION SYNC(JUNK) INTEGER JUNK CALL IUPDAT CALL WRDIR SYNC=(0) RETURN END INTEGER FUNCTION UNLINK(PATH) INTEGER PATH(80) INTEGER INODE(37) INTEGER I, IP, N, SCAN, LOOKUP COMMON /CUWDIR/ IUWDIR INTEGER IUWDIR COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD INTEGER DOT(3) DATA DOT(1)/46/,DOT(2)/46/,DOT(3)/10002/ I = 1 IF(.NOT.(SCAN(PATH, I) .EQ. 10001))GOTO 23044 UNLINK=(10001) RETURN 23044 CONTINUE IF(.NOT.(LOOKUP(PATH(I), IP) .EQ. 10001))GOTO 23046 UNLINK=(10001) RETURN 23046 CONTINUE CALL IGET(IP, INODE) IF(.NOT.(INODE(3) .EQ. 100))GOTO 23048 IF(.NOT.(IP .EQ. IUWDIR))GOTO 23050 UNLINK=(10001) RETURN 23050 CONTINUE N = IWDIR CALL RDDIR(IP) IF(.NOT.(WSIZE .NE. 2*21))GOTO 23052 UNLINK=(10001) RETURN 23052 CONTINUE IF(.NOT.(INODE(4) .NE. 2 .OR. LOOKUP(DOT, IIP) .EQ. 10001))GOTO 23 *054 CALL ERROR(29HUNLINK: ILL-FORMED DIRECTORY.) 23054 CONTINUE CALL IGET(IIP, INODE) INODE(4) = INODE(4) - 1 CALL IPUT(IIP, INODE) CALL RDDIR(N) CALL DELETE(PATH(I)) CALL IFREE(IP) UNLINK=(0) RETURN 23048 CONTINUE CALL DELETE(PATH(I)) INODE(4) = INODE(4) - 1 IF(.NOT.(INODE(4) .GT. 0))GOTO 23056 CALL IPUT(IP, INODE) GOTO 23057 23056 CONTINUE CALL IFREE(IP) 23057 CONTINUE UNLINK=(0) RETURN END SUBROUTINE DELETE(NAME) INTEGER NAME(20) INTEGER I, EQUAL COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD IF(.NOT.(IWDIR .EQ. 0))GOTO 23000 CALL RDDIR(1) 23000 CONTINUE I = 0 23002 IF(.NOT.(I .LT. WSIZE))GOTO 23004 IF(.NOT.(EQUAL(NAME, WDIR(I+2)) .EQ. 1))GOTO 23005 WDIR(I+1) = 0 WDIR(I+2) = 10002 WMOD = WMOD + 1 IF(.NOT.(WMOD .GE. 10))GOTO 23007 CALL WRDIR 23007 CONTINUE RETURN 23005 CONTINUE 23003 I = I + 21 GOTO 23002 23004 CONTINUE RETURN END SUBROUTINE ENTER(NAME, N) INTEGER NAME(26) INTEGER N INTEGER I COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD IF(.NOT.(IWDIR .EQ. 0))GOTO 23009 CALL RDDIR(1) 23009 CONTINUE I = 0 23011 IF(.NOT.(I .LT. WSIZE))GOTO 23013 IF(.NOT.(WDIR(I+1) .EQ. 0))GOTO 23014 GOTO 23013 23014 CONTINUE 23012 I = I + 21 GOTO 23011 23013 CONTINUE IF(.NOT.(I .GE. WSIZE))GOTO 23016 IF(.NOT.(I + 21 .GT. 250*21))GOTO 23018 CALL ERROR(30HENTER: OUT OF DIRECTORY SPACE.) 23018 CONTINUE WSIZE = I + 21 23016 CONTINUE WDIR(I+1) = N CALL SCOPY(NAME, 1, WDIR, I + 2) WMOD = WMOD + 1 IF(.NOT.(WMOD .GE. 10))GOTO 23020 CALL WRDIR 23020 CONTINUE RETURN END INTEGER FUNCTION LOOKUP(NAME, N) INTEGER NAME(20) INTEGER N INTEGER I, EQUAL COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD IF(.NOT.(IWDIR .EQ. 0))GOTO 23022 CALL RDDIR(1) 23022 CONTINUE I = 0 23024 IF(.NOT.(I .LT. WSIZE))GOTO 23026 IF(.NOT.(WDIR(I+1) .NE. 0 .AND. EQUAL(NAME, WDIR(I+2)) .EQ. 1))GOT *O 23027 N = WDIR(I+1) LOOKUP=(0) RETURN 23027 CONTINUE 23025 I = I + 21 GOTO 23024 23026 CONTINUE LOOKUP=(10001) RETURN END SUBROUTINE NEWDIR(N) INTEGER N COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD COMMON /CUWDIR/ IUWDIR INTEGER IUWDIR CALL WRDIR IWDIR = N WSIZE = 0 IF(.NOT.(N .EQ. 0))GOTO 23029 IUWDIR = 1 23029 CONTINUE RETURN END SUBROUTINE RDDIR(N) INTEGER N INTEGER I, FD, OPEN, INODE(37), CTOI, GETLIN, WBUF(120), LENGTH COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD IF(.NOT.(N .EQ. IWDIR))GOTO 23031 RETURN 23031 CONTINUE IF(.NOT.(WMOD .GT. 0))GOTO 23033 CALL WRDIR 23033 CONTINUE CALL IGET(N, INODE) IF(.NOT.(INODE(3) .NE. 100))GOTO 23035 CALL ERROR(23HRDDIR: NOT A DIRECTORY.) 23035 CONTINUE FD = OPEN(INODE(11), 0) IF(.NOT.(FD .EQ. 10001))GOTO 23037 CALL ERROR(28HRDDIR: CAN'T READ DIRECTORY.) 23037 CONTINUE WSIZE = 0 23039 IF(.NOT.(GETLIN(WBUF, FD) .NE. 10003))GOTO 23041 I = LENGTH(WBUF) IF(.NOT.(WBUF(I) .EQ. 10))GOTO 23042 WBUF(I) = 10002 23042 CONTINUE I = 1 WDIR(WSIZE+1) = CTOI(WBUF, I) CALL SCOPY(WBUF, I + 1, WDIR, WSIZE + 2) 23040 WSIZE = WSIZE + 21 GOTO 23039 23041 CONTINUE CALL CLOSE(FD) IWDIR = N WMOD = 0 RETURN END SUBROUTINE WRDIR INTEGER I, FD, CREATE, INODE(37) COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD IF(.NOT.(WMOD .EQ. 0))GOTO 23044 RETURN 23044 CONTINUE CALL IGET(IWDIR, INODE) FD = CREATE(INODE(11), 1) IF(.NOT.(FD .EQ. 10001))GOTO 23046 CALL ERROR(30HWRDIR: CAN'T CREATE DIRECTORY.) 23046 CONTINUE I = 0 23048 IF(.NOT.(I .LT. WSIZE))GOTO 23050 IF(.NOT.(WDIR(I+1) .NE. 0))GOTO 23051 CALL PUTINT(WDIR(I+1), 5, FD) CALL PUTCH(32, FD) CALL PUTLIN(WDIR(I+2), FD) CALL PUTCH(10, FD) 23051 CONTINUE 23049 I = I + 21 GOTO 23048 23050 CONTINUE CALL CLOSE(FD) WMOD = 0 RETURN END INTEGER FUNCTION IALLOC(ARRAY) INTEGER ARRAY(37) INTEGER I, J, FD INTEGER OPEN, GETLIN, UALLOC, LENGTH COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS IF(.NOT.(NINODE .EQ. 0))GOTO 23000 CALL IUPDAT FD = OPEN(INAME, 0) IF(.NOT.(FD .EQ. 10001))GOTO 23002 CALL ERROR(25HIALLOC: CAN'T READ ILIST.) 23002 CONTINUE NINODE = 15 I = 1 23004 IF(.NOT.(GETLIN(IBUF, FD) .NE. 10003))GOTO 23006 IF(.NOT.(IBUF(1) .EQ. 48))GOTO 23007 INUM(NINODE) = I NINODE = NINODE - 1 IF(.NOT.(NINODE .EQ. 0))GOTO 23009 GOTO 23006 23009 CONTINUE 23007 CONTINUE 23005 I = I + 1 GOTO 23004 23006 CONTINUE 23011 IF(.NOT.(NINODE .GT. 0))GOTO 23012 INUM(NINODE) = I I = I + 1 NINODE = NINODE - 1 GOTO 23011 23012 CONTINUE NINODE = 15 CALL CLOSE(FD) 23000 CONTINUE IALLOC = INUM(NINODE) NINODE = NINODE - 1 I = UALLOC(I) INODES(I+1) = 0 INODES(I+2) = IALLOC INODES(I+3) = 112 INODES(I+4) = 1 CALL DATE4(INODES(I+6), INODES(I+7), INODES(I+5), JUNK) CALL DATE4(INODES(I+9), INODES(I+10), INODES(I+8), JUNK) CALL SCOPY(INAME, 1, INODES(I+11), 1) J = LENGTH(INAME) KK = I + 11 + J INODES(KK) = 46 J = ITOC(IALLOC, INODES(KK+1), 37-11-J-1) CALL SCOPY(INODES, I + 1, ARRAY, 1) RETURN END SUBROUTINE ICLEAR(FLAG) INTEGER FLAG INTEGER I COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS IF(.NOT.(FLAG .EQ. 1))GOTO 23013 CALL IUPDAT 23013 CONTINUE NINODE = 0 I = 0 23015 IF(.NOT.(I .LT. 30*37))GOTO 23017 INODES(I+2) = 0 23016 I = I + 37 GOTO 23015 23017 CONTINUE RETURN END INTEGER FUNCTION ICMP(X, Y) INTEGER X, Y COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS ICMP=(INODES(X+2) - INODES(Y+2)) RETURN END SUBROUTINE IFREE(N) INTEGER N INTEGER INODE(37) COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS IF(.NOT.(NINODE .LT. 15))GOTO 23018 NINODE = NINODE + 1 INUM(NINODE) = N 23018 CONTINUE INODE(2) = N INODE(3) = 48 CALL IPUT(N, INODE) RETURN END SUBROUTINE IGET(N, ARRAY) INTEGER N INTEGER ARRAY(37) INTEGER I, J, OPEN, UALLOC, GETLIN COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS I = 0 23020 IF(.NOT.(I .LT. 30*37))GOTO 23022 IF(.NOT.(INODES(I+2) .EQ. N))GOTO 23023 GOTO 23022 23023 CONTINUE 23021 I = I + 37 GOTO 23020 23022 CONTINUE IF(.NOT.(I .GE. 30*37))GOTO 23025 I = UALLOC(I) IF(.NOT.(IFD .NE. 10003 .AND. N .LT. IPOS))GOTO 23027 CALL CLOSE(IFD) IFD = 10003 23027 CONTINUE IF(.NOT.(IFD .EQ. 10003))GOTO 23029 IFD = OPEN(INAME, 0) IPOS = 0 23029 CONTINUE IF(.NOT.(IFD .EQ. 10001))GOTO 23031 CALL ERROR(23HIGET: CAN'T READ ILIST.) 23031 CONTINUE 23033 IF(.NOT.(IPOS .LT. N))GOTO 23035 IF(.NOT.(GETLIN(IBUF, IFD) .EQ. 10003))GOTO 23036 CALL ERROR(18HIGET: BAD INUMBER.) 23036 CONTINUE 23034 IPOS = IPOS + 1 GOTO 23033 23035 CONTINUE CALL IREAD(INODES(I+1)) INODES(I+2) = N 23025 CONTINUE IF(.NOT.(INODES(I+3) .EQ. 48))GOTO 23038 CALL ERROR(17HIGET: FREE INODE.) 23038 CONTINUE CALL SCOPY(INODES, I + 1, ARRAY, 1) RETURN END SUBROUTINE IPUT(N, ARRAY) INTEGER N INTEGER ARRAY(37) INTEGER I, UALLOC COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS I = 0 23040 IF(.NOT.(I .LT. 30*37))GOTO 23042 IF(.NOT.(INODES(I+2) .EQ. N))GOTO 23043 GOTO 23042 23043 CONTINUE 23041 I = I + 37 GOTO 23040 23042 CONTINUE IF(.NOT.(I .GE. 30*37))GOTO 23045 I = UALLOC(I) 23045 CONTINUE CALL SCOPY(ARRAY, 1, INODES, I + 1) INODES(I+1) = 1 IMOD = IMOD + 1 IF(.NOT.(IMOD .GE. 10))GOTO 23047 CALL IUPDAT 23047 CONTINUE RETURN END SUBROUTINE IREAD(INODE) INTEGER INODE(37) INTEGER I, LENGTH, CTOI COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS I = LENGTH(IBUF) IF(.NOT.(IBUF(I) .EQ. 10))GOTO 23049 IBUF(I) = 10002 23049 CONTINUE INODE(1) = 0 INODE(2) = 0 INODE(3) = IBUF(1) I = 3 INODE(4) = CTOI(IBUF, I) INODE(5) = CTOI(IBUF, I) INODE(6) = CTOI(IBUF, I) INODE(7) = CTOI(IBUF, I) INODE(8) = CTOI(IBUF, I) INODE(9) = CTOI(IBUF, I) INODE(10) = CTOI(IBUF, I) CALL SCOPY(IBUF, I+1, INODE, 11) RETURN END SUBROUTINE IUPDAT INTEGER I, J, N, FDI, FDO, IP(30), JUNK, CREATE, OPEN, GETLIN EXTERNAL ICMP COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS INTEGER TMPNAM(6) DATA TMPNAM(1)/105/,TMPNAM(2)/46/,TMPNAM(3)/116/,TMPNAM(4)/109/,TM *PNAM(5)/112/,TMPNAM(6)/10002/ IF(.NOT.(IFD .NE. 10003))GOTO 23051 CALL CLOSE(IFD) IFD = 10003 23051 CONTINUE IF(.NOT.(IMOD .EQ. 0))GOTO 23053 RETURN 23053 CONTINUE IMOD = 0 J = 0 I = 0 23055 IF(.NOT.(I .LT. 30*37))GOTO 23057 IF(.NOT.(INODES(I+2) .GT. 0 .AND. INODES(I+1) .NE. 0))GOTO 23058 INODES(I+1) = 0 J = J + 1 IP(J) = I 23058 CONTINUE 23056 I = I + 37 GOTO 23055 23057 CONTINUE IF(.NOT.(J .EQ. 0))GOTO 23060 RETURN 23060 CONTINUE IP(J+1) = -1 CALL QSORT(J, IP, ICMP) FDI = OPEN(INAME, 0) IF(.NOT.(FDI .EQ. 10001))GOTO 23062 CALL ERROR(25HIUPDAT: CAN'T READ ILIST.) 23062 CONTINUE FDO = CREATE(TMPNAM, 1) IF(.NOT.(FDO .EQ. 10001))GOTO 23064 CALL ERROR(37HIUPDAT: CAN'T CREATE TEMPORARY ILIST.) 23064 CONTINUE I = 0 J = 1 23066 IF(.NOT.(IP(J) .GE. 0))GOTO 23068 N = IP(J) N = INODES(N+2) I = I + 1 23069 IF(.NOT.(I .LT. N))GOTO 23071 IF(.NOT.(GETLIN(IBUF, FDI) .NE. 10003))GOTO 23072 CALL PUTLIN(IBUF, FDO) 23072 CONTINUE 23070 I = I + 1 GOTO 23069 23071 CONTINUE JUNK = GETLIN(IBUF, FDI) N = IP(J) CALL IWRITE(INODES(N+1), FDO) 23067 J = J + 1 GOTO 23066 23068 CONTINUE 23074 IF(.NOT.(GETLIN(IBUF, FDI) .NE. 10003))GOTO 23075 CALL PUTLIN(IBUF, FDO) GOTO 23074 23075 CONTINUE CALL CLOSE(FDI) CALL CLOSE(FDO) CALL AMOVE(TMPNAM, INAME) RETURN END SUBROUTINE IWRITE(INODE, FD) INTEGER INODE(37), FD CALL PUTCH(INODE(3), FD) IF(.NOT.(INODE(3) .NE. 48))GOTO 23076 CALL PUTINT(INODE(4), 4, FD) CALL PUTINT(INODE(5), 5, FD) CALL PUTINT(INODE(6), 5, FD) CALL PUTINT(INODE(7), 5, FD) CALL PUTINT(INODE(8), 5, FD) CALL PUTINT(INODE(9), 5, FD) CALL PUTINT(INODE(10), 5, FD) CALL PUTCH(32, FD) CALL PUTLIN(INODE(11), FD) 23076 CONTINUE CALL PUTCH(10, FD) RETURN END INTEGER FUNCTION UALLOC(I) INTEGER I INTEGER LAST COMMON /CINODE/ NINODE, INUM(15), INODES(1110), IMOD, INAME(26), R *NAME(26), IBUF(120), IFD, IPOS INTEGER NINODE INTEGER INUM INTEGER INODES INTEGER IMOD INTEGER INAME INTEGER RNAME INTEGER IBUF INTEGER IFD INTEGER IPOS 23078 CONTINUE LAST = 0 I = 0 23081 IF(.NOT.(I .LT. 30*37))GOTO 23083 IF(.NOT.(INODES(I+2) .EQ. 0))GOTO 23084 UALLOC=(I) RETURN 23084 CONTINUE IF(.NOT.(INODES(I+1) .EQ. 0))GOTO 23086 LAST = I + 1 23086 CONTINUE 23085 CONTINUE 23082 I = I + 37 GOTO 23081 23083 CONTINUE IF(.NOT.(LAST .NE. 0))GOTO 23088 I = LAST - 1 UALLOC=(I) RETURN 23088 CONTINUE CALL IUPDAT 23079 GOTO 23078 23080 CONTINUE RETURN END INTEGER FUNCTION CSCAN(PATH, I) INTEGER PATH(80) INTEGER I INTEGER N, SCAN I = 1 IF(.NOT.(SCAN(PATH, I) .EQ. 10001))GOTO 23000 CSCAN=(10001) RETURN 23000 CONTINUE IF(.NOT.(PATH(1) .EQ. 47 .AND. PATH(2) .EQ. 10002))GOTO 23002 CSCAN=(10001) RETURN 23002 CONTINUE IF(.NOT.(LOOKUP(PATH(I), JUNK) .EQ. 0))GOTO 23004 CSCAN=(10001) RETURN 23004 CONTINUE CSCAN=(0) RETURN END INTEGER FUNCTION ISCAN(PATH, N) INTEGER PATH(80) INTEGER N INTEGER I, SCAN, LOOKUP I = 1 IF(.NOT.(SCAN(PATH, I) .EQ. 10001))GOTO 23006 ISCAN=(10001) RETURN 23006 CONTINUE IF(.NOT.(PATH(1) .EQ. 47 .AND. PATH(2) .EQ. 10002))GOTO 23008 N = 1 ISCAN=(0) RETURN 23008 CONTINUE ISCAN=(LOOKUP(PATH(I), N)) RETURN 23009 CONTINUE RETURN END INTEGER FUNCTION SCAN(PATH, I) INTEGER PATH(80) INTEGER I INTEGER INODE(37), NAME(20) INTEGER IP, J, LENGTH, LOOKUP COMMON /CWDIR/ IWDIR, WSIZE, WDIR(5250), WMOD INTEGER IWDIR INTEGER WSIZE INTEGER WDIR INTEGER WMOD COMMON /CUWDIR/ IUWDIR INTEGER IUWDIR IF(.NOT.(PATH(I) .EQ. 47 .OR. IWDIR .EQ. 0))GOTO 23010 IP = 1 GOTO 23011 23010 CONTINUE IP = IUWDIR 23011 CONTINUE 23012 CONTINUE 23015 IF(.NOT.(PATH(I) .EQ. 47))GOTO 23016 I = I + 1 GOTO 23015 23016 CONTINUE CALL IGET(IP, INODE) IF(.NOT.(INODE(3) .NE. 100))GOTO 23017 SCAN=(10001) RETURN 23017 CONTINUE CALL RDDIR(IP) J = 1 23019 IF(.NOT.(PATH(I) .NE. 47 .AND. PATH(I) .NE. 10002))GOTO 23021 IF(.NOT.(J .LT. 20))GOTO 23022 NAME(J) = PATH(I) J = J + 1 23022 CONTINUE 23020 I = I + 1 GOTO 23019 23021 CONTINUE NAME(J) = 10002 IF(.NOT.(PATH(I) .EQ. 10002))GOTO 23024 I = I - LENGTH(NAME) SCAN=(IP) RETURN 23024 CONTINUE IF(.NOT.(LOOKUP(NAME, IP) .EQ. 10001))GOTO 23026 SCAN=(10001) RETURN 23026 CONTINUE 23013 GOTO 23012 23014 CONTINUE RETURN END SUBROUTINE AMOVE(NAME1, NAME2) INTEGER NAME1(100), NAME2(100) INTEGER CREATE, OPEN INTEGER GETCH, C INTEGER FD1, FD2 FD1 = OPEN(NAME1, 0) IF(.NOT.(FD1 .EQ. 10001))GOTO 23000 CALL CANT(NAME1) 23000 CONTINUE FD2 = CREATE(NAME2, 1) IF(.NOT.(FD2 .EQ. 10001))GOTO 23002 CALL CANT(NAME2) 23002 CONTINUE 23004 IF(.NOT.(GETCH(C, FD1) .NE. 10003))GOTO 23005 CALL PUTCH(C, FD2) GOTO 23004 23005 CONTINUE CALL CLOSE(FD1) CALL CLOSE(FD2) RETURN END SUBROUTINE CANT(BUF) INTEGER BUF(120) CALL PUTLIN(BUF, 2) CALL REMARK(13H: CAN'T OPEN.) STOP RETURN END INTEGER FUNCTION CTOI(IN, I) INTEGER IN(100) INTEGER I, S 23006 IF(.NOT.(IN(I) .EQ. 32 .OR. IN(I) .EQ. 9))GOTO 23007 I = I + 1 GOTO 23006 23007 CONTINUE IF(.NOT.(IN(I) .EQ. 45 .OR. IN(I) .EQ. 43))GOTO 23008 S = IN(I) I = I + 1 GOTO 23009 23008 CONTINUE S = 0 23009 CONTINUE CTOI = 0 23010 IF(.NOT.(IN(I) .NE. 10002))GOTO 23012 IF(.NOT.(IN(I) .LT. 48 .OR. IN(I) .GT. 57))GOTO 23013 GOTO 23012 23013 CONTINUE CTOI = 10 * CTOI + IN(I) - 48 23011 I = I + 1 GOTO 23010 23012 CONTINUE IF(.NOT.(S .EQ. 45))GOTO 23015 CTOI = -CTOI 23015 CONTINUE RETURN END INTEGER FUNCTION EQUAL(STR1, STR2) INTEGER STR1(100), STR2(100) INTEGER I I = 1 23017 IF(.NOT.(STR1(I) .EQ. STR2(I)))GOTO 23019 IF(.NOT.(STR1(I) .EQ. 10002))GOTO 23020 EQUAL = 1 RETURN 23020 CONTINUE 23018 I = I + 1 GOTO 23017 23019 CONTINUE EQUAL = 0 RETURN END INTEGER FUNCTION GETLIN(LINE, F) INTEGER LINE(120), C, GETCH INTEGER F GETLIN = 0 23022 IF(.NOT.(GETCH(C, F) .NE. 10003))GOTO 23024 IF(.NOT.(GETLIN .LT. 120 - 1))GOTO 23025 GETLIN = GETLIN + 1 LINE(GETLIN) = C 23025 CONTINUE IF(.NOT.(C .EQ. 10))GOTO 23027 GOTO 23024 23027 CONTINUE 23023 GOTO 23022 23024 CONTINUE LINE(GETLIN+1) = 10002 IF(.NOT.(GETLIN .EQ. 0 .AND. C .EQ. 10003))GOTO 23029 GETLIN = 10003 23029 CONTINUE RETURN END INTEGER FUNCTION ITOC(INT, STR, SIZE) INTEGER IABS, MOD INTEGER I, INT, INTVAL, J, K, SIZE INTEGER STR(100) INTVAL = IABS(INT) STR(1) = 10002 I = 1 23031 CONTINUE I = I + 1 STR(I) = 48 + MOD(INTVAL,10) INTVAL = INTVAL / 10 23032 IF(.NOT.(INTVAL .EQ. 0 .OR. I .GE. SIZE))GOTO 23031 23033 CONTINUE IF(.NOT.(INT .LT. 0 .AND. I .LT. SIZE))GOTO 23034 I = I + 1 STR(I) = 45 23034 CONTINUE ITOC = I - 1 J = 1 23036 IF(.NOT.(J .LT. I))GOTO 23038 K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 23037 J = J + 1 GOTO 23036 23038 CONTINUE RETURN END INTEGER FUNCTION LENGTH(STR) INTEGER STR(100) LENGTH = 0 23039 IF(.NOT.(STR(LENGTH+1) .NE. 10002))GOTO 23041 23040 LENGTH = LENGTH + 1 GOTO 23039 23041 CONTINUE RETURN END SUBROUTINE PUTINT(N, W, F) INTEGER N, W, F INTEGER CHARS(10) INTEGER ITOC INTEGER JUNK JUNK = ITOC(N, CHARS, 10) CALL PUTSTR(CHARS, W, F) RETURN END SUBROUTINE PUTLIN(LINE, F) INTEGER LINE(120) INTEGER F, I I = 1 23042 IF(.NOT.(LINE(I) .NE. 10002))GOTO 23044 CALL PUTCH(LINE(I), F) 23043 I = I + 1 GOTO 23042 23044 CONTINUE RETURN END SUBROUTINE PUTSTR(STR, W, F) INTEGER STR(120) INTEGER W, F, LEN, I, LENGTH, NW LEN = LENGTH(STR) I = LEN 23045 IF(.NOT.(I .LT. W))GOTO 23047 CALL PUTCH(32, F) 23046 I = I + 1 GOTO 23045 23047 CONTINUE I = 1 23048 IF(.NOT.(STR(I) .NE. 10002))GOTO 23050 CALL PUTCH(STR(I), F) 23049 I = I + 1 GOTO 23048 23050 CONTINUE NW = -W I = LEN 23051 IF(.NOT.(I .LT. NW))GOTO 23053 CALL PUTCH(32, F) 23052 I = I + 1 GOTO 23051 23053 CONTINUE RETURN END SUBROUTINE QSORT(N, A, COMPAR) INTEGER N, A(100) EXTERNAL COMPAR INTEGER COMPAR INTEGER I, J, LV(20), P, PIVOT, UV(20), T LV(1) = 1 UV(1) = N P = 1 23054 IF(.NOT.(P .GT. 0))GOTO 23055 IF(.NOT.(LV(P) .GE. UV(P)))GOTO 23056 P = P - 1 GOTO 23057 23056 CONTINUE I = LV(P) - 1 J = UV(P) PIVOT = A(J) 23058 IF(.NOT.(I .LT. J))GOTO 23059 I=I+1 23060 IF(.NOT.(COMPAR(A(I), PIVOT) .LT. 0))GOTO 23062 23061 I=I+1 GOTO 23060 23062 CONTINUE J = J - 1 23063 IF(.NOT.(J .GT. I))GOTO 23065 IF(.NOT.(COMPAR(A(J), PIVOT) .LE. 0))GOTO 23066 GOTO 23065 23066 CONTINUE 23064 J = J - 1 GOTO 23063 23065 CONTINUE IF(.NOT.(I .LT. J))GOTO 23068 T = A(I) A(I) = A(J) A(J) = T 23068 CONTINUE GOTO 23058 23059 CONTINUE J = UV(P) T = A(I) A(I) = A(J) A(J) = T IF(.NOT.(I-LV(P) .LT. UV(P)-I))GOTO 23070 LV(P+1) = LV(P) UV(P+1) = I - 1 LV(P) = I + 1 GOTO 23071 23070 CONTINUE LV(P+1) = I + 1 UV(P+1) = UV(P) UV(P) = I - 1 23071 CONTINUE P = P + 1 23057 CONTINUE GOTO 23054 23055 CONTINUE RETURN END SUBROUTINE SCOPY(FROM, I, TO, J) INTEGER FROM(100), TO(100) INTEGER I, J, K1, K2 K2 = J K1 = I 23072 IF(.NOT.(FROM(K1) .NE. 10002))GOTO 23074 TO(K2) = FROM(K1) K2 = K2 + 1 23073 K1 = K1 + 1 GOTO 23072 23074 CONTINUE TO(K2) = 10002 RETURN END #========== RATFOR PREPROCESSOR AND I/O SYSTEM IN RATFOR AND FORTRAN ========== #-H- RATFOR.DOC 15977 1980 103 2140 # NAME # RATFOR - RATFOR PREPROCESSOR # # FILES # RATDEF STANDARD RATFOR DEFINITIONS # C[A-Z]* LABELED COMMONS # RATFOR.RAT MACHINE INDEPENDENT PART OF RATFOR # MAIN.RAT TRIVIAL MAIN PROGRAM FOR RATFOR # RATIO.RAT MACHINE INDEPENDENT I/O SYSTEM # EBCDIC.RAT EBCDIC-ASCII TRANSLATION TABLES # MBOOT BOOTSTRAP # # INSTALLATION # THE MACHINE-INDEPENDENT VERSION OF THE RATFOR PREPROCESSOR IS # INSTALLED BY A "BOOTSTRAPPING" PROCESS. THE RELEVANT FILES ARE # LISTED IN THE PREVIOUS SECTION. MBOOT IS A COMPLETE # MACHINE-INDEPENDENT RATFOR PREPROCESSOR WRITTEN IN FORTRAN. WITH # THE EXCEPTION OF HOLLERITH LITERALS, THE FORTRAN CODE IN MBOOT IS # IN UPPER CASE. IT WAS PRODUCED BY PREPROCESSING MAIN.RAT, # RATIO.RAT, AND RATFOR.RAT, AND CONCATENATING THE RESULTS. THIS # FILE IS READY FOR COMPILATION. # # CONCEPTUALLY, THE BOOTSTRAPPING PROCESS IS SIMPLE. MBOOT IS # COMPILED, TESTED, AND INSTALLED AS "VERSION 0" OF RATFOR. # MODIFICATIONS NECESSARY TO ACCOMODATE LOCAL CONVENTIONS AND USAGE # ARE MADE TO MAIN.RAT, RATIO.RAT, AND RATFOR.RAT. THE VERSION 0 # RATFOR IS USED TO PRODUCE A NEW, PRESUMABLY BETTER, VERSION 1 # RATFOR USING THE MODIFIED FILES. THIS PROCESS CAN CONTINUE UNTIL # FURTHER MODIFICATIONS ARE UNNECESSARY. # # IN PRACTICE, HOWEVER, OBTAINING VERSION 0 CANNOT BE ACCOMPLISHED # BY SIMPLY COMPILING MBOOT. A MORE TYPICAL SCENARIO IS THAT MBOOT # ITSELF MUST BE MODIFIED BEFORE IT IS USABLE AS A VERSION 0 # RATFOR. IN ADDITION, RATIO.RAT IS NOT MEANT TO BE USED IN THE # FINAL VERSION OF RATFOR; FORTRAN I/O IS SIMPLY TOO SLOW. THE # MAJOR STEP THAT MUST BE MADE IN ORDER TO MAKE ANY REAL USE OF # RATFOR IS THE IMPLEMENTATION OF A SYSTEM-SPECIFIC I/O SYSTEM. # WHAT FOLLOWS IS A DESCRIPTION OF HOW TO MODIFY MBOOT TO GET A # VERSION 0 RATFOR AND SOME SUGGESTIONS CONCERNING THE # IMPLEMENTATION OF AN I/O SYSTEM. # # THE MODIFICATIONS TO MBOOT ARE ESSENTIALLY THOSE NECESSARY TO MAKE # RATIO.RAT (AND PERHAPS MAIN.RAT) CONFORM TO LOCAL USAGE. # RATIO.RAT IS AN IMPLEMENTATION OF THE I/O PRIMITIVES DESCRIBED IN # SOFTWARE TOOLS USING FORTRAN I/O. THE PRIMITIVES ARE BASED ON THE # ASCII CHARACTER SET. CHARACTERS MUST BE MAPPED FROM THE HOST # CHARACTER SET TO ASCII ON INPUT AND VICE-VERSA ON OUTPUT. AS # DESCRIBED IN SOFTWARE TOOLS, STRINGS ARE IMPLEMENTED AS ARRAYS OF # ASCII CHARACTERS, ONE RIGHT-JUSTIFIED CHARACTER PER WORD, # TERMINATED BY THE VALUE OF THE PARAMETER EOS (SEE RATDEF). THE # IMPORTANT PRIMITIVES ARE AS FOLLOWS. # # INTERNAL-NAME = OPEN(EXTERNAL-NAME, MODE) # OPENS A FILE. THE SYSTEM-DEPENDENT NAME IS A CHARACTER STRING # PASSED IN THE ARRAY EXTERNAL-NAME; MODE IS 0 FOR READING, 1 FOR # WRITING, AND 2 FOR READING AND WRITING. THESE ARE THE VALUES # OF THE PARAMETERS READ, WRITE, AND READWRITE, RESPECTIVELY. # THE READWRITE MODE IS NOT USED BY RATFOR AND IS NOT IMPLEMENTED # IN RATIO.RAT. OPEN RETURNS AN INTERNAL-NAME, WHICH IS SIMPLY A # SMALL INTEGER. THESE INTEGERS ARE USUALLY CALLED FILE # DESCRIPTORS; THE VARIABLE FD IS OFTEN USED FOR A FILE # DESCRIPTOR. IF THE FILE CANNOT BE OPENED OR DOES NOT EXISTS, # OPEN RETURNS ERR, WHICH IS A SYMBOLIC PARAMETER WHOSE VALUE IS # NOT A VALID FILE DESCRIPTOR. # # INTERNAL-NAME = CREATE(EXTERNAL-NAME, MODE) # IS MUCH LIKE OPEN EXCEPT THAT THE INDICATED FILE IS CREATED AND # THEN OPENED ACCORDING TO MODE. # # CALL CLOSE(INTERNAL-NAME) # BREAKS THE CONNECTION BETWEEN THE INTERNAL-NAME AND THE OPENED # EXTERNAL FILE. # # C = GETCH(C, FD) # READS ONE CHARACTER FROM THE FILE OPENED ON FILE DESCRIPTOR # FD. THE RIGHT-JUSTIFIED ASCII CHARACTER IS RETURNED IN C AND # AS THE VALUE OF THE FUNCTION GETCH. GETCH PERFORMS THE # TRANSLATION FROM THE HOST MACHINE CHARACTER SET TO ASCII. IF # END OF FILE IS REACHED, GETCH RETURNS EOF (A SYMBOLIC # PARAMETER). AT THE END OF A LINE, GETCH MUST RETURN A NEWLINE # CHARACTER (SEE RATDEF) EVEN IF NO SUCH CHARACTER EXISTS IN THE # FILE. (SEE GETCH IN RATIO.RAT). # # CALL PUTCH(C, FD) # OUTPUTS THE RIGHT-JUSTIFIED ASCII CHARACTER C TO THE FILE # OPENED ON FILE DESCRIPTOR FD. PUTCH PERFORMS THE TRANSLATION # FROM ASCII TO THE HOST MACHINE CHARACTER SET. # # THERE ARE OTHER LESS IMPORTANT PRIMITIVES; SEE RATIO.RAT. # # BY CONVENTION, FILE DESCRIPTOR 0 IS THE "STANDARD INPUT", 1 IS # STANDARD OUTPUT, AND 2 IS ERROR OUTPUT. THESE FILES ARE ASSUMED # TO BE OPENED WHEN PROGRAM EXECUTION BEGINS. # # USING RATIO.RAT AS A GUIDE, MAKE THE FOLLOWING MODIFICATIONS TO # MBOOT AND TO RATIO.RAT AND MAIN.RAT. # # 1. THE MAPPING FROM ASCII TO THE HOST CHARACTER SET AND # VICE-VERSA IS CONTROLLED BY THE ARRAYS EXTCHR AND INTCHR. THESE # ARRAYS ARE INITIALIZED IN THE BLOCK DATA SUBPROGRAM IN RATIO.RAT. # CHECK THAT THE TRANSLATIONS ARE SATISFACTORY. # # 2. RATIO.RAT IS INITIALIZED SO THAT STANDARD INPUT CORRESPONDS TO # FORTRAN UNIT 5 AND STANDARD OUTPUT AND ERROR OUTPUT BOTH # CORRESPOND TO FORTRAN UNIT 6. THIS IS ACCOMPLISHED BY THE # INITIALIZATION OF SPECIFIC ELEMENTS OF THE ARRAY FILTAB IN THE # BLOCK DATA SUBPROGRAM. IF THESE CORRESPONDENCES ARE NOT # SATISFACTORY, CHANGE THE INITIAL VALUE OF FILTAB(4), FILTAB(144), # OR FILTAB(284) AS APPROPRIATE (FOR DESCRIPTORS 0, 1, OR 2, # RESPECTIVELY). # # 3. IF NECESSARY, CHANGE MAIN.RAT SO THAT STANDARD INPUT, STANDARD # OUTPUT, AND ERROR OUTPUT ARE OPENED. # # 4. THERE IS A FORMAT STATEMENT IN REMARK (RATIO.RAT) THAT # CONTAINS AN A5 CODE. IT APPEARS AT ABOUT LINE 413 IN MBOOT. THIS # SHOULD BE CHANGED TO WHATEVER IS APPROPRIATE; THE 5 REPRESENTS THE # NUMBER OF CHARACTERS PER WORD ON THE HOST COMPUTER. # # 5. CALLS TO OPEN AND CREATE RESULT IN CALLS TO OPNFIL (SEE # RATIO.RAT). OPNFIL MUST DO THE ACTUAL OPEN AND RETURN THE FORTRAN # UNIT NUMBER ON WHICH THE FILE IS OPENED. THE ASSOCIATION OF A # FORTRAN UNIT NUMBER IS DETERMINED BY OPNFIL. THE CALL IS # # UNIT = OPNFIL(NAME, MODE, FD) # # WHERE NAME IS THE EXTERNAL NAME OF THE FILE IN RIGHT-JUSTIFIED # ASCII, MODE IS THE I/O MODE (READ, WRITE, OR READWRITE), AND FD IS # THE FILE DESCRIPTOR THAT IS ULTIMATELY RETURNED BY OPEN OR # CREATE. THE LAST ARGUMENT IS USEFUL IN ASSIGNING FORTRAN UNIT # NUMBERS. IF THE FILE CANNOT BE OPENED, OPNFIL SHOULD RETURN ERR # (SEE RATDEF). THE DISTRIBUTED VERSION OF OPNFIL ASSUMES THAT THE # EXTERNAL NAME IS THE FORTRAN UNIT NUMBER AND SIMPLY CONVERTS THE # NAME TO AN INTEGER. THUS INCLUDE STATEMENTS ARE OF THE FORM # INCLUDE N. IN ORDER TO OBTAIN A USABLE VERSION 0, IT IS USUALLY # NECESSARY TO CHANGE OPNFIL SO THAT MEANINGFUL NAMES (LIKE RATDEF, # CDEFIO, ETC.) CAN BE USED. THIS IS NOT NECESSARY IF THE HOST # OPERATING SYSTEM PERMITS THE ASSOCIATION OF FORTRAN UNIT NUMBERS # WITH NAMED FILES BEFORE PROGRAM EXECUTION; THE IBM DD JCL # STATEMENT IS AN EXAMPLE OF A SUFFICIENT CAPABILITY. # # 6. CLSFIL IS SIMILAR TO OPNFIL; IT IS CALLED WHENEVER A FILE IS # CLOSED. SEE RATIO.RAT FOR DETAILS. THE IMPORTANT EFFECT OF # CLOSING A FILE IS THAT IT MUST BE POSSIBLE TO RE-OPEN IT AND READ # IT FROM THE BEGINNING. THIS IS NECESSARY, FOR EXAMPLE, TO INCLUDE # LABELED COMMONS IN SEVERAL PLACES. # # AFTER THESE MODIFICATIONS HAVE BEEN MADE, MBOOT CAN BE COMPILED. # RATFOR SOURCE IS READ FROM STANDARD INPUT AND THE GENERATED # FORTRAN IS WRITTEN TO STANDARD OUTPUT; ERRORS ARE WRITTEN TO ERROR # OUTPUT. THE PREPROCESSOR DOES NOT PRODUCE A LISTING. IN A BATCH # ENVIRONMENT, THE USUAL APPROACH IS TO USE A LOCAL UTILITY TO # PRODUCE A SOURCE LISTING ON THE PRINTER AND THEN ARRANGE THAT THE # ERROR OUTPUT IS ALSO DIRECTED TO THE PRINTER. RATFOR ERROR # MESSAGES ARE KEYED TO LINE NUMBERS; IT IS CONVENIENT IF THE # LISTING INCLUDES LINE NUMBERS IN INCREMENTS OF ONE. IN A # TIMESHARING ENVIRONMENT, THE LISTING IS USUALLY USELESS. # # AT THIS POINT, MBOOT CAN SERVE AS VERSION 0 RATFOR. # # TEST VERSION 0 WITH SEVERAL SMALL TEST PROGRAMS; MAIN.RAT IS A # GOOD TEST AS ARE SOME OF THE SHORTER PROGRAMS IN SOFTWARE TOOLS. # AFTER IT CAN CORRECTLY PROCESS SMALL TEST PROGRAMS, RATIO.RAT AND # THE APPROPRIATE INCLUDE FILES (RATDEF AND CRATIO) CAN BE USED AS A # TEST. THIS WILL TEST THE INCLUDE FACILITY, WHICH WILL TEST OPNFIL # AND CLSFIL. # # ALL OF THE MODIFICATIONS MADE TO MBOOT SHOULD ALSO BE APPLIED TO # THE RATFOR.RAT, RATIO.RAT, AND MAIN.RAT SO THEY STAY "IN PHASE" # WITH MBOOT. DO NOT DISCARD THE FIRST RUNNING VERSION OF MBOOT; IT # IS EASY TO ACCIDENTLY DELETE MBOOT AND BE LEFT STRANDED WITH ONLY # THE RATFOR SOURCE CODE. # # AS MENTIONED ABOVE, THE BEST WAY TO IMPROVE THE PERFORMANCE OF # RATFOR IS TO MAKE THE I/O MORE EFFICIENT. OTHER INEFFICIENCIES # ARE INSIGNIFICANT WHEN COMPARED TO THE I/O PROCESSING, WHICH # ACCOUNTS FOR OVER 50% OF THE PROCESSING TIME. # # ALTHOUGH RATIO.RAT IS TOO SLOW FOR PRODUCTION USE, THERE SEVERAL # IMPROVEMENTS CAN BE MADE THAT WILL MAKE IT SUITABLE FOR CASUAL # USE. # # 1. THE TRANSLATION FROM THE HOST CHARACTER SET TO ASCII AND # VICE-VERSA IS PERFORMED BY THE FUNCTIONS INMAP AND OUTMAP, # RESPECTIVELY. THE TRANSLATION IS ACCOMPLISHED BY SEARCHING EITHER # INTCHR OR EXTCHR FOR THE APPROPRIATE CHARACTER AND RETURNING THE # CORRESPONDING VALUE IN THE OTHER ARRAY. THESE FUNCTIONS SHOULD BE # REPLACED BY ARRAYS THAT SIMPLY USE THE VALUE OF THE CHARACTER PLUS # ONE AS AN INDEX, E.G. OUTMAP(BLANK+1) SHOULD BE INITIALIZED TO THE # HOST CHARACTER CODE FOR A BLANK. AS AN EXAMPLE, EBCDIC.RAT # CONTAINS AN ASCII-EBCDIC AND EBCDIC-ASCII TRANSLATION TABLE. THIS # MODIFICATION ALSO REQUIRES THAT RDLIN AND WRLIN BE CHANGED TO # HANDLE RIGHT-JUSTIFIED CHARACTERS INSTEAD OF THE A1 FORMAT # CURRENTLY USED. SOME FORTRAN IMPLEMENTATIONS HAVE A R1 FORMAT FOR # THIS PURPOSE; A SIMPLE SHIFT FUNCTION CAN ALSO BE USED. IF THIS # CHANGE IS MADE, THE ARRAYS INTCHR AND EXTCHR ARE NO LONGER # NEEDED. # # 2. IN RATIO.RAT, CREATE AND OPEN ARE EQUIVALENT. CREATE SHOULD # BE MODIFIED TO DO WHATEVER IS MOST APPROPRIATE IN THE LOCAL # ENVIRONMENT. A TYPICAL SCHEME IS TO CREATE AN EMPTY FILE AND THEN # CALL OPEN TO OPEN IT ACCORDING TO MODE. READING AN EMPTY FILE IS # NOT UNUSUAL. # # IF RATFOR AND THE PROGRAMS IN SOFTWARE TOOLS ARE TO BE USED # HEAVILY, IT IS WORTH THE EFFORT TO IMPLEMENT A SYSTEM-SPECIFIC I/O # SYSTEM. THE FOLLOWING SUGGESTIONS ARE BASED ON EXPERIENCE WITH # I/O SYSTEMS FOR THE DEC-10, PDP-11/70, ECLIPSE, AND THE CDC CYBER # 175. # # 1. OPEN, CREATE, AND CLOSE DO NOT HAVE TO BE EFFICIENT; GETCH AND # PUTCH DO. IF IT IS EASY TO MIX FORTRAN AND ASSEMBLY LANGUAGE # SUBROUTINES AND FUNCTIONS, IMPLEMENT GETCH AND PUTCH IN ASSEMBLY # LANGUAGE AND THE REST IN RATFOR. # # 2. ANOTHER PRIMITIVE DESCRIBED IN SOFTWARE TOOLS IS SEEK(N,FD), # WHICH "POSITIONS" THE FILE OPENED ON FD SO THAT THE NEXT READ OR # WRITE WILL ACCESS THE NTH CHARACTER. THIS PRIMITIVE IS # ESSENTIALLY IMPOSSIBLE TO IMPLEMENT ON SOME SYSTEMS IN ANY # EFFICIENT MANNER. IT ALSO SEEMS TO HAVE AN ENORMOUS INFLUENCE ON # THE IMPLEMENTATION OF THE REST OF THE PRIMITIVES. IF SEEK IS TO # BE IMPLEMENTED, ITS INFLUENCE SHOULD BE CONSIDERED FROM THE # ONSET. # # 3. GETCH AND PUTCH READ AND WRITE SINGLE CHARACTERS. THEY ARE # SPECIAL CASES OF MORE PRIMITIVE OPERATIONS. IN THE DEC-10 AND CDC # CYBER SYSTEMS, THE BASIC I/O PRIMITIVES ARE # # COUNT = READF(BUF, COUNT, FD) # # AND # # COUNT = WRITEF(BUF, COUNT, FD) # # READF READS AT MOST COUNT CHARACTERS FROM FD INTO BUF AND RETURNS # THE NUMBER OF CHARACTERS ACTUALLY READ, WHICH MIGHT BE LESS THAN # THE NUMBER REQUESTED. READF RETURNS EOF AT END OF FILE. WRITEF # WRITES COUNT CHARACTERS FROM BUF TO FILE FD AND RETURNS THE NUMBER # ACTUALLY WRITTEN (THIS IS ALMOST ALWAYS COUNT; THE FORM OF THE # CALL WAS CHOSEN TO BE SIMILAR TO READF). IN BOTH PRIMITIVES, BUF # HOLDS ONE RIGHT-JUSTIFIED CHARACTER PER WORD. # # 4. IT IS WORTH THE EFFORT TO MAKE OPEN AND CREATE ACCEPT THE MOST # GENERAL FILE NAME SPECIFICATION USED IN THE LOCAL INSTALLATION. # THIS WILL INSURE THAT PROGRAMS CAN ACCEPT FILE NAMES FROM COMMANDS # AND CALL OPEN OR CREATE WITHOUT HAVING TO EXAMINE THE ACTUAL # NAME. IF SEVERAL FILE FORMATS ARE AVAILABLE, IT APPEARS BEST TO # ADD ADDITIONAL SYNTAX TO FILE NAMES TO INDICATE FILE FORMATS ETC. # FOR EXAMPLE, ON THE CDC CYBER 175, A /A APPENDED TO A FILE NAME # INDICATES THAT THE FILE IS 12-BIT ASCII. THE POINT HERE IS THAT # ALL OF THE SYSTEM-DEPENDENT INFORMATION SHOULD BE PASSED IN THE # NAME SO THAT PROGRAMS DO NOT HAVE SYSTEM-DEPENDENCIES BUILT INTO # THEM; MAKE THE I/O SYSTEM HANDLE SUCH IDIOSYNCRACIES. # # 5. IF ADDITIONAL INFORMATION IS REQUIRED BY OPEN AND CREATE, ADD # OPTIONS TO THE SECOND ARGUMENT; DO NOT ADD MORE ARGUMENTS. FOR # EXAMPLE, ON THE DEC-10 AND CDC CYBER 175 I/O SYSTEMS, THE MODE IS # REALLY # # BYTESIZE*8 + MODE # # IF BYTESIZE IS OMITTED, IT DEFAULTS TO THE CORRECT SIZE FOR # CHARACTERS. # # 6. IT IS CONVENIENT IF OPEN AND CREATE ACCEPT EITHER AN UNPACKED # ASCII NAME OR A PACKED NAME IN THE HOST CHARACTER SET. # # 7. THE PRIMITIVES GETLIN AND PUTLIN, DESCRIBED IN SOFTWARE TOOLS, # CAN BE IMPLEMENTED IN TERMS OF GETCH AND PUTCH (OR READF AND # WRITEF). IT MAY BE NECESSARY, HOWEVER, TO WRITE THESE ROUTINES IN # ASSEMBLY LANGUAGE IF THE BASIC UNIT OF INFORMATION IN FILES IS THE # LINE OR RECORD. # # 8. AS MENTIONED ABOVE, THE "STANDARD" FILES ARE ASSUMED TO BE # OPENED WHEN PROGRAM EXECUTION BEGINS. TRY TO ARRANGE THIS WITHOUT # REQUIRING ANYTHING EXPLICIT IN THE MAIN PROGRAM. IF THIS IS NOT # POSSIBLE, ANOTHER APPROACH IS TO MAKE ALL RATFOR PROGRAMS # SUBROUTINES WITH THE "MAIN PROGRAM" AS A SUBROUTINE NAMED MAIN. # SUPPLY A STANDARD MAIN PROGRAM WHOSE SOLE PURPOSE IS TO OPEN THE # STANDARD FILES, GET ARGUMENTS IF PRESENT, AND CALL MAIN. # # 9. SOME ASCII-BASED SYSTEMS (SUCH AS THE DEC-10) INSIST ON USING # A TWO-CHARACTER SEQUENCE TO TERMINATE A LINE; A CARRIAGE RETURN # AND A LINEFEED IS TYPICAL. RATFOR PROGRAMS EXPECT A SINGLE # CHARACTER TO INDICATE THE END OF A LINE. ALTHOUGH IT IS POSSIBLE # TO RECOGNIZE THE TWO-CHARACTER SEQUENCE AND RETURN A SINGLE # CHARACTER, THE SIMPLER SOLUTION IS TO IGNORE ONE OF THE CHARACTERS # COMPLETELY AND RETURN THE OTHER AS THE NEWLINE CHARACTER. THE # IGNORED CHARACTER IS RESTORED WHENEVER A NEWLINE IS OUTPUT. FOR # EXAMPLE, ON THE DEC-10 CARRIAGE RETURNS ARE IGNORED AND LINEFEEDS # ARE TREATED AS NEWLINE CHARACTERS. PUTCH OUTPUTS A CARRIAGE # RETURN WHENEVER A LINEFEED IS OUTPUT. OF COURSE, THIS CONVENTION # MEANS THAT "BARE" CARRIAGE RETURNS ARE LOST AND BARE LINEFEEDS # SIGNAL A LINE BOUNDARY. THIS RESTRICTION HAS CAUSED FEW PROBLEMS # IN PRACTICE, HOWEVER. # # 10. SOME INSTALLATIONS FIND IT NECESSARY TO PERFORM ADDITIONAL # PROCESSING ON THE INPUT OR OUTPUT OF RATFOR. IF THIS IS # NECESSARY, MODIFY THE ROUTINES NGETCH AND OUTDON (FOR INPUT AND # OUTPUT, RESPECTIVELY). ONE WAY TO DO THIS MODIFICATION IS TO # WRITE AN EDIT SCRIPT (SEE SOFTWARE TOOLS) THAT, WHEN APPLIED TO # RATFOR.RAT, PERFORMS THE APPROPRIATE CHANGES. IF THE SCRIPT USES # ONLY CONTEXT EDITING COMMANDS (SEARCHES, ETC.), IT IS LIKELY THAT # IT CAN BE APPLIED TO SUBSEQUENT VERSIONS OF RATFOR WITHOUT # MODIFICATION. # #-H- RATDEF 2690 1980 103 2140 #========== STANDARD RATFOR DEFINITIONS ========== DEFINE(ACCENT,96) DEFINE(ALPHA,10100) DEFINE(AND,38) DEFINE(ANDIF,IF) DEFINE(ARB,100) DEFINE(ATSIGN,64) DEFINE(BACKSLASH,92) DEFINE(BACKSPACE,8) DEFINE(BANG,33) DEFINE(BAR,124) DEFINE(BIGA,65) DEFINE(BIGB,66) DEFINE(BIGC,67) DEFINE(BIGD,68) DEFINE(BIGE,69) DEFINE(BIGF,70) DEFINE(BIGG,71) DEFINE(BIGH,72) DEFINE(BIGI,73) DEFINE(BIGJ,74) DEFINE(BIGK,75) DEFINE(BIGL,76) DEFINE(BIGM,77) DEFINE(BIGN,78) DEFINE(BIGO,79) DEFINE(BIGP,80) DEFINE(BIGQ,81) DEFINE(BIGR,82) DEFINE(BIGS,83) DEFINE(BIGT,84) DEFINE(BIGU,85) DEFINE(BIGV,86) DEFINE(BIGW,87) DEFINE(BIGX,88) DEFINE(BIGY,89) DEFINE(BIGZ,90) DEFINE(BLANK,32) DEFINE(CARET,94) DEFINE(COLON,58) DEFINE(COMMA,44) DEFINE(DIG0,48) DEFINE(DIG1,49) DEFINE(DIG2,50) DEFINE(DIG3,51) DEFINE(DIG4,52) DEFINE(DIG5,53) DEFINE(DIG6,54) DEFINE(DIG7,55) DEFINE(DIG8,56) DEFINE(DIG9,57) DEFINE(DIGIT,2) DEFINE(DOLLAR,36) DEFINE(DQUOTE,34) DEFINE(EOF,10003) DEFINE(EOS,10002) DEFINE(EQUALS,61) DEFINE(ERR,10001) DEFINE(ERROUT,2) DEFINE(GREATER,62) DEFINE(HUGE,30000) DEFINE(LBRACE,123) DEFINE(LBRACK,91) DEFINE(LESS,60) DEFINE(LETA,97) DEFINE(LETB,98) DEFINE(LETC,99) DEFINE(LETD,100) DEFINE(LETE,101) DEFINE(LETF,102) DEFINE(LETG,103) DEFINE(LETH,104) DEFINE(LETI,105) DEFINE(LETJ,106) DEFINE(LETK,107) DEFINE(LETL,108) DEFINE(LETM,109) DEFINE(LETN,110) DEFINE(LETO,111) DEFINE(LETP,112) DEFINE(LETQ,113) DEFINE(LETR,114) DEFINE(LETS,115) DEFINE(LETT,116) DEFINE(LETTER,1) DEFINE(LETU,117) DEFINE(LETV,118) DEFINE(LETW,119) DEFINE(LETX,120) DEFINE(LETY,121) DEFINE(LETZ,122) DEFINE(LPAREN,40) DEFINE(MAXCHARS,20) DEFINE(MAXLINE,120)%# TYPICAL LINE LENGTH DEFINE(MAXNAME,30) %# TYPICAL FILE NAME SIZE DEFINE(MINUS,45) DEFINE(NEWLINE,10) DEFINE(NO,0) DEFINE(NOERR,0) DEFINE(NOT,126) # SAME AS TILDE DEFINE(OK,-2) DEFINE(OR,BAR) # SAME AS BAR DEFINE(PERCENT,37) DEFINE(PERIOD,46) DEFINE(PLUS,43) DEFINE(QMARK,63) DEFINE(RBRACE,125) DEFINE(RBRACK,93) DEFINE(READ,0) DEFINE(READWRITE,2) DEFINE(RPAREN,41) DEFINE(SEMICOL,59) DEFINE(SHARP,35) DEFINE(SLASH,47) DEFINE(SQUOTE,39) DEFINE(STAR,42) DEFINE(STDIN,0) DEFINE(STDOUT,1) DEFINE(STDERR,ERROUT) DEFINE(TAB,9) DEFINE(TILDE,126) DEFINE(UNDERLINE,95) DEFINE(WRITE,1) DEFINE(YES,1) DEFINE(ESCAPE,ATSIGN) DEFINE(CHARACTER,INTEGER) DEFINE(ABS,IABS) DEFINE(MIN,MIN0) DEFINE(MAX,MAX0) # HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE DEFINE(BPI,36)%%# BITS PER INTEGER DEFINE(BPC,7)%%# BITS PER CHARACTER DEFINE(CPI,5)%%# CHARACTERS PER INTEGER DEFINE(LIMIT,134217728)%# LARGEST POSITIVE INTEGER DEFINE(LIM1,28)%%# MAXIMUM EXPONENT (POWER OF TEN) DEFINE(LIM2,-28)%# MINIMUM EXPONENT (POWER OF TEN) DEFINE(PRECISION,7)%# DIGITS ACCURATE IN REAL #-H- CFNAME 87 1980 103 2140 COMMON /CFNAME/ FCNAME(MAXNAME) CHARACTER FCNAME # TEXT OF CURRENT FUNCTION NAME #-H- CFOR 144 1980 103 2140 COMMON /CFOR/ FORDEP, FORSTK(MAXFORSTK) INTEGER FORDEP # CURRENT DEPTH OF FOR STATEMENTS CHARACTER FORSTK # STACK OF REINIT STRINGS #-H- CGOTO 84 1980 103 2140 COMMON /CGOTO/ XFER INTEGER XFER # YES IF JUST MADE TRANSFER, NO OTHERWISE #-H- CLABEL 75 1980 103 2140 COMMON /CLABEL/ LABEL INTEGER LABEL # NEXT LABEL RETURNED BY LABGEN #-H- CLINE 392 1980 103 2140 COMMON /CLINE/ LEVEL, LINECT(NFILES), INFILE(NFILES), FNAMP, FNAMES(MAXFNAMES) INTEGER LEVEL # LEVEL OF FILE INCLUSION; INIT = 1 INTEGER LINECT # LINE COUNT ON INPUT FILE(LEVEL); INIT = 1 INTEGER INFILE # FILE NUMBER(LEVEL); INIT INFILE(1) = STDIN INTEGER FNAMP # NEXT FREE SLOT IN FNAMES; INIT = 2 CHARACTER FNAMES # STACK OF INCLUDE NAMES; INIT FNAMES(1) = EOS #-H- CLOOK 212 1980 103 2140 COMMON /CLOOK/ AVAIL, TABPTR(127), TABLE(MAXTBL) INTEGER AVAIL # FIRST FIRST LOCATION IN TABLE; INIT = 1 INTEGER TABPTR # NAME POINTERS; INIT = 0 CHARACTER TABLE # ACTUAL TEXT OF NAMES AND DEFNS #-H- COUTLN 151 1980 103 2140 COMMON /COUTLN/ OUTP, OUTBUF(74) INTEGER OUTP # LAST POSITION FILLED IN OUTBUF; INIT = 0 CHARACTER OUTBUF # OUTPUT LINES COLLECTED HERE #-H- CSBUF 151 1980 103 2140 COMMON /CSBUF/ SBP, SBUF(SBUFSIZE) INTEGER SBP # NEXT AVAILABLE CHARACTER POSITION; INIT = 1 CHARACTER SBUF # SAVED FOR DATA STATEMENTS #-H- CRATIO 290 1980 103 2140 COMMON /CRATIO/ FDTAB(MAXFILES), FILTAB(FILTABSIZE), EXTCHR(NCHARS), INTCHR(NCHARS) INTEGER FDTAB%# POINTERS TO FILE BLOCKS INTEGER FILTAB%# FILE BLOCKS CHARACTER EXTCHR%# EXTERNAL REPRESENTATION OF CHARACTERS CHARACTER INTCHR%# INTERNAL (ASCII) REPRESENTATION OF CHARACTERS #-H- RATIO.RAT 12226 1980 103 2140 # MACHINE-INDEPENDENT RATFOR I/O SYSTEM IN RATFOR INCLUDE RATDEF DEFINE(MAXFILES,8) # NUMBER OF OPENED FILES PERMITTED DEFINE(MAXLINE,80) # MAXIMUM LINE SIZE ON INPUT DEFINE(MAXBUF,132) # MAXIMUM LINE SIZE ON OUTPUT DEFINE(NCHARS,96) # NUMBER OF CHARACTERS IN CHARACTER MAP # FILE BLOCK FORMAT DEFINE(USECNT,0) # USE COUNT DEFINE(MODE,1) # OPEN MODE DEFINE(EOFFLG,2) # YES, IF AT END OF FILE DEFINE(UNIT,3) # FORTRAN UNIT NUMBER DEFINE(LASTC,4) # LAST CHARACTER GET/PUT IN BUFFER DEFINE(BUF,5) # START OF LINE BUFFER DEFINE(FBLEN,140) # SIZE OF FILE BLOCK; # 7 + MAX(MAXLINE, MAXBUF) DEFINE(FILTABSIZE,1120) # MUST BE MAXFILES*FBLEN # BLOCK DATA BLOCK DATA INCLUDE CRATIO # THESE INITIALIZATIONS MUST BE CHANGED IF DEFINITIONS ARE CHANGED # INITIAL ASSIGNMENTS FOR DESCRIPTORS 0, 1, AND 2 REFLECT # ASSIGNMENTS OF STANDARD INPUT, OUTPUT, AND ERROR OUTPUT. DATA FDTAB(1) /1/ DATA FILTAB(1), FILTAB(2), FILTAB(3), FILTAB(4), FILTAB(5)/_ 1, READ, NO, 5, 0/ DATA FDTAB(2) /141/ DATA FILTAB(141), FILTAB(142), FILTAB(143), FILTAB(144), FILTAB(145)/_ 1, WRITE, NO, 6, 146/ DATA FDTAB(3) /281/ DATA FILTAB(281), FILTAB(282), FILTAB(283), FILTAB(284), FILTAB(285)/_ 1, WRITE, NO, 6, 286/ DATA FDTAB(4) /0/ DATA FILTAB(421) /0/ DATA FDTAB(5) /0/ DATA FILTAB(561) /0/ DATA FDTAB(6) /0/ DATA FILTAB(701) /0/ DATA FDTAB(7) /0/ DATA FILTAB(841) /0/ DATA FDTAB(8) /0/ DATA FILTAB(981) /0/ # CHARACTER MAP DATA EXTCHR( 1) /' '/, INTCHR( 1) /BLANK/ DATA EXTCHR( 2) /'0'/, INTCHR( 2) /DIG0/ DATA EXTCHR( 3) /'1'/, INTCHR( 3) /DIG1/ DATA EXTCHR( 4) /'2'/, INTCHR( 4) /DIG2/ DATA EXTCHR( 5) /'3'/, INTCHR( 5) /DIG3/ DATA EXTCHR( 6) /'4'/, INTCHR( 6) /DIG4/ DATA EXTCHR( 7) /'5'/, INTCHR( 7) /DIG5/ DATA EXTCHR( 8) /'6'/, INTCHR( 8) /DIG6/ DATA EXTCHR( 9) /'7'/, INTCHR( 9) /DIG7/ DATA EXTCHR(10) /'8'/, INTCHR(10) /DIG8/ DATA EXTCHR(11) /'9'/, INTCHR(11) /DIG9/ DATA EXTCHR(12) /'A'/, INTCHR(12) /LETA/ DATA EXTCHR(13) /'B'/, INTCHR(13) /LETB/ DATA EXTCHR(14) /'C'/, INTCHR(14) /LETC/ DATA EXTCHR(15) /'D'/, INTCHR(15) /LETD/ DATA EXTCHR(16) /'E'/, INTCHR(16) /LETE/ DATA EXTCHR(17) /'F'/, INTCHR(17) /LETF/ DATA EXTCHR(18) /'G'/, INTCHR(18) /LETG/ DATA EXTCHR(19) /'H'/, INTCHR(19) /LETH/ DATA EXTCHR(20) /'I'/, INTCHR(20) /LETI/ DATA EXTCHR(21) /'J'/, INTCHR(21) /LETJ/ DATA EXTCHR(22) /'K'/, INTCHR(22) /LETK/ DATA EXTCHR(23) /'L'/, INTCHR(23) /LETL/ DATA EXTCHR(24) /'M'/, INTCHR(24) /LETM/ DATA EXTCHR(25) /'N'/, INTCHR(25) /LETN/ DATA EXTCHR(26) /'O'/, INTCHR(26) /LETO/ DATA EXTCHR(27) /'P'/, INTCHR(27) /LETP/ DATA EXTCHR(28) /'Q'/, INTCHR(28) /LETQ/ DATA EXTCHR(29) /'R'/, INTCHR(29) /LETR/ DATA EXTCHR(30) /'S'/, INTCHR(30) /LETS/ DATA EXTCHR(31) /'T'/, INTCHR(31) /LETT/ DATA EXTCHR(32) /'U'/, INTCHR(32) /LETU/ DATA EXTCHR(33) /'V'/, INTCHR(33) /LETV/ DATA EXTCHR(34) /'W'/, INTCHR(34) /LETW/ DATA EXTCHR(35) /'X'/, INTCHR(35) /LETX/ DATA EXTCHR(36) /'Y'/, INTCHR(36) /LETY/ DATA EXTCHR(37) /'Z'/, INTCHR(37) /LETZ/ DATA EXTCHR(38) /'A'/, INTCHR(38) /BIGA/ DATA EXTCHR(39) /'B'/, INTCHR(39) /BIGB/ DATA EXTCHR(40) /'C'/, INTCHR(40) /BIGC/ DATA EXTCHR(41) /'D'/, INTCHR(41) /BIGD/ DATA EXTCHR(42) /'E'/, INTCHR(42) /BIGE/ DATA EXTCHR(43) /'F'/, INTCHR(43) /BIGF/ DATA EXTCHR(44) /'G'/, INTCHR(44) /BIGG/ DATA EXTCHR(45) /'H'/, INTCHR(45) /BIGH/ DATA EXTCHR(46) /'I'/, INTCHR(46) /BIGI/ DATA EXTCHR(47) /'J'/, INTCHR(47) /BIGJ/ DATA EXTCHR(48) /'K'/, INTCHR(48) /BIGK/ DATA EXTCHR(49) /'L'/, INTCHR(49) /BIGL/ DATA EXTCHR(50) /'M'/, INTCHR(50) /BIGM/ DATA EXTCHR(51) /'N'/, INTCHR(51) /BIGN/ DATA EXTCHR(52) /'O'/, INTCHR(52) /BIGO/ DATA EXTCHR(53) /'P'/, INTCHR(53) /BIGP/ DATA EXTCHR(54) /'Q'/, INTCHR(54) /BIGQ/ DATA EXTCHR(55) /'R'/, INTCHR(55) /BIGR/ DATA EXTCHR(56) /'S'/, INTCHR(56) /BIGS/ DATA EXTCHR(57) /'T'/, INTCHR(57) /BIGT/ DATA EXTCHR(58) /'U'/, INTCHR(58) /BIGU/ DATA EXTCHR(59) /'V'/, INTCHR(59) /BIGV/ DATA EXTCHR(60) /'W'/, INTCHR(60) /BIGW/ DATA EXTCHR(61) /'X'/, INTCHR(61) /BIGX/ DATA EXTCHR(62) /'Y'/, INTCHR(62) /BIGY/ DATA EXTCHR(63) /'Z'/, INTCHR(63) /BIGZ/ DATA EXTCHR(64) /'!'/, INTCHR(64) /BANG/ DATA EXTCHR(65) /'"'/, INTCHR(65) /DQUOTE/ DATA EXTCHR(66) /"#"/, INTCHR(66) /SHARP/ DATA EXTCHR(67) /'$'/, INTCHR(67) /DOLLAR/ DATA EXTCHR(68) /'%'/, INTCHR(68) /PERCENT/ DATA EXTCHR(69) /'&'/, INTCHR(69) /AND/ DATA EXTCHR(70) /"'"/, INTCHR(70) /SQUOTE/ DATA EXTCHR(71) /'('/, INTCHR(71) /LPAREN/ DATA EXTCHR(72) /')'/, INTCHR(72) /RPAREN/ DATA EXTCHR(73) /'*'/, INTCHR(73) /STAR/ DATA EXTCHR(74) /'+'/, INTCHR(74) /PLUS/ DATA EXTCHR(75) /','/, INTCHR(75) /COMMA/ DATA EXTCHR(76) /'-'/, INTCHR(76) /MINUS/ DATA EXTCHR(77) /'.'/, INTCHR(77) /PERIOD/ DATA EXTCHR(78) /'/'/, INTCHR(78) /SLASH/ DATA EXTCHR(79) /':'/, INTCHR(79) /COLON/ DATA EXTCHR(80) /';'/, INTCHR(80) /SEMICOL/ DATA EXTCHR(81) /'<'/, INTCHR(81) /LESS/ DATA EXTCHR(82) /'='/, INTCHR(82) /EQUALS/ DATA EXTCHR(83) /'>'/, INTCHR(83) /GREATER/ DATA EXTCHR(84) /'?'/, INTCHR(84) /QMARK/ DATA EXTCHR(85) /'@'/, INTCHR(85) /ATSIGN/ DATA EXTCHR(86) /'['/, INTCHR(86) /LBRACK/ DATA EXTCHR(87) /'\'/, INTCHR(87) /BACKSLASH/ DATA EXTCHR(88) /']'/, INTCHR(88) /RBRACK/ DATA EXTCHR(89) /'_'/, INTCHR(89) /UNDERLINE/ DATA EXTCHR(90) /'<'/, INTCHR(90) /LBRACE/ DATA EXTCHR(91) /'\'/, INTCHR(91) /BAR/ DATA EXTCHR(92) /'!'/, INTCHR(92) /RBRACE/ DATA EXTCHR(93) /'6'/, INTCHR(93) /BACKSPACE/ DATA EXTCHR(94) /'%'/, INTCHR(94) /TAB/ DATA EXTCHR(95) /'^'/, INTCHR(95) /CARET/ DATA EXTCHR(96) /'^'/, INTCHR(96) /TILDE/ # NCHARS IS LAST SUBSCRIPT IN THESE ARRAYS END # CLOSE - CLOSE FILE ON FD SUBROUTINE CLOSE(FD) INTEGER FD INTEGER I, K INTEGER WRLIN, OUTMAP INCLUDE CRATIO I = FDTAB(FD+1) IF (I == 0) RETURN # ALLOW CLOSE OF UNOPENED FILE FILTAB(I+USECNT) = FILTAB(I+USECNT) - 1 IF (FILTAB(I+USECNT) <= 0) < IF (FILTAB(I+MODE) == WRITE & FILTAB(I+LASTC) > I + BUF) < K = FILTAB(I+LASTC) FOR (J = I + BUF; J < K; J = J + 1) FILTAB(J) = OUTMAP(FILTAB(J)) K = WRLIN(FILTAB(I+BUF), K - (I + BUF), FILTAB(I+UNIT)) FILTAB(I+LASTC) = I + BUF ! CALL CLSFIL(FILTAB(I+UNIT), FILTAB(I+MODE)) ! FDTAB(FD+1) = 0 # FREE SLOT RETURN END # CLSFIL - DO ACTUAL CLOSE OF FILE OPENED ON UNIT IN MODE MD SUBROUTINE CLSFIL(UNIT, MD) INTEGER UNIT, MD REWIND UNIT RETURN END # CREATE - CREATE FILE NAME AND OPEN IN MODE MD INTEGER FUNCTION CREATE(NAME, MD) CHARACTER NAME(MAXNAME) INTEGER MD INTEGER OPEN CREATE = OPEN(NAME, MD) RETURN END # DUP - DUPLICATE FILE DESCRIPTOR FD INTEGER FUNCTION DUP(FD) INTEGER FD INTEGER I INCLUDE CRATIO FOR (DUP = 0; DUP < MAXFILES; DUP = DUP + 1) # FIND A FREE DESCRIPTOR IF (FDTAB(DUP+1) == 0) BREAK IF (DUP >= MAXFILES) DUP = ERR ELSE < FDTAB(DUP+1) = FDTAB(FD+1) # POINT TO SAME FILE BLOCK I = FDTAB(DUP+1) FILTAB(I+USECNT) = FILTAB(I+USECNT) + 1 # BUMP REFERENCE COUNT ! RETURN END # ERROR - ISSUE FATAL ERROR SUBROUTINE ERROR(MSG) INTEGER MSG(MAXLINE) CALL REMARK(MSG) CALL EXIT RETURN END # EXIT - CLOSE ALL OPEN FILES AND STOP SUBROUTINE EXIT INTEGER FD FOR (FD = 0; FD < MAXFILES; FD = FD + 1) CALL CLOSE(FD) STOP RETURN END # GETCH - GET NEXT CHARACTER FROM FILE FD INTO C CHARACTER FUNCTION GETCH(C, FD) CHARACTER C CHARACTER INMAP INTEGER FD, I, J, K, N INTEGER RDLIN INCLUDE CRATIO I = FDTAB(FD+1) IF (FILTAB(I+MODE) ^= READ) CALL ERROR(" INPUT ERROR: FILE NOT OPENED FOR READING.") IF (FILTAB(I+EOFFLG) == YES) GO TO 10 K = FILTAB(I+LASTC) IF (K == 0) < # READ NEXT LINE N = FILTAB(I+UNIT) K = RDLIN(FILTAB(I+BUF), N) IF (K == EOF) GO TO 10 ELSE IF (K == ERR) CALL ERROR(" INPUT ERROR.") J = I + BUF + K FILTAB(J) = NEWLINE FOR (J = I + BUF; K > 0; J = J + 1) < # TRANSLATE TO ASCII FILTAB(J) = INMAP(FILTAB(J)) K = K - 1 ! K = I + BUF # RESET READ POINTER FILTAB(I+LASTC) = K ! C = FILTAB(K) GETCH = C IF (C == NEWLINE) FILTAB(I+LASTC) = 0 # CAUSES READ ON NEXT GETCH ELSE FILTAB(I+LASTC) = K + 1 RETURN 10 # HERE ON END OF FILE FILTAB(I+EOFFLG) = YES C = EOF GETCH = EOF RETURN END # INMAP - CONVERT LEFT ADJUSTED EXTERNAL REP TO RIGHT ADJ ASCII INTEGER FUNCTION INMAP(C) CHARACTER C INTEGER I INCLUDE CRATIO DO I = 1, NCHARS IF (C == EXTCHR(I)) < INMAP = INTCHR(I) RETURN ! INMAP = C RETURN END # OPEN - OPEN FILE NAME ACCORDING TO MODE MD, RETURN DESCRIPTOR INTEGER FUNCTION OPEN(NAME, MD) CHARACTER NAME(MAXNAME) INTEGER MD INTEGER FD, I INTEGER OPNFIL INCLUDE CRATIO OPEN = ERR FOR (FD = 0; FD < MAXFILES; FD = FD + 1) # FIND A DESCRIPTOR IF (FDTAB(FD+1) == 0) BREAK IF (FD >= MAXFILES) RETURN FOR (I = 1; I < FBLEN*MAXFILES; I = I + FBLEN) # FIND A FILE BLOCK IF (FILTAB(I+USECNT) == 0) BREAK IF (I >= FBLEN*MAXFILES) RETURN FILTAB(I+UNIT) = OPNFIL(NAME, MD, FD) # DO ACTUAL OPEN IF (FILTAB(I+UNIT) == ERR) RETURN FILTAB(I+USECNT) = 1 # INITIALIZE FILE BLOCK FILTAB(I+MODE) = MD FILTAB(I+EOFFLG) = NO IF (MD == READ) FILTAB(I+LASTC) = 0 ELSE FILTAB(I+LASTC) = I + BUF FDTAB(FD+1) = I # CONNECT FILE DESCRIPTOR TO FILE BLOCK OPEN = FD RETURN END # OPNFIL - DO ACTUAL OPEN OF FILE NAME IN MODE; FD IS DESCRIPTOR INTEGER FUNCTION OPNFIL(NAME, MODE, FD) CHARACTER NAME(MAXNAME) INTEGER MODE, FD INTEGER I INTEGER CTOI I = 1 RETURN (CTOI(NAME, I)) END # OUTMAP - CONVERT RIGHT ADJ ASCII TO LEFT ADJUSTED EXTERNAL REP INTEGER FUNCTION OUTMAP(C) CHARACTER C INTEGER I INCLUDE CRATIO DO I = 1, NCHARS IF (C == INTCHR(I)) < OUTMAP = EXTCHR(I) RETURN ! OUTMAP = C RETURN END # PUTCH - PUT CHARACTER C TO FILE FD SUBROUTINE PUTCH(C, FD) CHARACTER C INTEGER FD INTEGER I, J, K INTEGER OUTMAP, WRLIN INCLUDE CRATIO I = FDTAB(FD+1) IF (FILTAB(I+MODE) ^= WRITE) CALL ERROR(" OUTPUT ERROR: FILE NOT OPENED FOR WRITING.") K = FILTAB(I+LASTC) IF (C == NEWLINE \ K > I + BUF + MAXBUF - 1) < # WRITE A LINE FOR (J = I + BUF; J < K; J = J + 1) FILTAB(J) = OUTMAP(FILTAB(J)) IF (WRLIN(FILTAB(I+BUF), K - (I + BUF), FILTAB(I+UNIT)) == ERR) CALL ERROR(" OUTPUT ERROR.") FILTAB(I+LASTC) = I + BUF ! ELSE < FILTAB(K) = C FILTAB(I+LASTC) = K + 1 ! RETURN END # RDLIN - READ A LINE IN A1 FORMAT INTO BUF FROM UNIT N INTEGER FUNCTION RDLIN(BUF, N) INTEGER BUF(MAXLINE), N INTEGER EXTBLK INTEGER I DATA EXTBLK /" "/ READ(N, 100, END=10) BUF 100 FORMAT(MAXLINE A1) FOR (RDLIN = MAXLINE; RDLIN > 0; RDLIN = RDLIN - 1) IF (BUF(RDLIN) ^= EXTBLK) BREAK RETURN 10 RDLIN = EOF RETURN END # REMARK - PRINT WARNING MESSAGE SUBROUTINE REMARK(BUF) INTEGER BUF(MAXBUF) INTEGER I, N INCLUDE CRATIO I = ERROUT I = FDTAB(I+1) N = FILTAB(I+UNIT) WRITE(N, 10) (BUF(I), I = 1, 10) 10 FORMAT(10A CPI) # FIX FOR YOUR MACHINE RETURN END # REMOVE - REMOVE FILE NAME SUBROUTINE REMOVE(NAME) CHARACTER NAME(MAXNAME) RETURN END # WRLIN - WRITE A K-CHARACTER LINE IN A1 FORMAT FROM BUF TO FORTRAN UNIT N INTEGER FUNCTION WRLIN(BUF, K, N) INTEGER BUF(MAXBUF), K, N INTEGER I IF (K > 0) < WRITE(N, 100) (BUF(I), I = 1, K) 100 FORMAT(MAXBUF A1) ! ELSE < WRITE(N, 200) 200 FORMAT(/) ! WRLIN = 0 RETURN END #-H- MAIN.RAT 68 1980 103 2140 # MAIN PROGRAM FOR RATFOR CALL PARSE CALL EXIT STOP END #-H- RATFOR.RAT 35214 1980 103 2140 # RATFOR IN RATFOR INCLUDE RATDEF DEFINE(ALPHA,10100) DEFINE(RADIX,PERCENT) # % INDICATES ALTERNATE RADIX DEFINE(BUFSIZE,300) # PUSHBACK BUFFER FOR NGETCH AND PUTBAK DEFINE(SBUFSIZE,500) # BUFFER FOR STRING STATEMENTS DEFINE(DEFTYPE,10010) DEFINE(DIGIT,2) DEFINE(LEXBREAK,10264) DEFINE(LEXDIGITS,10260) DEFINE(LEXDO,10266) DEFINE(LEXELSE,10262) DEFINE(LEXFOR,10268) DEFINE(LEXIF,10261) DEFINE(LEXNEXT,10265) DEFINE(LEXOTHER,10267) DEFINE(LEXREPEAT,10269) DEFINE(LEXUNTIL,10270) DEFINE(LEXWHILE,10263) DEFINE(LEXRETURN,10271) DEFINE(LEXEND,10272) DEFINE(LEXSTOP,10273) DEFINE(LEXSTRING,10274) DEFINE(MAXCHARS,10) # CHARACTERS FOR OUTNUM DEFINE(MAXDEF,200) # MAX CHARS IN A DEFN DEFINE(MAXFORSTK,200) # MAX SPACE FOR FOR REINIT CLAUSES DEFINE(MAXFNAMES,150) # MAX CHARS IN FILE NAME STACK = NFILES*MAXNAME DEFINE(MAXNAME,30) # FILE NAME SIZE IN GETTOK DEFINE(MAXSTACK,100) # MAX STACK DEPTH FOR PARSER DEFINE(MAXTBL,7000) # MAX CHARS IN ALL DEFINITIONS DEFINE(MAXTOK,200) # MAX CHARS IN A TOKEN DEFINE(NFILES,5) # MAX DEPTH OF FILE INCLUSION DEFINE(OR,BAR)%# SAME AS \ # ADDCHR - PUT C IN BUF(BP) IF IT FITS, INCREMENT BP SUBROUTINE ADDCHR(C, BUF, BP, MAXSIZ) INTEGER BP, MAXSIZ CHARACTER C, BUF(ARB) IF (BP > MAXSIZ) CALL BADERR("BUFFER OVERFLOW.") BUF(BP) = C BP = BP + 1 RETURN END # ADDSTR - PUT S IN BUF(BP) BY REPEATED CALLS TO ADDCHR SUBROUTINE ADDSTR(S, BUF, BP, MAXSIZ) CHARACTER S(ARB), BUF(ARB) INTEGER BP, MAXSIZ INTEGER I FOR (I = 1; S(I) ^= EOS; I = I + 1) CALL ADDCHR(S(I), BUF, BP, MAXSIZ) RETURN END # ALLDIG - RETURN YES IF STR IS ALL DIGITS INTEGER FUNCTION ALLDIG(STR) CHARACTER TYPE CHARACTER STR(ARB) INTEGER I ALLDIG = NO IF (STR(1) == EOS) RETURN FOR (I = 1; STR(I) ^= EOS; I = I + 1) IF (TYPE(STR(I)) ^= DIGIT) RETURN ALLDIG = YES RETURN END # BADERR - PRINT ERROR MESSAGE, THEN DIE SUBROUTINE BADERR(MSG) INTEGER MSG(ARB) CALL SYNERR(MSG) CALL EXIT RETURN END # BALPAR - COPY BALANCED PAREN STRING SUBROUTINE BALPAR CHARACTER GETTOK, GNBTOK CHARACTER T, TOKEN(MAXTOK) INTEGER NLPAR IF (GNBTOK(TOKEN, MAXTOK) ^= LPAREN) < CALL SYNERR("MISSING LEFT PAREN.") RETURN ! CALL OUTSTR(TOKEN) NLPAR = 1 REPEAT < T = GETTOK(TOKEN, MAXTOK) IF (T==SEMICOL \ T==LBRACE \ T==RBRACE \ T==EOF) < CALL PBSTR(TOKEN) BREAK ! IF (T == NEWLINE) # DELETE NEWLINES TOKEN(1) = EOS ELSE IF (T == LPAREN) NLPAR = NLPAR + 1 ELSE IF (T == RPAREN) NLPAR = NLPAR - 1 # ELSE NOTHING SPECIAL CALL OUTSTR(TOKEN) ! UNTIL (NLPAR <= 0) IF (NLPAR ^= 0) CALL SYNERR("MISSING PARENTHESIS IN CONDITION.") RETURN END # BRKNXT - GENERATE CODE FOR BREAK N AND NEXT N; N = 1 IS DEFAULT SUBROUTINE BRKNXT(SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN INTEGER I, N, ALLDIG, CTOI CHARACTER T, PTOKEN(MAXTOK), GNBTOK # INCLUDE COMMONBLOCKS INCLUDE CGOTO N = 0 T = GNBTOK(PTOKEN, MAXTOK) IF (ALLDIG(PTOKEN) == YES) < # HAVE BREAK N OR NEXT N I = 1 N = CTOI(PTOKEN, I) - 1 ! ELSE IF (T ^= SEMICOL) # DEFAULT CASE CALL PBSTR(PTOKEN) FOR (I = SP; I > 0; I = I - 1) IF (LEXTYP(I) == LEXWHILE \ LEXTYP(I) == LEXDO \ LEXTYP(I) == LEXFOR \ LEXTYP(I) == LEXREPEAT) < IF (N > 0) < N = N - 1 NEXT # SEEK PROPER LEVEL ! ELSE IF (TOKEN == LEXBREAK) CALL OUTGO(LABVAL(I)+1) ELSE CALL OUTGO(LABVAL(I)) XFER = YES RETURN ! IF (TOKEN == LEXBREAK) CALL SYNERR("ILLEGAL BREAK.") ELSE CALL SYNERR("ILLEGAL NEXT.") RETURN END # CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I INTEGER FUNCTION CTOI(IN, I) CHARACTER IN(ARB) INTEGER I WHILE (IN(I) == BLANK \ IN(I) == TAB) I = I + 1 FOR (CTOI = 0; IN(I) ^= EOS; I = I + 1) < IF (IN(I) < DIG0 \ IN(I) > DIG9) BREAK CTOI = 10 * CTOI + IN(I) - DIG0 ! RETURN END # DEFTOK - GET TOKEN; PROCESS MACRO CALLS AND INVOCATIONS CHARACTER FUNCTION DEFTOK(TOKEN, TOKSIZ, FD) CHARACTER GTOK INTEGER FD, TOKSIZ CHARACTER DEFN(MAXDEF), T, TOKEN(MAXTOK) INTEGER LOOKUP FOR (T=GTOK(TOKEN, TOKSIZ, FD); T^=EOF; T=GTOK(TOKEN, TOKSIZ, FD)) < IF (T ^= ALPHA) # NON-ALPHA BREAK IF (LOOKUP(TOKEN, DEFN) == NO) # UNDEFINED BREAK IF (DEFN(1) == DEFTYPE) < # GET DEFINITION CALL GETDEF(TOKEN, TOKSIZ, DEFN, MAXDEF, FD) CALL INSTAL(TOKEN, DEFN) ! ELSE CALL PBSTR(DEFN) # PUSH REPLACEMENT ONTO INPUT ! DEFTOK = T IF (DEFTOK == ALPHA) # CONVERT TO SINGLE CASE CALL FOLD(TOKEN) RETURN END # FOLD - CONVERT ALPHABETIC TOKEN TO SINGLE CASE SUBROUTINE FOLD(TOKEN) CHARACTER TOKEN(ARB) INTEGER I FOR (I = 1; TOKEN(I) ^= EOS; I = I + 1) IF (TOKEN(I) >= BIGA & TOKEN(I) <= BIGZ) TOKEN(I) = TOKEN(I) - BIGA + LETA RETURN END # DOCODE - GENERATE CODE FOR BEGINNING OF DO SUBROUTINE DOCODE(LAB) INTEGER LABGEN INTEGER LAB # INCLUDE COMMONBLOCKS INCLUDE CGOTO STRING SDO "DO" XFER = NO CALL OUTTAB CALL OUTSTR(SDO) LAB = LABGEN(2) CALL OUTNUM(LAB) CALL EATUP CALL OUTDON RETURN END # DOSTAT - GENERATE CODE FOR END OF DO STATEMENT SUBROUTINE DOSTAT(LAB) INTEGER LAB CALL OUTCON(LAB) CALL OUTCON(LAB+1) RETURN END # EATUP - PROCESS REST OF STATEMENT; INTERPRET CONTINUATIONS SUBROUTINE EATUP CHARACTER GETTOK CHARACTER PTOKEN(MAXTOK), T, TOKEN(MAXTOK) INTEGER NLPAR NLPAR = 0 REPEAT < T = GETTOK(TOKEN, MAXTOK) IF (T == SEMICOL \ T == NEWLINE) BREAK IF (T == RBRACE \ T == LBRACE) < CALL PBSTR(TOKEN) BREAK ! IF (T == EOF) < CALL SYNERR("UNEXPECTED EOF.") CALL PBSTR(TOKEN) BREAK ! IF (T == COMMA \ T == PLUS \ T == MINUS \ T == STAR \ T == LPAREN \ T == AND \ T == BAR \ T == BANG \ T == EQUALS \ T == UNDERLINE ) < WHILE (GETTOK(PTOKEN, MAXTOK) == NEWLINE) ; CALL PBSTR(PTOKEN) IF (T == UNDERLINE) TOKEN(1) = EOS ! IF (T == LPAREN) NLPAR = NLPAR + 1 ELSE IF (T == RPAREN) NLPAR = NLPAR - 1 CALL OUTSTR(TOKEN) ! UNTIL (NLPAR < 0) IF (NLPAR ^= 0) CALL SYNERR("UNBALANCED PARENTHESES.") RETURN END # ELSEIF - GENERATE CODE FOR END OF IF BEFORE ELSE SUBROUTINE ELSEIF(LAB) INTEGER LAB CALL OUTGO(LAB+1) CALL OUTCON(LAB) RETURN END # EQUAL - COMPARE STR1 TO STR2; RETURN YES IF EQUAL, NO IF NOT INTEGER FUNCTION EQUAL(STR1, STR2) CHARACTER STR1(ARB), STR2(ARB) INTEGER I FOR (I = 1; STR1(I) == STR2(I); I = I + 1) IF (STR1(I) == EOS) < EQUAL = YES RETURN ! EQUAL = NO RETURN END # FORCOD - BEGINNING OF FOR STATEMENT SUBROUTINE FORCOD(LAB) CHARACTER GETTOK, GNBTOK CHARACTER T, TOKEN(MAXTOK) INTEGER LENGTH, LABGEN INTEGER I, J, LAB, NLPAR # INCLUDE COMMONBLOCKS INCLUDE CFOR STRING IFNOT "IF(.NOT." LAB = LABGEN(3) CALL OUTCON(0) IF (GNBTOK(TOKEN, MAXTOK) ^= LPAREN) < CALL SYNERR("MISSING LEFT PAREN.") RETURN ! IF (GNBTOK(TOKEN, MAXTOK) ^= SEMICOL) < # REAL INIT CLAUSE CALL PBSTR(TOKEN) CALL OUTTAB CALL EATUP CALL OUTDON ! IF (GNBTOK(TOKEN, MAXTOK) == SEMICOL) # EMPTY CONDITION CALL OUTCON(LAB) ELSE < # NON-EMPTY CONDITION CALL PBSTR(TOKEN) CALL OUTNUM(LAB) CALL OUTTAB CALL OUTSTR(IFNOT) CALL OUTCH(LPAREN) NLPAR = 0 WHILE (NLPAR >= 0) < T = GETTOK(TOKEN, MAXTOK) IF (T == SEMICOL) BREAK IF (T == LPAREN) NLPAR = NLPAR + 1 ELSE IF (T == RPAREN) NLPAR = NLPAR - 1 IF (T == EOF) < CALL PBSTR(TOKEN) RETURN ! IF (T ^= NEWLINE & T ^= UNDERLINE) CALL OUTSTR(TOKEN) ! CALL OUTCH(RPAREN) CALL OUTCH(RPAREN) CALL OUTGO(LAB+2) IF (NLPAR < 0) CALL SYNERR("INVALID FOR CLAUSE.") ! FORDEP = FORDEP + 1 # STACK REINIT CLAUSE J = 1 FOR (I = 1; I < FORDEP; I = I + 1) # FIND END J = J + LENGTH(FORSTK(J)) + 1 FORSTK(J) = EOS # NULL, IN CASE NO REINIT NLPAR = 0 T = GNBTOK(TOKEN, MAXTOK) CALL PBSTR(TOKEN) WHILE (NLPAR >= 0) < T = GETTOK(TOKEN, MAXTOK) IF (T == LPAREN) NLPAR = NLPAR + 1 ELSE IF (T == RPAREN) NLPAR = NLPAR - 1 IF (T == EOF) < CALL PBSTR(TOKEN) BREAK ! IF (NLPAR >= 0 & T ^= NEWLINE & T ^= UNDERLINE) < IF (J + LENGTH(TOKEN) >= MAXFORSTK) CALL BADERR("FOR CLAUSE TOO LONG.") CALL SCOPY(TOKEN, 1, FORSTK, J) J = J + LENGTH(TOKEN) ! ! LAB = LAB + 1 # LABEL FOR NEXT'S RETURN END # FORS - PROCESS END OF FOR STATEMENT SUBROUTINE FORS(LAB) INTEGER LENGTH INTEGER I, J, LAB # INCLUDE COMMONBLOCKS INCLUDE CFOR INCLUDE CGOTO XFER = NO CALL OUTNUM(LAB) J = 1 FOR (I = 1; I < FORDEP; I = I + 1) J = J + LENGTH(FORSTK(J)) + 1 IF (LENGTH(FORSTK(J)) > 0) < CALL OUTTAB CALL OUTSTR(FORSTK(J)) CALL OUTDON ! CALL OUTGO(LAB-1) CALL OUTCON(LAB+1) FORDEP = FORDEP - 1 RETURN END # GETDEF (FOR NO ARGUMENTS) - GET NAME AND DEFINITION SUBROUTINE GETDEF(TOKEN, TOKSIZ, DEFN, DEFSIZ, FD) CHARACTER GTOK, NGETCH INTEGER DEFSIZ, FD, I, NLPAR, TOKSIZ CHARACTER C, DEFN(MAXDEF), TOKEN(MAXTOK), T, PTOKEN(MAXTOK) CALL SKPBLK(FD) C = GTOK(PTOKEN, MAXTOK, FD) IF (C == LPAREN) T = LPAREN # DEFINE (NAME, DEFN) ELSE < T = BLANK # DEFINE NAME DEFN CALL PBSTR(PTOKEN) ! CALL SKPBLK(FD) IF (GTOK(TOKEN, TOKSIZ, FD) ^= ALPHA) CALL BADERR("NON-ALPHANUMERIC NAME.") CALL SKPBLK(FD) C = GTOK(PTOKEN, MAXTOK, FD) IF (T == BLANK) < # DEFINE NAME DEFN CALL PBSTR(PTOKEN) I = 1 REPEAT < C = NGETCH(C, FD) IF (I > DEFSIZ) CALL BADERR("DEFINITION TOO LONG.") DEFN(I) = C I = I + 1 ! UNTIL (C == SHARP \ C == NEWLINE \ C == EOF) IF (C == SHARP) CALL PUTBAK(C) ! ELSE IF (T == LPAREN) < # DEFINE (NAME, DEFN) IF (C ^= COMMA) CALL BADERR("MISSING COMMA IN DEFINE.") # ELSE GOT (NAME, NLPAR = 0 FOR (I = 1; NLPAR >= 0; I = I + 1) IF (I > DEFSIZ) CALL BADERR("DEFINITION TOO LONG.") ELSE IF (NGETCH(DEFN(I), FD) == EOF) CALL BADERR("MISSING RIGHT PAREN.") ELSE IF (DEFN(I) == LPAREN) NLPAR = NLPAR + 1 ELSE IF (DEFN(I) == RPAREN) NLPAR = NLPAR - 1 # ELSE NORMAL CHARACTER IN DEFN(I) ! ELSE CALL BADERR("GETDEF IS CONFUSED.") DEFN(I-1) = EOS RETURN END # GETTOK - GET TOKEN. HANDLES FILE INCLUSION AND LINE NUMBERS CHARACTER FUNCTION GETTOK(TOKEN, TOKSIZ) INTEGER EQUAL, OPEN, LENGTH INTEGER T, I, TOKSIZ, F CHARACTER DEFTOK CHARACTER NAME(MAXNAME), TOKEN(MAXTOK) # INCLUDE COMMONBLOCKS INCLUDE CLINE INCLUDE CFNAME STRING FNCN "FUNCTION" STRING INCL "INCLUDE" FOR ( ; LEVEL > 0; LEVEL = LEVEL - 1) < F = INFILE(LEVEL) FOR (GETTOK = DEFTOK(TOKEN, TOKSIZ, F); GETTOK ^= EOF; GETTOK = DEFTOK(TOKEN, TOKSIZ, F)) < IF (EQUAL(TOKEN, FNCN) == YES) < CALL SKPBLK(INFILE(LEVEL)) T = DEFTOK(FCNAME, MAXNAME, F) CALL PBSTR(FCNAME) IF (T ^= ALPHA) CALL SYNERR("MISSING FUNCTION NAME.") CALL PUTBAK(BLANK) RETURN ! ELSE IF (EQUAL(TOKEN, INCL) == NO) RETURN CALL SKPBLK(INFILE(LEVEL)) FOR (I = 1;; I = LENGTH(NAME) + 1) < T = DEFTOK(NAME(I), MAXNAME, F) IF (T == NEWLINE \ T == SEMICOL) < CALL PBSTR(NAME(I)) BREAK ! ! NAME(I) = EOS IF (LEVEL >= NFILES) CALL SYNERR("INCLUDES NESTED TOO DEEPLY.") ELSE < INFILE(LEVEL+1) = OPEN(NAME, READ) LINECT(LEVEL+1) = 1 IF (INFILE(LEVEL+1) == ERR) CALL SYNERR("CAN'T OPEN INCLUDE.") ELSE < LEVEL = LEVEL + 1 IF (FNAMP + I <= MAXFNAMES) < CALL SCOPY(NAME, 1, FNAMES, FNAMP) FNAMP = FNAMP + I # PUSH FILE NAME STACK ! F = INFILE(LEVEL) ! ! ! IF (LEVEL > 1) < # CLOSE INCLUDE AND POP FILE NAME STACK CALL CLOSE(INFILE(LEVEL)) FOR (FNAMP = FNAMP - 1; FNAMP > 1; FNAMP = FNAMP - 1) IF (FNAMES(FNAMP-1) == EOS) BREAK ! ! TOKEN(1) = EOF # IN CASE CALLED MORE THAN ONCE TOKEN(2) = EOS GETTOK = EOF RETURN END # GNBTOK - GET NONBLANK TOKEN CHARACTER FUNCTION GNBTOK(TOKEN, TOKSIZ) INTEGER TOKSIZ CHARACTER TOKEN(MAXTOK), GETTOK # INCLUDE COMMONBLOCKS INCLUDE CLINE CALL SKPBLK(INFILE(LEVEL)) GNBTOK = GETTOK(TOKEN, TOKSIZ) RETURN END # GTOK - GET TOKEN FOR RATFOR CHARACTER FUNCTION GTOK(LEXSTR, TOKSIZ, FD) CHARACTER NGETCH, TYPE INTEGER FD, I, B, N, TOKSIZ, ITOC CHARACTER C, LEXSTR(MAXTOK) # INCLUDE COMMONBLOCKS INCLUDE CLINE C = NGETCH(LEXSTR(1), FD) IF (C == BLANK \ C == TAB) < LEXSTR(1) = BLANK WHILE (C == BLANK \ C == TAB) # COMPRESS MANY BLANKS TO ONE C = NGETCH(C, FD) IF (C == SHARP) WHILE (NGETCH(C, FD) ^= NEWLINE) # STRIP COMMENTS ; IF (C ^= NEWLINE) CALL PUTBAK(C) ELSE LEXSTR(1) = NEWLINE LEXSTR(2) = EOS GTOK = LEXSTR(1) RETURN ! I = 1 GTOK = TYPE(C) IF (GTOK == LETTER) <%# ALPHA FOR (I = 1; I < TOKSIZ - 2; I = I + 1) < GTOK = TYPE(NGETCH(LEXSTR(I+1), FD)) IF (GTOK ^= LETTER & GTOK ^= DIGIT & GTOK ^= UNDERLINE & GTOK ^= PERIOD) BREAK ! CALL PUTBAK(LEXSTR(I+1)) GTOK = ALPHA ! ELSE IF (GTOK == DIGIT) <%# DIGITS B = C - DIG0%# IN CASE ALTERNATE BASE NUMBER FOR (I = 1; I < TOKSIZ - 2; I = I + 1) < IF (TYPE(NGETCH(LEXSTR(I+1), FD)) ^= DIGIT) BREAK B = 10*B + LEXSTR(I+1) - DIG0 ! IF (LEXSTR(I+1) == RADIX & B >= 2 & B <= 36) < #N%DDD... FOR (N = 0;; N = B*N + C - DIG0) < C = NGETCH(LEXSTR(1), FD) IF (C >= LETA & C <= LETZ) C = C - LETA + DIG9 + 1 ELSE IF (C >= BIGA & C <= BIGZ) C = C - BIGA + DIG9 + 1 IF (C < DIG0 \ C >= DIG0 + B) BREAK ! CALL PUTBAK(LEXSTR(1)) I = ITOC(N, LEXSTR, TOKSIZ) ! ELSE CALL PUTBAK(LEXSTR(I+1)) GTOK = DIGIT ! ELSE IF (C == LBRACK) < # ALLOW [ FOR < LEXSTR(1) = LBRACE GTOK = LBRACE ! ELSE IF (C == RBRACK) < # ALLOW ] FOR ! LEXSTR(1) = RBRACE GTOK = RBRACE ! ELSE IF (C == DOLLAR) < # ALLOW $( AND $) FOR < AND ! IF (NGETCH(LEXSTR(2), FD) == LPAREN) < LEXSTR(1) = LBRACE GTOK = LBRACE ! ELSE IF (LEXSTR(2) == RPAREN) < LEXSTR(1) = RBRACE GTOK = RBRACE ! ELSE CALL PUTBAK(LEXSTR(2)) ! ELSE IF (C == SQUOTE \ C == DQUOTE) < FOR (I = 2; NGETCH(LEXSTR(I), FD) ^= LEXSTR(1); I = I + 1) < IF (LEXSTR(I) == UNDERLINE) IF (NGETCH(C, FD) == NEWLINE) < WHILE (C == NEWLINE \ C == BLANK \ C == TAB) C = NGETCH(C, FD) LEXSTR(I) = C ! ELSE CALL PUTBAK(C) IF (LEXSTR(I) == NEWLINE \ I >= TOKSIZ-1) < CALL SYNERR("MISSING QUOTE.") LEXSTR(I) = LEXSTR(1) CALL PUTBAK(NEWLINE) BREAK ! ! ! ELSE IF (C == SHARP) < # STRIP COMMENTS WHILE (NGETCH(LEXSTR(1), FD) ^= NEWLINE) ; GTOK = NEWLINE ! ELSE IF (C == GREATER \ C == LESS \ C == NOT \ C == BANG \ C == CARET \ C == EQUALS \ C == AND \ C == OR) CALL RELATE(LEXSTR, I, FD) IF (I >= TOKSIZ-1) CALL SYNERR("TOKEN TOO LONG.") LEXSTR(I+1) = EOS IF (LEXSTR(1) == NEWLINE) LINECT(LEVEL) = LINECT(LEVEL) + 1 RETURN END # IFCODE - GENERATE INITIAL CODE FOR IF SUBROUTINE IFCODE(LAB) INTEGER LABGEN INTEGER LAB # INCLUDE COMMONBLOCKS INCLUDE CGOTO XFER = NO LAB = LABGEN(2) CALL IFGO(LAB) RETURN END # IFGO - GENERATE "IF(.NOT.(...))GOTO LAB" SUBROUTINE IFGO(LAB) INTEGER LAB STRING IFNOT "IF(.NOT." CALL OUTTAB # GET TO COLUMN 7 CALL OUTSTR(IFNOT) # " IF(.NOT. " CALL BALPAR # COLLECT AND OUTPUT CONDITION CALL OUTCH(RPAREN) # " ) " CALL OUTGO(LAB) # " GOTO LAB " RETURN END # INIT - INITIALIZE SUBROUTINE INIT INTEGER I, DEFTYP(2) # INCLUDE COMMONBLOCKS INCLUDE COUTLN INCLUDE CLINE INCLUDE CDEFIO INCLUDE CFOR INCLUDE CLOOK INCLUDE CFNAME INCLUDE CLABEL INCLUDE CSBUF STRING DEF "DEFINE" STRING BDEF "DEFINE" DATA DEFTYP(1), DEFTYP(2) /DEFTYPE, EOS/ OUTP = 0%%# OUTPUT CHARACTER POINTER LEVEL = 1%%# FILE CONTROL LINECT(1) = 1 INFILE(1) = STDIN FNAMP = 2 FNAMES(1) = EOS BP = 0%%# PUSHBACK BUFFER POINTER FORDEP = 0%%# FOR STACK AVAIL = 1%%# POINTERS FOR LOOKUP DO I = 1,127 TABPTR(I) = 0 CALL INSTAL(DEF, DEFTYP)%# DEFAULT DEFINITIONS CALL INSTAL(BDEF, DEFTYP) FCNAME(1) = EOS%# CURRENT FUNCTION NAME LABEL = 23000%# NEXT GENERATED LABEL SBP = 1%%# STRING STATEMENT BUFFER RETURN END # INSTAL - ADD NAME AND DEFINITION TO TABLE SUBROUTINE INSTAL(NAME, DEFN) CHARACTER DEFN(MAXTOK), NAME(MAXDEF), C INTEGER LENGTH INTEGER DLEN, NLEN # INCLUDE COMMONBLOCKS INCLUDE CLOOK NLEN = LENGTH(NAME) + 1 DLEN = LENGTH(DEFN) + 1 IF (AVAIL + NLEN + DLEN > MAXTBL) < CALL PUTLIN(NAME, ERROUT) CALL REMARK(": TOO MANY DEFINITIONS.") RETURN ! C = NAME(1) TABLE(AVAIL) = TABPTR(C) TABPTR(C) = AVAIL CALL SCOPY(NAME, 1, TABLE, AVAIL + 1) CALL SCOPY(DEFN, 1, TABLE, AVAIL + NLEN + 1) AVAIL = AVAIL + NLEN + DLEN + 1 RETURN END # ITOC - CONVERT INTEGER INT TO CHAR STRING IN STR INTEGER FUNCTION ITOC(INT, STR, SIZE) INTEGER ABS, MOD INTEGER I, INT, INTVAL, J, K, SIZE CHARACTER STR(MAXCHARS) INTVAL = ABS(INT) STR(1) = EOS I = 1 REPEAT < # GENERATE DIGITS I = I + 1 STR(I) = MOD(INTVAL, 10) + DIG0 INTVAL = INTVAL / 10 ! UNTIL (INTVAL == 0 \ I >= SIZE) IF (INT < 0 & I < SIZE) < # THEN SIGN I = I + 1 STR(I) = MINUS ! ITOC = I - 1 FOR (J = 1; J < I; J = J + 1) < # THEN REVERSE K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 ! RETURN END # LABELC - OUTPUT STATEMENT NUMBER SUBROUTINE LABELC(LEXSTR) CHARACTER LEXSTR(ARB) INTEGER LENGTH # INCLUDE COMMONBLOCKS INCLUDE CGOTO XFER = NO # CAN'T SUPPRESS GOTO'S NOW IF (LENGTH(LEXSTR) == 5) # WARN ABOUT 23XXX LABELS IF (LEXSTR(1) == DIG2 & LEXSTR(2) == DIG3) CALL SYNERR("WARNING: POSSIBLE LABEL CONFLICT.") CALL OUTSTR(LEXSTR) CALL OUTTAB RETURN END # LABGEN - GENERATE N CONSECUTIVE LABELS, RETURN FIRST ONE INTEGER FUNCTION LABGEN(N) INTEGER N # INCLUDE COMMONBLOCKS INCLUDE CLABEL LABGEN = LABEL LABEL = LABEL + N RETURN END # LENGTH - COMPUTE LENGTH OF STRING INTEGER FUNCTION LENGTH(STR) INTEGER STR(ARB) FOR (LENGTH = 0; STR(LENGTH+1) ^= EOS; LENGTH = LENGTH + 1) ; RETURN END # LEX - RETURN LEXICAL TYPE OF TOKEN INTEGER FUNCTION LEX(LEXSTR) CHARACTER GNBTOK CHARACTER LEXSTR(MAXTOK) INTEGER EQUAL # INCLUDE COMMONBLOCKS STRING SIF "IF" STRING SELSE "ELSE" STRING SWHILE "WHILE" STRING SDO "DO" STRING SBREAK "BREAK" STRING SNEXT "NEXT" STRING SFOR "FOR" STRING SREPT "REPEAT" STRING SUNTIL "UNTIL" STRING SRET "RETURN" STRING SSTR "STRING" FOR (LEX = GNBTOK(LEXSTR, MAXTOK); LEX == NEWLINE; LEX = GNBTOK(LEXSTR, MAXTOK)) ; IF (LEX == EOF \ LEX == SEMICOL \ LEX == LBRACE \ LEX == RBRACE) RETURN IF (LEX == DIGIT) LEX = LEXDIGITS ELSE IF (EQUAL(LEXSTR, SIF) == YES) LEX = LEXIF ELSE IF (EQUAL(LEXSTR, SELSE) == YES) LEX = LEXELSE ELSE IF (EQUAL(LEXSTR, SWHILE) == YES) LEX = LEXWHILE ELSE IF (EQUAL(LEXSTR, SDO) == YES) LEX = LEXDO ELSE IF (EQUAL(LEXSTR, SBREAK) == YES) LEX = LEXBREAK ELSE IF (EQUAL(LEXSTR, SNEXT) == YES) LEX = LEXNEXT ELSE IF (EQUAL(LEXSTR, SFOR) == YES) LEX = LEXFOR ELSE IF (EQUAL(LEXSTR, SREPT) == YES) LEX = LEXREPEAT ELSE IF (EQUAL(LEXSTR, SUNTIL) == YES) LEX = LEXUNTIL ELSE IF (EQUAL(LEXSTR, SRET) == YES) LEX = LEXRETURN ELSE IF (EQUAL(LEXSTR, SSTR) == YES) LEX = LEXSTRING ELSE LEX = LEXOTHER RETURN END # LOOKUP - LOCATE NAME, EXTRACT DEFINITION FROM TABLE INTEGER FUNCTION LOOKUP(NAME, DEFN) CHARACTER DEFN(MAXDEF), NAME(MAXTOK), C INTEGER I, J, K # INCLUDE COMMONBLOCKS INCLUDE CLOOK C = NAME(1) FOR (I = TABPTR(C); I > 0; I = TABLE(I)) < J = I + 1 FOR (K = 1; NAME(K) == TABLE(J) & NAME(K) ^= EOS; K = K + 1) J = J + 1 IF (NAME(K) == TABLE(J)) < # GOT ONE CALL SCOPY(TABLE, J+1, DEFN, 1) LOOKUP = YES RETURN ! ! LOOKUP = NO RETURN END # NGETCH - GET A (POSSIBLY PUSHED BACK) CHARACTER CHARACTER FUNCTION NGETCH(C, FD) CHARACTER GETCH CHARACTER C INTEGER FD # INCLUDE COMMONBLOCKS INCLUDE CDEFIO IF (BP > 0) < C = BUF(BP) BP = BP - 1 ! ELSE C = GETCH(C, FD) NGETCH = C RETURN END # OTHERC - OUTPUT ORDINARY FORTRAN STATEMENT SUBROUTINE OTHERC(LEXSTR) CHARACTER LEXSTR(ARB) # INCLUDE COMMONBLOCKS INCLUDE CGOTO XFER = NO CALL OUTTAB CALL OUTSTR(LEXSTR) CALL EATUP CALL OUTDON RETURN END # OUTCH - PUT ONE CHARACTER INTO OUTPUT BUFFER SUBROUTINE OUTCH(C) CHARACTER C INTEGER I # INCLUDE COMMONBLOCKS INCLUDE COUTLN IF (OUTP >= 72) < # CONTINUATION CARD CALL OUTDON FOR (I = 1; I < 6; I = I + 1) OUTBUF(I) = BLANK OUTBUF(6) = STAR OUTP = 6 ! OUTP = OUTP + 1 OUTBUF(OUTP) = C RETURN END # OUTCON - OUTPUT "N CONTINUE" SUBROUTINE OUTCON(N) INTEGER N # INCLUDE COMMONBLOCKS INCLUDE CGOTO INCLUDE COUTLN STRING CONTIN "CONTINUE" XFER = NO IF (N <= 0 & OUTP == 0) RETURN # DON'T NEED UNLABELED CONTINUES IF (N > 0) CALL OUTNUM(N) CALL OUTTAB CALL OUTSTR(CONTIN) CALL OUTDON RETURN END # OUTDON - FINISH OFF AN OUTPUT LINE SUBROUTINE OUTDON # INCLUDE COMMONBLOCKS INCLUDE COUTLN OUTBUF(OUTP+1) = NEWLINE OUTBUF(OUTP+2) = EOS CALL PUTLIN(OUTBUF, STDOUT) OUTP = 0 RETURN END # OUTGO - OUTPUT "GOTO N" SUBROUTINE OUTGO(N) INTEGER N # INCLUDE COMMONBLOCKS INCLUDE CGOTO STRING GOTO "GOTO " IF (XFER == YES) RETURN CALL OUTTAB CALL OUTSTR(GOTO) CALL OUTNUM(N) CALL OUTDON RETURN END # OUTNUM - OUTPUT POSITIVE DECIMAL NUMBER SUBROUTINE OUTNUM(N) CHARACTER CHARS(MAXCHARS) INTEGER I, M M = N I = 0 REPEAT < I = I + 1 CHARS(I) = MOD(M, 10) + DIG0 M = M / 10 ! UNTIL (M == 0 \ I >= MAXCHARS) FOR ( ; I > 0; I = I - 1) CALL OUTCH(CHARS(I)) RETURN END # OUTSTR - OUTPUT STRING; HANDLES QUOTED LITERALS SUBROUTINE OUTSTR(STR) CHARACTER C, STR(ARB) INTEGER I, J FOR (I = 1; STR(I) ^= EOS; I = I + 1) < C = STR(I) IF (C ^= SQUOTE & C ^= DQUOTE) < IF (C >= LETA & C <= LETZ)%# REMOVE THIS IF YOU C = C - LETA + BIGA%%# DON'T NEED UPPER CASE FORTRAN CALL OUTCH(C) ! ELSE < I = I + 1 FOR (J = I; STR(J) ^= C; J = J + 1) # FIND END ; CALL OUTNUM(J-I) CALL OUTCH(BIGH) FOR ( ; I < J; I = I + 1) CALL OUTCH(STR(I)) ! ! RETURN END # OUTTAB - GET PAST COLUMN 6 SUBROUTINE OUTTAB # INCLUDE COMMONBLOCKS INCLUDE COUTLN WHILE (OUTP < 6) CALL OUTCH(BLANK) RETURN END # PARSE - PARSE RATFOR SOURCE PROGRAM SUBROUTINE PARSE CHARACTER LEXSTR(MAXTOK) INTEGER LEX INTEGER LAB, LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN INCLUDE CGOTO INCLUDE CFOR INCLUDE CFNAME INCLUDE CLINE INCLUDE CSBUF INCLUDE CLABEL INCLUDE CLOOK INCLUDE CDEFIO INCLUDE COUTLN CALL INIT SP = 1 LEXTYP(1) = EOF FOR (TOKEN = LEX(LEXSTR); TOKEN ^= EOF; TOKEN = LEX(LEXSTR)) < IF (TOKEN == LEXIF) CALL IFCODE(LAB) ELSE IF (TOKEN == LEXDO) CALL DOCODE(LAB) ELSE IF (TOKEN == LEXWHILE) CALL WHILEC(LAB) ELSE IF (TOKEN == LEXFOR) CALL FORCOD(LAB) ELSE IF (TOKEN == LEXREPEAT) CALL REPCOD(LAB) ELSE IF (TOKEN == LEXDIGITS) CALL LABELC(LEXSTR) ELSE IF (TOKEN == LEXELSE) < IF (LEXTYP(SP) == LEXIF) CALL ELSEIF(LABVAL(SP)) ELSE CALL SYNERR("ILLEGAL ELSE.") ! IF (TOKEN == LEXIF \ TOKEN == LEXELSE \ TOKEN == LEXWHILE \ TOKEN == LEXFOR \ TOKEN == LEXREPEAT \ TOKEN == LEXDO \ TOKEN == LEXDIGITS \ TOKEN == LBRACE) < SP = SP + 1 # BEGINNING OF STATEMENT IF (SP > MAXSTACK) CALL BADERR("STACK OVERFLOW IN PARSER.") LEXTYP(SP) = TOKEN # STACK TYPE AND VALUE LABVAL(SP) = LAB ! ELSE < # END OF STATEMENT - PREPARE TO UNSTACK IF (TOKEN == RBRACE) < IF (LEXTYP(SP) == LBRACE) SP = SP - 1 ELSE CALL SYNERR("ILLEGAL RIGHT BRACE.") ! ELSE IF (TOKEN == LEXOTHER) CALL OTHERC(LEXSTR) ELSE IF (TOKEN == LEXBREAK \ TOKEN == LEXNEXT) CALL BRKNXT(SP, LEXTYP, LABVAL, TOKEN) ELSE IF (TOKEN == LEXRETURN) CALL RETCOD ELSE IF (TOKEN == LEXSTRING) CALL STRDCL TOKEN = LEX(LEXSTR) # PEEK AT NEXT TOKEN CALL PBSTR(LEXSTR) CALL UNSTAK(SP, LEXTYP, LABVAL, TOKEN) ! ! IF (SP ^= 1) CALL SYNERR("UNEXPECTED EOF.") RETURN END # PBSTR - PUSH STRING BACK ONTO INPUT SUBROUTINE PBSTR(IN) CHARACTER IN(ARB) INTEGER LENGTH INTEGER I FOR (I = LENGTH(IN); I > 0; I = I - 1) CALL PUTBAK(IN(I)) RETURN END # PUTBAK - PUSH CHARACTER BACK ONTO INPUT SUBROUTINE PUTBAK(C) CHARACTER C # INCLUDE COMMONBLOCKS INCLUDE CDEFIO BP = BP + 1 IF (BP > BUFSIZE) CALL BADERR("TOO MANY CHARACTERS PUSHED BACK.") BUF(BP) = C RETURN END # PUTLIN - PUT OUT LINE BY REPEATED CALLS TO PUTCH SUBROUTINE PUTLIN(B, F) CHARACTER B(ARB) INTEGER F, I FOR (I = 1; B(I) ^= EOS; I = I + 1) CALL PUTCH(B(I), F) RETURN END # RELATE - CONVERT RELATIONAL SHORTHANDS INTO LONG FORM SUBROUTINE RELATE(TOKEN, LAST, FD) CHARACTER NGETCH CHARACTER TOKEN(ARB) INTEGER LENGTH INTEGER FD, LAST IF (NGETCH(TOKEN(2), FD) ^= EQUALS) < CALL PUTBAK(TOKEN(2)) TOKEN(3) = LETT ! ELSE TOKEN(3) = LETE TOKEN(4) = PERIOD TOKEN(5) = EOS TOKEN(6) = EOS%# FOR .NOT. AND .AND. IF (TOKEN(1) == GREATER) TOKEN(2) = LETG ELSE IF (TOKEN(1) == LESS) TOKEN(2) = LETL ELSE IF (TOKEN(1) == NOT \ TOKEN(1) == BANG \ TOKEN(1) == CARET) < IF (TOKEN(2) ^= EQUALS) < TOKEN(3) = LETO TOKEN(4) = LETT TOKEN(5) = PERIOD ! TOKEN(2) = LETN ! ELSE IF (TOKEN(1) == EQUALS) < IF (TOKEN(2) ^= EQUALS) < TOKEN(2) = EOS LAST = 1 RETURN ! TOKEN(2) = LETE TOKEN(3) = LETQ ! ELSE IF (TOKEN(1) == AND) < TOKEN(2) = LETA TOKEN(3) = LETN TOKEN(4) = LETD TOKEN(5) = PERIOD ! ELSE IF (TOKEN(1) == OR) < TOKEN(2) = LETO TOKEN(3) = LETR ! ELSE # CAN'T HAPPEN TOKEN(2) = EOS TOKEN(1) = PERIOD LAST = LENGTH(TOKEN) RETURN END # REPCOD - GENERATE CODE FOR BEGINNING OF REPEAT SUBROUTINE REPCOD(LAB) INTEGER LABGEN INTEGER LAB CALL OUTCON(0) # IN CASE THERE WAS A LABEL LAB = LABGEN(3) CALL OUTCON(LAB) LAB = LAB + 1 # LABEL TO GO ON NEXT'S RETURN END # RETCOD - GENERATE CODE FOR RETURN SUBROUTINE RETCOD CHARACTER TOKEN(MAXTOK), GNBTOK, T # INCLUDE COMMONBLOCKS INCLUDE CFNAME INCLUDE CGOTO STRING SRET "RETURN" T = GNBTOK(TOKEN, MAXTOK) IF (T ^= NEWLINE & T ^= SEMICOL & T ^= RBRACE) < CALL PBSTR(TOKEN) CALL OUTTAB CALL OUTSTR(FCNAME) CALL OUTCH(EQUALS) CALL EATUP CALL OUTDON ! ELSE IF (T == RBRACE) CALL PBSTR(TOKEN) CALL OUTTAB CALL OUTSTR(SRET) CALL OUTDON XFER = YES RETURN END # SCOPY - COPY STRING AT FROM(I) TO TO(J) SUBROUTINE SCOPY(FROM, I, TO, J) CHARACTER FROM(ARB), TO(ARB) INTEGER I, J, K1, K2 K2 = J FOR (K1 = I; FROM(K1) ^= EOS; K1 = K1 + 1) < TO(K2) = FROM(K1) K2 = K2 + 1 ! TO(K2) = EOS RETURN END # SKPBLK - SKIP BLANKS AND TABS IN FILE FD SUBROUTINE SKPBLK(FD) INTEGER FD CHARACTER C, NGETCH FOR (C = NGETCH(C, FD); C == BLANK \ C == TAB; C = NGETCH(C, FD)) ; CALL PUTBAK(C) RETURN END # STRDCL - GENERATE CODE FOR STRING DECLARATION SUBROUTINE STRDCL CHARACTER T, TOKEN(MAXTOK), GNBTOK INTEGER I, J, K, LEN, LENGTH, CTOI, LEX INCLUDE CSBUF STRING INT "INTEGER " STRING DAT "DATA " STRING EOSS "EOS/" T = GNBTOK(TOKEN, MAXTOK) IF (T ^= ALPHA) CALL SYNERR("MISSING STRING TOKEN.") CALL OUTTAB CALL OUTSTR(INT) CALL OUTSTR(TOKEN) CALL ADDSTR(TOKEN, SBUF, SBP, SBUFSIZE) # SAVE FOR LATER CALL ADDCHR(EOS, SBUF, SBP, SBUFSIZE) IF (GNBTOK(TOKEN, MAXTOK) ^= LPAREN) < # MAKE SIZE SAME AS INITIAL VALUE LEN = LENGTH(TOKEN) + 1 IF (TOKEN(1) == SQUOTE \ TOKEN(1) == DQUOTE) LEN = LEN - 2 ! ELSE <%# FORM IS STRING NAME(SIZE) INIT T = GNBTOK(TOKEN, MAXTOK) I = 1 LEN = CTOI(TOKEN, I) IF (TOKEN(I) ^= EOS) CALL SYNERR("INVALID STRING SIZE.") IF (GNBTOK(TOKEN, MAXTOK) ^= RPAREN) CALL SYNERR("MISSING RIGHT PAREN.") ELSE T = GNBTOK(TOKEN, MAXTOK) ! CALL OUTCH(LPAREN) CALL OUTNUM(LEN) CALL OUTCH(RPAREN) CALL OUTDON IF (TOKEN(1) == SQUOTE \ TOKEN(1) == DQUOTE) < LEN = LENGTH(TOKEN) TOKEN(LEN) = EOS CALL ADDSTR(TOKEN(2), SBUF, SBP, SBUFSIZE) ! ELSE CALL ADDSTR(TOKEN, SBUF, SBP, SBUFSIZE) CALL ADDCHR(EOS, SBUF, SBP, SBUFSIZE) T = LEX(TOKEN) # PEEK AT NEXT TOKEN CALL PBSTR(TOKEN) IF (T ^= LEXSTRING) < # DUMP ACCUMULATED DATA STATEMENTS FOR (I = 1; I < SBP; I = J + 1) < CALL OUTTAB CALL OUTSTR(DAT) K = 1 FOR (J = I + LENGTH(SBUF(I)) + 1; ; J = J + 1) < IF (K > 1) CALL OUTCH(COMMA) CALL OUTSTR(SBUF(I)) CALL OUTCH(LPAREN) CALL OUTNUM(K) CALL OUTCH(RPAREN) CALL OUTCH(SLASH) IF (SBUF(J) == EOS) BREAK CALL OUTNUM(SBUF(J)) CALL OUTCH(SLASH) K = K + 1 ! CALL PBSTR(EOSS)%# USE DEFINED MEANING OF EOS REPEAT < T = GNBTOK(TOKEN, MAXTOK) CALL OUTSTR(TOKEN) ! UNTIL (T == SLASH) CALL OUTDON ! SBP = 1 ! RETURN END # SYNERR - REPORT RATFOR SYNTAX ERROR SUBROUTINE SYNERR(MSG) CHARACTER LC(MAXCHARS), MSG(ARB) INTEGER ITOC INTEGER I, JUNK # INCLUDE COMMONBLOCKS INCLUDE CLINE STRING ERRMSG "ERROR AT LINE " STRING IN " IN " CALL PUTLIN(ERRMSG, ERROUT) IF (LEVEL >= 1) I = LEVEL ELSE I = 1 # FOR EOF ERRORS JUNK = ITOC(LINECT(I), LC, MAXCHARS) CALL PUTLIN(LC, ERROUT) FOR (I = FNAMP - 1; I > 1; I = I - 1) IF (FNAMES(I-1) == EOS) < # PRINT FILE NAME CALL PUTLIN(IN, ERROUT) CALL PUTLIN(FNAMES(I), ERROUT) BREAK ! CALL PUTCH(COLON, ERROUT) CALL PUTCH(BLANK, ERROUT) CALL REMARK(MSG) RETURN END # TYPE - RETURN LETTER, DIGIT OR CHARACTER; WORKS WITH ASCII ALPHABET INTEGER FUNCTION TYPE(C) INTEGER C IF (C >= DIG0 & C <= DIG9) TYPE = DIGIT ELSE IF (C >= LETA & C <= LETZ) TYPE = LETTER ELSE IF (C >= BIGA & C <= BIGZ) TYPE = LETTER ELSE TYPE = C RETURN END # UNSTAK - UNSTACK AT END OF STATEMENT SUBROUTINE UNSTAK(SP, LEXTYP, LABVAL, TOKEN) INTEGER LABVAL(MAXSTACK), LEXTYP(MAXSTACK), SP, TOKEN FOR ( ; SP > 1; SP = SP - 1) < IF (LEXTYP(SP) == LBRACE) BREAK IF (LEXTYP(SP) == LEXIF & TOKEN == LEXELSE) BREAK IF (LEXTYP(SP) == LEXIF) CALL OUTCON(LABVAL(SP)) ELSE IF (LEXTYP(SP) == LEXELSE) < IF (SP > 2) SP = SP - 1 CALL OUTCON(LABVAL(SP)+1) ! ELSE IF (LEXTYP(SP) == LEXDO) CALL DOSTAT(LABVAL(SP)) ELSE IF (LEXTYP(SP) == LEXWHILE) CALL WHILES(LABVAL(SP)) ELSE IF (LEXTYP(SP) == LEXFOR) CALL FORS(LABVAL(SP)) ELSE IF (LEXTYP(SP) == LEXREPEAT) CALL UNTILS(LABVAL(SP), TOKEN) ! RETURN END # UNTILS - GENERATE CODE FOR UNTIL OR END OF REPEAT SUBROUTINE UNTILS(LAB, TOKEN) CHARACTER PTOKEN(MAXTOK) INTEGER LEX INTEGER JUNK, LAB, TOKEN # INCLUDE COMMONBLOCKS INCLUDE CGOTO XFER = NO CALL OUTNUM(LAB) IF (TOKEN == LEXUNTIL) < JUNK = LEX(PTOKEN) CALL IFGO(LAB-1) ! ELSE CALL OUTGO(LAB-1) CALL OUTCON(LAB+1) RETURN END # WHILEC - GENERATE CODE FOR BEGINNING OF WHILE SUBROUTINE WHILEC(LAB) INTEGER LABGEN INTEGER LAB CALL OUTCON(0) # UNLABELED CONTINUE, IN CASE THERE WAS A LABEL LAB = LABGEN(2) CALL OUTNUM(LAB) CALL IFGO(LAB+1) RETURN END # WHILES - GENERATE CODE FOR END OF WHILE SUBROUTINE WHILES(LAB) INTEGER LAB CALL OUTGO(LAB) CALL OUTCON(LAB+1) RETURN END #-H- EBCDIC.RAT 17293 1980 103 2141 # EBCDIC - SUGGESTED TRANSLATION TABLES FOR EBCDIC <-> ASCII BLOCK DATA EBCDIC INTEGER ETOI(256), ITOE(256) # ETOI AND ITOE SHOULD BE IN SOME COMMON # EBCDIC TO INTERNAL ASCII; TABLE IS INDEXED BY C+1 DATA ETOI(001) /000/ # (00) DATA ETOI(002) /001/ # (01) DATA ETOI(003) /002/ # (02) DATA ETOI(004) /003/ # (03) DATA ETOI(005) /019/ # (04) DATA ETOI(006) /009/ # (05) DATA ETOI(007) /010/ # (06) DATA ETOI(008) /127/ # (07) DATA ETOI(009) /128/ # (08) DATA ETOI(010) /129/ # (09) DATA ETOI(011) /130/ # (0A) DATA ETOI(012) /011/ # (0B) DATA ETOI(013) /012/ # (0C) DATA ETOI(014) /013/ # (0D) DATA ETOI(015) /014/ # (0E) DATA ETOI(016) /015/ # (0F) DATA ETOI(017) /016/ # (10) DATA ETOI(018) /017/ # (11) DATA ETOI(019) /018/ # (12) DATA ETOI(020) /131/ # (13) DATA ETOI(021) /132/ # (14) DATA ETOI(022) /133/ # (15) DATA ETOI(023) /008/ # (16) DATA ETOI(024) /022/ # (17) DATA ETOI(025) /024/ # (18) DATA ETOI(026) /025/ # (19) DATA ETOI(027) /134/ # (1A) DATA ETOI(028) /135/ # (1B) DATA ETOI(029) /136/ # (1C) DATA ETOI(030) /029/ # (1D) DATA ETOI(031) /137/ # (1E) DATA ETOI(032) /031/ # (1F) DATA ETOI(033) /138/ # (20) DATA ETOI(034) /139/ # (21) DATA ETOI(035) /028/ # (22) DATA ETOI(036) /140/ # (23) DATA ETOI(037) /141/ # (24) DATA ETOI(038) /142/ # (25) DATA ETOI(039) /023/ # (26) DATA ETOI(040) /027/ # (27) DATA ETOI(041) /143/ # (28) DATA ETOI(042) /144/ # (29) DATA ETOI(043) /145/ # (2A) DATA ETOI(044) /146/ # (2B) DATA ETOI(045) /147/ # (2C) DATA ETOI(046) /005/ # (2D) DATA ETOI(047) /006/ # (2E) DATA ETOI(048) /007/ # (2F) DATA ETOI(049) /148/ # (30) DATA ETOI(050) /149/ # (31) DATA ETOI(051) /150/ # (32) DATA ETOI(052) /151/ # (33) DATA ETOI(053) /152/ # (34) DATA ETOI(054) /030/ # (35) DATA ETOI(055) /153/ # (36) DATA ETOI(056) /004/ # (37) DATA ETOI(057) /154/ # (38) DATA ETOI(058) /155/ # (39) DATA ETOI(059) /156/ # (3A) DATA ETOI(060) /157/ # (3B) DATA ETOI(061) /020/ # (3C) DATA ETOI(062) /021/ # (3D) DATA ETOI(063) /158/ # (3E) DATA ETOI(064) /026/ # (3F) DATA ETOI(065) /032/ # (40) DATA ETOI(066) /159/ # (41) DATA ETOI(067) /160/ # (42) DATA ETOI(068) /161/ # (43) DATA ETOI(069) /162/ # (44) DATA ETOI(070) /163/ # (45) DATA ETOI(071) /164/ # (46) DATA ETOI(072) /165/ # (47) DATA ETOI(073) /166/ # (48) DATA ETOI(074) /167/ # (49) DATA ETOI(075) /168/ # (4A) DATA ETOI(076) /046/ # (4B)%. DATA ETOI(077) /060/ # (4C)%< DATA ETOI(078) /040/ # (4D)%( DATA ETOI(079) /043/ # (4E)%+ DATA ETOI(080) /124/ # (4F)%\ DATA ETOI(081) /038/ # (50)%& DATA ETOI(082) /169/ # (51) DATA ETOI(083) /170/ # (52) DATA ETOI(084) /171/ # (53) DATA ETOI(085) /172/ # (54) DATA ETOI(086) /173/ # (55) DATA ETOI(087) /174/ # (56) DATA ETOI(088) /175/ # (57) DATA ETOI(089) /176/ # (58) DATA ETOI(090) /177/ # (59) DATA ETOI(091) /033/ # (5A)%! DATA ETOI(092) /036/ # (5B)%$ DATA ETOI(093) /042/ # (5C)%* DATA ETOI(094) /041/ # (5D)%) DATA ETOI(095) /059/ # (5E)%; DATA ETOI(096) /094/ # (5F)%^ DATA ETOI(097) /045/ # (60)%- DATA ETOI(098) /047/ # (61)%/ DATA ETOI(099) /178/ # (62) DATA ETOI(100) /179/ # (63) DATA ETOI(101) /180/ # (64) DATA ETOI(102) /181/ # (65) DATA ETOI(103) /182/ # (66) DATA ETOI(104) /183/ # (67) DATA ETOI(105) /184/ # (68) DATA ETOI(106) /185/ # (69) DATA ETOI(107) /186/ # (6A) DATA ETOI(108) /044/ # (6B)%, DATA ETOI(109) /037/ # (6C)%% DATA ETOI(110) /095/ # (6D)%_ DATA ETOI(111) /062/ # (6E)%> DATA ETOI(112) /063/ # (6F)%? DATA ETOI(113) /187/ # (70) DATA ETOI(114) /188/ # (71) DATA ETOI(115) /189/ # (72) DATA ETOI(116) /190/ # (73) DATA ETOI(117) /191/ # (74) DATA ETOI(118) /192/ # (75) DATA ETOI(119) /193/ # (76) DATA ETOI(120) /194/ # (77) DATA ETOI(121) /195/ # (78) DATA ETOI(122) /096/ # (79)%@ DATA ETOI(123) /058/ # (7A)%: DATA ETOI(124) /035/ # (7B)%# DATA ETOI(125) /064/ # (7C)%@ DATA ETOI(126) /039/ # (7D)%' DATA ETOI(127) /061/ # (7E)%= DATA ETOI(128) /034/ # (7F)%" DATA ETOI(129) /196/ # (80) DATA ETOI(130) /097/ # (81)%A DATA ETOI(131) /098/ # (82)%B DATA ETOI(132) /099/ # (83)%C DATA ETOI(133) /100/ # (84)%D DATA ETOI(134) /101/ # (85)%E DATA ETOI(135) /102/ # (86)%F DATA ETOI(136) /103/ # (87)%G DATA ETOI(137) /104/ # (88)%H DATA ETOI(138) /105/ # (89)%I DATA ETOI(139) /197/ # (8A) DATA ETOI(140) /123/ # (8B)%< DATA ETOI(141) /198/ # (8C) DATA ETOI(142) /199/ # (8D) DATA ETOI(143) /200/ # (8E) DATA ETOI(144) /201/ # (8F) DATA ETOI(145) /202/ # (90) DATA ETOI(146) /106/ # (91)%J DATA ETOI(147) /107/ # (92)%K DATA ETOI(148) /108/ # (93)%L DATA ETOI(149) /109/ # (94)%M DATA ETOI(150) /110/ # (95)%N DATA ETOI(151) /111/ # (96)%O DATA ETOI(152) /112/ # (97)%P DATA ETOI(153) /113/ # (98)%Q DATA ETOI(154) /114/ # (99)%R DATA ETOI(155) /203/ # (9A) DATA ETOI(156) /125/ # (9B)%! DATA ETOI(157) /092/ # (9C)%\ DATA ETOI(158) /204/ # (9D) DATA ETOI(159) /205/ # (9E) DATA ETOI(160) /206/ # (9F) DATA ETOI(161) /207/ # (A0) DATA ETOI(162) /126/ # (A1)%^ DATA ETOI(163) /115/ # (A2)%S DATA ETOI(164) /116/ # (A3)%T DATA ETOI(165) /117/ # (A4)%U DATA ETOI(166) /118/ # (A5)%V DATA ETOI(167) /119/ # (A6)%W DATA ETOI(168) /120/ # (A7)%X DATA ETOI(169) /121/ # (A8)%Y DATA ETOI(170) /122/ # (A9)%Z DATA ETOI(171) /208/ # (AA) DATA ETOI(172) /209/ # (AB) DATA ETOI(173) /210/ # (AC) DATA ETOI(174) /091/ # (AD)%[ DATA ETOI(175) /211/ # (AE) DATA ETOI(176) /212/ # (AF) DATA ETOI(177) /213/ # (B0) DATA ETOI(178) /214/ # (B1) DATA ETOI(179) /215/ # (B2) DATA ETOI(180) /216/ # (B3) DATA ETOI(181) /217/ # (B4) DATA ETOI(182) /218/ # (B5) DATA ETOI(183) /219/ # (B6) DATA ETOI(184) /220/ # (B7) DATA ETOI(185) /221/ # (B8) DATA ETOI(186) /222/ # (B9) DATA ETOI(187) /223/ # (BA) DATA ETOI(188) /224/ # (BB) DATA ETOI(189) /225/ # (BC) DATA ETOI(190) /093/ # (BD)%] DATA ETOI(191) /226/ # (BE) DATA ETOI(192) /227/ # (BF) DATA ETOI(193) /228/ # (C0) DATA ETOI(194) /065/ # (C1)%A DATA ETOI(195) /066/ # (C2)%B DATA ETOI(196) /067/ # (C3)%C DATA ETOI(197) /068/ # (C4)%D DATA ETOI(198) /069/ # (C5)%E DATA ETOI(199) /070/ # (C6)%F DATA ETOI(200) /071/ # (C7)%G DATA ETOI(201) /072/ # (C8)%H DATA ETOI(202) /073/ # (C9)%I DATA ETOI(203) /229/ # (CA) DATA ETOI(204) /230/ # (CB) DATA ETOI(205) /231/ # (CC) DATA ETOI(206) /232/ # (CD) DATA ETOI(207) /233/ # (CE) DATA ETOI(208) /234/ # (CF) DATA ETOI(209) /235/ # (D0) DATA ETOI(210) /074/ # (D1)%J DATA ETOI(211) /075/ # (D2)%K DATA ETOI(212) /076/ # (D3)%L DATA ETOI(213) /077/ # (D4)%M DATA ETOI(214) /078/ # (D5)%N DATA ETOI(215) /079/ # (D6)%O DATA ETOI(216) /080/ # (D7)%P DATA ETOI(217) /081/ # (D8)%Q DATA ETOI(218) /082/ # (D9)%R DATA ETOI(219) /236/ # (DA) DATA ETOI(220) /237/ # (DB) DATA ETOI(221) /238/ # (DC) DATA ETOI(222) /239/ # (DD) DATA ETOI(223) /240/ # (DE) DATA ETOI(224) /241/ # (DF) DATA ETOI(225) /242/ # (E0) DATA ETOI(226) /243/ # (E1) DATA ETOI(227) /083/ # (E2)%S DATA ETOI(228) /084/ # (E3)%T DATA ETOI(229) /085/ # (E4)%U DATA ETOI(230) /086/ # (E5)%V DATA ETOI(231) /087/ # (E6)%W DATA ETOI(232) /088/ # (E7)%X DATA ETOI(233) /089/ # (E8)%Y DATA ETOI(234) /090/ # (E9)%Z DATA ETOI(235) /244/ # (EA) DATA ETOI(236) /245/ # (EB) DATA ETOI(237) /246/ # (EC) DATA ETOI(238) /247/ # (ED) DATA ETOI(239) /248/ # (EE) DATA ETOI(240) /249/ # (EF) DATA ETOI(241) /048/ # (F0)%0 DATA ETOI(242) /049/ # (F1)%1 DATA ETOI(243) /050/ # (F2)%2 DATA ETOI(244) /051/ # (F3)%3 DATA ETOI(245) /052/ # (F4)%4 DATA ETOI(246) /053/ # (F5)%5 DATA ETOI(247) /054/ # (F6)%6 DATA ETOI(248) /055/ # (F7)%7 DATA ETOI(249) /056/ # (F8)%8 DATA ETOI(250) /057/ # (F9)%9 DATA ETOI(251) /250/ # (FA) DATA ETOI(252) /251/ # (FB) DATA ETOI(253) /252/ # (FC) DATA ETOI(254) /253/ # (FD) DATA ETOI(255) /254/ # (FE) DATA ETOI(256) /255/ # (FF) # INTERNAL ASCII TO EBCDIC; TABLE IS INDEXED BY C+1 DATA ITOE(001) /000/ # (000) DATA ITOE(002) /001/ # (001) DATA ITOE(003) /002/ # (002) DATA ITOE(004) /003/ # (003) DATA ITOE(005) /055/ # (004) DATA ITOE(006) /045/ # (005) DATA ITOE(007) /046/ # (006) DATA ITOE(008) /047/ # (007) DATA ITOE(009) /022/ # (010) DATA ITOE(010) /005/ # (011) DATA ITOE(011) /006/ # (012) DATA ITOE(012) /011/ # (013) DATA ITOE(013) /012/ # (014) DATA ITOE(014) /013/ # (015) DATA ITOE(015) /014/ # (016) DATA ITOE(016) /015/ # (017) DATA ITOE(017) /016/ # (020) DATA ITOE(018) /017/ # (021) DATA ITOE(019) /018/ # (022) DATA ITOE(020) /004/ # (023) DATA ITOE(021) /060/ # (024) DATA ITOE(022) /061/ # (025) DATA ITOE(023) /023/ # (026) DATA ITOE(024) /038/ # (027) DATA ITOE(025) /024/ # (030) DATA ITOE(026) /025/ # (031) DATA ITOE(027) /063/ # (032) DATA ITOE(028) /039/ # (033) DATA ITOE(029) /034/ # (034) DATA ITOE(030) /029/ # (035) DATA ITOE(031) /053/ # (036) DATA ITOE(032) /031/ # (037) DATA ITOE(033) /064/ # (040) DATA ITOE(034) /090/ # (041)%! DATA ITOE(035) /127/ # (042)%" DATA ITOE(036) /123/ # (043)%# DATA ITOE(037) /091/ # (044)%$ DATA ITOE(038) /108/ # (045)%% DATA ITOE(039) /080/ # (046)%& DATA ITOE(040) /125/ # (047)%' DATA ITOE(041) /077/ # (050)%( DATA ITOE(042) /093/ # (051)%) DATA ITOE(043) /092/ # (052)%* DATA ITOE(044) /078/ # (053)%+ DATA ITOE(045) /107/ # (054)%, DATA ITOE(046) /096/ # (055)%- DATA ITOE(047) /075/ # (056)%. DATA ITOE(048) /097/ # (057)%/ DATA ITOE(049) /240/ # (060)%0 DATA ITOE(050) /241/ # (061)%1 DATA ITOE(051) /242/ # (062)%2 DATA ITOE(052) /243/ # (063)%3 DATA ITOE(053) /244/ # (064)%4 DATA ITOE(054) /245/ # (065)%5 DATA ITOE(055) /246/ # (066)%6 DATA ITOE(056) /247/ # (067)%7 DATA ITOE(057) /248/ # (070)%8 DATA ITOE(058) /249/ # (071)%9 DATA ITOE(059) /122/ # (072)%: DATA ITOE(060) /094/ # (073)%; DATA ITOE(061) /076/ # (074)%< DATA ITOE(062) /126/ # (075)%= DATA ITOE(063) /110/ # (076)%> DATA ITOE(064) /111/ # (077)%? DATA ITOE(065) /124/ # (100)%@ DATA ITOE(066) /193/ # (101)%A DATA ITOE(067) /194/ # (102)%B DATA ITOE(068) /195/ # (103)%C DATA ITOE(069) /196/ # (104)%D DATA ITOE(070) /197/ # (105)%E DATA ITOE(071) /198/ # (106)%F DATA ITOE(072) /199/ # (107)%G DATA ITOE(073) /200/ # (110)%H DATA ITOE(074) /201/ # (111)%I DATA ITOE(075) /209/ # (112)%J DATA ITOE(076) /210/ # (113)%K DATA ITOE(077) /211/ # (114)%L DATA ITOE(078) /212/ # (115)%M DATA ITOE(079) /213/ # (116)%N DATA ITOE(080) /214/ # (117)%O DATA ITOE(081) /215/ # (120)%P DATA ITOE(082) /216/ # (121)%Q DATA ITOE(083) /217/ # (122)%R DATA ITOE(084) /226/ # (123)%S DATA ITOE(085) /227/ # (124)%T DATA ITOE(086) /228/ # (125)%U DATA ITOE(087) /229/ # (126)%V DATA ITOE(088) /230/ # (127)%W DATA ITOE(089) /231/ # (130)%X DATA ITOE(090) /232/ # (131)%Y DATA ITOE(091) /233/ # (132)%Z DATA ITOE(092) /173/ # (133)%[ DATA ITOE(093) /156/ # (134)%\ DATA ITOE(094) /189/ # (135)%] DATA ITOE(095) /095/ # (136)%^ DATA ITOE(096) /109/ # (137)%_ DATA ITOE(097) /121/ # (140)%@ DATA ITOE(098) /129/ # (141)%A DATA ITOE(099) /130/ # (142)%B DATA ITOE(100) /131/ # (143)%C DATA ITOE(101) /132/ # (144)%D DATA ITOE(102) /133/ # (145)%E DATA ITOE(103) /134/ # (146)%F DATA ITOE(104) /135/ # (147)%G DATA ITOE(105) /136/ # (150)%H DATA ITOE(106) /137/ # (151)%I DATA ITOE(107) /145/ # (152)%J DATA ITOE(108) /146/ # (153)%K DATA ITOE(109) /147/ # (154)%L DATA ITOE(110) /148/ # (155)%M DATA ITOE(111) /149/ # (156)%N DATA ITOE(112) /150/ # (157)%O DATA ITOE(113) /151/ # (160)%P DATA ITOE(114) /152/ # (161)%Q DATA ITOE(115) /153/ # (162)%R DATA ITOE(116) /162/ # (163)%S DATA ITOE(117) /163/ # (164)%T DATA ITOE(118) /164/ # (165)%U DATA ITOE(119) /165/ # (166)%V DATA ITOE(120) /166/ # (167)%W DATA ITOE(121) /167/ # (170)%X DATA ITOE(122) /168/ # (171)%Y DATA ITOE(123) /169/ # (172)%Z DATA ITOE(124) /139/ # (173)%< DATA ITOE(125) /079/ # (174)%\ DATA ITOE(126) /155/ # (175)%! DATA ITOE(127) /161/ # (176)%^ DATA ITOE(128) /007/ # (177) DATA ITOE(129) /008/ # (200) DATA ITOE(130) /009/ # (201) DATA ITOE(131) /010/ # (202) DATA ITOE(132) /019/ # (203) DATA ITOE(133) /020/ # (204) DATA ITOE(134) /021/ # (205) DATA ITOE(135) /026/ # (206) DATA ITOE(136) /027/ # (207) DATA ITOE(137) /028/ # (210) DATA ITOE(138) /030/ # (211) DATA ITOE(139) /032/ # (212) DATA ITOE(140) /033/ # (213) DATA ITOE(141) /035/ # (214) DATA ITOE(142) /036/ # (215) DATA ITOE(143) /037/ # (216) DATA ITOE(144) /040/ # (217) DATA ITOE(145) /041/ # (220) DATA ITOE(146) /042/ # (221) DATA ITOE(147) /043/ # (222) DATA ITOE(148) /044/ # (223) DATA ITOE(149) /048/ # (224) DATA ITOE(150) /049/ # (225) DATA ITOE(151) /050/ # (226) DATA ITOE(152) /051/ # (227) DATA ITOE(153) /052/ # (230) DATA ITOE(154) /054/ # (231) DATA ITOE(155) /056/ # (232) DATA ITOE(156) /057/ # (233) DATA ITOE(157) /058/ # (234) DATA ITOE(158) /059/ # (235) DATA ITOE(159) /062/ # (236) DATA ITOE(160) /065/ # (237) DATA ITOE(161) /066/ # (240) DATA ITOE(162) /067/ # (241) DATA ITOE(163) /068/ # (242) DATA ITOE(164) /069/ # (243) DATA ITOE(165) /070/ # (244) DATA ITOE(166) /071/ # (245) DATA ITOE(167) /072/ # (246) DATA ITOE(168) /073/ # (247) DATA ITOE(169) /074/ # (250) DATA ITOE(170) /081/ # (251) DATA ITOE(171) /082/ # (252) DATA ITOE(172) /083/ # (253) DATA ITOE(173) /084/ # (254) DATA ITOE(174) /085/ # (255) DATA ITOE(175) /086/ # (256) DATA ITOE(176) /087/ # (257) DATA ITOE(177) /088/ # (260) DATA ITOE(178) /089/ # (261) DATA ITOE(179) /098/ # (262) DATA ITOE(180) /099/ # (263) DATA ITOE(181) /100/ # (264) DATA ITOE(182) /101/ # (265) DATA ITOE(183) /102/ # (266) DATA ITOE(184) /103/ # (267) DATA ITOE(185) /104/ # (270) DATA ITOE(186) /105/ # (271) DATA ITOE(187) /106/ # (272) DATA ITOE(188) /112/ # (273) DATA ITOE(189) /113/ # (274) DATA ITOE(190) /114/ # (275) DATA ITOE(191) /115/ # (276) DATA ITOE(192) /116/ # (277) DATA ITOE(193) /117/ # (300) DATA ITOE(194) /118/ # (301) DATA ITOE(195) /119/ # (302) DATA ITOE(196) /120/ # (303) DATA ITOE(197) /128/ # (304) DATA ITOE(198) /138/ # (305) DATA ITOE(199) /140/ # (306) DATA ITOE(200) /141/ # (307) DATA ITOE(201) /142/ # (310) DATA ITOE(202) /143/ # (311) DATA ITOE(203) /144/ # (312) DATA ITOE(204) /154/ # (313) DATA ITOE(205) /157/ # (314) DATA ITOE(206) /158/ # (315) DATA ITOE(207) /159/ # (316) DATA ITOE(208) /160/ # (317) DATA ITOE(209) /170/ # (320) DATA ITOE(210) /171/ # (321) DATA ITOE(211) /172/ # (322) DATA ITOE(212) /174/ # (323) DATA ITOE(213) /175/ # (324) DATA ITOE(214) /176/ # (325) DATA ITOE(215) /177/ # (326) DATA ITOE(216) /178/ # (327) DATA ITOE(217) /179/ # (330) DATA ITOE(218) /180/ # (331) DATA ITOE(219) /181/ # (332) DATA ITOE(220) /182/ # (333) DATA ITOE(221) /183/ # (334) DATA ITOE(222) /184/ # (335) DATA ITOE(223) /185/ # (336) DATA ITOE(224) /186/ # (337) DATA ITOE(225) /187/ # (340) DATA ITOE(226) /188/ # (341) DATA ITOE(227) /190/ # (342) DATA ITOE(228) /191/ # (343) DATA ITOE(229) /192/ # (344) DATA ITOE(230) /202/ # (345) DATA ITOE(231) /203/ # (346) DATA ITOE(232) /204/ # (347) DATA ITOE(233) /205/ # (350) DATA ITOE(234) /206/ # (351) DATA ITOE(235) /207/ # (352) DATA ITOE(236) /208/ # (353) DATA ITOE(237) /218/ # (354) DATA ITOE(238) /219/ # (355) DATA ITOE(239) /220/ # (356) DATA ITOE(240) /221/ # (357) DATA ITOE(241) /222/ # (360) DATA ITOE(242) /223/ # (361) DATA ITOE(243) /224/ # (362) DATA ITOE(244) /225/ # (363) DATA ITOE(245) /234/ # (364) DATA ITOE(246) /235/ # (365) DATA ITOE(247) /236/ # (366) DATA ITOE(248) /237/ # (367) DATA ITOE(249) /238/ # (370) DATA ITOE(250) /239/ # (371) DATA ITOE(251) /250/ # (372) DATA ITOE(252) /251/ # (373) DATA ITOE(253) /252/ # (374) DATA ITOE(254) /253/ # (375) DATA ITOE(255) /254/ # (376) DATA ITOE(256) /255/ # (377) END #-H- MBOOT 56521 1980 103 2146 CALL PARSE CALL EXIT STOP END BLOCK DATA COMMON /CRATIO/ FDTAB(8), FILTAB(1120), EXTCHR(96), INTCHR(96) INTEGER FDTAB INTEGER FILTAB INTEGER EXTCHR INTEGER INTCHR DATA FDTAB(1) /1/ DATA FILTAB(1), FILTAB(2), FILTAB(3), FILTAB(4), FILTAB(5)/ 1, 0, *0, 5, 0/ DATA FDTAB(2) /141/ DATA FILTAB(141), FILTAB(142), FILTAB(143), FILTAB(144), FILTAB(14 *5)/ 1, 1, 0, 6, 146/ DATA FDTAB(3) /281/ DATA FILTAB(281), FILTAB(282), FILTAB(283), FILTAB(284), FILTAB(28 *5)/ 1, 1, 0, 6, 286/ DATA FDTAB(4) /0/ DATA FILTAB(421) /0/ DATA FDTAB(5) /0/ DATA FILTAB(561) /0/ DATA FDTAB(6) /0/ DATA FILTAB(701) /0/ DATA FDTAB(7) /0/ DATA FILTAB(841) /0/ DATA FDTAB(8) /0/ DATA FILTAB(981) /0/ DATA EXTCHR( 1) /1H /, INTCHR( 1) /32/ DATA EXTCHR( 2) /1H0/, INTCHR( 2) /48/ DATA EXTCHR( 3) /1H1/, INTCHR( 3) /49/ DATA EXTCHR( 4) /1H2/, INTCHR( 4) /50/ DATA EXTCHR( 5) /1H3/, INTCHR( 5) /51/ DATA EXTCHR( 6) /1H4/, INTCHR( 6) /52/ DATA EXTCHR( 7) /1H5/, INTCHR( 7) /53/ DATA EXTCHR( 8) /1H6/, INTCHR( 8) /54/ DATA EXTCHR( 9) /1H7/, INTCHR( 9) /55/ DATA EXTCHR(10) /1H8/, INTCHR(10) /56/ DATA EXTCHR(11) /1H9/, INTCHR(11) /57/ DATA EXTCHR(12) /1HA/, INTCHR(12) /97/ DATA EXTCHR(13) /1HB/, INTCHR(13) /98/ DATA EXTCHR(14) /1HC/, INTCHR(14) /99/ DATA EXTCHR(15) /1HD/, INTCHR(15) /100/ DATA EXTCHR(16) /1HE/, INTCHR(16) /101/ DATA EXTCHR(17) /1HF/, INTCHR(17) /102/ DATA EXTCHR(18) /1HG/, INTCHR(18) /103/ DATA EXTCHR(19) /1HH/, INTCHR(19) /104/ DATA EXTCHR(20) /1HI/, INTCHR(20) /105/ DATA EXTCHR(21) /1HJ/, INTCHR(21) /106/ DATA EXTCHR(22) /1HK/, INTCHR(22) /107/ DATA EXTCHR(23) /1HL/, INTCHR(23) /108/ DATA EXTCHR(24) /1HM/, INTCHR(24) /109/ DATA EXTCHR(25) /1HN/, INTCHR(25) /110/ DATA EXTCHR(26) /1HO/, INTCHR(26) /111/ DATA EXTCHR(27) /1HP/, INTCHR(27) /112/ DATA EXTCHR(28) /1HQ/, INTCHR(28) /113/ DATA EXTCHR(29) /1HR/, INTCHR(29) /114/ DATA EXTCHR(30) /1HS/, INTCHR(30) /115/ DATA EXTCHR(31) /1HT/, INTCHR(31) /116/ DATA EXTCHR(32) /1HU/, INTCHR(32) /117/ DATA EXTCHR(33) /1HV/, INTCHR(33) /118/ DATA EXTCHR(34) /1HW/, INTCHR(34) /119/ DATA EXTCHR(35) /1HX/, INTCHR(35) /120/ DATA EXTCHR(36) /1HY/, INTCHR(36) /121/ DATA EXTCHR(37) /1HZ/, INTCHR(37) /122/ DATA EXTCHR(38) /1HA/, INTCHR(38) /65/ DATA EXTCHR(39) /1HB/, INTCHR(39) /66/ DATA EXTCHR(40) /1HC/, INTCHR(40) /67/ DATA EXTCHR(41) /1HD/, INTCHR(41) /68/ DATA EXTCHR(42) /1HE/, INTCHR(42) /69/ DATA EXTCHR(43) /1HF/, INTCHR(43) /70/ DATA EXTCHR(44) /1HG/, INTCHR(44) /71/ DATA EXTCHR(45) /1HH/, INTCHR(45) /72/ DATA EXTCHR(46) /1HI/, INTCHR(46) /73/ DATA EXTCHR(47) /1HJ/, INTCHR(47) /74/ DATA EXTCHR(48) /1HK/, INTCHR(48) /75/ DATA EXTCHR(49) /1HL/, INTCHR(49) /76/ DATA EXTCHR(50) /1HM/, INTCHR(50) /77/ DATA EXTCHR(51) /1HN/, INTCHR(51) /78/ DATA EXTCHR(52) /1HO/, INTCHR(52) /79/ DATA EXTCHR(53) /1HP/, INTCHR(53) /80/ DATA EXTCHR(54) /1HQ/, INTCHR(54) /81/ DATA EXTCHR(55) /1HR/, INTCHR(55) /82/ DATA EXTCHR(56) /1HS/, INTCHR(56) /83/ DATA EXTCHR(57) /1HT/, INTCHR(57) /84/ DATA EXTCHR(58) /1HU/, INTCHR(58) /85/ DATA EXTCHR(59) /1HV/, INTCHR(59) /86/ DATA EXTCHR(60) /1HW/, INTCHR(60) /87/ DATA EXTCHR(61) /1HX/, INTCHR(61) /88/ DATA EXTCHR(62) /1HY/, INTCHR(62) /89/ DATA EXTCHR(63) /1HZ/, INTCHR(63) /90/ DATA EXTCHR(64) /1H!/, INTCHR(64) /33/ DATA EXTCHR(65) /1H"/, INTCHR(65) /34/ DATA EXTCHR(66) /1H#/, INTCHR(66) /35/ DATA EXTCHR(67) /1H$/, INTCHR(67) /36/ DATA EXTCHR(68) /1H%/, INTCHR(68) /37/ DATA EXTCHR(69) /1H&/, INTCHR(69) /38/ DATA EXTCHR(70) /1H'/, INTCHR(70) /39/ DATA EXTCHR(71) /1H(/, INTCHR(71) /40/ DATA EXTCHR(72) /1H)/, INTCHR(72) /41/ DATA EXTCHR(73) /1H*/, INTCHR(73) /42/ DATA EXTCHR(74) /1H+/, INTCHR(74) /43/ DATA EXTCHR(75) /1H,/, INTCHR(75) /44/ DATA EXTCHR(76) /1H-/, INTCHR(76) /45/ DATA EXTCHR(77) /1H./, INTCHR(77) /46/ DATA EXTCHR(78) /1H//, INTCHR(78) /47/ DATA EXTCHR(79) /1H:/, INTCHR(79) /58/ DATA EXTCHR(80) /1H;/, INTCHR(80) /59/ DATA EXTCHR(81) /1H/, INTCHR(83) /62/ DATA EXTCHR(84) /1H?/, INTCHR(84) /63/ DATA EXTCHR(85) /1H@/, INTCHR(85) /64/ DATA EXTCHR(86) /1H[/, INTCHR(86) /91/ DATA EXTCHR(87) /1H\/, INTCHR(87) /92/ DATA EXTCHR(88) /1H]/, INTCHR(88) /93/ DATA EXTCHR(89) /1H_/, INTCHR(89) /95/ DATA EXTCHR(90) /1H,NWORDS]+1 %PUSHJ%P,QQALLC##%; ALLOCATE THE BLOCK %POP%P,A%%; RESTORE A %CAMN%R,[-1]%%; ERROR? % POPJ%P,%%; COULD NOT ALLOCATE %AOS%(P)%%; GIVE SKIP RETURN %HRL%C,R%%; SAVE RESULT %CLEARM%@R%%; CLEAR BUFFER AREA %HRL%R,R %ADDI%R,1 %HLR%C,R %ADD%C,NWORDS%; POINT TO END %BLT%R,-1(C)%%; ZAP %HLRZS%C%%; RESET RESULT %MOVE%R,C%%; RETURN RESULT IN R TOO %POPJ%P,%%; RETURN, MAY SKIP RELOC NWORDS:%BLOCK%1 RELOC END #-H- ALLOC.RAT 149 1980 103 2148 # ALLOC(N) - ALLOCATE N WORDS, RETURN ADDRESS OF FIRST WORD INTEGER FUNCTION ALLOC(N) INTEGER N INTEGER QQALLC RETURN(QQALLC(N)) END #-H- AMOVE.MAC 1054 1980 103 2148 SEARCH%IOPARM TITLE.%AMOVE ; AMOVE(NAME1:STRING,NAME2:STRING) -- DELETE NAME2 AND RENAME NAME1 ; TO NAME2. ; AMOVE::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %PUSH%P,A%%; SAVE ARGUMENT LIST POINTER %ADDI%A,1%%; POINT TO NAME2 %PUSHJ%P,REMOVE##%; DELETE NAME2 %MOVE%A,0(P)%%; RESTORE ARGUMENT LIST %MOVEI%T1,@0(A)%; POINT TO NAME1 %MOVEM%T1,NAMPTR %MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1 %PUSHJ%P,QQPARS##%; PARSE THE FILE SPEC %POP%P,A%%; RESTORE A %CAMN%R,[ERR]%%; DIE ON ERROR % POPJ%P, %CLEARM%OPNBK$%%; CLEAR OTHER WORDS IN OPNBK$ %CLEARM%OPNBK$+2 %OPEN.%0,OPNBK$ % JRST%$99%%; CAN'T OPEN %LOOKUP%0,UUOBK$## % JRST%$99%%; CAN'T FIND %PUSH%P,A%%; SAVE A AGAIN %MOVEI%T1,@1(A)%; POINT TO NAME2 %MOVEM%T1,NAMPTR %MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1 %PUSHJ%P,QQPARS%; PARSE IT %POP%P,A%%; RESTORE A %CAMN%R,[ERR]%%; DIE ON ERROR % JRST%$99 %RENAME%0,UUOBK$ % SKIPA%%%; OOPS %TDZA%R,R%%; INDICATE SUCCESS $99:%MOVE%R,[ERR]%%; INDICATE ERROR %RELEAS%0,0%%; RELEASE CHANNEL %POPJ%P,%%; RETURN RELOC NAMPTR:%BLOCK%1 RELOC END #-H- ARG.MAC 94 1980 103 2148 SEARCH%IOPARM TITLE.%ARG ; ARG(I:INT):ADDR -- RETURN ADDRESS OF ARGUMENT I ; ARG==QQARG## END #-H- CALLOC 176 1980 103 2148 COMMON /CALLOC/ LOWPAG, MEMOFF, MEM(1) INTEGER LOWPAG%# LOWEST PAGE ALLOCATED SO FAR INTEGER MEMOFF%# OFFSET FOR INDICES INTO MEM INTEGER MEM%%# USED TO ACCESS MEMORY #-H- CARGS 666 1980 103 2148 COMMON /CARGS/ TTYFLG, RUNPTR, INPTR, OUTPTR, ERRPTR, NARGS, ARGPTR, MEMOFF, MEM(1), PEEK, NMETA INTEGER TTYFLG%# NO IF NO COMMAND LINE WAS TYPED INTEGER RUNPTR%# POINTER TO NAME OF NEXT PROGRAM OR 0 INTEGER INPTR%# POINTER TO STANDARD INPUT NAME OR 0 INTEGER OUTPTR%# POINTER TO STANDARD OUTPUT NAME OR 0 INTEGER ERRPTR%# POINTER TO STANDARD ERROR NAME OR 0 INTEGER NARGS%# NUMBER OF ARGUMENTS INTEGER ARGPTR%# POINTER TO THE LIST OF ARGUMENTS INTEGER MEMOFF%# OFFSET FOR ADDRESSING MEMORY INTEGER MEM%%# USE TO ADDRESS MEMORY CHARACTER PEEK%# LOOKAHEAD CHARACTER FOR ATOK INTEGER NMETA%# COUNT OF META CHARACTERS IN AN ARGUMENT #-H- CIOSYS 346 1980 103 2148 COMMON /CIOSYS/ FDTAB(MAXFILES), FBKTAB(FBLEN, MAXFILES), OPNBLK(23) INTEGER FDTAB%# POINTERS TO FILE BLOCKS INTEGER FBKTAB%# FILE BLOCKS INTEGER OPNBLK%# FOR UUOS INTEGER UUOBLK(20)%# FOR LOOKUP AND ENTER UUOS INTEGER FILTAB(1)%# FOR SINGLE-DIMENSION ACCESS TO FBKTAB EQUIVALENCE (FBKTAB(1), FILTAB(1)), (OPNBLK(4), UUOBLK(1)) #-H- CLOSE.RAT 591 1980 103 2148 INCLUDE RATDEF INCLUDE IODEFS # CLOSE - CLOSE FILE FD SUBROUTINE CLOSE(FD) INTEGER FD INTEGER I, JUNK INTEGER QQCLS INCLUDE CIOSYS I = FDTAB(FD+1) FDTAB(FD+1) = 0 # MARK DESCRIPTOR FREE IF (I == 0)%# PERMIT CLOSE ON UNOPENED FILES RETURN FILTAB(I+USECNT) = FILTAB(I+USECNT) - 1 # DECREMENT USE COUNT IF (FILTAB(I+USECNT) == 0) < # CLOSE FILE IF NECESSARY JUNK = QQCLS(FILTAB(I+MAJOR), FILTAB(I+MINOR), FILTAB(I+USECNT)) FILTAB(I+MAJOR) = 0 # CLEAR RELEVANT FIELDS FILTAB(I+MINOR) = 0 FILTAB(I+CHANNEL) = 0 ! RETURN END #-H- CNTRL.MAC 373 1980 103 2148 SEARCH%IOPARM TITLE.%CNTRL ; CNTRL(FD,FCT,VALUE) - PERFORM CONTROL FUNCTION ON FD. ; CNTRL::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVE%F,@0(A)%%; POINT TO FILE BLOCK %MOVE%F,FDTAB$##(F) %MOVEI%F,FLTAB$##-1(F) %MOVE%T1,@1(A)%; GET FUNCTION CODE %MOVE%T2,@2(A)%; GET VALUE %MOVE%C,MAJOR(F)%; GET MAJOR DEVICE NUMBER %JRST%@CNSW$##(C)%; SWITCH TO PROPER CONTROL ROUTINE END #-H- COMMAN.RAT 2088 1980 103 2148 INCLUDE RATDEF DEFINE(MAXARG,60) # COMMAN - READ DEC10 COMMAND STRING FROM FILE FD INTEGER FUNCTION COMMAN(FD, NIARGS, NOARGS) INTEGER FD, NIARGS, NOARGS INTEGER I, NLPAR, P INTEGER LOC, ALLOC, LENGTH, GETCH CHARACTER C, ARG(MAXARG) INCLUDE CARGS MEMOFF = 1 - LOC(MEM(1))%# GET ADDRESSING OFFSET NARGS = 0 NOARGS = -1 ARG(1) = DQUOTE P = ARGPTR MEM(P+MEMOFF) = 0%# BREAK LINK TO PREVIOUS ARGUMENTS REPEAT < NLPAR = 0 FOR (I = 1; GETCH(C, FD) ^= EOF; I = I + 1) < # GET AN ARGUMENT IF (C == NEWLINE & I > 1) IF (ARG(I-1) == MINUS) <%# CONTINUATION I = I - 2 NEXT ! IF (I >= MAXARG) < CALL REMARK("ARGUMENT TOO LONG.") RETURN(ERR) ! ARG(I) = C IF (C == LPAREN \ C == LBRACK) NLPAR = NLPAR + 1 ELSE IF (C == RPAREN \ C == RBRACK) < NLPAR = NLPAR - 1 IF (NLPAR < 0) < CALL REMARK("MISSING LEFT PAREN OR BRACKET.") RETURN(ERR) ! ! IF (C == NEWLINE \ C == EQUALS \ (C == COMMA & NLPAR == 0)) BREAK ! IF (NLPAR ^= 0) < CALL REMARK("MISSING RIGHT PAREN OR BRACKET.") RETURN(ERR) ! IF (I == 1 & (C == EOF \ C == NEWLINE)) BREAK ARG(I) = DQUOTE ARG(I+1) = EOS I = ALLOC(LENGTH(ARG) + 3) IF (I == -1) < CALL REMARK("TOO MANY ARGUMENTS.") RETURN(ERR) ! CALL SCOPY(ARG, 1, MEM, I + MEMOFF + 2) NARGS = NARGS + 1 IF (C == EQUALS) IF (NOARGS == -1) NOARGS = NARGS ELSE < CALL REMARK("MULTIPLE OUTPUT SPECIFICATIONS NOT ALLOWED.") RETURN(ERR) ! MEM(P+MEMOFF) = I MEM(I+MEMOFF) = 0 MEM(I+MEMOFF+1) = DQUOTE P = I ! UNTIL (C == NEWLINE \ C == EOF) IF (NOARGS == -1) < NOARGS = 0 NIARGS = NARGS ! ELSE NIARGS = NARGS - NOARGS RETURN(NARGS) END #-H- CON.MAC 244 1980 103 2148 SEARCH%IOPARM TITLE.%CON ; CON(A:ADDR):INTEGER -- RETURN CONTENTS OF CELL AT ADDRESS A. ; CON:: MOVE 1,@0(16) ; POINT AT DESIRED CELL MOVE R,0(1) ; FETCH DESIRED CELL POPJ P, ; RETURN END #-H- CREATE.RAT 255 1980 103 2148 INCLUDE RATDEF INCLUDE IODEFS # CREATE - CREATE FILE NAME AND OPEN ACCORDING TO MODE INTEGER FUNCTION CREATE(NAME, MODE) CHARACTER NAME(ARB) INTEGER MODE INTEGER QQOPEN, FD EXTERNAL QQCRT FD = QQOPEN(QQCRT, NAME, MODE) RETURN (FD) END #-H- CTOSIX.RAT 457 1980 103 2148 INCLUDE RATDEF # CTOSIX - RETURN SIXBIT PACKED REPRESENTATION OF NAME INTEGER FUNCTION CTOSIX(NAME) CHARACTER NAME(ARB) INTEGER SHIFT CTOSIX = 0 FOR(I = 1; I <= 6 & NAME(I) ^= EOS; I = I + 1) IF (NAME(I) >= LETA & NAME(I) <= LETZ) CTOSIX = SHIFT(CTOSIX, 6) + NAME(I) - LETA + BIGA - BLANK ELSE CTOSIX = SHIFT(CTOSIX, 6) + NAME(I) - BLANK FOR (; I <= 6; I = I + 1) CTOSIX = SHIFT(CTOSIX, 6) RETURN END #-H- DATE4.RAT 452 1980 103 2148 INCLUDE RATDEF # DATE4 - RETURN DATE, YEAR, TIME, & SECS IN D, Y, T, & S (DEC-10 VERSION) SUBROUTINE DATE4(D, Y, T, S) INTEGER D, Y, T, S INTEGER GETTAB D = 100*GETTAB(9, 47) + GETTAB(9, 48) # RETURN DATE AS MMDD INTEGER Y = GETTAB(9, 46) # RETURN YEAR AS INTEGER (E.G. 1978) T = 100*GETTAB(9, 49) + GETTAB(9, 50) # RETURN TIME AS HHMM INTEGER S = GETTAB(9, 51) # RETURN SECONDS AS INTEGER (E.G. 56) RETURN END #-H- DELARG.RAT 368 1980 103 2148 INCLUDE RATDEF # DELARG - DELETE ARGUMENT N FROM COMMAND STRING SUBROUTINE DELARG(N) INTEGER N, I, J INCLUDE CARGS IF (N > NARGS \ N <= 0) RETURN J = ARGPTR%# WALK DOWN LIST TO PROPER ARGUMENT FOR (I = 0; I < N; I = I + 1) < K = J J = MEM(J+MEMOFF) ! MEM(K+MEMOFF) = MEM(J+MEMOFF) NARGS = NARGS - 1 RETURN END #-H- DEV.MAC 4483 1980 103 2148 TITLE%DEV - GENERAL DEVICE DRIVER SEARCH%IOPARM TWOSEG ENTRY%DEVOP$, DEVCL$, DEVRD$, DEVWR$ RELOC%400000 PHASE%%; DEV BLOCK LAYOUT DEVBUF:%BLOCK%1%%; # BUFFERS,,BUFFER ADDRESS DEVBHD:%BLOCK%3%%; BUFFER HEADER DEVBFR:%%%%; ACTUAL BUFFER IN SOME CASES DEVLEN==. DEPHASE RELOC%400000 ; DEVOP$ - OPEN A DEVICE; FOR OTHER THAN MAJOR DEVICE 0, EXPECTS ; SIZE,,BUFFER ADDRESS IN DEVPTR(F); DEVPTR(F) = 0 CAUSES DEFAULT ; BUFFER SPACE TO BE ALLOCATED. ; DEVOP$:%SKIPN%MAJOR(F)%; MAJOR DEVICE 0? % CLEARM%DEVPTR(F)%; YES, ALLOCATE BUFFERS %SKIPE%DEVPTR(F)%; BUFFER ADDRESS SPECIFIED? % JRST%$1%%; YES, USING THIS DRIVER INDIRECTLY %MOVEI%T2,OPNBK$##%; POINT TO OPEN BLOCK %DEVSIZ%T2,%%; GET BUFFER SIZE % JRST%$99%%; FAILED %JUMPLE%T2,$99%%; SO DO FUNNY DEVICES %HLRZ%Z,T2%%; COMPUTE TOTAL SPACE REQUIRED %IMULI%Z,(T2) %ADDI%Z,DEVLEN%; ADD IN DEV BLOCK OVERHEAD %PUSHJ%P,ALCBK$##%; GET THE CORE % JRST%$99%%; LOSER %MOVEI%Z,DEVBFR(C)%; POINT TO BUFFER %MOVEM%Z,DEVBUF(C)%; STASH FOR LATER %HLLM%T2,DEVBUF(C)%; SAVE NUMBER OF BUFFERS %JRST%$2%%; MERGE BELOW $1:%MOVEI%Z,DEVLEN%; ALLOCATE A DEV BLOCK %PUSHJ%P,ALCBK$## % JRST%$99%%; FAILED %MOVE%Z,DEVPTR(F)%; GET BUFFER ADDRESS %MOVEM%Z,DEVBUF(C)%; SAVE IT %MOVEI%T2,OPNBK$##%; COMPUTE NUMBER OF BUFFERS REQUIRED %DEVSIZ%T2, % JRST%$98%%; FAILED OR NOT IMPLEMENTED %JUMPLE%T2,$98%%; STRANGE DEVICE? %HLRZ%Z,DEVBUF(C)%; GET SIZE OF BUFFER AREA %IDIVI%Z,(T2)%%; COMPUTE NUMBER OF BUFFERS %JUMPE%Z,$98%%; BUFFER AREA TOO SMALL %HRLM%Z,DEVBUF(C)%; SAVE FOR INBUF/OUTBUF UUOS $2:%PUSHJ%P,FDCHN$##%; FIND A CHANNEL %JUMPE%Z,$98%%; NONE AVAILABLE %MOVEM%Z,CHANNEL(F)%; STORE IN FILE BLOCK %LDB%T2,[MODEPTR]%; GET THE MODE %CAIE%T2,READ%%; READ? % JRST%$3%%; NO %MOVEI%Z,DEVBHD(C)%; POINT TO INPUT BUFFER HEADER %MOVEM%Z,OPNBK$+2%; STASH IN OPEN BLOCK %PUSHJ%P,XUUO$##%; DO THE OPEN %OPEN.%0,OPNBK$ % JRST%$98%%; OPEN FAILED %PUSHJ%P,XUUO$%%; DO A LOOKUP %LOOKUP%0,UUOBK$## % JRST%$97%%; LOOKUP FAILED %PUSH%P,.JBFF##%; FAKE .JBFF FOR BUFFER FORMATTING %HLRZ%T2,DEVBUF(C)%; GET NUMBER OF BUFFERS %HRRZ%Z,DEVBUF(C)%; GET BUFFER ADDRESS %MOVEM%Z,.JBFF %PUSHJ%P,XUUO$%%; FORMAT THE BUFFERS %INBUF%0,(T2) %POP%P,.JBFF%%; PUT BACK FIRST FREE %JRST%$5%%; MERGE BELOW FOR COMPLETION $3:%CAIE%T2,WRITE%; OPEN FOR WRITING? % JRST%$98%%; NO, BAD MODE %MOVSI%Z,DEVBHD(C)%; POINT TO OUTPUT BUFFER HEADER %MOVEM%Z,OPNBK$+2%; STASH IN OPEN BLOCK %PUSHJ%P,XUUO$%%; DO THE OPEN %OPEN.%0,OPNBK$ % JRST%$98%%; OPEN FAILED %PUSHJ%P,XUUO$%%; DO AN ENTER %ENTER%0,UUOBK$ % JRST%$97%%; ENTER FAILED %PUSH%P,.JBFF##%; FAKE .JBFF FOR BUFFER FORMATTING %HLRZ%T2,DEVBUF(C)%; GET NUMBER OF BUFFERS %HRRZ%Z,DEVBUF(C)%; GET BUFFER ADDRESS %MOVEM%Z,.JBFF %PUSHJ%P,XUUO$%%; FORMAT THE BUFFERS %OUTBUF%0,(T2) %POP%P,.JBFF%%; PUT BACK FIRST FREE %JRST%$5%%; MERGE BELOW FOR COMPLETION $5:%LDB%Z,[SIZEPTR]%; GET BYTE SIZE %DPB%Z,[POINT 6,DEVBHD+1(C),11]%; STASH IN BUFFER HEADER %HRRM%C,DEVPTR(F)%; SAVE DEV BLOCK ADDRESS FOR READ/WRITE %CLEAR%R,%%; RETURN SUCCESSFULLY %POPJ%P, $97:%PUSHJ%P,XUUO$%%; SOME ERROR, RELEASE THE CHANNEL %RELEAS%0,0 $98:%PUSHJ%P,FREBK$##%; RELEASE CORE $99:%MOVE%R,[ERR]%%; RETURN ERROR CODE %POPJ%P, ; DEVCL$ - CLOSE A DEVICE; FREES UP A DEVICE BLOCK. ; DEVCL$::PUSHJ%P,XUUO$%%; DO A CLOSE %CLOSE%0,0 %PUSHJ%P,XUUO$%%; AND A RELEASE %RELEAS%0,0 %HRRZ%C,DEVPTR(F)%; POINT TO DEVICE BLOCK %PUSHJ%P,FREBK$##%; FREE BLOCK %CLEAR%R,%%; INDICATE SUCCESS %POPJ%P,%%; RETURN ; DEVRD$ - READ FROM A DEVICE; POINTER TO STRING IN T1, MAX COUNT IN T2. ; DEVRD$::PUSH%P,T2%%; SAVE COUNT %MOVE%C,DEVPTR(F)%; POINT TO DEVICE BLOCK $8:%SOSGE%DEVBHD+2(C)%; DECREMENT AND TEST BYTE COUNT % JRST $10%%; GET A NEW BUFFER %ILDB%Z,DEVBHD+1(C)%; GET THE BYTE %IDPB%Z,T1%%; STASH THE BYTE %SOJG%T2,$8%%; LOOP BACK FOR MORE $9:%POP%P,R%%; GET BACK ORIGINAL COUNT %SUB%R,T2%%; COMPUTE NUMBER OF CHARACTERS READ %POPJ%P, $10:%PUSHJ%P,XUUO$%%; DO AN IN %IN%0,0 % JRST%$8%%; OK, GO ON %AOS%EOFFLAG(F)%; LIGHT EOF FLAG %CAME%T2,(P)%%; DID WE GET SOMETHING? % JRST%$9%%; YES, DON'T GIVE EOF YET %POP%P,R%%; NO, TOSS ORIGINAL COUNT %MOVE%R,[EOF]%%; GIVE A REAL EOF %POPJ%P,%%; RETURN ; DEVWR$ - WRITE TO A DEVICE; POINTER TO STRING IN T1, COUNT IN T2. ; DEVWR$::MOVE%C,DEVPTR(F)%; POINT TO DEVICE BLOCK $12:%SOSG%DEVBHD+2(C)%; DECREMENT AND TEST BYTE COUNT % JRST%$14%%; DUMP THE BUFFER $13:%ILDB%Z,T1%%; GET A BYTE %IDPB%Z,DEVBHD+1(C)%; DEPOSIT THE BYTE %SOJG%T2,$12%%; CONTINUE UNTIL DONE %POPJ%P,%%; RETURN $14:%PUSHJ%P,XUUO$%%; DO THE OUTPUT %OUTPUT%0,0 %JRST%$13%%; GO ON END #-H- DEVSW.MAC 1336 1980 103 2148 TITLE%DEVSW - I/O FUNCTION SWITCH TWOSEG RELOC%400000 SEARCH%IOPARM DEFINE DEVSW(Y),< ENTRY%Y Y:: ; CREATE OPEN CLOSE READ WRITE SEEK CNTRL X DEVOP$, DEVOP$, DEVCL$, DEVRD$, DEVWR$, NULDV$, NULDV$ ; 0 UNKNOWN DEVICE X NULDV$, NULDV$, NULDV$, NULDV$, NULDV$, NULDV$, NULDV$ ; 1 NULL DEVICE X MEMOP$, MEMOP$, MEMCL$, MEMRD$, MEMWR$, MEMSK$, NULDV$ ; 2 MEMORY X DSKCR$, DSKOP$, DSKCL$, DSKRD$, DSKWR$, DSKSK$, NULDV$ ; 3 DISK X MTAOP$, MTAOP$, DEVCL$, DEVRD$, DEVWR$, NULDV$, NULDV$ ; 4 MAGNETIC TAPE X TTYOP$, TTYOP$, TTYCL$, TTYRD$, TTYWR$, NULDV$, TTYCN$ ; 5 TERMINAL X LPTOP$, LPTOP$, DEVCL$, ERRDV$, DEVWR$, NULDV$, NULDV$ ; 6 LINE PRINTER X PTYOP$, PTYOP$, PTYCL$, PTYRD$, PTYWR$, NULDV$, NULDV$ ; 7 PSEUDO TERMINAL X TMPCR$, TMPOP$, TMPCL$, MEMRD$, MEMWR$, MEMSK$, NULDV$ ; 8 TEMP CORE > DEFINE X(A,B,C,D,E,F,G), DEVSW(CRSW$) DEFINE X(A,B,C,D,E,F,G), DEVSW(OPSW$) DEFINE X(A,B,C,D,E,F,G), DEVSW(CLSW$) DEFINE X(A,B,C,D,E,F,G), DEVSW(RDSW$) DEFINE X(A,B,C,D,E,F,G), DEVSW(WRSW$) DEFINE X(A,B,C,D,E,F,G), DEVSW(SKSW$) DEFINE X(A,B,C,D,E,F,G), DEVSW(CNSW$) PRGEND TITLE SEARCH%IOPARM TWOSEG RELOC%400000 ENTRY%NULDV$, ERRDV$ NULDV$::TDZA%R,R ERRDV$::MOVE%R,[ERR] %POPJ%P, FDTAB$=:CIOSYS## FLTAB$=:CIOSYS+MAXFILES OPNBK$=:FLTAB$+ UUOBK$=:OPNBK$+3 END #-H- DSK.MAC 8874 1980 103 2148 TITLE%DSK - DISK DRIVER SEARCH%IOPARM TWOSEG ENTRY%DSKCR$, DSKOP$, DSKCL$, DSKRD$, DSKWR$, DSKSK$, DSKGC$ RELOC%400000 PHASE%%; DSK BLOCK LAYOUT DSKSIZ:%BLOCK%1%%; LENGTH OF FILE IN BYTES DSKCNT:%BLOCK%1%%; NUMBER OF BYTES REMAINING IN BUFFER DSKREC:%BLOCK%1%%; RECORD # FOR CONTENTS OF CURRENT BUF. DSKPOS:%BLOCK%1%%; CURRENT POSITION IN FILE DSKMOD:%BLOCK%1%%; 1 IF CURRENT BUFFER HAS BEEN MODIFIED DSKPTR::BLOCK%1%%; BYTE POINTER DSKCSZ:%BLOCK%1%%; CLUSTER SIZE DSKBSZ:%BLOCK%1%%; BUFFER SIZE IN WORDS DSKBUF:%BLOCK%1%%; POINTER TO BUFFER DSKLEN==. DEPHASE RELOC%0 IOCMD:%BLOCK%2%%; FOR I/O COMMAND RELOC%400000 ; DSKCR$ - CREATE AND OPEN A FILE ; DSKCR$::MOVEI%Z,17%%; SET UP DUMP MODE %MOVEM%Z,OPNBK$## %OPEN.%0,OPNBK$%; OPEN FILE % JRST%$99%%; FAILED %HLLZS%Z,UUOBK$+3%; CLEAR ERROR IN UUOBK$ %ENTER%0,UUOBK$%; CREATE FILE % JRST%[RELEAS 0,0%; FAILED % JRST $99] %CLOSE%0,0%%; CLOSE & RELEASE FILE RELEAS%0,0 %HLLZS%UUOBK$+3%; CLEAR ERROR BITS %CLEARM%UUOBK$+4%; CLEAR PRIV BITS %MOVE%Z,UUOBK$+1%; GET PATH %TLNE%Z,-1%%; PATH? %CLEARM%Z,UUOBK$+1%; NO, USE DEFAULT %%%%; FALL INTO OPEN CODE ; DSKOP$ - OPEN A DISK FILE; SETS UP DEVICE DEPENDENT DATA ; DSKOP$::MOVEI%Z,DSKLEN%; ALLOCATE CORE FOR DISK BLOCK %PUSHJ%P,ALCBK$## % JRST%$99%%; NOT ENOUGH CORE %MOVEM%C,DEVPTR(F)%; SET DEVICE POINTER IN FILE BLOCK %PUSHJ%P,FDCHN$##%; FIND A FREE CHANNEL %JUMPE%Z,$98%%; NONE AVIALABLE %MOVEM%Z,CHANNEL(F)%; SAVE IN FILE BLOCK %MOVEI%Z,17%%; SET UP DUMP MODE %MOVEM%Z,OPNBK$## %PUSHJ%P,XUUO$##%; OPEN THE DISK %OPEN.%0,OPNBK$ % JRST%$98%%; FAILED %PUSHJ%P,XUUO$%%; LOOKUP THE FILE %LOOKUP%0,UUOBK$## % JRST%$97%%; FAILED %LDB%Z,[MODEPTR]%; GET OPEN MODE %CAIN%Z,READ%%; READ ONLY ? % JRST%$1%%; YES, DON'T ENTER %PUSHJ%P,XUUO$%%; ENTER FILE (OPENS IN UPDATE MODE) %ENTER%0,UUOBK$ % JRST%$97%%; FAILED $1:%MOVE%Z,UUOBK$+5%; COMPUTE FILE SIZE %IMUL%Z,BYTEPW(F) %MOVEM%Z,DSKSIZ(C) %CLEARM%DSKREC(C)%; INITIALIZE RECORD NUMBER %CLEARM%DSKPOS(C)%; INITIALIZE POSITION %CLEARM%DSKMOD(C)%; BUFFER NOT MODIFIED YET %MOVE%Z,CHANNEL(F)%; FIND CLUSTER SIZE %LSH%Z,-^D23 %MOVEM%Z,UUOBK$ %MOVE%Z,[6,,UUOBK$]%; GET DISK CHARACTERISTICS %DSKCHR%Z, % SKIPA%T1,[1_^D27]%; FAILED, USE DEFAULT %MOVE%T1,UUOBK$+5%; CLUSTER SIZE HIDDEN IN HERE %LSH%T1,-^D27 %MOVEM%T1,DSKCSZ(C)%; SAVE FOR LATER %IMULI%T1,200%%; COMPUTE BUFFER SIZE %MOVEM%T1,DSKBSZ(C)%; SAVE FOR LATER %MOVE%Z,T1 %PUSHJ%P,ALCBK$%; ALLOCATE CORE FOR BUFFER % JRST%$97%%; FAILED %MOVE%C,DEVPTR(F)%; POINT TO DISK BLOCK AGAIN %MOVEM%Z,DSKBUF(C)%; SAVE BUFFER POINTER %MOVE%Z,BYTEPW(F)%; COMPUTE BYTES PER BUFFER %IMUL%Z,DSKBSZ(C) %MOVEM%Z,DSKCNT(C)%; INITIALIZE COUNT %MOVE%Z,BYTEPTR(F)%; INITIALIZE BYTE POINTER %HRR%Z,DSKBUF(C) %MOVEM%Z,DSKPTR(C) %PUSHJ%P,GETBUF%; READ FIRST BUFFER %CLEAR%R,%%; NORMAL RETURN %POPJ%P, $97:%MOVE%C,DEVPTR(F)%; MAKE SURE WE POINT TO DISK BLOCK %PUSHJ%P,XUUO$ %RELEAS%0,0%%; RELEASE FILE $98:%PUSHJ%P,FREBK$##%; RELEASE CORE %CLEARM%DEVPTR(F)%; CLEAR DEVICE POINTER $99:%MOVE%R,[ERR]%%; ERROR RETURN %POPJ%P, ; DSKCL$ - CLOSE A DISK FILE; FREE UP DEVICE BLOCK ; DSKCL$::MOVE%C,DEVPTR(F)%; GET POINTER DISK BLOCK %PUSHJ%P,PUTBUF%; WRITE CURRENT BUFFER IF NECESSARY %PUSHJ%P,XUUO$%%; CLOSE DEVICE %CLOSE%0,0 %PUSHJ%P,XUUO$%%; RELEASE DEVICE CHANNEL %RELEAS%0,0 %MOVE%C,DSKBUF(C)%; FREE BUFFER SPACE %PUSHJ%P,FREBK$## %MOVE%C,DEVPTR(F)%; POINT TO DISK BLOCK AGAIN %CLEARM%DEVPTR(F)%; CLEAR DISK BLOCK POINTER %JRST%FREBK$##%; FREE CORE BLOCK AND RETURN ; DSKRD$ - READ FROM DISK; POINTER TO STRING IN T1, MAX COUNT IN T2 ; DSKRD$::MOVE%C,DEVPTR(F)%; POINT TO DISK FILE BLOCK %MOVE%Z,T2%%; INCREMENT AND CHECK POSITION %ADDB%Z,DSKPOS(C) %CAMLE%Z,DSKSIZ(C) % JRST%$3%%; GONE PAST END %HRL%C,T2%%; SAVE ORIGINAL COUNT $2:%SOSGE%DSKCNT(C)%; MORE IN THIS BUFFER? % JRST%[PUSHJ%P,REFRESH%; NO, GET NEXT BUFFER %% JRST%$2]%%; AND CONTINUE %ILDB%Z,DSKPTR(C)%; GET A BYTE %IDPB%Z,T1%%; STASH IT %SOJG%T2,$2%%; DECREMENT AND TEST COUNT %HLRZ%R,C%%; RETURN COUNT %POPJ%P,%%; RETURN $3:%SUB%T2,DSKPOS(C)%; COMPUTE NUMBER OF BYTES LEFT %ADD%T2,DSKSIZ(C) %MOVE%Z,DSKSIZ(C)%; RESET POSITION %MOVEM%Z,DSKPOS(C) %HRL%C,T2%%; SAVE NEW COUNT %JUMPG%T2,$2%%; READ UNLESS AT END %AOS%EOFFLAG(F)%; LIGHT EOF FLAG %MOVE%R,[EOF]%%; RETURN EOF INDICATOR %POPJ%P, ; DSKWR$ - WRITE TO DISK; POINTER TO STRING IN T1, MAX COUNT IN T2 ; DSKWR$::MOVE%C,DEVPTR(F)%; POINT TO DISK FILE BLOCK %MOVE%Z,T2%%; INCREMENT AND TEST POSITION %ADDB%Z,DSKPOS(C) %CAMLE%Z,DSKSIZ(C)%; PAST END? % MOVEM%Z,DSKSIZ(C)%; YES, UPDATE SIZE %SETOM%DSKMOD(C)%; NOTE BUFFER MODIFICATION $4:%SOSGE%DSKCNT(C)%; ANY ROOM LEFT? % JRST%[PUSHJ%P,REFRESH%; NO, DUMP CURRENT BUFFER %% JRST%$4-1]%%; CONTINUE %ILDB%Z,T1%%; GET A BYTE %IDPB%Z,DSKPTR(C)%; STASH IN BUFFER %SOJG%T2,$4%%; DECREMENT AND TEST COUNT %MOVE%R,@1(A)%%; RELOAD COUNT %POPJ%P,%%; RETURN ; DSKSK$ - SEEK, POSITION IN T1 ; DSKSK$::MOVE%C,DEVPTR(F)%; GET POINTER TO DISK BLOCK %SKIPGE%T1%%; -1 MEANS END OF FILE % MOVE%T1,DSKSIZ(C) %CAMLE%T1,DSKSIZ(C)%; WITHIN FILE? % JRST%$6%%; NO %MOVEM%T1,DSKPOS(C)%; RESET POSITION %CLEARM%EOFFLAG(F)%; CLEAR EOF FLAG %IDIV%T1,BYTEPW(F)%; T1=WORD IN FILE, T2=BYTE IN WORD %MOVE%Z,BYTEPTR(F)%; REBUILD BYTE POINTER %HRR%Z,DSKBUF(C) %MOVEM%Z,DSKPTR(C) %LDB%Z,[SIZEPTR]%; GET BYTE SIZE %IMULI%Z,(T2)%%; COMPUTE POSITION IN WORD %MOVNS%Z %ADDI%Z,^D36 %DPB%Z,[POINT 6,DSKPTR(C),5] %MOVNM%T2,DSKCNT(C)%; SAVE FOR COUNT COMPUTATION %IDIV%T1,DSKBSZ(C)%; T1=RECORD NUMBER, T2=WORD IN BUFFER %ADDM%T2,DSKPTR(C)%; COMPLETE BYTE POINTER %MOVE%Z,DSKBSZ(C)%; COMPUTE NEW BYTE COUNT %SUBI%Z,(T2) %IMUL%Z,BYTEPW(F) %ADDM%Z,DSKCNT(C)%; ADD TO -BYTE NUMBER IN COUNT FIELD %CAMN%T1,DSKREC(C)%; NEED TO READ NEW RECORD? % JRST%$5%%; NO %PUSHJ%P,PUTBUF%; YES, WRITE THIS ONE IF NECCESSARY %MOVEM%T1,DSKREC(C)%; SET NEW RECORD NUMBER %PUSHJ%P,GETBUF%; READ IT $5:%TDZA%R,R%%; INDICATE SUCCESS $6:%MOVE%R,[ERR]%%; BAD POSITION %POPJ%P,%%; RETURN ; DSKGC$ - SPECIAL INTERFACE FOR GETCH; IGNORES LINE NUMBERS ; DSKGC$::MOVE%C,DEVPTR(F)%; POINT TO DISK FILE BLOCK $7:%AOS%T1,DSKPOS(C)%; INCREMENT AND LOAD POSITION %CAMLE%T1,DSKSIZ(C) % JRST%$10%%; GONE PAST END $8:%SOSGE%DSKCNT(C)%; MORE IN THIS BUFFER? % JRST%[PUSHJ%P,REFRESH%; NO, GET NEXT BUFFER %% JRST%$8]%%; AND CONTINUE %ILDB%Z,DSKPTR(C)%; GET A CHARACTER %SKIPE%T1,@DSKPTR(C)%; GET WORD FROM BUFFER %TRNN%T1,1%%; SEQUENCE NUMBER? % JRST%$9%%; NOPE %AOS%DSKPTR(C)%; YES, BUMP POINTER %MOVEI%T1,5%%; SKIP 5 CHARACTERS %ADDM%T1,DSKPOS(C) %MOVNI%T1,5%%; DECREMENT COUNT %ADDB%T1,DSKCNT(C) %JUMPG%T1,$7%%; TRY AGAIN UNLESS AT END OF BUFFER %PUSHJ%P,REFRESH%; GET NEXT BUFFER %IBP%DSKPTR(C)%; BUMP POINTER PAST THE TAB %SOS%DSKCNT(C)%; AND ADJUST THE COUNT %JRST%$7%%; TRY AGAIN $9:%MOVE%T1,[X.SKP]%; GET SKIP BITS %LSH%T1,@R%%; SHIFT TO SIGN BIT %JUMPL%T1,$7%%; TRY AGAIN %MOVEM%R,@0(A)%%; STORE CHARACTER %POPJ%P, $10:%MOVE%Z,DSKSIZ(C)%; RESET POSITION %MOVEM%Z,DSKPOS(C) %AOS%EOFFLAG(F)%; LIGHT EOF FLAG %MOVE%R,[EOF]%%; RETURN EOF INDICATOR %MOVEM%R,@0(A)%%; RESET FIRST ARGUMENT %POPJ%P, ; REFRESH - DUMP CURRENT BUFFER AND READ NEXT RECORD. CALL IS ;%PUSHJ%P,REFRESH ; REFRESH:PUSHJ%P,PUTBUF%; WRITE CURRENT BUFFER IF NECESSARY %AOS%DSKREC(C)%; ADVANCE TO NEXT RECORD %MOVE%Z,BYTEPTR(F)%; REBUILD BYTE POINTER %HRR%Z,DSKBUF(C) %MOVEM%Z,DSKPTR(C) %MOVE%Z,BYTEPW(F)%; RESET COUNT %IMUL%Z,DSKBSZ(C) %MOVEM%Z,DSKCNT(C) %JRST%GETBUF%%; GET BUFFER AND RETURN ; GETBUF - GET BUFFER AT RECORD DSKREC ; GETBUF:%MOVN%Z,DSKBSZ(C)%; BUILD I/O COMMAND %HRLS%Z %HRR%Z,DSKBUF(C) %SUBI%Z,1 %MOVEM%Z,IOCMD %CLEARM%IOCMD+1 %MOVE%Z,DSKREC(C)%; COMPUTE BLOCK NUMBER IN FILE %IMUL%Z,DSKCSZ(C) %ADDI%Z,1 %PUSHJ%P,XUUO$%%; POSITION FOR INPUT %USETI%0,@Z %PUSHJ%P,XUUO$%%; READ BUFFER %INPUT%0,IOCMD %POPJ%P,%%; RETURN ; PUTBUF - WRITE CURRENT BUFFER AT DSKREC IF NECESSARY ; PUTBUF:%SKIPN%DSKMOD(C)%; MODIFIED? % POPJ%P,%%; NO %CLEARM%DSKMOD(C)%; YES, INDICATE CLEAN SLATE %PUSH%P,T1%%; SAVE T1 AND T2 %PUSH%P,T2 %MOVE%Z,DSKSIZ(C)%; COMPUTE LAST RECORD NUMBER %IDIV%Z,BYTEPW(F)%; Z=WORD IN FILE, T1=BYTE IN WORD %MOVE%T2,T1%%; SAVE FOR LATER ADJUSTMENT %IDIV%Z,DSKBSZ(C)%; Z=RECORD NUMBER, T1=WORD IN BUFFER %CAME%Z,DSKREC(C)%; WRITING LAST RECORD? % JRST%$11%%; NO %SKIPN%T2%%; YES, NEED TO ADJUST FOR ODD SIZE? % JRST%$12%%; NO %LDB%Z,[SIZEPTR]%; GET BYTE SIZE %IMUL%T2,Z%%; COMPUTE SHIFT AMOUNT %MOVNS%T2 %SETO%Z,%%; GET A BUNCH OF 1'S %LSH%Z,(T2)%%; SLIDE OVER A BIT %MOVE%T2,DSKBUF(C)%; POINT TO LAST WORD %ADD%T2,T1 %ANDCAM%Z,(T2)%%; CLEAR OUT TRAILING BITS IN LAST WORD %AOJA%T1,$12%%; ADJUST COUNT AND MERGE BELOW $11:%MOVE%T1,DSKBSZ(C)%; JUST USE BUFFER SIZE $12:%MOVNS%T1%%; BUILD I/O COMMAND %HRL%Z,T1 %HRR%Z,DSKBUF(C) %SUBI%Z,1 %MOVEM%Z,IOCMD %CLEARM%IOCMD+1 %MOVE%Z,DSKREC(C)%; COMPUTE BLOCK NUMBER IN FILE %IMUL%Z,DSKCSZ(C) %ADDI%Z,1 %PUSHJ%P,XUUO$%%; POSITION FOR OUTPUT %USETO%0,@Z %PUSHJ%P,XUUO$%%; WRITE THE BUFFER %OUTPUT%0,IOCMD %POP%P,T2%%; RESTORE T1 AND T2 %POP%P,T1 %POPJ%P,%%; RETURN END #-H- DUP.RAT 445 1980 103 2148 INCLUDE RATDEF INCLUDE IODEFS # DUP - DUPLICATE FILE DESCRIPTOR FD. INTEGER FUNCTION DUP(FD) INTEGER FD INTEGER I, J INCLUDE CIOSYS FOR (I = 1; I <= MAXFILES; I = I + 1) # FIND A FREE DESCRIPTOR IF (FDTAB(I) == 0) BREAK IF (I > MAXFILES) RETURN (ERR) FDTAB(I) = FDTAB(FD+1)%# POINT TO SAME FILE BLOCK J = FDTAB(I) FILTAB(J+USECNT) = FILTAB(J+USECNT) + 1%# BUMP REFERENCE COUNT RETURN (I-1) END #-H- ERROR.RAT 144 1980 103 2148 INCLUDE RATDEF # ERROR - PRINT FATAL ERROR MESSAGE, THEN DIE SUBROUTINE ERROR(BUF) INTEGER BUF(ARB) CALL REMARK(BUF) STOP END #-H- EXEC.RAT 133 1980 103 2148 INCLUDE RATDEF # EXEC - EXECUTE PROGRAM NAME SUBROUTINE EXEC(NAME) CHARACTER NAME(ARB) CALL RUN(NAME, 1) RETURN END #-H- EXECC.RAT 928 1980 103 2148 INCLUDE RATDEF # EXECC - EXECUTE COMMAND CMD SUBROUTINE EXECC(CMD) CHARACTER CMD(ARB) CHARACTER NAME(MAXNAME), C CHARACTER GETCH INTEGER FDI, FDO, I INTEGER GETWRD, OPEN, CREATE INCLUDE CARGS FDI = OPEN("TMP:ARG", READ) IF (FDI == ERR) FDI = CREATE("TMP:ARG", READ) FDO = CREATE("TMP:ARG", WRITE) IF (FDI == ERR \ FDO == ERR) RETURN I = 1 JUNK = GETWRD(CMD, I, NAME)%# GET THE COMMAND NAME CALL QQPUTS(FDO, NAME, 0) IF (INPTR ^= 0) CALL QQPUTS(FDO, " \0", MEM(INPTR+MEMOFF+2), 0) CALL QQPUTS(FDO, " \0", CMD(I), 0) IF (OUTPTR ^= 0) CALL QQPUTS(FDO, " \0", MEM(OUTPTR+MEMOFF+2), 0) IF (ERRPTR ^= 0) CALL QQPUTS(FDO, " \0", MEM(ERRPTR+MEMOFF+2), 0) IF (GETCH(C, FDI) ^= EOF) < CALL PUTCH(SEMICOL, FDO) CALL PUTCH(C, FDO) ! CALL FCOPY(FDI, FDO) CALL CLOSE(FDI) CALL CLOSE(FDO) CALL RUN(NAME, 1) RETURN END #-H- EXIT.MAC 97 1980 103 2148 SEARCH%IOPARM TITLE.%EXIT ; EXIT -- EXIT TO THE MONITOR. CLOSES ALL FILES. ; EXIT==QQEXIT## END #-H- FCANON.RAT 1317 1980 103 2148 INCLUDE RATDEF INCLUDE IODEFS DEFINE(DSK, 8%0446353) # FCANON - RETURN NAME1 IN NAME2 IN DEC-10 FILE SPEC FORM INTEGER FUNCTION FCANON(NAME1, NAME2) CHARACTER NAME1(ARB), NAME2(ARB) INTEGER QQPARS, SIXTOC, XTOC, SHIFT INTEGER I, J INCLUDE CIOSYS NAME2(1) = EOS IF (QQPARS(NAME1, OPNBLK, 9) == ERR) RETURN (ERR) I = 1 IF (OPNBLK(2) ^= 0 & OPNBLK(2) ^= SHIFT(DSK, 18)) <%# DEVICE I = I + 1 + SIXTOC(OPNBLK(2), NAME2(I), MAXNAME) NAME2(I-1) = COLON ! IF (OPNBLK(6) ^= 0)%%# NAME I = I + SIXTOC(OPNBLK(6), NAME2(I), MAXNAME) IF (OPNBLK(7) ^= 0) <%# EXTENSION NAME2(I) = PERIOD I = I + 1 + SIXTOC(OPNBLK(7), NAME2(I+1), MAXNAME) ! IF (OPNBLK(5) ^= 0) <%# PPN NAME2(I) = LBRACK I = I + 2 + XTOC(SHIFT(OPNBLK(9+7), -18), NAME2(I+1), MAXNAME, 8) NAME2(I-1) = COMMA I = I + 1 + XTOC(OPNBLK(9+7) & 8%0777777, NAME2(I), MAXNAME, 8) FOR (J = 9+8; OPNBLK(J) ^= 0; J = J + 1) < NAME2(I-1) = COMMA I = I + 1 + SIXTOC(OPNBLK(J), NAME2(I), MAXNAME) ! NAME2(I-1) = RBRACK ! IF (OPNBLK(8) ^= 0) <%# PROTECTION NAME2(I) = LESS I = I + 2 + XTOC(SHIFT(OPNBLK(8), -27), NAME2(I+1), MAXNAME, 8) NAME2(I-1) = GREATER ! NAME2(I) = EOS RETURN (I-1) END #-H- FDCHN.MAC 378 1980 103 2148 SEARCH%IOPARM TITLE.%FDCHN$ ; FDCHN$ -- FIND A CHANNEL; RETURNS 0 IF NONE AVAILABLE. FDCHN$::PUSH%P,T1%%; SAVE A REGISTER %MOVEI%R,17%%; START FROM TOP AND GO DOWN $1:%HRRZ%T1,R%%; COPY CHANNEL NUMBER %DEVNAM%T1,%%; IS THIS CHANNEL IN USE? % JRST%$2%%; NO %SOJG%R,$1%%; TRY ANOTHER ONE BUT DON'T USE 0 $2:%LSH%R,^D23%%; SHIFT TO RIGHT PLACE %POP%P,T1%%; RESTORE T1 %POPJ%P, END #-H- FREBK.MAC 311 1980 103 2148 SEARCH%IOPARM TITLE.%FREBK$ ; FREBK$ - I/O SYSTEM INTERFACE TO FREE TO FREE CORE. CALL IS ;%MOVE%C,POINTER TO BLOCK ;%PUSHJ%P,FREBK$ ; FREBK$::PUSHJ%P,SAVR$##%; SAVE THE WORLD %MOVEM%C,PTR%%; SET UP FOR CALL %MOVEI%A,[EXP <-1,,0>,PTR]+1 %JRST%QQFREE##%%; FREE THE BLOCK AND RETURN RELOC PTR:%BLOCK%1 RELOC END #-H- FREE.RAT 107 1980 103 2148 # FREE - FREE CORE POINTED TO BY P. SUBROUTINE FREE(P) INTEGER P CALL QQFREE(P) RETURN END #-H- FSIZEW.RAT 235 1980 103 2148 INCLUDE RATDEF # FSIZEW - SIZE OF FILE IN WORDS INTEGER FUNCTION FSIZEW(NAME) CHARACTER NAME(ARB) INTEGER FSTAT, INFO(4) IF (FSTAT(NAME, INFO, 4) == ERR) FSIZEW = -1 ELSE FSIZEW = INFO(4) RETURN END #-H- FSTAT.RAT 1422 1980 103 2148 INCLUDE RATDEF # FSTAT - RETURN INFORMATION ABOUT FILE NAME # A(1) = CREATION DATE, A(2) = CREATION YEAR, A(3) = CREATION TIME, # A(4) = WORDS WRITTEN, A(5) = PROTECTION, A(6) = ACCESS DATE, # A(7) = ACCESS YEAR, A(8) = BLOCKS ALLOCATED, A(9) = STATUS BITS INTEGER FUNCTION FSTAT(NAME, A, N) CHARACTER NAME(ARB) INTEGER A(ARB), N INTEGER BUF(45), ARG(30), D, T INTEGER SHIFT, MOD, QQPARS, LKPUUO EQUIVALENCE (BUF(5), ARG(1)) IF (QQPARS(NAME, BUF, 29) == ERR) RETURN(ERR) IF (LKPUUO(BUF) == ERR)%# GET RIB INFORMATION RETURN(ERR) IF (N >= 1) <%# A(1) = CREATION DATE D = SHIFT(SHIFT(ARG(3), -15) & 8%07, 12) + (ARG(4) & 8%07777) A(1) = 100*(MOD(D, 12*31)/31 + 1) + MOD(MOD(D, 12*31), 31) + 1 ! IF (N >= 2)%%# A(2) = CREATION YEAR A(2) = D/(12*31) + 1964 IF (N >= 3) <%# A(3) = CREATION TIME T = SHIFT(ARG(4), -12) & 8%03777 A(3) = 100*(T/60) + MOD(T, 60) ! IF (N >= 4)%%# A(4) = WORDS WRITTEN A(4) = ARG(5) IF (N >= 5)%%# A(5) = PROTECTION A(5) = SHIFT(ARG(4), -27) IF (N >= 6) <%# A(6) = ACCESS DATE D = ARG(3) & 8%077777 A(6) = 100*(MOD(D, 12*31)/31 + 1) + MOD(MOD(D, 12*31), 31) + 1 ! IF (N >= 7)%%# A(7) = ACCESS YEAR A(7) = D/(12*31) + 1964 IF (N >= 8)%%# A(8) = BLOCKS ALLOCATED A(8) = ARG(9) IF (N >= 9)%%# A(9) = STATUS BITS A(9) = ARG(15) RETURN(N) END #-H- GETARG.RAT 1071 1980 103 2148 INCLUDE RATDEF DEFINE(EFLAG,8%400000) # GETARG - GET ARGUMENT N FROM COMMAND STRING INTO ARRAY INTEGER FUNCTION GETARG(N, ARRAY, MAXSIZ) CHARACTER ARRAY(ARB) INTEGER N, MAXSIZ CHARACTER C INTEGER I, J, P INTEGER ESC INCLUDE CARGS ARRAY(1) = EOS IF (N == -1) GETARG = NARGS ELSE IF (N > NARGS \ N < 0) GETARG = EOF ELSE < J = ARGPTR%# WALK DOWN LIST TO PROPER ARGUMENT FOR (I = 0; I < N; I = I + 1) J = MEM(J+MEMOFF) C = EOS IF (MEM(J+MEMOFF+2) == DQUOTE \ MEM(J+MEMOFF+2) == SQUOTE) < C = MEM(J+MEMOFF+2) J = J + 1 ! FOR (I = 1; I < MAXSIZ; I = I + 1) < ARRAY(I) = MEM(J+MEMOFF+2) & ^EFLAG J = J + 1 IF (ARRAY(I) == C) BREAK ! ARRAY(I) = EOS IF (C == EOS) <%# EXPAND ESCAPES I = 1 FOR (J = 1; ARRAY(J) ^= EOS; J = J + 1) < ARRAY(I) = ESC(ARRAY, J) I = I + 1 ! ARRAY(I) = EOS ! GETARG = I - 1 ! RETURN END #-H- GETCH.MAC 958 1980 103 2148 SEARCH%IOPARM TITLE.%GETCH ; GETCH(C,F) - GET NEXT CHARACTER FROM F INTO C AND AS FUNCTION VALUE. ; IGNORES LINE NUMBERS ON DISK FILES. ; GETCH::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVE%F,@1(A)%%; POINT TO FILE BLOCK %MOVE%F,FDTAB$##(F) %MOVEI%F,FLTAB$##-1(F) %MOVE%Z,OPNMODE(F)%; GET MODE %TRNE%Z,1%%; OPEN FOR WRITE ONLY? % JRST%[MOVE%R,[ERR] %% JRST%$2]%; OPEN FOR WRITE ONLY %SKIPE%EOFFLAG(F) % JRST%[MOVE%R,[EOF] %% JRST%$2]%; PREVIOUS EOF SO RETURN %MOVEI%Z,^D3%%; DISK? %CAMN%Z,MAJOR(F) % JRST%DSKGC$##%; YES $1:%MOVEI%T1,@0(A)%; NO, JUST READ A CHARACTER %HRLI%T1,(POINT 36) %MOVEI%T2,1 %MOVE%C,MAJOR(F)%; GET DEVICE NUMBER %PUSHJ%P,@RDSW$##(C)%; READ A CHARACTER %CAME%R,[ERR]%%; ERROR OR EOF? %CAMN%R,[EOF] % JRST%$2%%; YES %JUMPE%R,$2%%; OR 0 CHARACTERS READ %MOVE%R,@0(A)%%; GET CHARACTER %MOVE%T1,[X.SKP]%; GET SKIP BITS %LSH%T1,@R %JUMPL%T1,$1%%; IGNORE THESE %POPJ%P,%%; RETURN $2:%MOVEM%R,@0(A)%%; STASH ERR OR EOF %POPJ%P,%%; RETURN END #-H- GETPPN.MAC 124 1980 103 2148 SEARCH%IOPARM TITLE.%GETPPN ; GETPPN(JUNK) - RETURNS PPN OF CURRENT JOB. ; GETPPN::CALLI%R,24%; GET PPN % JFCL %POPJ%P, END #-H- GETSW.RAT 598 1980 103 2148 INCLUDE RATDEF # GETSW - SEPARATE SWITCHES FROM FILE NAME IN ARG SUBROUTINE GETSW(ARG, SW1, NAME, SW2) CHARACTER ARG(MAXNAME), SW1(MAXNAME), NAME(MAXNAME), SW2(MAXNAME) INTEGER I CHARACTER C I = 1 CALL SKIPBL(ARG, I) J = 1 IF (ARG(I) == SLASH) < FOR (; ARG(I) ^= EOS & ARG(I) ^= BLANK & ARG(I) ^= TAB; J = J + 1) < SW1(J) = ARG(I) I = I + 1 ! ! SW1(J) = EOS FOR (J = 1; ARG(I) ^= EOS & ARG(I) ^= SLASH; J = J + 1) < NAME(J) = ARG(I) I = I + 1 ! CALL SCOPY(ARG, I, SW2, 1) NAME(J) = EOS RETURN END #-H- GETTAB.MAC 438 1980 103 2148 SEARCH%IOPARM TITLE.%GETTAB ; GETTAB(TABLE,INDEX,RESULT:INTEGER):INTEGER - DO A GETTAB UUO; VALUE IS ; RETURNED IN RESULT (IF PRESENT) AND AS FUNCTION VALUE. ; GETTAB::HRR%R,@0(A)%%; GET TABLE NUMBER %HRL%R,@1(A)%%; GET INDEX %CALLI%R,41%%; DO GETTAB % MOVE%R,[ERR]%%; SIGNAL ERROR %HLRE%T1,-1(A)%; GET NUMBER OF ARGUMENTS %CAMGE%T1,[-2]%%; IS THIRD ARGUMENT PRESENT? % MOVEM%R,@2(A)%%; YES, STORE RESULT THERE TOO %POPJ%P,%%; RETURN END #-H- GOBSTR.MAC 226 1980 103 2148 SEARCH%IOPARM TITLE.%GOBSTR ; GOBSTR(A:ARRAY,N:INTEGER):INTEGER -- DO A GOBSTR UUO. ; GOBSTR::HRL%Z,@1(A)%%; GET COUNT %HRRI%Z,@0(A)%%; POINT TO ARGUMENT BLOCK %CALLI%Z,66%%; DO IT % SKIPA %TDZA%Z,Z %MOVE%Z,[ERR] %POPJ%P, END #-H- HIBER.MAC 174 1980 103 2148 SEARCH%IOPARM TITLE.%HIBER ; HIBER(N) - DO HIBER UUO WITH ARGUMENT OF N. ; HIBER::%MOVE%Z,@0(A)%%; GET ARGUMENT %CALLI%Z,72%%; NIGHTY NITE % CLEAR%R,%%; MMMM... %POPJ%P, END #-H- INCHRW.MAC 214 1980 103 2148 SEARCH%IOPARM TITLE.%INCHRW ; INCHRW(C) -- READ NEXT CHARACTER FROM TTY; WAIT IF NECESSARY ; INCHRW::TTCALL%0,R%%; GET CHARACTER %MOVEM R,@0(16) ; STORE IN ARG POPJ P, ; RETURN END #-H- INMAP.MAC 215 1980 103 2148 SEARCH%IOPARM TITLE.%INMAP ; INMAP(C:A1 CHARACTER):CHAR -- CONVERT LEFT-JUSTIFIED CHARACTER TO ; ASCII EQUIVALENT. ; INMAP::%MOVE%R,@0(A)%%; LOAD WORD %LSH%R,-^D29%%; SHIFT TO RIGHMOST 7 BITS %POPJ%P,%%; RETURN END #-H- IODEFS 667 1980 103 2148 DEFINE(MAXFILES,16)%# NUMBER OF OPENED FILES PERMITTED # FILE BLOCK FORMAT DEFINE(USECNT,0)%# USE COUNT DEFINE(MAJOR,1)%%# MAJOR DEVICE NUMBER DEFINE(MINOR,2)%%# MINOR DEVICE NUMBER DEFINE(BYTEPTR,3)%# BYTE POINTER FOR I/O DEFINE(PACKPTR,4)%# BYTE POINTER TO CHECK FOR PACKED BUFFER DEFINE(OPNMODE,5)%# OPEN MODE DEFINE(EOFFLAG,6)%# END OF FILE FLAG DEFINE(DEVPTR,7)%# POINTER TO DEVICE DEPENDENT DATA DEFINE(CHANNEL,8)%# IO CHANNEL IF NEEDED DEFINE(BYTEPW,9)%# NUMBER OF BYTES PER WORD DEFINE(FBLEN,10)%# LENGTH OF EACH BLOCK # NEW MODE MODIFIERS DEFINE(WORDMODE,8*36)%# 36-BIT BYTES DEFINE(SIXBIT,8*6)%# 6-BIT BYTES DEFINE(READPACKED,8*64*1)%# PACK INPUT RECORDS #-H- IOPARM.MAC 1520 1980 103 2148 UNIVERSAL IOPARM - I/O SYSTEM PARAMETERS R==0%%; RESULT REGISTER FOR FORTRAN Z==0 T1==1%%; TEMPORARY T2==2 F==5%%; FILE BLOCK C==6%%; CHARACTERS OR POINTER TO DEVICE-SPECIFIC BLOCK A==16%%; FORTRAN ARGUMENT POINTER P==17%%; STACK STKSIZ==^D200%; STACK SIZE EOL==12%%; END OF LINE INDICATOR EOF==^D10003%; END OF FILE CHARACTER ERR==^D10001%; OPEN ERROR CHARACTER EOS==^D10002%; END OF STRING INDICATOR C.NL==0%%; NULL C.HT==11%; HORIZONTAL TAB C.LF==12%; LINE FEED C.VT==13%; VERTICAL TAB C.FF==14%; FORM FEED C.CR==15%; CARRIAGE RETURN C.ES==33%; ALTMODE C.CZ==32%; CONTROL-Z X.SKP==1B!1B%; IGNORE ON INPUT X.EOL==1B!1B!1B%; DEFINES END OF LINE ; FILE BLOCK LAYOUT (SEE IODEFS) MAXFILES==^D16%%; MAXIMUM NUMBER OF FILES USECNT==0%%; USE COUNT MAJOR==1%%; MAJOR DEVICE NUMBER MINOR==2%%; MINOR DEVICE NUMBER BYTEPTR==3%%; BYTE POINTER FOR I/O PACKPTR==4%%; BYTE POINTER TO CHECK FOR PACKED BUFFER OPNMODE==5%%; OPEN MODE EOFFLAG==6%%; END OF FILE FLAG DEVPTR==7%%; POINTER TO DEVICE DEPENDENT DATA CHANNEL==^D8%%; CHANNEL IN PROPER PLACE IF NEEDED BYTEPW==^D9%%; NUMBER OF BYTES PER WORD FBLEN==^D10%%; LENGTH OF EACH BLOCK ; MODES READ==0%%; OPEN CODE FOR READING WRITE==1%; OPEN CODE FOR WRITING READWRITE==2%; OPEN CODE FOR READING AND WRITING MODEPTR==POINT 3,OPNMODE(F),35%; TO GET MODE SIZEPTR==POINT 6,OPNMODE(F),32%; TO GET BYTE SIZE READPACKED==1B26%%; INDICATES PACKED INPUT RECORDS OPDEF%OPEN.%[050000000000] DEFINE%TITLE.(X),< TITLE%X TWOSEG RELOC%400000 ENTRY%X > END #-H- JOBSTS.MAC 322 1980 103 2148 SEARCH%IOPARM TITLE.%JOBSTS ; JOBSTS(FD) - RETURN STATUS OF PTY ON FD. ; JOBSTS::PUSHJ%P,SAVR$##%; SAVE REGISTERS %MOVE%F,@0(A)%%; POINT TO FILE BLOCK %MOVE%F,FDTAB$##(F) %MOVEI%F,FLTAB$##-1(F) %MOVE%R,CHANNEL(F)%; GET CHANNEL WORD %LSH%R,-^D23%%; RIGHT JUSTIFY %CALLI%R,61 % MOVE%R,[ERR]%%; ERROR INDICATION %POPJ%P, END #-H- LDC.MAC 104 1980 103 2148 SEARCH%IOPARM TITLE.%LDC ; LDC(C,A,I):C - GET THE ITH CHARACTER (0-BASED) FROM A IN C. ; LDC==LLC## END #-H- LKPUUO.MAC 365 1980 103 2148 SEARCH%IOPARM TITLE.%LKPUUO ; LKPUUO(BUF:ARRAY):INTEGER -- DO A LOOKUP UUO ON GIVEN BLOCK. ; LKPUUO::PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVEI%T1,@0(A)%; POINT TO BLOCK %OPEN.%0,0(T1)%%; OPEN THE DEVICE % JRST%$1%%; CAN'T OPEN %LOOKUP%0,3(T1)%%; FIND THE FILE % JRST%$1%%; CAN'T FIND %RELEAS%0,0 %TDZA%R,R%%; RETURN SUCCESS $1:%MOVE%R,[ERR]%%; OOPS %POPJ%P, END #-H- LLC.MAC 106 1980 103 2148 SEARCH%IOPARM TITLE.%LLC ; LLC(C,A,I):C - GET THE ITH CHARACTER (0-BASED) FROM A IN C. ; LLC==QQLLC## END #-H- LOC.MAC 95 1980 103 2148 SEARCH%IOPARM TITLE.%LOC ; LOC(V:VAR):ADDR -- RETURN ADDRESS OF VARIABLE V. ; LOC==QQLOC## END #-H- LPT.MAC 291 1980 103 2148 TITLE%LPT - LINE PRINTER DRIVER SEARCH%IOPARM TWOSEG ENTRY%LPTOP$ RELOC%400000 ; LPTOP$ - OPEN A LINE PRINTER; JUST VALIDATES BYTE SIZE ; LPTOP$::LDB%Z,[SIZEPTR]%; GET BYTE SIZE %CAIN%Z,7%%; MUST BE CHARACTER % JRST%DEVOP$##%; GO OPEN AS GENERAL DEVICE %MOVE%R,[ERR]%%; LOSER %POPJ%P, END #-H- MAKNAM.RAT 558 1980 103 2148 INCLUDE RATDEF # MAKNAM - MAKE A FILE NAME IN FNAME USING PREFIX, NAME & SUFFIX. SUBROUTINE MAKNAM(PREFIX, NAME, SUFFIX, FNAME) CHARACTER PREFIX(MAXNAME), NAME(MAXNAME), SUFFIX(MAXNAME), FNAME(ARB) CHARACTER BUF(MAXLINE) INTEGER I INTEGER LENGTH, FCANON BUF(1) = EOS I = 1 IF (PREFIX(1) ^= 0) CALL SCOPY(PREFIX, 1, BUF, I) I = LENGTH(BUF) + 1 IF (NAME(1) ^= 0) CALL SCOPY(NAME, 1, BUF, I) I = LENGTH(BUF) + 1 IF (SUFFIX(1) ^= 0) CALL SCOPY(SUFFIX, 1, BUF, I) I = FCANON(BUF, FNAME) RETURN END #-H- MEM.MAC 3337 1980 103 2148 TITLE%MEM - MEMORY DRIVER SEARCH%IOPARM TWOSEG ENTRY%MEMOP$, MEMCL$, MEMRD$, MEMWR$, MEMSK$ RELOC%400000 PHASE%%; MEM BLOCK LAYOUT MEMADR:%BLOCK%1%%; ADDRESS OF STREAM MEMSIZ::BLOCK%1%%; CURRENT SIZE OF STREAM MEMPOS:%BLOCK%1%%; CURRENT POSITION IN STREAM MEMPTR:%BLOCK%1%%; POINTER TO CURRENT POSITION MEMMAX:%BLOCK%1%%; MAXIMUM SIZE OF STREAM MEMLEN==. DEPHASE RELOC%400000 ; MEMOP$ - OPEN A MEMORY STREAM; F CONTAINS FILE BLOCK ADDRESS. ; MEMOP$::MOVEI%Z,MEMLEN%; ALLOCATE A MEMORY BLOCK %PUSHJ%P,ALCBK$## % JRST%$99%%; FAILED %MOVE%Z,OPNBK$##%; GET ADDRESS OF STREAM %MOVEM%Z,MEMADR(C)%; SAVE IT %SKIPN%T2,OPNBK$+1%; CHECK AND LOAD SIZE % MOVEI%T2,-1%%; 0 MEANS HUGE %IMUL%T2,BYTEPW(F)%; COMPUTE TOTAL NUMBER OF BYTES %SUBI%T2,1%%; 0 BASED %MOVEM%T2,MEMMAX(C)%; SAVE HI WATER MARK %MOVE%T2,OPNBK$+2%; COMPUTE INITIAL SIZE %IMUL%T2,BYTEPW(F) %SKIPE%T2%%; MAKE ZERO BASED UNLESS 0 % SUBI%T2,1 %MOVEM%T2,MEMSIZ(C) %CLEARM%MEMPOS(C)%; START AT POSITION 0 %MOVE%Z,BYTEPTR(F)%; GET BYTE POINTER %ADDI%Z,@MEMADR(C)%; CONSTRUCT STREAM POINTER %MOVEM%Z,MEMPTR(C) %MOVEM%C,DEVPTR(F)%; SAVE POINTER TO THIS MEM BLOCK %CLEAR%R,%%; INDICATE SUCCESS %POPJ%P, $99:%MOVE%R,[ERR]%%; INDICATE ERROR %POPJ%P, ; MEMCL$ - CLOSE A MEMORY STREAM; FREES UP A MEM BLOCK ; MEMCL$::MOVE%C,DEVPTR(F)%; POINT TO MEM BLOCK %JRST%FREBK$##%; FREE IT ; MEMRD$ - READ FROM A STREAM; POINTER TO STRING IN T1, MAX COUNT IN T2. ; MEMRD$::PUSH%P,T2%%; SAVE COUNT %MOVE%C,DEVPTR(F)%; POINT TO MEM BLOCK $4:%MOVE%Z,MEMPOS(C)%; GET CURRENT POSITION %CAMLE%Z,MEMSIZ(C)%; HIT THE END YET? % JRST%$6%%; YES %ILDB%Z,MEMPTR(C)%; READ A BYTE %IDPB%Z,T1%%; STASH IT %AOS%MEMPOS(C)%; BUMP POSITION %SOJG%T2,$4%%; LOOP UNTIL DONE $5:%POP%P,R%%; GET BACK ORIGINAL COUNT %SUB%R,T2%%; COMPUTE NUMBER OF BYTES READ %POPJ%P,%%; RETURN $6:%AOS%EOFFLAG(F)%; INDICATE EOF %CAME%T2,(P)%%; GET ANYTHING? % JRST%$5%%; YES, DON'T RETURN EOF YET %POP%P,R%%; NO, TOSS ORIGINAL COUNT %MOVE%R,[EOF]%%; INDICATE EOF %POPJ%P,%%; RETURN ; MEMWR$ - WRITE TO A STREAM; POINTER TO STRING IN T1, COUNT IN T2. ; MEMWR$::MOVE%C,DEVPTR(F)%; POINT TO MEM BLOCK $8:%MOVE%Z,MEMPOS(C)%; GET CURRENT POSITION %CAMLE%Z,MEMMAX(C)%; OVER THE EDGE YET? % JRST%$9%%; YES %ILDB%Z,T1%%; GET A BYTE %IDPB%Z,MEMPTR(C)%; WRITE IT %AOS%MEMPOS(C)%; BUMP POSITION %SOJG%T2,$8%%; LOOP UNTIL DONE %MOVE%Z,MEMPOS(C)%; GET CURRENT POSITION %CAMLE%Z,MEMSIZ(C)%; DID WE EXTEND THE SIZE? % MOVEM%Z,MEMSIZ(C)%; YES, SAVE NEW SIZE %MOVE%R,@1(A)%%; RETURN COUNT %POPJ%P,%%; RETURN $9:%MOVE%T1,MEMMAX(C)%; PUT POSITION BACK %PUSHJ%P,MEMSK$ %MOVE%R,[ERR]%%; INDICATE ERROR %POPJ%P, ; MEMSK$ - SEEK IN A STREAM; T1 CONTAINS NEW POSITION ; MEMSK$::MOVE%C,DEVPTR(F)%; POINT TO MEM BLOCK %SKIPGE%T1%%; POSITION < 0 MEANS THE END % MOVE%T1,MEMSIZ(C) %CAMLE%T1,MEMMAX(C)%; WITHIN RANGE? % JRST%$12%%; NOPE %MOVEM%T1,MEMPOS(C)%; ESTABLISH NEW POSITION %CAMLE%T1,MEMSIZ(C)%; EXTENDING STREAM? % MOVEM%T1,MEMSIZ(C)%; YES %IDIV%T1,BYTEPW(F)%; COMPUTE WORD AND BYTE OFFSET %MOVE%Z,BYTEPTR(F)%; BUILD NEW BYTE POINTER %ADDI%Z,@MEMADR(C)%; ADD IN ADDRESS %ADDI%Z,(T1)%%; ADD IN WORD OFFSET %LDB%T1,[SIZEPTR]%; GET BYTE SIZE %IMULI%T1,(T2)%%; COMPUTE POSITION %MOVNS%T1 %ADDI%T1,^D36 %DPB%T1,[POINT 6,Z,5]%; STASH IN POINTER %MOVEM%Z,MEMPTR(C)%; STORE IT %CLEAR%R,%%; INDICATE SUCCESS %POPJ%P, $12:%MOVE%R,[ERR]%%; INDICATE AN ERROR %POPJ%P, END #-H- MEMORY.RAT 969 1980 103 2148 INCLUDE RATDEF INCLUDE IODEFS # MEMORY - OPEN ARRAY A FOR I/O ACCORDING TO MODE, RETURN FILE DESCRIPTOR INTEGER FUNCTION MEMORY(A, N, M, MODE) INTEGER A(ARB), N, M, MODE INTEGER I, FD INTEGER LOC, QQOPN INCLUDE CIOSYS FOR (FD = 1; FD <= MAXFILES; FD = FD + 1) # FIND A DESCRIPTOR IF (FDTAB(FD) == 0) BREAK IF (FD > MAXFILES) RETURN (ERR) FOR (I = 1; I < FBLEN*MAXFILES; I = I + FBLEN) # FIND A FILE BLOCK IF (FILTAB(I+USECNT) == 0) BREAK IF (I >= FBLEN*MAXFILES) RETURN (ERR) FILTAB(I+MAJOR) = 2 FILTAB(I+MINOR) = 1 FILTAB(I+OPNMODE) = MODE FILTAB(I+EOFFLAG) = NO OPNBLK(1) = LOC(A(1))%# USE OPNBLK FOR ARGUMENTS TO MEMOPN OPNBLK(2) = N%# MAXIMUM SIZE OPNBLK(3) = M%# INITIAL SIZE IF (QQOPN(FILTAB(I+MAJOR), FILTAB(I+MINOR), FILTAB(I+USECNT)) == ERR) RETURN (ERR) FDTAB(FD) = I # CONNECT FILE DESCRIPTOR TO FILE BLOCK FILTAB(I+USECNT) = 1 RETURN (FD-1) END #-H- MTA.MAC 669 1980 103 2148 TITLE%MTA - MAGNETIC TAPE DRIVER SEARCH%IOPARM TWOSEG ENTRY%MTAOP$ RELOC%400000 ; MTAOP$ - OPEN MTA; HANDLES MINOR DEVICE 2 (MT:) OR 8-BIT BYTES ; IN ASCII MODE ; MTAOP$::LDB%Z,[SIZEPTR]%; GET BYTE SIZE %CAIN%Z,8%%; 8 = MINOR DEVICE 2 % MOVEI%T1,2 %MOVEM%T1,MINOR(F)%; RESET MINOR DEVICE NUMBER %CAIE%T1,2%%; MT: (8-BIT BYTES; ASCII MODE)? % JRST%DEVOP$##%; NO, JUST OPEN IT %MOVEI%Z,4%%; YES, 8-BIT BYTES %MOVEM%Z,BYTEPW(F)%; RESET NUMBER BYTES PER WORD %MOVEI%Z,8 %DPB%Z,[SIZEPTR]%; SET EIGHT BIT BYTES %PUSHJ%P,DEVOP$##%; OPEN THE DEVICE %CAMN%R,[ERR]%%; ERROR? % POPJ%P,%%; OOPS %PUSHJ%P,XUUO$##%; SET INDUSTRY COMPATIBLE MODE %MTIND.%0,0 %POPJ%P,%%; RETURN END #-H- MTAPE.MAC 848 1980 103 2148 SEARCH%IOPARM TITLE.%MTAPE OPDEF%MTAPE.%[072000000000] ; MTAPE(N:INTEGER;F:FILE) - PERFORM THE INDICATED MAGNETIC TAPE FUNCTION ; ON FILE F (WHICH SHOULD BE A MAGNETIC TAPE). BACKSPACE FILE IS ; HANDLED CORRECTLY. ; MTAPE::%PUSHJ P,SAVR$##%; SAVE SOME REGISTERS MOVE F,@1(A) ; GET THE FILE DESCRIPTOR %MOVE%F,FDTAB$##(F)%; POINTER TO ENTRY INTO FILTAB %MOVEI%F,FLTAB$##-1(F)%; POINT TO FILE BLOCK %MOVE%T1,@0(A)%; GET THE FUNCTION CODE %CAIE%T1,17%%; BACKSPACE FILE? % JRST%$1%%; NO %PUSHJ%P,XUUO$##%; YES, DO A BACKSPACE FILE %MTBSF.%0, %PUSHJ%P,XUUO$%%; WAIT FOR COMPLETION %MTWAT.%0, %PUSHJ%P,XUUO$%%; AT BEGINNING OF TAPE? %STATZ%0,4000 % POPJ%P,%%; YES, JUST RETURN %PUSHJ%P,XUUO$%%; NO, JUMP OVER FILE MARK %MTSKF.%0, %POPJ%P,%%; NOW RETURN $1:%PUSHJ%P,XUUO$%%; DO APPROPRIATE CODE %MTAPE.%0,(T1) %POPJ%P,%%; RETURN END #-H- OPEN.RAT 264 1980 103 2148 INCLUDE RATDEF INCLUDE IODEFS # OPEN - OPEN FILE NAME ACCORDING TO MODE, RETURN FILE DESCRIPTOR INTEGER FUNCTION OPEN(NAME, MODE) CHARACTER NAME(ARB) INTEGER MODE INTEGER QQOPEN, FD EXTERNAL QQOPN FD = QQOPEN(QQOPN, NAME, MODE) RETURN (FD) END #-H- OUTMAP.MAC 256 1980 103 2148 SEARCH%IOPARM TITLE.%OUTMAP ; OUTMAP(C:CHAR):A1 CHARACTER -- CONVERT ASCII CODE TO LEFT-JUSTIFIED ; CHARACTER. ; OUTMAP::MOVE%R,@0(A)%%; GET CHARACTER %LSH%R,^D29%%; SHIFT TO HIGH 7 BITS %TDO%R,[_<-^D7>]%; OR IN BLANKS %POPJ%P,%%; RETURN END #-H- PACK.MAC 963 1980 103 2148 SEARCH%IOPARM TITLE.%PACK ; PACK(N:INTEGER,S:STRING,D:PACKED STRING):INTEGER -- PACK N CHARACTERS ; FROM S INTO D. STOPS IF AN EOS IS ENCOUNTERED. RETURNS THE NUMBER OF ; CHARACTERS PACKED AND PUTS A NULL AT THE END OF D. ; PACK:: PUSHJ P,SAVR$## ; SAVE SOME REGISTERS MOVEI T1,@1(A) ; GET ADDRESS OF S HRLI T2,(POINT 7) ; SET UP A POINTER ... HRRI T2,@2(A) ; TO D %MOVE%R,@0(A)%%; GET N %JUMPLE%R,$2%%; DONE ALREADY $1:%MOVE C,(T1) ; GET A CHARACTER FROM S CAMN C,[EOS] ; CHECK FOR EOS JRST $2%%; QUIT IF EOS IDPB C,T2 ; STASH IN D ADDI T1,1 ; BUMP ADDRESS OF S SOJG R,$1%%; CONTINUE TILL DONE $2:%MOVEI C,0 ; GET A NULL IDPB C,T2 ; PUT AT END OF D MOVE R,T1 ; COMPUTE LENGTH SUBI R,@1(A) POPJ P, ; RETURN END #-H- PATH.MAC 218 1980 103 2148 SEARCH%IOPARM TITLE.%PATH ; PATH(A:ARRAY,N:INTEGER):INTEGER -- DO A PATH. UUO. ; PATH::%HRL%Z,@1(A)%%; GET COUNT %HRRI%Z,@0(A)%%; POINT TO ARGUMENT BLOCK %PATH.%Z,%%; DO IT % SKIPA %TDZA%Z,Z %MOVE%Z,[ERR] %POPJ%P, END #-H- PJOB.MAC 172 1980 103 2148 SEARCH%IOPARM TITLE.%PJOB ; PJOB(N:INTEGER):INTEGER - RETURNS JOB NUMBER IN N AND AS VALUE. ; PJOB::%CALLI%R,30%%; GET IT %MOVEM%R,@1(A)%%; STASH IT %POPJ%P,%%; RETURN END #-H- PRINTF.RAT 4212 1980 103 2148 INCLUDE RATDEF DEFINE(MAXCHARS,30) # PRINTF - PRINT ARGUMENTS ACCORDING TO S SUBROUTINE PRINTF(S) CHARACTER S(ARB) INTEGER LLC, LOC, ARG, UNPACK, CTOI, LENGTH, FTOC, XTOC, R50TOC, SIXTOC INTEGER FD, I, J, C, W, P, AP, LEN, ADR INTEGER FMT(MAXLINE), BUF(MAXCHARS) INTEGER MEMOFF, MEM(1) MEMOFF = 1 - LOC(MEM(1)) # FIND ADDRESSING OFFSET FD = STDOUT AP = 2 IF (S(1) > 127 \ S(1) < 0) LEN = UNPACK(MAXLINE, S, FMT) ELSE CALL SCOPY(S, 1, FMT, 1) FOR (I = 1; FMT(I) ^= EOS; I = I + 1) < C = FMT(I) IF (C == BACKSLASH) < # SPECIAL CHARACTER I = I + 1 C = FMT(I) IF (C == DIG0) RETURN ELSE IF (C == LETT \ C == BIGT) C = TAB ELSE IF (C == LETN \ C == BIGN) C = NEWLINE ELSE IF (C == LETB \ C == BIGB) C = BACKSPACE CALL PUTCH(C, FD) ! ELSE IF (C ^= PERCENT) # ORDINARY CHARACTER CALL PUTCH(C, FD) ELSE < # FORMAT CODE I = I + 1 W = CTOI(FMT, I) IF (FMT(I) == PERIOD) < I = I + 1 P = CTOI(FMT, I) ! ELSE P = -1 C = FMT(I) ADR = ARG(AP) + MEMOFF # COMPUTE INDEX IN MEM OF ARGUMENT IF (C == LETD \ C == BIGD) # %WD PRINT DECIMAL INTEGER CALL PUTINT(MEM(ADR), W, FD) ELSE IF (C == LETO \ C == BIGO) < # %WO PRINT OCTAL INTEGER LEN = XTOC(MEM(ADR), BUF, MAXCHARS, 8) CALL PUTSTR(BUF, W, FD) ! ELSE IF (C == LETX \ C == BIGX) < # %W.BX PRINT INTEGER IN BASE B IF (P < 2 \ P > 36)%# DEFAULT IS HEX P = 16 LEN = XTOC(MEM(ADR), BUF, MAXCHARS, P) CALL PUTSTR(BUF, W, FD) ! ELSE IF (C == LETS \ C == BIGS) < # %WS PRINT STRING IF (MEM(ADR) <= 127 & MEM(ADR) > 0) # UNPACKED STRING LEN = LENGTH(MEM(ADR)) ELSE # PACKED STRING FOR (LEN = 0; LLC(C, MEM(ADR), LEN) ^= 0; LEN = LEN + 1) IF (C == BACKSLASH) IF (LLC(C, MEM(ADR), LEN+1) == DIG0) BREAK IF (P > 0 & P < LEN) # TRUNCATE IF PRECISION GIVEN LEN = P FOR ( ; W > LEN; W = W - 1) CALL PUTCH(BLANK, FD) IF (MEM(ADR) <= 127 & MEM(ADR) > 0) # UNPACKED STRING FOR (J = 0; J < LEN; J = J + 1) CALL PUTCH(MEM(ADR+J), FD) ELSE # PACKED STRING FOR (J = 0; J < LEN; J = J + 1) CALL PUTCH(LLC(C, MEM(ADR), J), FD) FOR ( ; W < -LEN; W = W + 1) CALL PUTCH(BLANK, FD) ! ELSE IF (C == LETF \ C == BIGF) < # %W.DF PRINT REAL NUMBER IF (P == -1)%# DEFAULT PRECISION IS 6 P = 6 LEN = FTOC(MEM(ADR), BUF, P, MAXCHARS) CALL PUTSTR(BUF, W, FD) ! ELSE IF (C == LETE \ C == BIGE) < # %W.DE PRINT REAL NUMBER IF (P == -1) P = 6 LEN = FTOC(MEM(ADR), BUF, -P, MAXCHARS) # FORCE E FORMAT CALL PUTSTR(BUF, W, FD) ! ELSE IF (C == LETC \ C == BIGC) < # %WC PRINT CHARACTER FOR ( ; W > 1; W = W - 1) CALL PUTCH(BLANK, FD) IF (MEM(ADR) <= 127 & MEM(ADR) > 0) CALL PUTCH(MEM(ADR), FD) ELSE CALL PUTCH(LLC(C, MEM(ADR), 0), FD) FOR ( ; W < -1; W = W + 1) CALL PUTCH(BLANK, FD) ! ELSE IF (C == LETN \ C == BIGN) # %N CHANGE OUTPUT FILE FD = MEM(ADR) ELSE IF (C == LETR \ C == BIGR) < # %WR PRINT RADIX50 SYMBOL LEN = R50TOC(MEM(ADR), BUF, MAXCHARS) CALL PUTSTR(BUF, W, FD) ! ELSE IF (C == LETK \ C == BIGK) < # %WK PRINT SIXBIT SYMBOL LEN = SIXTOC(MEM(ADR), BUF, MAXCHARS) CALL PUTSTR(BUF, W, FD) ! ELSE < # FUNNY CODE CALL PUTCH(C, FD) NEXT ! AP = AP + 1 ! ! END #-H- PTY.MAC 2990 1980 103 2149 TITLE%PTY - PSEUDO TTY DRIVER SEARCH%IOPARM TWOSEG ENTRY%PTYOP$, PTYCL$, PTYRD$, PTYWR$ RELOC%400000 PHASE%%; PTY BLOCK LAYOUT PTYIBH:%BLOCK%3%%; INPUT BUFFER HEADER PTYOBH:%BLOCK%3%%; OUTPUT BUFFER HEADER PTYIBF:%BLOCK%23%%; INPUT BUFFER PTYOBF:%BLOCK%23%%; OUTPUT BUFFER PTYLEN==. DEPHASE RELOC%400000 ; PTYOP$ - OPEN A PTY; F CONTAINS FILE BLOCK ADDRESS. ; PTYOP$::LDB%Z,[SIZEPTR]%; GET BYTE SIZE %CAIE%Z,7%%; MUST BE CHARACTER % JRST%$99 %MOVEI%Z,PTYLEN%; ALLOCATE A PTY BLOCK %PUSHJ%P,ALCBK$## % JRST%$99%%; CAN'T ALLOCATE %MOVEM%C,DEVPTR(F)%; STASH POINTER IN FILE BLOCK %PUSHJ%P,FDCHN$##%; FIND A CHANNEL %JUMPE%Z,$98%%; NONE AVAILABLE %MOVEM%Z,CHANNEL(F)%; STORE IN FILE BLOCK %MOVEI%Z,1%%; OPEN IN ASCII LINE MODE %MOVEM%Z,OPNBK$## %HRRI%Z,PTYIBH(C) %HRLI%Z,PTYOBH(C)%; FORM AND STORE BUFFER HEADER POINTERS %MOVEM%Z,OPNBK$+2 %PUSHJ%P,XUUO$##%; OPEN THE PTY %OPEN.%0,OPNBK$## % JRST%$98%%; FAILED %PUSH%P,.JBFF##%; SAVE FIRST FREE POINTER %MOVEI%Z,PTYIBF(C)%; POINT TO BUFFER SPACE %MOVEM%Z,.JBFF%%; FAKE .JBFF FOR BUFFER FORMATION %PUSHJ%P,XUUO$%%; FORMAT INPUT AND OUTPUT BUFFERS %INBUF%0,1%%; NOTE ORDER IS IMPORTANT! %PUSHJ%P,XUUO$ %OUTBUF%0,1 %POP%P,.JBFF%%; RESTORE .JBFF %CLEAR%R,%%; INDICATE SUCCESS %POPJ%P, $98:%PUSHJ%P,FREBK$##%; FREE CORE BLOCK $99:%MOVE%R,[ERR]%%; RETURN ERROR INDICATION %POPJ%P, ; PTYCL$ - CLOSE A PTY; FREES UP A PTY BLOCK. ; PTYCL$::MOVE%C,DEVPTR(F)%; GET POINTER TO PTY BLOCK %JUMPE%C,$4%%; IGNORE CLOSE ON CLOSED PTYS %PUSHJ%P,XUUO$%%; CLOSE AND RELEASE THE PTY %CLOSE%0,0 %PUSHJ%P,XUUO$ %RELEAS%0,0 %PUSHJ%P,FREBK$##%; FREE THE PTY BLOCK $4:%CLEAR%R,%%; INDICATE SUCCESS %POPJ%P, ; PTYRD$ - READ A PTY; POINTER TO STRING IN T1, MAX COUNT IN T2. ; PTYRD$::PUSH%P,T2%%; SAVE COUNT %MOVE%C,DEVPTR(F)%; POINT TO PTY BLOCK $6:%SOSGE%PTYIBH+2(C)%; DECREMENT AND TEST BYTE COUNT % JRST%$8%%; GO GET ANOTHER BUFFER FULL %ILDB%Z,PTYIBH+1(C)%; GET A CHARACTER %IDPB%Z,T1%%; STASH IT %SOJLE%T2,$7%%; DECREMENT AND TEST COUNT %CAIE%Z,C.LF%%; CHECK FOR END OF LINE % JRST%$6%%; CONTINUE UNLESS HIT EOL $7:%POP%P,R%%; GET BACK ORIGINAL COUNT %SUB%R,T2%%; COMPUTE NUMBER OF CHARACTERS READ %POPJ%P,%%; RETURN $8:%PUSHJ%P,XUUO$%%; FILL A BUFFER %IN%0,0 % SKIPA%%%; MUST CHECK FOR EMPTY BUFFER %JRST%$9%%; END OF FILE %SKIPE%PTYIBH+2(C)%; GET ANYTHING? % JRST%$6%%; YES, GO GET IT %JRST%$7%%; NO, RETURN FROM READ CALL $9:%AOS%EOFFLAG(F)%; HERE ON EOF, LIGHT EOF FLAG %CAME%T2,(P)%%; DID WE GET ANYTHING? % JRST%$7%%; YES, DON'T GIVE EOF YET %POP%P,R%%; NO, TOSS COUNT %MOVE%R,[EOF]%%; GIVE AN EOF %POPJ%P, ; PTYWR$ - WRITE TO A PTY; POINTER TO STRING IN T1, COUNT IN T2. ; PTYWR$::MOVE%C,DEVPTR(F)%; POINT TO PTY BLOCK $12:%SOSG%PTYOBH+2(C)%; DECREMENT AND TEST BYTE COUNT % JRST%$14%%; DUMP THE BUFFER $13:%ILDB%Z,T1%%; GET A BYTE %IDPB%Z,PTYOBH+1(C)%; DEPOSIT THE BYTE %SOJG%T2,$12%%; CONTINUE UNTIL DONE %PUSHJ%P,XUUO$##%; BUT DUMP BUFFER ONCE MORE %OUTPUT%0,0 %POPJ%P,%%; RETURN $14:%PUSHJ%P,XUUO$%%; DO THE OUTPUT %OUTPUT%0,0 %JRST%$13%%; GO ON END #-H- PUTCH.RAT 247 1980 103 2149 INCLUDE RATDEF # PUTCH - WRITE C TO FILE FD CHARACTER FUNCTION PUTCH(C, FD) CHARACTER C INTEGER FD, JUNK, WRITEF IF (C == NEWLINE) JUNK = WRITEF(13, 1, FD) # NEED A CARRIAGE RETURN JUNK = WRITEF(C, 1, FD) RETURN (C) END #-H- QQALLC.KA 1320 1980 103 2149 DEFINE(JBFF,8%0121+MEMOFF)%# FOR KA'S DEFINE(JBREL,8%044+MEMOFF) # QQALLC(N) - ALLOCATE N WORDS, RETURN ADDRESS OF FIRST WORD (KA10) INTEGER FUNCTION QQALLC(N) INTEGER N INTEGER I, M, QQLOC, QQCORE INCLUDE CALLOC IF (MEMOFF == 0) <%# INITIALIZE MEMOFF = 1 - QQLOC(MEM(1)) M = MEM(JBREL) - MEM(JBFF) + 1 MEM(MEM(JBFF)+MEMOFF) = M MEM(MEM(JBREL)+MEMOFF) = M ! REPEAT < M = N + 2%# ACCOUNT FOR OVERHEAD FOR (I = MEM(JBFF) + MEMOFF; I <= MEM(JBREL) + MEMOFF; ) IF (MEM(I) < 0) I = I - MEM(I)%# BUMP PAST ALLOCATED BLOCK ELSE IF (MEM(I) < M) I = I + MEM(I)%# FREE, BUT TOO SMALL ELSE <%# FOUND A HOLE IF (MEM(I) > M + 2) <%# DIVIDE HOLE INTO TWO SMALLER ONES MEM(I+M) = MEM(I) - M MEM(I+MEM(I)-1) = MEM(I) - M MEM(I) = M MEM(I+M-1) = M ! MEM(I+MEM(I)-1) = -MEM(I) MEM(I) = -MEM(I) RETURN(I - MEMOFF + 1) ! I = MEM(JBREL) IF (QQCORE(I + M) == NO)%# NEED TO GET MORE CORE RETURN(-1)%# DIDN'T GET ENOUGH M = MEM(JBREL) - I%# DETERMINE ACTUAL AMOUNT OBTAINED MEM(I+MEMOFF+1) = M MEM(I+MEMOFF+M) = M !%# DO IT AGAIN (GUARANTEED SUCCESS) END #-H- QQALLC.RAT 1315 1980 103 2149 # QQALLC(N) - ALLOCATE N WORDS, RETURN ADDRESS OF FIRST WORD INTEGER FUNCTION QQALLC(N) INTEGER N INTEGER I, M, QQLOC, QQAPAG INCLUDE CALLOC IF (MEMOFF == 0) <%# INITIALIZE MEMOFF = 1 - QQLOC(MEM(1)) LOWPAG = 448 ! REPEAT < M = N + 2%# ACCOUNT FOR OVERHEAD FOR (I = LOWPAG*512 + MEMOFF; I < 448*512 + MEMOFF; ) IF (MEM(I) < 0) I = I - MEM(I)%# BUMP PAST ALLOCATED BLOCK ELSE IF (MEM(I) < M) I = I + MEM(I)%# FREE, BUT TOO SMALL ELSE <%# FOUND A HOLE IF (MEM(I) > M + 2) <%# DIVIDE HOLE INTO TWO SMALLER ONES MEM(I+M) = MEM(I) - M MEM(I+MEM(I)-1) = MEM(I) - M MEM(I) = M MEM(I+M-1) = M ! MEM(I+MEM(I)-1) = -MEM(I) MEM(I) = -MEM(I) RETURN(I - MEMOFF + 1) ! I = LOWPAG%# MAP IN SOME MORE PAGES FOR (M = M/512 + 1; M > 0; M = M - 1) < IF (QQAPAG(I - 1) == NO) BREAK I = I - 1 ! IF (I < LOWPAG) < MEM(I*512+MEMOFF) = (LOWPAG - I)*512 MEM(LOWPAG*512+MEMOFF-1) = (LOWPAG - I)*512 LOWPAG = I ! IF (M > 0) RETURN(-1)%# DIDN'T GET ENOUGH !%# DO IT AGAIN (GUARANTEED SUCCESS) END #-H- QQAPAG.RAT 180 1980 103 2149 # QQAPAG - ADD PAGE N TO WORKING SET INTEGER FUNCTION QQAPAG(N) INTEGER N INTEGER ARG(2), QQPAGE ARG(1) = 1%# SET UP ARGUMENTS ARG(2) = N RETURN(QQPAGE(1,ARG)) END #-H- QQARG.MAC 269 1980 103 2149 SEARCH%IOPARM TITLE.%QQARG ; QQARG(I:INT):ADDR -- RETURN ADDRESS OF ARGUMENT I ; QQARG::%MOVE%1,-1(17)%; ->INST FOLLOWING CALL TO CALLER %MOVEI%1,@-2(1)%; ->CALLER'S ARG LIST %ADD%1,@0(16)%; POINT AT HIS ARG I+1 %MOVEI%R,@-1(1)%; FETCH HIS ARG I %POPJ%P,%%; RETURN END #-H- QQCLS.MAC 312 1980 103 2149 SEARCH%IOPARM TITLE.%QQCLS ; QQCLS(MAJOR,MINOR,FILTAB BLOCK) - SWITCH ON CLOSE TABLE. ; QQCLS::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVEI%F,@2(A)%%; POINT TO FILTAB BLOCK %MOVE%T2,@0(A)%; GET MAJOR DEVICE NUMBER %MOVE%T1,@1(A)%; GET MINOR DEVICE NUMBER %JRST%@CLSW$##(T2)%; SWITCH TO PROPER CLOSE ROUTINE END #-H- QQCORE.MAC 241 1980 103 2149 SEARCH%IOPARM TITLE.%QQCORE ; QQCORE(ARG) - PERFORM CORE UUO. RETURNS NO IF UUO FAILED, YES OTHERWISE. QQCORE::MOVE%T1,@0(A)%; GET ARGUMENT %MOVEI%R,1%%; ASSUME SUCCESS %CORE%T1,%%; DO IT % CLEAR%R,%%; INDICATE ERROR %POPJ%P,%%; RETURN END #-H- QQCRT.MAC 811 1980 103 2149 SEARCH%IOPARM TITLE.%QQCRT ; QQCRT(MAJOR,MINOR,FILTAB BLOCK) - SWITCH ON CREATE TABLE. ; QQCRT::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVEI%F,@2(A)%%; POINT TO FILTAB BLOCK %CLEARM%DEVPTR(F)%; CLEAR DEVICE DATA POINTER %LDB%T1,[SIZEPTR]%; GET BYTE SIZE %SKIPN%T1 % MOVEI%T1,7%%; CHARACTER IS DEFAULT %DPB%T1,[SIZEPTR]%; PUT IT BACK IN CASE DEFAULT %MOVEI%Z,(POINT 0)%; CONSTRUCT BYTE POINTERS %DPB%T1,[POINT 6,Z,29] %HRLZM%Z,BYTEPTR(F) %ORI%Z,(POINT 0,(T1)) %MOVNS%T1 %ADDI%T1,^D36%%; COMPUTE POSITION INDICATOR %DPB%T1,[POINT 6,Z,23] %HRLZM%Z,PACKPTR(F) %MOVEI%T1,^D36%%; COMPUTE BYTES PER WORD %LDB%Z,[SIZEPTR] %IDIV%T1,Z %MOVEM%T1,BYTEPW(F)%; SAVE FOR DEVICE DRIVERS %MOVE%T2,@0(A)%; GET MAJOR DEVICE NUMBER %MOVE%T1,@1(A)%; GET MINOR DEVICE NUMBER %JRST%@CRSW$##(T2)%; SWITCH TO PROPER CREATE ROUTINE END #-H- QQCTOK.RAT 1723 1980 103 2149 INCLUDE RATDEF DEFINE(MAXARG,60) # QQCTOK - GET A COMMAND TOKEN INTEGER FUNCTION QQCTOK(T, TOK, FD) CHARACTER T, TOK(MAXARG) INTEGER FD CHARACTER QQGETC, C INTEGER I, NCOMMA INCLUDE CARGS FOR (C = QQGETC(C, FD, ESCAPE); C == BLANK \ C == TAB; C = QQGETC(C, FD, ESCAPE)) ; IF (C == NEWLINE \ C == EOF) < TOK(1) = C TOK(2) = EOS T = EOF ! ELSE IF (C == DQUOTE \ C == SQUOTE) < # QUOTED ARGUMENT T = C TOK(1) = C FOR (I = 2; QQGETC(TOK(I), FD, -1) ^= EOF; I = I + 1) IF (TOK(I) == C \ TOK(I) == NEWLINE) BREAK ELSE IF (I > MAXARG) CALL QQERR1("ARGUMENT TOO LONG\0") IF (TOK(I) ^= C) CALL QQERR1("MISSING QUOTE\0") TOK(I+1) = EOS ! ELSE IF (C == SEMICOL \ C == BAR) <%# COMMAND TERMINATOR TOK(1) = C TOK(2) = EOS T = C ! ELSE < # REGULAR ARGUMENT NCOMMA = 0 I = 1 REPEAT < IF (C == NEWLINE \ C == BLANK \ C == TAB \ C == SEMICOL \ C == BAR) < PEEK = C BREAK ! IF (I >= MAXARG) CALL QQERR1("ARGUMENT TOO LONG\0") TOK(I) = C IF (C == STAR \ (I > 1 & C == QMARK)) NMETA = NMETA + 1 ELSE IF (C == LBRACK) NCOMMA = 0 ELSE IF (C == RBRACK & NCOMMA == 0 & I >= 3) < IF (TOK(I-2) ^= LBRACK \ TOK(I-1) ^= MINUS)%# [-] CASE NMETA = NMETA + 1 ! ELSE IF (C == COMMA) NCOMMA = NCOMMA + 1 I = I + 1 ! UNTIL (QQGETC(C, FD, ESCAPE) == EOF) TOK(I) = EOS T = ALPHA ! RETURN(T) END #-H- QQDEV.MAC 210 1980 103 2149 SEARCH%IOPARM TITLE.%QQDEV ; QQDEV(NAME) - DO DEVTYP UUO FOR DEVICE NAME (IN SIXBIT). ; QQDEV::MOVE%R,@0(A)%%; GET THE NAME %CALLI%R,53%%; GET GOOD BITS % MOVE%R,[ERR]%%; FAILED, RETURN ERROR CODE %POPJ%P, END #-H- QQERR1.RAT 156 1980 103 2149 INCLUDE RATDEF # QQERR1 - PRINT ERROR MESSAGE AND DIE SUBROUTINE QQERR1(BUF) INTEGER BUF(ARB) CALL QQPUTS(ERROUT, BUF, "\N\0", 0) STOP END #-H- QQERR2.RAT 193 1980 103 2149 INCLUDE RATDEF # QQERR2 - PRINT CAN'T OPEN FILE MESSAGE AND DIE SUBROUTINE QQERR2(BUF) INTEGER BUF(MAXLINE) CALL QQPUTS(ERROUT, BUF, ": CAN'T OPEN\N\0", 0) STOP RETURN END #-H- QQEXIT.MAC 775 1980 103 2149 SEARCH%IOPARM RUNPTR==CARGS##+1 TITLE.%QQEXIT ENTRY%EXIT. ; QQEXIT -- EXIT TO THE MONITOR. CLOSES ALL FILES. ; EXIT.:: QQEXIT::MOVEI%Z,MAXFILES-1%; INITIALIZE TO CLOSE ALL FILES %MOVEM%Z,FD %MOVEI%A,[EXP <-1,,0>,FD]+1 $2:%PUSHJ%P,CLOSE##%; CLOSE A FILE %SOSL%FD%%; DECREMENT TO NEXT DESCRIPTOR % JRST%$2%%; LOOP TILL DONE %SKIPN%T1,RUNPTR%; ANOTHER PROGRAM TO RUN? % JRST%$3%%; NOPE %MOVEM%T1,NAMPTR%; YES, SAVE ITS ADDRESS %MOVEI%A,[EXP <-2,,0>,1B13!NAMPTR,[1]]+1 %PUSHJ%P,QQRUN##%; YES, RUN IT $3:%MOVEI%A,[EXP <-1,,0>,[ASCIZ "PIP.TMP[,]"]]+1%; REMOVE PIPE %PUSHJ%P,QQRM## %MOVEI%A,[EXP <-1,,0>,[ASCIZ "TMP:ARG"]]+1%; REMOVE ARG FILE %PUSHJ%P,QQRM## %CALLI%1,12%%; EXIT EXIT %JRST%.-1%%; DON'T CONTINUE RELOC NAMPTR: FD:%BLOCK%1%%; HOLDS ARGUMENT TO CLOSE & RUN RELOC END #-H- QQFREE.KA 691 1980 103 2149 DEFINE(JBFF,8%0121+MEMOFF)%# FOR KA'S DEFINE(JBREL,8%044+MEMOFF) # QQFREE - FREE CORE POINTED TO BY P. SUBROUTINE QQFREE(P) INTEGER P INTEGER I, M INCLUDE CALLOC I = P + MEMOFF - 1 MEM(I) = -MEM(I)%# FREE UP THIS BLOCK MEM(I+MEM(I)-1) = MEM(I) WHILE (I > MEM(JBFF) + MEMOFF) <%# COALESCE PREDECESSORS IF (MEM(I-1) < 0) BREAK M = MEM(I-1) + MEM(I) I = I - MEM(I-1) MEM(I) = M MEM(I+M-1) = M ! I = I + MEM(I) - 1 WHILE (I < MEM(JBREL) + MEMOFF) <%# COALESCE SUBSEQUENTS IF (MEM(I+1) < 0) BREAK M = MEM(I) + MEM(I+1) I = I + MEM(I+1) MEM(I) = M MEM(I-M+1) = M ! RETURN END #-H- QQFREE.RAT 628 1980 103 2149 # QQFREE - FREE CORE POINTED TO BY P. SUBROUTINE QQFREE(P) INTEGER P INTEGER I, M INCLUDE CALLOC I = P + MEMOFF - 1 MEM(I) = -MEM(I)%# FREE UP THIS BLOCK MEM(I+MEM(I)-1) = MEM(I) WHILE (I > LOWPAG*512 + MEMOFF) <%# COALESCE PREDECESSORS IF (MEM(I-1) < 0) BREAK M = MEM(I-1) + MEM(I) I = I - MEM(I-1) MEM(I) = M MEM(I+M-1) = M ! I = I + MEM(I) - 1 WHILE (I < 448*512 - 1 + MEMOFF) <%# COALESCE SUBSEQUENTS IF (MEM(I+1) < 0) BREAK M = MEM(I) + MEM(I+1) I = I + MEM(I+1) MEM(I) = M MEM(I-M+1) = M ! RETURN END #-H- QQGETC.RAT 510 1980 103 2149 INCLUDE RATDEF DEFINE(EFLAG,8%400000) # QQGETC - GET A COMMAND CHARACTER, USING EC AS ESCAPE CHARACTER CHARACTER FUNCTION QQGETC(C, FD, EC) CHARACTER C, EC INTEGER FD CHARACTER GETCH INCLUDE CARGS IF (PEEK ^= 0) C = PEEK ELSE C = GETCH(C, FD) PEEK = 0 IF (C == EC) IF (GETCH(PEEK, FD) == NEWLINE) < C = BLANK PEEK = 0 ! ELSE PEEK = PEEK \ EFLAG ELSE IF (C == NEWLINE & FD ^= STDIN) C = BLANK RETURN(C) END #-H- QQGLOB.RAT 1386 1980 103 2149 INCLUDE RATDEF DEFINE(EFLAG,8%400000) # QQGLOB - EXECUTE GLOB TO EXPAND ARGUMENTS SUBROUTINE QQGLOB INTEGER FDI, FDO, I, P CHARACTER C INTEGER OPEN, CREATE CHARACTER GETCH INCLUDE CARGS STRING GLOB "STDN:GLOB[5,13,TOOLS]" FDI = OPEN("TMP:ARG", READ) IF (FDI == ERR) FDI = CREATE("TMP:ARG", READ) FDO = CREATE("TMP:ARG", WRITE) IF (FDI == ERR \ FDO == ERR) CALL QQERR1("CAN'T CREATE ARG FILE FOR GLOB\0") CALL QQPUTS(FDO, GLOB, 0) IF (GETCH(C, FDI) ^= EOF) < CALL PUTCH(SEMICOL, FDO) CALL PUTCH(C, FDO) ! WHILE (GETCH(C, FDI) ^= EOF) CALL PUTCH(C, FDO) CALL CLOSE(FDI) CALL CLOSE(FDO) FDO = CREATE("TMP:GLB", WRITE) IF (FDO == ERR) CALL QQERR1("CAN'T CREATE TEMPORARY FILE FOR GLOB\0") FOR (P = ARGPTR; P ^= 0; P = MEM(P+MEMOFF)) < CALL WRITEF(QQLEN(MEM(P+MEMOFF+2)), 1, FDO) CALL QQPUTS(FDO, MEM(P+MEMOFF+2), 0) ! IF (INPTR ^= 0) < CALL WRITEF(QQLEN(MEM(INPTR+MEMOFF+2)), 1, FDO) CALL QQPUTS(FDO, MEM(INPTR+MEMOFF+2), 0) ! IF (OUTPTR ^= 0) < CALL WRITEF(QQLEN(MEM(OUTPTR+MEMOFF+2)), 1, FDO) CALL QQPUTS(FDO, MEM(OUTPTR+MEMOFF+2), 0) ! IF (ERRPTR ^= 0) < CALL WRITEF(QQLEN(MEM(ERRPTR+MEMOFF+2)), 1, FDO) CALL QQPUTS(FDO, MEM(ERRPTR+MEMOFF+2), 0) ! CALL CLOSE(FDO) CALL RUN(GLOB, 1) RETURN END #-H- QQINIT.RAT 4533 1980 103 2149 INCLUDE RATDEF DEFINE(MAXARG,60) DEFINE(NFILES,5)%# MAXIMUM DEPTH OF INCLUDE ARGUMENTS DEFINE(EFLAG,8%400000) # QQINIT - INITIALIZE STDIN, STDOUT, AND ERROUT AND THE COMMAND ARGS SUBROUTINE QQINIT INTEGER I, FD, FDO, P, META, LEVEL, IFILES(NFILES), PEEKED(NFILES) INTEGER QQLOC, OPEN, CREATE, QQALLC, QQLEN CHARACTER C, T, ARG(MAXARG) CHARACTER QQCTOK, QQGETC INCLUDE CARGS STRING PIPE " >PIP.TMP[,]" STRING RUN "RUN" MEMOFF = 1 - QQLOC(MEM(1))%# GET ADDRESSING OFFSET IF (OPEN("TTY:", READ) ^= STDIN \ OPEN("TTY:", WRITE) ^= STDOUT \ OPEN("TTY:", WRITE) ^= ERROUT) STOP 100 ARG(1) = EOS PEEK = 0 FD = STDIN IF (TTYFLG == NO) FD = OPEN("TMP:ARG", READ)%# READ ARGS FROM COMMAND FILE IF (FD == STDIN) < CALL QQRM("TMP:ARG") IF (QQCTOK(T, ARG, FD) == ALPHA) < FOR (I = 1; ARG(I) ^= EOS & RUN(I) ^= EOS; I = I + 1) IF (ARG(I) ^= RUN(I) & ARG(I) ^= RUN(I) - LETA + BIGA) BREAK IF (ARG(I) == EOS) <%# RUN COMMAND SEEN FOR (I = 1; QQGETC(C, FD, -1) ^= EOF; ) < ARG(I) = C IF (I < MAXARG) I = I + 1 IF (C == SEMICOL \ C == MINUS \ C == NEWLINE) BREAK ! ARG(I-1) = EOS IF (C == NEWLINE) PEEK = C ! ! ! ELSE IF (FD ^= ERR) T = QQCTOK(T, ARG, FD) ARGPTR = QQALLC(QQLEN(ARG) + 3) MEM(ARGPTR+MEMOFF) = 0 MEM(ARGPTR+MEMOFF+1) = ALPHA CALL QQSCPY(ARG, 1, MEM, ARGPTR + MEMOFF + 2) IF (FD == ERR) RETURN LEVEL = 0 META = 0 P = ARGPTR REPEAT < NMETA = 0 IF (QQCTOK(T, ARG, FD) == EOF) < IF (LEVEL == 0) BREAK CALL CLOSE(FD) FD = IFILES(LEVEL) PEEK = PEEKED(LEVEL) LEVEL = LEVEL - 1 NEXT ! IF (LEVEL == 0 & (T == SEMICOL \ T == NEWLINE \ T == BAR)) BREAK I = QQALLC(QQLEN(ARG) + 3) IF (I == -1) CALL QQERR1("TOO MANY ARGUMENTS\0") MEM(I+MEMOFF) = 0 MEM(I+MEMOFF+1) = T CALL QQSCPY(ARG, 1, MEM, I + MEMOFF + 2) IF (ARG(1) == LESS) INPTR = I ELSE IF (ARG(1) == GREATER) OUTPTR = I ELSE IF (ARG(1) == QMARK) ERRPTR = I ELSE IF (ARG(1) == BANG) RUNPTR = I + 3%%# POINT DIRECTLY TO NAME ELSE IF (ARG(1) == ACCENT) < LEVEL = LEVEL + 1 IF (LEVEL > NFILES) CALL QQERR1("INCLUDE FILES NESTED TOO DEEPLY\0") IFILES(LEVEL) = FD PEEKED(LEVEL) = PEEK FD = OPEN(ARG(2), READ) IF (FD == ERR) CALL QQERR2(ARG(2)) PEEK = 0 ! ELSE < NARGS = NARGS + 1 MEM(P+MEMOFF) = I P = I IF (NMETA > 0) META = META + 1 ! ! IF (T == BAR \ T == SEMICOL) <%# MORE COMMANDS COMING IF (QQCTOK(C, ARG, FD) == EOF) CALL QQERR1("SYNTAX ERROR\0") RUNPTR = QQLOC(ARG) FDO = CREATE("TMP:ARG", WRITE) IF (FDO == ERR) CALL QQERR1("CAN'T CREATE TEMPORARY FILE\0") CALL QQPUTS(FDO, ARG, 0) IF (T == BAR) <%# THIS IS A PIPE; WRITE 0) CALL QQGLOB RETURN END #-H- QQLEN.RAT 188 1980 103 2149 INCLUDE RATDEF # QQLEN - COMPUTE LENGTH OF STRING INTEGER FUNCTION QQLEN(STR) INTEGER STR(ARB) FOR (QQLEN = 0; STR(QQLEN+1) ^= EOS; QQLEN = QQLEN + 1) ; RETURN END #-H- QQLLC.MAC 401 1980 103 2149 SEARCH%IOPARM TITLE.%QQLLC ; QQLLC(C,A,I):C - GET THE ITH CHARACTER (0-BASED) FROM A IN C. ; QQLLC::%HRRZ%1,@2(16)%; GET I %IDIVI%1,5%%; COMPUTE WORD AND BYTE OFFSET %ADDI%1,@1(16)%; ADD IN ADDRESS %HLL%1,[POINT 7,0%; MAKE IT A POINTER %% POINT 7,0,6 %% POINT 7,0,13 %% POINT 7,0,20 %% POINT 7,0,27](2) %ILDB%0,1%%; EXTRACT THE CHARACTER %MOVEM%0,@0(16)%; STORE RESULT %POPJ%17,%%; RETURN END #-H- QQLOC.MAC 190 1980 103 2149 SEARCH%IOPARM TITLE.%QQLOC ; QQLOC(V:VAR):ADDR -- RETURN ADDRESS OF VARIABLE V. ; QQLOC:: MOVEI R,@0(16) ; MOVE ADDR TO RESULT REGISTER POPJ P, ; RETURN END #-H- QQOPEN.RAT 1513 1980 103 2149 INCLUDE RATDEF INCLUDE IODEFS DEFINE(NULLDEV,-18426626048)%# NUL IN SIXBIT DEFINE(TMPDEV,-12117344256)%# TMP IN SIXBIT DEFINE(TMPCORDEV,-12117197838)%# TMPCOR IN SIXBIT DEFINE(MTDEV,-19528679424)%# MT IN SIXBIT # QQOPEN - CREATE/OPEN NAME ACCORDING TO MODE, RETURN FILE DESCRIPTOR INTEGER FUNCTION QQOPEN(FCT, NAME, MODE) CHARACTER NAME(ARB) INTEGER MODE, FCT EXTERNAL FCT INTEGER FD, I, M, DEVTAB(14) INTEGER QQPARS, QQDEV INCLUDE CIOSYS DATA DEVTAB/3, 0, 4, 5, 0, 0, 0, 6, 0, 0, 7, 0, 0, 0/ FOR (FD = 1; FD <= MAXFILES; FD = FD + 1) # FIND A DESCRIPTOR IF (FDTAB(FD) == 0) BREAK IF (FD > MAXFILES) RETURN (ERR) FOR (I = 1; I < FBLEN*MAXFILES; I = I + FBLEN) # FIND A FILE BLOCK IF (FILTAB(I+USECNT) == 0) BREAK IF (I >= FBLEN*MAXFILES) RETURN (ERR) IF (QQPARS(NAME, OPNBLK, 9) == ERR) RETURN (ERR) M = QQDEV(OPNBLK(2)) # DETERMINE DEVICE NUMBERS IF (M == ERR \ (M & 63) > 13) M = 0 ELSE M = DEVTAB((M&63)+1) IF (OPNBLK(2) == NULLDEV) M = 1 ELSE IF (OPNBLK(2) == TMPDEV \ OPNBLK(2) == TMPCORDEV) M = 8 FILTAB(I+MAJOR) = M # FILL IN FILE BLOCK FILTAB(I+MINOR) = 1 IF (M == 4 & OPNBLK(2) == MTDEV) FILTAB(I+MINOR) = 2 FILTAB(I+OPNMODE) = MODE FILTAB(I+EOFFLAG) = NO IF (FCT(FILTAB(I+MAJOR), FILTAB(I+MINOR), FILTAB(I+USECNT)) == ERR) RETURN (ERR) FDTAB(FD) = I # CONNECT FILE DESCRIPTOR TO FILE BLOCK FILTAB(I+USECNT) = 1 RETURN (FD-1) END #-H- QQOPN.MAC 807 1980 103 2149 SEARCH%IOPARM TITLE.%QQOPN ; QQOPN(MAJOR,MINOR,FILTAB BLOCK) - SWITCH ON OPEN TABLE. ; QQOPN::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVEI%F,@2(A)%%; POINT TO FILTAB BLOCK %CLEARM%DEVPTR(F)%; CLEAR DEVICE DATA POINTER %LDB%T1,[SIZEPTR]%; GET BYTE SIZE %SKIPN%T1 % MOVEI%T1,7%%; CHARACTER IS DEFAULT %DPB%T1,[SIZEPTR]%; PUT IT BACK IN CASE DEFAULT %MOVEI%Z,(POINT 0)%; CONSTRUCT BYTE POINTERS %DPB%T1,[POINT 6,Z,29] %HRLZM%Z,BYTEPTR(F) %ORI%Z,(POINT 0,(T1)) %MOVNS%T1 %ADDI%T1,^D36%%; COMPUTE POSITION INDICATOR %DPB%T1,[POINT 6,Z,23] %HRLZM%Z,PACKPTR(F) %MOVEI%T1,^D36%%; COMPUTE BYTES PER WORD %LDB%Z,[SIZEPTR] %IDIV%T1,Z %MOVEM%T1,BYTEPW(F)%; SAVE FOR DEVICE DRIVERS %MOVE%T2,@0(A)%; GET MAJOR DEVICE NUMBER %MOVE%T1,@1(A)%; GET MINOR DEVICE NUMBER %JRST%@OPSW$##(T2)%; SWITCH TO PROPER OPEN ROUTINE END #-H- QQPAGE.MAC 545 1980 103 2149 SEARCH%IOPARM TITLE.%QQPAGE ; QQPAGE(FCN,A) - PERFORM PAGE. UUO OPERATION PER FCN. A IS PAGE. ; UUO ARGUMENT BLOCK. RETURNS NO IF UUO FAILED, YES OTHERWISE. ; QQPAGE::MOVE%T1,@0(A)%; GET FCN WORD %TLNE%T1,-1%%; CHECK FOR CODE 6 % JRST%$1%%; DON'T ANYTHING ELSE %MOVEI%T1,@1(A)%; GET ADDRESS OF ARGUMENT BLOCK %HRL%T1,@0(A)%; INDICATE FUNCTION %MOVEI%R,1%%; ASSUME SUCCESS %PAGE.%T1,%%; DO IT % CLEAR%R,%%; INDICATE ERROR %POPJ%P,%%; RETURN $1:%MOVE%R,T1%%; FUNCTION 6 REQUIRES SPECIAL TREATMENT %PAGE.%R, % MOVE%R,[ERR]%%; FAILED %POPJ%P, END #-H- QQPARS.MAC 9102 1980 103 2149 SEARCH%IOPARM TITLE.%QQPARS ; QQPARS(NAME,A,N) - PARSE FILE SPECIFICATION NAME INTO A. RETURNS ; BLOCK IN A AS FOLLOWS: A(1) = 0, A(2) = DEVICE NAME IN SIXBIT ; (DEFAULT IS DSK), A(3) = 0, A(4) = N (N >= 5), A(5) = POINTER TO ; A(N+5) WHERE PATH IS STORED OR 0, A(6) = FILE NAME IN SIXBIT, ; A(7) = EXTENSION IN SIXBIT, A(8) = PRIVILEGE LEFT JUSTIFIED, A(9) ; THROUGH A(N+6) = 0, A(N+7) = PPN IF PRESENT, A(N+8) THROUGH A(N+13) ; = SFD NAMES IN SIXBIT, A(N+14) = 0. A(1)...A(3) ARE IN THE CORRECT ; FORMAT FOR AN OPEN UUO, AND A(4)...A(N+14) ARE SUITABLE FOR LOOKUP ; AND ENTER UUOS. NOTE THAT A(N+5)...A(N+14) ARE IN THE PROPER ; FORM FOR A PATH. UUO. RETURNS ERR IF THERE IS A SYNTAX ERROR. ; DEV==1%%; OFFSETS TO FIELDS IN A CNT==3 PTR==4 NAM==5 EXT==6 PRV==7 PTH==4%%; REALLY N+5 PPN==2%%; REALLY N+7 SFD==3%%; REALLY N+8 SFDEND==13%; REALLY N+14 ALPHA==1111%; RETURNED BY GTOK ; QQPARS::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVEI%T1,@0(A)%; GET ADDRESS OF STRING %MOVEM%T1,STPTR%; SAVE IT MOVE T1,@STPTR ; GET FIRST WORD OF STRING TLNE T1,-1 ; PACKED OR UNPACKED? SKIPA T1,[POINT 7,0,6]; PACKED MOVE T1,[POINT 36,0,35]; UNPACKED ADDM T1,STPTR ; COMPLETE THE POINTER %CLEARM%PSHDBK%%; CLEAR LOOKAHEAD %MOVEI%F,@1(A)%%; GET ADDRESS OF ARRAY A %ADD%F,@2(A)%%; MAKE LEFT HALF POINT TO PATH %ADDI%F,PTH %HRLS%F %HRRI%F,@1(A) %HRL%T1,F%%; ZAP A %HRRI%T1,1(F) %MOVE%T2,@2(A)%; COMPUTE END %ADDI%T2,SFDEND(F) %CLEARM%-1(T1) %BLT%T1,(T2)%%; SPRAY IT WITH 0'S %MOVSI%T1,'DSK'%; SET UP DEFAULT DEVICE %MOVEM%T1,DEV(F) %MOVE%T1,@2(A)%; LENGTH OF EXTENDED LOOKUP BLOCK %MOVEM%T1,CNT(F) %CLEAR%T1,%%; GET READY TO GO LOOP:%PUSHJ%P,GTOK%%; GET A TOKEN %CAIN%C,ALPHA%%; NAME? % JRST%DONAM%%; YES %CAIN%C,":"%%; COLON? % JRST%DODEV%%; YES %CAIN%C,"."%%; PERIOD? % JRST%DOEXT%%; YES %CAIN%C,"["%%; PPN? % JRST%DOPPN%%; YES %CAIN%C,"<"%%; BRACKET? % JRST%DOPRV%%; YES %CAMN%C,[EOS]%%; END OF STRING? % JRST%DOEOS%%; YES %MOVE%T2,[X.SKP!X.EOL]; WE SKIP THESE %LSH%T2,(C)%%; SHIFT TO SIGN BIT %JUMPL%T2,LOOP%%; IGNORE IF ONE OF THEM %JRST%DOERR%%; YOU LOSE DONAM:%PUSHJ%P,SKIPBL%; SKIP BLANKS %PUSHJ%P,PEEKN%%; IS THERE A NAME COMING? % JRST%LOOP%%; NO %MOVEM%T1,NAM(F)%; YES, SAVE CURRENT NAME AS FILE NAME %CLEAR%T1,%%; ZAP NAME %JRST%LOOP%%; BACK FOR MORE DODEV:%SKIPN%T1%%; IS THERE A NAME? % JRST%DOERR%%; NO, YOU LOSE %MOVEM%T1,DEV(F)%; YES, SAVE IT AS DEVICE %CLEAR%T1,%%; CLEAR NAME %JRST%LOOP%%; BACK FOR MORE DOEXT:%SKIPE%T1%%; WAS THERE A FILE NAME? % MOVEM%T1,NAM(F)%; YES %CLEARB%T1,EXT(F)%; CLEAR NAME AND EXTENSION %PUSHJ%P,PEEKN%%; IS THERE A NAME COMING % JRST%LOOP%%; NO %PUSHJ%P,GTOK%%; YES, GET NEXT TOKEN %EXCH%T1,EXT(F)%; SAVE IT AND CLEAR T1 %CAIE%C,ALPHA%%; WAS THERE A NAME? % HRROM%C,PSHDBK%; NO, PUT TOKEN BACK %JRST%LOOP%%; BACK FOR MORE DOPPN:%SKIPE%T1%%; WAS THERE A FILE NAME? % MOVEM%T1,NAM(F)%; YES %CLEARM%PTR(F)%%; ZAP POINTER TO PATH %PUSHJ%P,SKIPBL%; SKIP BLANKS %PUSHJ%P,GETCHR%; CHECK FOR [-] AND [] CASE %CAIN%C,"]" % JRST%LOOP%%; LEAVE PPN ZAPPED %HLRZM%F,PTR(F)%; STASH POINTER TO PATH %CAIE%C,"-" % JRST%$6%%; NOPE TRY USUAL PPN %PUSHJ%P,GTOK%%; GET NEXT TOKEN %CAIE%C,"]"%%; MUST BE THIS % JRST%DOERR %HLR%T2,F%%; POINT TO PATH BLOCK %HRLI%T2,10 %SETOM%(T2)%%; TO GET CURRENT PATH %PATH.%T2,%%; GET DEFAULT PATH % HALT%%%; CAN'T HAPPEN %CLEAR%T1,%%; CLEAR NAME %JRST%LOOP%%; BACK FOR MORE $6:%HRROM%C,PSHDBK%; PUSH BACK CHARACTER %MOVSS%F%%; SWAP HALVES SO POINTING TO PATH %CLEAR%T1,%%; CLEAR NAME %GETPPN%T2,%%; GET USER'S PPN %MOVEM%T2,PPN(F)%; SAVE IT %CLEARM%PPN+1(F)%; ZAP ANY OLD SFD NAMES %PUSHJ%P,GETOCT%; GET PROJECT NUMBER %SKIPG%T2%%; ZERO? % HLRZ%T2,PPN(F)%; YES, USE DEFAULT %PUSHJ%P,GTOK%%; GET NEXT TOKEN %CAIG%T2,377777%; PROJECT NUMBER CAN'T BE TOO BIG %CAIE%C,","%%; ALSO MUST TERMINATE WITH A COMMA % JRST%DOERR%%; ERROR, TOO BIG OR NO COMMA %HRLM%T2,PPN(F)%; STASH PROJECT NUMBER %PUSHJ%P,GETOCT%; GET PROGRAMMER NUMBER %SKIPG%T2%%; ZERO? % HRRZ%T2,PPN(F)%; YES, USE DEFAULT %PUSHJ%P,GTOK%%; GET NEXT TOKEN %CAIE%C,"]"%%; TERMINATOR MUST BE A RIGHT BRACKET %CAIN%C,","%%; OR A COMMA %CAILE%T2,377777%; AND IT MUST BE IN RANGE % JRST%DOERR%%; LOSER %HRRM%T2,PPN(F)%; STASH PROGRAMMER NUMBER %CAIE%C,","%%; SFDS COMING? % JRST%NOSFD%%; NO, GO BACK FOR MORE %MOVEI%T2,SFD(F)%; POINT TO FIRST SFD SLOT DOSFD:%PUSHJ%P,GTOK%%; GET A NAME %CAIE%C,ALPHA%%; MUST BE A NAME % JRST%DOERR%%; OR IT'S AN ERROR %MOVEM%T1,(T2)%%; STASH IT %ADDI%T2,1%%; BUMP POINTER %PUSHJ%P,GTOK%%; GET NEXT TOKEN %CAIN%C,","%%; DONE? % JRST%DOSFD%%; NOPE, GO ON %CLEARM%(T2)%%; YES, CLEAR LAST HOLE %CAIE%C,"]"%%; MUST BE A BRACKET % JRST%DOERR%%; ERROR %CLEAR%T1,%%; CLEAR NAME NOSFD:%MOVSS%F%%; PUT PROPER POINTER BACK %JRST%LOOP%%; BACK FOR MORE DOPRV:%SKIPE%T1%%; WAS THERE A FILE NAME? % MOVEM%T1,NAM(F)%; YES %CLEAR%T1,%%; CLEAR NAME %PUSHJ%P,GETOCT%; GET PROTECTION %PUSHJ%P,GTOK%%; AND NEXT TOKEN %CAIG%T2,777%%; OUT OF RANGE? %CAIE%C,">"%%; NO, BUT DO WE HAVE PROPER TERMINATOR? % JRST%DOERR%%; NOPE, LOSER %LSH%T2,^D27%%; PROTECTION OK, SHIFT TO BITS 0-8 %MOVEM%T2,PRV(F)%; STORE IT %JRST%LOOP%%; BACK FOR MORE DOEOS:%CLEAR%R,%%; ASSUME SUCCESS %SKIPE%T1%%; WAS THERE A FILE NAME? % MOVEM%T1,NAM(F)%; YES %HLRZ%T1,EXT(F)%; GET EXTENSION %MOVE%T2,DEV(F)%; GET DEVICE %CAIN%T1,'TMP'%; DSK:XXXYYY.TMP ? %CAME%T2,['DSK '] % JRST%$9%%; NOPE %HRRZ%T1,NAM(F)%; YES, GET RIGHT PART OF NAME %JUMPN%T1,$9%%; LONG NAMES DON'T GET MODIFIED %PUSHJ%P,JOBNO$##%; GET JOB NUMBER AS XXX %HLR%T1,NAM(F)%; FORM NNNXXX %HRL%T1,Z %MOVEM%T1,NAM(F)%; NO, STORE NEW NAME %CLEAR%R, $9:%SKIPE%NAM(F)%%; NULL FILE NAME? % POPJ%P,%%; NO, WE'RE DONE %SKIPE%EXT(F)%%; EXTENSION? % POPJ%P,%%; NOPE, WE'RE DONE %MOVSS%F%%; POINT TO PATH %SKIPN%T1,PPN(F)%; PATH HERE MEANS OPEN DIRECTORY % POPJ%P,%%; RETURN %MOVEI%T2,SFD(F)%; POINT TO SFD NAMES $7:%SKIPE%(T2)%%; END OF LIST YET? % AOJA%T2,$7 %CAIE%T2,SFD(F)%; SFDS? % JRST%$8%%; THERE IS A PATH %CALLI%T2,41%%; NO SFDS, GET MFD AREA % MOVE%T2,[1,,1]%; OOPS, ASSUME THE USUAL %EXCH%T2,PPN(F) %MOVSS%F%%; POINT BACK TO TOP OF A %MOVEM%T2,NAM(F)%; STASH NAME %MOVSI%T2,'UFD' %MOVEM%T2,EXT(F)%; SET USUAL EXTENSION %POPJ%P,%%; RETURN $8:%MOVE%T1,-1(T2)%; GET LAST SFD NAME %CLEARM%-1(T2)%%; RESET END OF SFD LIST %MOVSS%F%%; POINT BACK TO TOP OF A %MOVEM%T1,NAM(F)%; STASH NAME %MOVSI%T1,'SFD'%; SET EXTENSION %MOVEM%T1,EXT(F) %POPJ%P,%%; RETURN DOERR:%MOVE%R,[ERR]%%; INDICATE ERROR %POPJ%P,%%; RETURN ; GETOCT -- GET AN OCTAL NUMBER. CALL IS ;%PUSHJ%P,GETOCT ;%RETURN, RESULT IN T2 ; GETOCT:%CLEAR%T2,%%; CLEAR RESULT %PUSHJ%P,SKIPBL%; SKIP BLANKS $1:%PUSHJ%P,GETCHR%; GET A CHARACTER %CAIL%C,"0"%%; IN RANGE? %CAILE%C,"7" % JRST%[HRROM%C,PSHDBK%; NO, PUT TOKEN BACK %% POPJ%P,]%%; RETURN %LSH%T2,3%%; SHIFT PREVIOUS RESULT %ADDI%T2,-"0"(C)%; ADD IT NEW DIGIT %JRST%$1%%; LOOP ; GETCHR -- GET NEXT CHARACTER FROM THE STRING. CALL IS ;%PUSHJ%P,GETCHR ;%RETURN, CHARACTER IN C GETCHR:%SKIPL%PSHDBK%%; IS THERE A PUSHED BACK CHARACTER? % JRST%$2%%; NO %HRRZS%C,PSHDBK%; YES, GET IT AND CLEAR FLAG %POPJ%P,%%; RETURN $2:%LDB %C,STPTR ; GET A REGULAR CHARACTER SKIPN C ; NULL? MOVE C,[EOS]%%; YES, ASSUME EOS %CAMN%C,[EOS]%%; END OF STRING? % POPJ%P,%%; YES, RETURN AND DON'T BUMP POINTER %IBP%STPTR%%; NO, BUMP POINTER %CAIL%C,"A"%%; LOWER CASE? %CAILE%C,"^" % POPJ%P,%%; NO %SUBI%C,40%%; YES, CONVERT IT %POPJ%P,%%; RETURN ; GTOK -- GET NEXT TOKEN FROM THE FILE SPECIFICATION. CALL IS ;%PUSHJ%P,GTOK ;%RETURN, C HAS TOKEN AND T1 HAS NAME IF C HAS ALPHA CODE GTOK:%PUSHJ%P,SKIPBL%; SKIP BLANKS AND TABS %PUSHJ%P,PEEKN%%; IS THERE A NAME COMING? % JRST%GETCHR%%; NO, JUST RETURN THE CHARACTER %CLEAR%T1,%%; YES, SET UP FOR NAME $3:%PUSHJ%P,GETCHR%; GET ANOTHER CHARACTER %PUSHJ%P,ISALPH%; PART OF A NAME? % JRST%$4%%; NO %TLNE%T1,770000%; GOT 6 ALREADY? % JRST%$3%%; YES %LSH%T1,6%%; SHIFT PREVIOUS NAME %ADDI%T1,-40(C)%; ADD IN NEW CHARACTER %JRST%$3%%; AND GO BACK FOR MORE $4:%HRROM%C,PSHDBK%; PUT BACK LAST CHARACTER %MOVEI%C,ALPHA%%; GET ALPHA CODE $5:%TLNE%T1,770000%; LEFT JUSTIFY NAME % POPJ%P,%%; DONE, RETURN %LSH%T1,6%%; MOVE OVER ANOTHER 6 %JRST%$5%%; LOOP ; ISALPH -- CHECKS IF A CHARACTER IS ALPHNUMERIC OR NOT. CALL IS ;%MOVE%C,CHARACTER ;%PUSHJ%P,ISALPH ;% NO ;%YES ISALPH:%CAIL%C,"0"%%; A DIGIT? %CAILE%C,"Z"%%; OR LETTER? % POPJ%P,%%; NO WAY %CAILE%C,"9"%%; A DIGIT? %CAIL%C,"A"%%; OR LOWER CASE LETTER? % JRST%CPOPJ1%%; YES %CAIL%C,"A"%%; UPPER CASE? %CAILE%C,"Z" % POPJ%P,%%; NO CPOPJ1:%AOS%(P)%%; BUMP FOR SKIP RETURN %POPJ%P,%%; RETURN ; PEEKN -- CHECK TO SEE IF A NAME IS COMING. CALL IS ;%PUSHJ%P,PEEKN ;% NO ;%YES PEEKN:%PUSHJ%P,GETCHR%; GET NEXT CHARACTER %HRROM%C,PSHDBK%; BUT PUT IT BACK %PUSHJ%P,ISALPH%; IS IT BEGINNING OF A NAME? % POPJ%P,%%; NO %JRST%CPOPJ1%%; YES ; SKIPBL -- SKIP BLANKS AND TABS. CALL IS ;%PUSHJ%P,SKIPBL SKIPBL:%PUSHJ%P,GETCHR%; GET A CHARACTER %CAIE%C," "%%; BLANK? %CAIN%C,"I"-100%; OR TAB? % JRST%SKIPBL%%; YES %HRROM%C,PSHDBK%; NO, PUT IT BACK %POPJ%P,%%; RETURN RELOC STPTR:%BLOCK%1%%; POINTER TO NAME PSHDBK:%BLOCK%1%%; PUSHED BACK CHARACTER RELOC END #-H- QQPUTS.RAT 775 1980 103 2149 INCLUDE RATDEF # QQPUTS - WRITES STRINGS S1... TO FILE F SUBROUTINE QQPUTS(F, S1) INTEGER F CHARACTER S1(ARB) INTEGER I, AP, MEMOFF, MEM(1) CHARACTER QQLLC INTEGER QQARG, QQLOC CHARACTER C MEMOFF = 1 - QQLOC(MEM(1)) # GET ADDRESSING OFFSET FOR (AP = 2; MEM(QQARG(AP)+MEMOFF) ^= 0; AP = AP + 1) < ADR = QQARG(AP) + MEMOFF FOR (I = 0; QQLLC(C, MEM(ADR), I) ^= 0; I = I + 1) < IF (C == BACKSLASH) < I = I + 1 IF (QQLLC(C, MEM(ADR), I) == DIG0) BREAK ELSE IF (C == LETN) C = NEWLINE ! CALL PUTCH(C, F) ! IF (I == 0) FOR (; MEM(ADR) ^= EOS; ADR = ADR + 1) CALL PUTCH(MEM(ADR), F) ! RETURN END #-H- QQRM.MAC 1527 1980 103 2149 SEARCH%IOPARM TITLE.%QQRM ; QQRM(NAME:STRING) -- DELETE FILE NAME. ; QQRM::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVEI%T1,@0(A)%; POINT TO NAME %MOVEM%T1,NAMPTR %MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1 %PUSHJ%P,QQPARS##%; CRACK THE FILE SPEC %CAMN%R,[ERR]%%; DIE IF ERROR % POPJ%P, %CLEARM%OPNBK$%%; CLEAR OTHER WORDS IN OPNBK$ %CLEARM%OPNBK$+2 %MOVE%Z,OPNBK$+1%; GET DEVICE NAME %DEVTYP%Z,%%; GET ITS TYPE % MOVEI%Z,100%%; ASSUME DISK %SKIPN%Z%%; IF NOT LEGAL DEVICE % MOVEI%Z,77%%; FAKE IT %ANDI%Z,77%%; GET DEVICE TYPE CODE %CAIE%Z,0%%; DISK? % JRST%$2%%; NOPE $1:%OPEN.%0,OPNBK$%; YES, OPEN IT % JRST%$99%%; CAN'T OPEN %LOOKUP%0,UUOBK$## % JRST%$99%%; CAN'T FIND %CLEARM%UUOBK$%%; SET UP FILE BLOCK FOR DELETION %RENAME%0,UUOBK$ % JRST%$99%%; OOPS %JRST%$98%%; SUCCESS $2:%MOVE%Z,OPNBK$+1%; GET DEVICE %CAME%Z,['TMP ']%; TMPCOR? %CAMN%Z,['TMPCOR'] % SKIPA%%%; YEP %JRST%$98%%; NOPE, JUST RETURN %HLLZ%T1,UUOBK$+2%; GET NAME %CLEAR%T2, %MOVE%Z,[2,,T1] %TMPCOR%Z,%%; READ AND DELETE IT % JFCL%%%; SO WHAT %MOVSI%Z,'DSK'%%; ALSO DELETE DSK:XXXNAM.TMP %MOVEM%Z,OPNBK$+1 %PJOB%Z,%%; FORM FILE NAME XXXNAM %IDIVI%Z,^D100 %IDIVI%T1,^D10 %ADDI%Z,'0' %LSH%Z,6 %ADDI%Z,'0'(T1) %LSH%Z,6 %ADDI%Z,'0'(T2) %HLL%Z,UUOBK$+2%; GET NAME PART %MOVSM%Z,UUOBK$+2%; SWAP HALVES AND STORE %MOVSI%Z,'TMP'%%; EXTENSION %MOVEM%Z,UUOBK$+3 %JRST%$1%%; GO DELETE DISK FILE $98:%TDZA%R,R%%; INDICATE SUCCESS $99:%MOVE%R,[ERR]%%; INDICATE ERROR %RELEAS%0,0%%; RELEASE CHANNEL IF USED %POPJ%P,%%; RETURN RELOC NAMPTR:%BLOCK%1 RELOC END #-H- QQRUN.MAC 758 1980 103 2149 SEARCH%IOPARM TITLE.%QQRUN ; QQRUN(NAME,OFFSET) - RUN NAME AT RUN OFFSET (0 OR 1). ; QQRUN::%PUSHJ%P,SAVR$##%; SAVE REGISTERS %MOVEI%Z,@0(A)%%; GET ADDRESS OF STRING %MOVEM%Z,NAMPTR %PUSH%P,A%%; SAVE ARGUMENT LIST POINTER %MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1 %PUSHJ%P,QQPARS##%; PARSE FILE SPEC %POP%P,A%%; GET ARGUMENT LIST POINTER BACK %CAMN%Z,[ERR]%%; ERROR? % JRST%$99 %MOVE%Z,OPNBK$##+1%; GET DEVICE NAME %EXCH%Z,UUOBK$##+1%; STASH FOR RUN UUO %MOVEM%Z,UUOBK$+5 %CLEARM%UUOBK$+4 %CLEARM%UUOBK$+6 %HRL%Z,@1(A)%%; GET RUN OFFSET %HRRI%Z,UUOBK$+1%; POINT TO RUN BLOCK %JRST%$1%%; GO TO LOW SEGMENT TO DO RUN UUO RELOC $1:%CALLI%Z,35 % HALT RELOC $99:%MOVE%R,[ERR]%%; ERROR %POPJ%P, RELOC NAMPTR:%BLOCK%1%%; FOR POINTER TO NAME RELOC END #-H- QQSCPY.RAT 295 1980 103 2149 INCLUDE RATDEF # QQSCPY - COPY STRING AT FROM(I) TO TO(J) SUBROUTINE QQSCPY(FROM, I, TO, J) CHARACTER FROM(ARB), TO(ARB) INTEGER I, J, K1, K2 K2 = J FOR (K1 = I; FROM(K1) ^= EOS; K1 = K1 + 1) < TO(K2) = FROM(K1) K2 = K2 + 1 ! TO(K2) = EOS RETURN END #-H- R50TOC.RAT 825 1980 103 2149 INCLUDE RATDEF # R50TOC - CONVERT RADIX50 SYMBOL INT TO STRING IN STR INTEGER FUNCTION R50TOC(INT, STR, SIZE) INTEGER MOD INTEGER I, INT, INTVAL, J, K, SIZE CHARACTER STR(ARB) INTVAL = INT STR(1) = EOS I = 1 REPEAT < # GENERATE CHARACTERS I = I + 1 K = MOD(INTVAL, 40) IF (K >= 11 & K <= 36) STR(I) = LETA - 11 + K ELSE IF (K >= 1 & K <= 10) STR(I) = DIG0 - 1 + K ELSE IF (K == 38 \ K == 39) STR(I) = DOLLAR - 38 + K ELSE IF (K == 37) STR(I) = PERIOD ELSE I = I - 1 INTVAL = INTVAL / 40 ! UNTIL (INTVAL == 0 \ I >= SIZE) R50TOC = I - 1 FOR (J = 1; J < I; J = J + 1) < # THEN REVERSE K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 ! RETURN END #-H- RATDEF 2690 1980 103 2149 #========== STANDARD RATFOR DEFINITIONS ========== DEFINE(ACCENT,96) DEFINE(ALPHA,10100) DEFINE(AND,38) DEFINE(ANDIF,IF) DEFINE(ARB,100) DEFINE(ATSIGN,64) DEFINE(BACKSLASH,92) DEFINE(BACKSPACE,8) DEFINE(BANG,33) DEFINE(BAR,124) DEFINE(BIGA,65) DEFINE(BIGB,66) DEFINE(BIGC,67) DEFINE(BIGD,68) DEFINE(BIGE,69) DEFINE(BIGF,70) DEFINE(BIGG,71) DEFINE(BIGH,72) DEFINE(BIGI,73) DEFINE(BIGJ,74) DEFINE(BIGK,75) DEFINE(BIGL,76) DEFINE(BIGM,77) DEFINE(BIGN,78) DEFINE(BIGO,79) DEFINE(BIGP,80) DEFINE(BIGQ,81) DEFINE(BIGR,82) DEFINE(BIGS,83) DEFINE(BIGT,84) DEFINE(BIGU,85) DEFINE(BIGV,86) DEFINE(BIGW,87) DEFINE(BIGX,88) DEFINE(BIGY,89) DEFINE(BIGZ,90) DEFINE(BLANK,32) DEFINE(CARET,94) DEFINE(COLON,58) DEFINE(COMMA,44) DEFINE(DIG0,48) DEFINE(DIG1,49) DEFINE(DIG2,50) DEFINE(DIG3,51) DEFINE(DIG4,52) DEFINE(DIG5,53) DEFINE(DIG6,54) DEFINE(DIG7,55) DEFINE(DIG8,56) DEFINE(DIG9,57) DEFINE(DIGIT,2) DEFINE(DOLLAR,36) DEFINE(DQUOTE,34) DEFINE(EOF,10003) DEFINE(EOS,10002) DEFINE(EQUALS,61) DEFINE(ERR,10001) DEFINE(ERROUT,2) DEFINE(GREATER,62) DEFINE(HUGE,30000) DEFINE(LBRACE,123) DEFINE(LBRACK,91) DEFINE(LESS,60) DEFINE(LETA,97) DEFINE(LETB,98) DEFINE(LETC,99) DEFINE(LETD,100) DEFINE(LETE,101) DEFINE(LETF,102) DEFINE(LETG,103) DEFINE(LETH,104) DEFINE(LETI,105) DEFINE(LETJ,106) DEFINE(LETK,107) DEFINE(LETL,108) DEFINE(LETM,109) DEFINE(LETN,110) DEFINE(LETO,111) DEFINE(LETP,112) DEFINE(LETQ,113) DEFINE(LETR,114) DEFINE(LETS,115) DEFINE(LETT,116) DEFINE(LETTER,1) DEFINE(LETU,117) DEFINE(LETV,118) DEFINE(LETW,119) DEFINE(LETX,120) DEFINE(LETY,121) DEFINE(LETZ,122) DEFINE(LPAREN,40) DEFINE(MAXCHARS,20) DEFINE(MAXLINE,120)%# TYPICAL LINE LENGTH DEFINE(MAXNAME,30) %# TYPICAL FILE NAME SIZE DEFINE(MINUS,45) DEFINE(NEWLINE,10) DEFINE(NO,0) DEFINE(NOERR,0) DEFINE(NOT,126) # SAME AS TILDE DEFINE(OK,-2) DEFINE(OR,BAR) # SAME AS BAR DEFINE(PERCENT,37) DEFINE(PERIOD,46) DEFINE(PLUS,43) DEFINE(QMARK,63) DEFINE(RBRACE,125) DEFINE(RBRACK,93) DEFINE(READ,0) DEFINE(READWRITE,2) DEFINE(RPAREN,41) DEFINE(SEMICOL,59) DEFINE(SHARP,35) DEFINE(SLASH,47) DEFINE(SQUOTE,39) DEFINE(STAR,42) DEFINE(STDIN,0) DEFINE(STDOUT,1) DEFINE(STDERR,ERROUT) DEFINE(TAB,9) DEFINE(TILDE,126) DEFINE(UNDERLINE,95) DEFINE(WRITE,1) DEFINE(YES,1) DEFINE(ESCAPE,ATSIGN) DEFINE(CHARACTER,INTEGER) DEFINE(ABS,IABS) DEFINE(MIN,MIN0) DEFINE(MAX,MAX0) # HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE DEFINE(BPI,36)%%# BITS PER INTEGER DEFINE(BPC,7)%%# BITS PER CHARACTER DEFINE(CPI,5)%%# CHARACTERS PER INTEGER DEFINE(LIMIT,134217728)%# LARGEST POSITIVE INTEGER DEFINE(LIM1,28)%%# MAXIMUM EXPONENT (POWER OF TEN) DEFINE(LIM2,-28)%# MINIMUM EXPONENT (POWER OF TEN) DEFINE(PRECISION,7)%# DIGITS ACCURATE IN REAL #-H- READF.MAC 803 1980 103 2149 SEARCH%IOPARM TITLE.%READF ; READF(BUF,COUNT,FD) -- READ FROM FILE FD. ; READF::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %SKIPG%T2,@1(A)%; COUNT % JRST%[CLEAR%R, %% POPJ%P, ]%; EMPTY BUFFER SO RETURN %MOVEI%T1,@0(A)%; POINTER TO BUFFER %MOVE%F,@2(A) %MOVE%F,FDTAB$##(F)%; POINTER TO ENTRY INTO FILTAB %MOVEI%F,FLTAB$##-1(F)%; POINT TO FILE BLOCK %MOVE%Z,OPNMODE(F)%; GET MODE %TRNE%Z,1%%; OPEN FOR WRITE ONLY? % JRST%[MOVE%R,[ERR] %% POPJ%P, ] ; OPEN FOR WRITE ONLY %SKIPE%EOFFLAG(F) % JRST%[MOVE%R,[EOF] %% POPJ%P, ]%; PREVIOUS EOF, RETURN EOF %MOVE%C,MAJOR(F)%; DEVICE NUMBER FOR COMPUTED CALL %TRNN%Z,READPACKED%; CHECK FOR PACKED BUFFER % JRST%.+3 %HLL%T1,BYTEPTR(F)%; USE PACKED POINTER %JRST%@RDSW$##(C)%; DISPATCH TO DEVICE DRIVER %HRLI%T1,(POINT 36)%; USE UNPACKED POINTER %JRST%@RDSW$(C) END #-H- REMARK.RAT 593 1980 103 2149 INCLUDE RATDEF # REMARK - PRINT WARNING MESSAGE SUBROUTINE REMARK(BUF) INTEGER BUF(ARB), I, LLC CHARACTER C FOR (I = 0; LLC(C, BUF, I) ^= PERIOD; I = I + 1) < IF (C == 0) BREAK IF (C == ESCAPE) < I = I + 1 IF (LLC(C, BUF, I) == DIG0) BREAK ELSE IF (C == LETN \ C == BIGN) C = NEWLINE ELSE IF (C == LETB \ C == BIGB) C = BACKSPACE ELSE IF (C == LETT \ C == BIGT) C = TAB ! CALL PUTCH(C, ERROUT) ! CALL PUTCH(NEWLINE, ERROUT) RETURN END #-H- REMOVE.RAT 146 1980 103 2149 INCLUDE RATDEF # REMOVE - DELETE FILE NAME INTEGER FUNCTION REMOVE(NAME) CHARACTER NAME(ARB) INTEGER QQRM RETURN(QQRM(NAME)) END #-H- RESET.MAC 653 1980 103 2149 SEARCH%IOPARM TTYFLG==CARGS## TITLE.%RESET. ; RESET. -- SIMULATES FORTRAN RESET FUNCTION TO INITIALIZE STACK. ; NOTE CALLING SEQUENCE IS ;%JSA%16,RESET. ;%0 ; RESET.::MOVE%P,.JBFF##%; GET FIRST FREE ADDRESS %HRLI%P,-STKSIZ+1%; SET UP STACK POINTER %MOVEI%T1,STKSIZ(P)%; COMPUTE NEW FIRST FREE %HRRM%T1,.JBFF%; STASH IT %CAMGE%T1,.JBREL##%; GOT ENOUGH CORE? % JRST%$1%%; YES %CORE%T1,%%; CORE UP % HALT%%%; OOPS $1:%HLLZS%.JBERR##%; CLEAR ERROR INDICATOR %CLEARM%TTYFLG%%; ASSUME ARG FILE %TTCALL%10,1%%; RESCAN THE COMMAND LINE %SKPINL%%%; ANYTHING THERE? % SKIPA%%%; NOPE %AOS%TTYFLG%%; YES %PUSHJ%P,QQINIT##%; INITIALIZE I/O %JRST%1(16)%%; RETURN END #-H- RUN.MAC 98 1980 103 2149 SEARCH%IOPARM TITLE.%RUN ; RUN(NAME,OFFSET) - RUN NAME AT RUN OFFSET (0 OR 1). ; RUN==QQRUN## END #-H- SAVR.MAC 469 1980 103 2149 SEARCH%IOPARM TITLE.%SAVR$ ; SAVR$ -- SAVE REGISTERS. MODIFIES STACK TO DO AUTO-RESTORE. CALL IS ;%PUSHJ%P,SAVR$ ; SAVR$::%EXCH%T1,(P)%%; SAVE T1 AND GET RETURN POINT %HRLI%T1,(P)%%; POINT TO WHERE T1 IS SAVED %PUSH%P,T2%%; SAVE THE REST %PUSH%P,F %PUSH%P,C %PUSHJ%P,[JRA T1,(T1)]%; RETURN RESTORING T1 % SKIPA%%%; GIVE NONSKIP RETURN %AOS%-4(P)%%; GIVE SKIP RETURN %POP%P,C%%; RESTORE THE REGISTERS %POP%P,F %POP%P,T2 %POP%P,T1 %POPJ%P,%%; RETURN TO REAL CALLER END #-H- SEEK.MAC 327 1980 103 2149 SEARCH%IOPARM TITLE.%SEEK ; SEEK(OFFSET,FD) - SEEK TO OFFSET IN FILE FD. ; SEEK::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVE%F,@1(A)%%; POINT TO FILE BLOCK %MOVE%F,FDTAB$##(F) %MOVEI%F,FLTAB$##-1(F) %MOVE%T1,@0(A)%; GET OFFSET %MOVE%T2,MAJOR(F)%; GET MAJOR DEVICE NUMBER %JRST%@SKSW$##(T2)%; SWITCH TO PROPER SEEK ROUTINE END #-H- SHIFT.MAC 201 1980 103 2149 SEARCH%IOPARM TITLE.%SHIFT ; SHIFT(X,N) - RETURN X SHIFTED BY N BITS AS IN LSH INSTRUCTION. ; SHIFT::%MOVE%0,@0(16)%; GET N MOVE%1,@1(16)%; GET SHIFT COUNT %LSH%0,(1)%%; SHIFT IT %POPJ%17, END #-H- SIXTOC.RAT 528 1980 103 2149 INCLUDE RATDEF # SIXTOC - CONVERT SIXBIT SYMBOL INT TO STRING IN STR INTEGER FUNCTION SIXTOC(INT, STR, SIZE) INTEGER SHIFT INTEGER I, INT, SIZE, N CHARACTER STR(ARB) N = MIN0(6, SIZE-1) FOR (I = 1; I <= N; I = I + 1) < STR(I) = (SHIFT(INT, -36 + 6*I) & 8%077) + BLANK IF (STR(I) >= BIGA & STR(I) <= BIGZ) STR(I) = STR(I) + LETA - BIGA ! FOR (I = MIN0(6, SIZE-1); I > 0; I = I - 1) # TRIM BLANKS IF (STR(I) ^= BLANK) BREAK STR(I+1) = EOS RETURN(I) END #-H- STC.MAC 381 1980 103 2149 SEARCH%IOPARM TITLE.%STC ; STC(C,A,I):C - STORE C AT ITH CHARACTER (0-BASED) IN A. ; STC::%HRRZ%1,@2(16)%; GET I %IDIVI%1,5%%; COMPUTE WORD AND BYTE OFFSET %ADDI%1,@1(16)%; ADD IN ADDRESS %HLL%1,[POINT 7,0%; MAKE IT A POINTER %% POINT 7,0,6 %% POINT 7,0,13 %% POINT 7,0,20 %% POINT 7,0,27](2) %MOVE%0,@0(16)%; GET C %IDPB%0,1%%; STORE THE CHARACTER %POPJ%17,%%; RETURN END #-H- STOP.MAC 549 1980 103 2149 SEARCH%IOPARM RUNPTR==CARGS##+1 TITLE.%STOP. ; STOP. -- ABNORMAL TERMINATION. ; STOP.::%CLEARM%RUNPTR%%; DON'T RUN SUBSEQUENTS IN THIS CASE %SKIPL%-1(A)%%; EXPLICIT ARGUMENT? % JRST%EXIT.##%%; NO, JUST EXIT %OUTSTR%[ASCIZ /STOP /] %MOVE%Z,@0(A)%%; YES, GET ARGUMENT %PUSHJ%P,$1%%; PRINT NUMBER %OUTSTR%[ASCIZ / /] %JRST%EXIT.%%; THEN EXIT $1:%IDIVI%Z,8%%; PRINT STOP NUMBER IN OCTAL %PUSH%P,T1 %SKIPE%Z%%; DONE YET? % PUSHJ%P,$1%%; NO, KEEP GOING %POP%P,Z%%; YES, GET A DIGIT %ADDI%Z,"0"%%; MAKE IT ASCII %OUTCHR%Z%%; PRINT IT %POPJ%P,%%; GO ON END #-H- TAPOP.MAC 2036 1980 103 2149 SEARCH%IOPARM TITLE.%TAPOP ; TAPOP(FCN:INTEGER,F:FILE/NAME:STRING,A:ARRAY,N:INTEGER):INTEGER -- ; PERFORM THE MAG TAPE OPERATION INDICATED BY FCN ON FILE F OR TAPE ; UNIT NAME. IF THE FIRST WORD OF NAME IS < MAXFILES, IT IS ASSUMED TO ; BE A FILE DESCRIPTOR, NOT A NAME. ARGUMENTS ARE PASSED OR RECEIVED ; IN A(1)..A(N). ; TAPOP::%PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %MOVEI%T1,@1(A)%; GET ADDRESS OF NAME OR FILE DESCRIPTOR %MOVE%F,(T1)%%; GET FIRST WORD %CAIGE%F,MAXFILES%; CHANNEL NUMBER? % JRST%$A%%; YES %MOVEM%T1,NAMPTR%; NO, PREPARE TO PARSE THE NAME %PUSH%P,A %MOVEI%A,[EXP <-3,,0>,1B13!NAMPTR,OPNBK$##,[EXP ^D9]]+1 %PUSHJ%P,QQPARS##%; CRACK THE NAME %POP%P,A %CAMN%R,[ERR] % JRST%$7%%; BAD SYNTAX %MOVE%T1,OPNBK$+1%; USE DEVICE NAME %MOVEM%T1,TAPARG+1%; IN TAPOP. ARGUMENT LIST %JRST%$B%%; HOP AROUND $A:%MOVE%F,FDTAB$##(F)%; POINTER TO ENTRY INTO FILTAB %MOVEI%F,FLTAB$##-1(F)%; POINT TO FILE BLOCK %LDB%Z,[POINT 4,CHANNEL(F),12] %MOVEM%Z,TAPARG+1%; STORE CHANNEL NUMBER $B:%MOVE%T1,@0(A)%; GET THE FUNCTION CODE %MOVEM%T1,TAPARG%; STORE IT %MOVEI%T2,@2(A)%; GET ADDRESS OF ARRAY %CAILE%T1,777%%; PERFORM A SPECIFIC ACTION? % JRST%$1%%; NO %MOVE%T1,[2,,TAPARG]%; YES, DO IT %TAPOP.%T1, % JRST%$7%%; ERROR %CLEAR%R, %POPJ%P,%%; RETURN SUCCESSFULLY $1:%CAILE%T1,1777%%; READ A PARAMETER? % JRST%$4%%; NO %MOVE%T1,[2,,TAPARG]%; SET UP ARGUMENT POINTER %TAPOP.%T1, % JRST%$7%%; ERROR %MOVE%R,@3(A)%%; GET N %CAIL%R,1%%; MUST BE ONE % MOVEM%T1,(T2)%%; STORE VALUE OF PARAMETER %CLEAR%R, %POPJ%P,%%; RETURN SUCCESSFULLY $4:%CAILE%T1,2777%%; SET A PARAMETER ? % JRST%$7%%; NO %MOVEI%T1,1%%; INITIALIZE FOR COPY LOOP $5:%CAMLE%T1,@3(A)%; DONE? % JRST%$6%%; YES %MOVE%R,(T2)%%; COPY ITEM %MOVEM%R,TAPARG+1(T1) %ADDI%T2,1%%; BUMP ARRAY ADDRESS %AOJA%T1,$5%%; CONTINUE $6:%HRLZ%T1,@3(A)%; POINT TO ARGUMENTS %ADD%T1,[2,,TAPARG] %TAPOP.%T1, % JRST%$7%%; ERROR %CLEAR%R, %POPJ%P,%%; RETURN SUCCESSFULLY $7:%MOVE%R,[ERR]%%; ERROR RETURN %POPJ%P, RELOC NAMPTR:%BLOCK%1%%; POINTS TO NAME TAPARG:%BLOCK%12%%; FOR TAPOP. ARGUMENTS RELOC END #-H- TMP.MAC 4666 1980 103 2149 TITLE%TMP - TEMP CORE DRIVER SEARCH%IOPARM TWOSEG ENTRY%TMPCR$, TMPOP$, TMPCL$, JOBNO$ BUFSIZ==1000%; BUFFER SIZE RELOC%400000 PHASE%%; TMP BLOCK LAYOUT TMPNAM:%BLOCK%1%%; FILE NAME TMPBUF:%BLOCK%1%%; THE ACTUAL BUFFER TMPLEN==.+BUFSIZ DEPHASE RELOC%400000 ; TMPCR$ - CREATE AND OPEN A TEMP CORE FILE ; TMPCR$::HLLZ%T1,UUOBK$##+2%; GET NAME %CLEAR%T2, %MOVE%Z,[3,,T1]%; WRITE EMPTY TEMP CORE FILE %TMPCOR%Z, % SKIPA%%%; COULD NOT CREATE %JRST%TMPOP$%%; MERGE BELOW %HLRM%T1,UUOBK$+2%; STASH NAME %PUSHJ%P,JOBNO$%; GET JOB NUMBER PART %HRLM%Z,UUOBK$+2%; STASH IT %MOVEI%C,UUOBK$+2-TMPNAM%; FAKE C FOR OPNDSK %PUSHJ%P,OPNDSK%; OPEN THE DISK %ENTER%0,UUOBK$%; ENTER THE FILE % JRST%[RELEAS%0,0%%; FAILED, DIE %% MOVE%R,[ERR] %% POPJ%P,] %RELEAS%0,0%%; WRITE ZERO-LENGTH FILE %MOVSS%UUOBK$+2%; PUT NAME BACK IN PROPER POSITION %JRST%TMPOP$%%; GO OPEN IT ; TMPOP$ - OPEN A TEMP CORE FILE; F CONTAINS FILE BLOCK ADDRESS. ; TMPOP$::MOVEI%Z,TMPLEN%; ALLOCATE A TEMP BLOCK %PUSHJ%P,ALCBK$## % JRST%$99%%; FAILED %PUSHJ%P,JOBNO$%; FORM FILE NAME XXXNAM %HLL%Z,UUOBK$+2%; GET NAME PART %MOVSM%Z,TMPNAM(C)%; SWAP HALVES AND STORE %HRLZ%T1,TMPNAM(C)%; GET NAME,,0 %HRLI%T2,-BUFSIZ%; TRY READING TMPCOR FILE %HRRI%T2,TMPBUF-1(C) %MOVE%Z,[1,,T1] %TMPCOR%Z,%%; READ IT % SKIPA%%%; FAILED, MUST TRY DISK %JRST%$1%%; GOT IT %PUSHJ%P,OPNDSK%; PREPARE AND OPEN DISK %LOOKUP%0,UUOBK$%; LOOKUP FILE % JRST%$97%%; FAILED %MOVE%Z,UUOBK$+5%; GET SIZE %CAILE%Z,BUFSIZ%; SMALL ENOUGH? % JRST%$97%%; NOPE %HRLI%T1,-BUFSIZ%; READ DISK FILE %HRRI%T1,TMPBUF-1(C) %CLEAR%T2, %INPUT%0,T1 %RELEAS%0,0 $1:%MOVEM%Z,OPNBK$+2%; SET CURRENT SIZE %MOVEI%Z,BUFSIZ%; SET MAXIMUM SIZE %MOVEM%Z,OPNBK$+1 %MOVEI%Z,TMPBUF(C)%; SET BUFFER ADDRESS %MOVEM%Z,OPNBK$ %PUSH%P,C%%; SAVE TMP BLOCK POINTER %PUSHJ%P,MEMOP$##%; OPEN AS A MEMORY STREAM %POP%P,C%%; RESTORE C %CAMN%R,[ERR]%%; OK? % JRST%$98%%; NOPE %HRLM%C,DEVPTR(F)%; SAVE TMP BLOCK POINTER %CLEAR%R,%%; INDICATE SUCCESS %POPJ%P,%%; RETURN $97:%RELEAS%0,0%%; RELEASE CHANNEL $98:%PUSHJ%P,FREBK$##%; FREE TMP BLOCK %CLEARM%DEVPTR(F) $99:%MOVE%R,[ERR]%%; INDICATE ERROR %POPJ%P,%%; RETURN ; TMPCL$ - CLOSE A TMP CORE FILE; MAY WRITE THE ACTUAL FILE ; TMPCL$::LDB%Z,[MODEPTR]%; GET MODE %CAIN%Z,READ%%; OPEN FOR READ ONLY? % JRST%$5%%; YES, ALL DONE %HLRZ%C,DEVPTR(F)%; POINT TO TMP BLOCK %HRLZ%T1,TMPNAM(C)%; DELETE OLD TMP FILE %CLEAR%T2, %MOVE%Z,[2,,T1] %TMPCOR%Z,%%; READ AND DELETE IT % JFCL%%%; DON'T CARE %PUSHJ%P,OPNDSK%; DELETE DSK:XXXNAM.TMP %LOOKUP%0,UUOBK$ % JRST%$2%%; CAN'T FIND %CLEARM%UUOBK$%%; SET UP FILE BLOCK FOR DELETION %RENAME%0,UUOBK$ % JFCL%%%; CAN'T DELETE $2:%RELEAS%0,0%%; RELEASE CHANNEL %HRRZ%C,DEVPTR(F)%; POINT TO MEM BLOCK %MOVE%Z,MEMSIZ##(C)%; GET CURRENT SIZE %HLRZ%C,DEVPTR(F)%; POINT BACK TO TMP BLOCK %IDIV%Z,BYTEPW(F)%; COMPUTE SIZE IN WORDS, T1=BYTE IN WORD %SKIPN%T1%%; NEED TO ADJUST FOR ODD SIZE? % JRST%$3%%; NO %LDB%T2,[SIZEPTR]%; GET BYTE SIZE %IMUL%T1,T2%%; COMPUTE SHIFT AMOUNT %MOVNS%T1 %SETO%T2,%%; GET A BUNCH OF 1'S %LSH%T2,(T1)%%; SLIDE OVER A BIT %MOVEI%T1,TMPBUF(C)%; POINT TO LAST WORD %ADD%T1,Z %ANDCAM%T2,(T1)%%; CLEAR OUT TRAILING BITS IN LAST WORD %ADDI%Z,1%%; ONE MORE WORD $3:%MOVNS%Z%%; FORM -N %HRLZ%T1,TMPNAM(C)%; GET NAME,,0 %HRL%T2,Z%%; FORM I/O WORD %HRRI%T2,TMPBUF-1(C) %MOVE%Z,[3,,T1] %TMPCOR%Z,%%; ATTEMPT TO WRITE TMPCOR FILE % SKIPA%%%; FAILED, TRY DISK %JRST%$5%%; SUCCESS, ALL DONE %PUSHJ%P,OPNDSK%; OPEN DISK %ENTER%0,UUOBK$%; ENTER THE FILE % JRST%$4%%; FAILED %MOVE%T1,T2%%; PUT I/O WORD IN T1 %CLEAR%T2, %OUTPUT%0,T1%%; WRITE FILE %RELEAS%0,0%%; RELEASE CHANNEL %CLEAR%T2,%%; SET RETURN CODE %JRST%$5%%; MERGE BELOW $4:%RELEAS%0,0%%; SOME ERROR %MOVE%T2,[ERR]%; SET RETURN CODE $5:%HLRZ%C,DEVPTR(F)%; RELEASE TMP BLOCK %PUSHJ%P,FREBK$## %HRRZ%C,DEVPTR(F)%; RELEASE MEM BLOCK %PUSHJ%P,FREBK$ %CLEARM%DEVPTR(F) %MOVE%R,T2%%; SET RETURN CODE %POPJ%P,%%; RETURN ; OPNDSK - OPEN THE DISK FOR LOOKUP/ENTER. CALL IS ;%PUSHJ%P,OPNDSK ;%CHANNEL 0 OPENED ;%FAILED%(NOTE FUNNY ORDER) OPNDSK:%MOVEI%Z,17%%; SET DUMP MODE %MOVEM%Z,OPNBK$## %MOVSI%Z,'DSK'%%; DEFAULT DEVICE %MOVEM%Z,OPNBK$+1 %CLEARM%OPNBK$+2%; NO HEADERS %OPEN.%0,OPNBK$ % AOS%(P)%%; CAUSE A SKIP %MOVEI%Z,5%%; SET UP UUOBK$ FOR LOOKUP/ENTER %MOVEM%Z,UUOBK$## %CLEARM%UUOBK$+1%; DEFAULT PATH %MOVE%Z,TMPNAM(C)%; USE FULL NAME %MOVEM%Z,UUOBK$+2 %MOVSI%Z,'TMP' %MOVEM%Z,UUOBK$+3 %CLEARM%UUOBK$+4%; DEFAULT PRIVILEGE %POPJ%P,%%; RETURN FOR LOOKUP/ENTER ; JOBNO$ - RETURN JOB NUMBER IN Z AS XXX IN SIXBIT. JOBNO$::PUSH%P,T1%%; SAVE T1 AND T2 %PUSH%P,T2 %PJOB%Z,%%; GET CURRENT JOB NUMBER %IDIVI%Z,^D100 %IDIVI%T1,^D10 %ADDI%Z,'0' %LSH%Z,6 %ADDI%Z,'0'(T1) %LSH%Z,6 %ADDI%Z,'0'(T2) %POP%P,T2 %POP%P,T1 %POPJ%P,%%; RETURN END #-H- TRMNO.MAC 251 1980 103 2149 SEARCH%IOPARM TITLE.%TRMNO ; TRMNO(J:INTEGER,R:INTEGER):INTEGER -- DO A TRMNO UUO. RESULT IS ; RETURNED AS FUNCTION VALUE AND IN R. ; TRMNO::%MOVE%Z,@0(A)%%; GET JOB NUMBER %TRMNO.%Z, % MOVE%Z,[ERR]%%; LOSER %MOVEM%Z,@1(A)%%; STORE IN R %POPJ%P, END #-H- TRMOP.MAC 222 1980 103 2149 SEARCH%IOPARM TITLE.%TRMOP ; TRMOP(A:ARRAY,N:INTEGER):INTEGER -- DO A TRMOP UUO. ; TRMOP::%HRL%Z,@1(A)%%; GET COUNT %HRRI%Z,@0(A)%%; POINT TO ARGUMENT BLOCK %TRMOP.%Z,%%; DO IT % SKIPA %TDZA%Z,Z %MOVE%Z,[ERR] %POPJ%P, END #-H- TTY.MAC 5657 1980 103 2149 TITLE%TTY - TTY DRIVER SEARCH%IOPARM TWOSEG ENTRY%TTYOP$, TTYCL$, TTYRD$, TTYWR$, TTYCN$ RAW==1B29%; RAW MODE COOKED==1%; COOKED MODE NOECHO==1B28%; ECHO BIT RELOC%0 TTYCHN:%BLOCK%1%%; I/O CHANNEL FOR STATUS ICALL:%BLOCK%1%%; CURRENT MODE INPUT CALL OCALL:%BLOCK%1%%; CURRENT MODE OUTPUT CALL OLDRT:%BLOCK%1%%; ORIGINAL ^R ^T SETTING OLDSQ:%BLOCK%1%%; ORIGINAL ^S ^Q SETTING TARGS:%BLOCK%3%%; TRMOP. ARGUMENTS LINBUF:%BLOCK%^D16%%; LINE BUFFER FOR COOKED OUTPUT %BLOCK%1 LBPTR:%BLOCK%1%%; LINE BUFFER POINTER COUNT:%BLOCK%1%%; CHARACTER COUNT RELOC%400000 ; TTYOP$ - OPEN TTY; SETS UP DEVICE-DEPENDENT DATA. ; TTYOP$::LDB%Z,[SIZEPTR]%; GET BYTE SIZE %CAIE%Z,7%%; MUST BE CHARACTER % JRST%ERRDV$##%; OR IT'S AN ERROR %MOVE%Z,TTYCHN%; COPY CHANNEL %MOVEM%Z,CHANNEL(F) %SKIPE%LBPTR%%; FIRST TIME? % POPJ%P,%%; NO, JUST RETURN %MOVE%Z,[INCHWL C]%; YES, SET UP I/O CALLS %MOVEM%Z,ICALL %MOVE%Z,[PUSHJ P,OUTC] %MOVEM%Z,OCALL %PUSHJ%P,FDCHN$##%; FIND A CHANNEL %JUMPE%Z,ERRDV$%; NONE AVAILABLE %MOVEM%Z,TTYCHN%; SAVE FOR LATER %MOVEM%Z,CHANNEL(F) %PUSHJ%P,XUUO$##%; OPEN THE TTY %OPEN%0,[EXP COOKED,'TTY ',0] % JRST%ERRDV$%%; OOPS %SETO%Z,%%; GET UNIVERSAL I/O INDEX %TRMNO.%Z, % JRST%$1%%; SHOULDN'T HAPPEN %MOVEM%Z,TARGS+1%; SET FOR TRMOP. %MOVSI%Z,1036%%; READ CURRENT ^R^T SETTING %PUSHJ%P,TRMOP % JRST%ERRDV$ %MOVEM%Z,OLDRT%%; SAVE FOR SETTING COOKED MODE %MOVSI%Z,1021%%; DO SAME FOR ^S^Q SETTING %PUSHJ%P,TRMOP % JRST%ERRDV$ %MOVEM%Z,OLDSQ $1:%MOVE%Z,[POINT 7,LINBUF]%; INITIALIZE OUTPUT BUFFER %MOVEM%Z,LBPTR %MOVEI%Z,^D80% %MOVEM%Z,COUNT %CLEAR%R, %POPJ%P,%%; RETURN ; TTYCL$ - CLOSE THE TTY; JUST FLUSHES THE OUTPUT BUFFER. ; TTYCL$::JRST%FLUSH ; TTYRD$ - READ THE TTY; POINTER TO STRING IN T1, MAX COUNT IN T2. ; TTYRD$::PUSH%P,T2%%; SAVE COUNT %PUSHJ%P,FLUSH%%; FLUSH ANY PENDING OUTPUT $2:%XCT%ICALL%%; GET A CHARACTER %CAIN%C,"Z"-100%; END OF FILE? % JRST%$4%%; YES %IDPB%C,T1%%; STASH CHARACTER %SOJLE%T2,$3%%; DECREMENT AND TEST COUNT %MOVE%Z,[X.EOL]%; CHECK FOR END OF LINE %LSH%Z,(C) %JUMPGE%Z,$2%%; CONTINUE UNLESS HIT EOL $3:%POP%P,R%%; GET BACK ORIGINAL COUNT %SUB%R,T2%%; COMPUTE NUMBER OF CHARACTERS READ %POPJ%P,%%; RETURN $4:%AOS%EOFFLAG(F)%; LIGHT EOF FLAG %PUSHJ%P,XUUO$%%; CLOSE BUT CONTINUE FOR OTHER FILES %CLOSE%0,0 %CAME%T2,(P)%%; DID WE GET SOMETHING? % JRST%$3%%; YES, DON'T GIVE EOF YET %POP%P,R%%; NO, TOSS ORIGINAL COUNT %MOVE%R,[EOF]%%; GIVE A REAL EOF %POPJ%P,%%; RETURN ; TTYWR$ - WRITE TO THE TTY; POINTER TO STRING IN T1, COUNT IN T2. ; TTYWR$::SOJL%T2,$5%%; DECREMENT COUNT AND RETURN IF DONE %ILDB%C,T1%%; GET A BYTE %XCT%OCALL%%; DO OUTPUT %JRST%TTYWR$%%; LOOP UNTIL DONE $5:%MOVE%R,@1(A)%%; RETURN ORIGINAL COUNT %POPJ%P, ; OUTC - OUTPUT A CHARACTER IN COOKED MODE; CHAR IN C. ; OUTC:%TRNN%C,177%%; IGNORE NULLS % POPJ%P, %SOSG%COUNT%%; DECREMENT AND TEST COUNT % PUSHJ%P,FLUSH%%; GO DUMP LINE BUFFER %IDPB%C,LBPTR%%; DEPOSIT CHARACTER %CAIN%C,C.LF%%; NEWLINE? % PUSHJ%P,FLUSH%%; YES, FLUSH THE LINE %POPJ%P, ; FLUSH - DUMP CURRENT LINE BUFFER ; FLUSH:%PUSH%P,Z%%; SAVE CHARACTER %MOVE%Z,COUNT%%; GET COUNT %CAIN%Z,^D80%%; ANYTHING THERE? % JRST%$6%%; NOTHING TO DO %CLEAR%Z,%%; TERMINATE LINE BUFFER WITH A NULL %IDPB%Z,LBPTR %OUTSTR%LINBUF%%; DUMP IT %PUSHJ%P,$1%%; RESET BUFFER POINTERS $6:%POP%P,Z%%; RESTORE Z %POPJ%P,%%; RETURN ; TTYCN$ - CONTROL OPERATIONS; T1 = FUNCTION CODE, T2 = VALUE ; FCT%VALUE%EFFECT ; 2% 0%TURN OFF ECHO ;% 1%TURN ON ECHO ; 3% 0%SET COOKED MODE ;% 1%SET RAW MODE ; 15% 0%BLANK LINES PERMITTED ;% 1%BLANK LINES SUPPRESSED ; TTYCN$::PUSHJ%P,FLUSH%%; FLUSH PENDING OUTPUT %SETO%Z,%%; GET I/O INDEX FOR TERMINAL %TRMNO.%Z, % JRST%ERRDV$##%; OOPS %MOVEM%Z,TARGS+1%; SAVE FOR TRMOP. %CAIN%T1,^D2%%; DISPATCH ACCORDING TO FUNCTION % JRST%SETECHO %CAIN%T1,^D3 % JRST%SETMODE %CAIN%T1,^D15 % JRST%SETBLANKS %JRST%ERRDV$%%; BAD FUNCTION SETECHO:%; FCT 2: SET ECHO %PUSHJ%P,XUUO$%%; READ CURRENT ECHO % GETSTS%0,T1 %TRNE%T1,NOECHO%; TEST ECHO BIT % TDZA%R,R%%; ECHO IS OFF %MOVEI%R,1%%; ECHO IS ON %JUMPL%T2,$10%%; EXIT IF READ ONLY %SKIPL%T2%%; LEGAL VALUE? %CAILE%T2,1 % JRST%ERRDV$%%; NOPE %TRNN%T2,1%%; TURN ECHO ON? % TROA%T1,NOECHO%; NO %TRZ%T1,NOECHO%; YES %PUSHJ%P,XUUO$%%; SET NEW MODE %SETSTS%0,(T1) %POPJ%P,%%; RETURN SETMODE:%; FCT 3: SET RAW OR COOKED MODE %PUSHJ%P,XUUO$%%; GET CURRENT MODE %GETSTS%0,T1 %TRNE%T1,COOKED%; COOKED? % TDZA%C,C%%; YES %MOVEI%C,1%%; NO, RAW %JUMPL%T2,$9%%; EXIT IF READ ONLY %SKIPL%T2%%; LEGAL VALUE? %CAILE%T2,1 % JRST%ERRDV$%%; NOPE %TRZ%T1,RAW!COOKED%; CLEAR OUT MODE %CAIE%T2,0%%; SET TO COOKED? % JRST%$7%%; NOPE %TRO%T1,COOKED%; YES %PUSH%P,[INCHWL C]%; SET NEW I/O CALLS %PUSH%P,[PUSHJ P,OUTC] %HRL%T2,OLDRT%; USE ORIGINAL ^R^T AND ^S^Q SETTINGS %HRR%T2,OLDSQ %JRST%$8%%; MERGE BELOW $7:%TRO%T1,RAW%%; SET TO RAW %PUSH%P,[INCHRW C]%; CHANGE I/O CALLS %PUSH%P,[OUTCHR C] %MOVSI%T2,1%%; MAKE ^R^T ^S^Q ORDINARY CHARACTERS $8:%POP%P,OCALL%%; RESET I/O CALLS %POP%P,ICALL %PUSHJ%P,XUUO$%%; RESET STATUS %SETSTS%0,(T1) %HLR%Z,T2%%; RESET ^R^T %HRLI%Z,2036 %PUSHJ%P,TRMOP % JFCL%%%; IGNORE THIS %HRR%Z,T2%%; RESET ^S^Q %HRLI%Z,2021 %PUSHJ%P,TRMOP % JFCL %JRST%$9%%; RETURN OLD VALUE SETBLANKS:%; FCT 15: SET BLANKS %MOVSI%Z,1025%%; GET OLD SETTING %PUSHJ%P,TRMOP % JRST%ERRDV$%%; SHOULDN'T HAPPEN %JUMPL%T2,$10%%; RETURN IF READ ONLY %MOVE%C,Z%%; SAVE IT %HRR%Z,T2%%; SET NEW SETTING %HRLI%Z,2025 %PUSHJ%P,TRMOP % JRST%ERRDV$%%; OOPS $9:%MOVE%R,C%%; RETURN OLD SETTING $10:%POPJ%P,%%; RETURN ; TRMOP - DO TRMOP UUO; SET Z TO FCT,,VALUE; RESULT RETURNED IN Z ; TRMOP:%HLRZM%Z,TARGS%%; SET UP ARG BLOCK FOR TRMOP. %HRRZM%Z,TARGS+2 %MOVE%Z,[3,,TARGS]%; DO IT %TRMOP.%Z, % SKIPA%%%; OOPS %AOS%(P)%%; GIVE SKIP RETURN %POPJ%P, END #-H- UNPACK.MAC 952 1980 103 2149 SEARCH%IOPARM TITLE.%UNPACK ; UNPACK(N:INTEGER,S:PACKED STRING,D:STRING):INTEGER -- UNPACK N ; CHARACTERS FROM S TO D. STOPS IF A NULL CHARACTER IS ENCOUNTERED. ; RETURNS THE NUMBER OF CHARACTERS UNPACKED AND PUTS A EOS ON THE ; END OF D. ; UNPACK::PUSHJ P,SAVR$## ; SAVE REGISTERS HRRI T1,@1(A) ; SET UP POINTER ... HRLI T1,(POINT 7) ; TO S MOVEI T2,@2(A) ; GET ADDRESS OF D MOVE%R,@0(A) ; GET N JUMPE%R,$2%%; DONE ALREADY? $1:%ILDB C,T1%%; GET A CHARACTER FROM S JUMPE C,$2%%; QUIT IF IT IS NULL MOVEM C,(T2) ; STORE IN D ADDI T2,1 ; INCREMENT ADDRESS OF D SOJG R,$1%%; LOOP TILL DONE $2:%MOVE%C,[EOS]%%; GET END OF STRING INDICATOR MOVEM C,(T2) ; PUT AT END OF D MOVE R,T2 ; COMPUTE LENGTH SUBI R,@2(A) POPJ P, ; RETURN END #-H- WRITEF.MAC 732 1980 103 2149 SEARCH%IOPARM TITLE.%WRITEF ; WRITEF(BUF,COUNT,FD) -- WRITE TO FILE FD. ; WRITEF::PUSHJ%P,SAVR$##%; SAVE SOME REGISTERS %SKIPG%T2,@1(A)%; COUNT % JRST%[CLEAR%R, %% POPJ%P, ]%; EMPTY BUFFER SO RETURN %MOVEI%T1,@0(A)%; POINTER TO BUFFER %MOVE%F,@2(A) %MOVE%F,FDTAB$##(F)%; POINTER TO ENTRY INTO FILTAB %MOVEI%F,FLTAB$##-1(F)%; POINT TO FILE BLOCK %MOVE%Z,OPNMODE(F)%; GET MODE %TRNN%Z,3%%; OPEN FOR READ ONLY? % JRST%[MOVE%R,[ERR] %% POPJ%P, ] ; RETURN ERROR READ ONLY MODE %MOVE%C,MAJOR(F)%; DEVICE NUMBER FOR COMPUTED CALL %LDB%Z,PACKPTR(F)%; CHECK FOR PACKED BUFFER %JUMPE%Z,.+3 %HLL%T1,BYTEPTR(F)%; USE PACKED POINTER %JRST%@WRSW$##(C)%; DISPATCH TO DEVICE DRIVER %HRLI%T1,(POINT 36)%; USE UNPACKED POINTER %JRST%@WRSW$(C) END #-H- XOR.MAC 165 1980 103 2149 SEARCH%IOPARM TITLE.%XOR ; XOR(I:CHR,J:CHR):CHR -- RETURN I XOR J ; XOR::%MOVE%R,@0(16)%; FETCH I %XOR%R,@1(16)%; XOR J POPJ P, ; RETURN END #-H- XUUO.MAC 519 1980 103 2149 SEARCH%IOPARM TITLE.%XUUO$ ; XUUO$ -- EXECUTE AN I/O UUO. CALL IS ;%MOVE%F,POINTER TO FILE BLOCK ;%PUSHJ%P,XUUO$ ;%UUO%0,E ;% UUO DID NOT SKIP ;%UUO SKIPPED ; XUUO$::PUSH%P,T1%%; SAVE AN AC %MOVE%T1,CHANNEL(F)%; GET CHANNEL %IOR%T1,@-1(P)%; OR IN THE UUO %EXCH%T1,(P)%%; STASH ON TOP OF STACK AND RESTORE T1 %XCT%(P)%%; EXECUTE THE UUO % SKIPA%%%; NONSKIP RETURN %AOS%-1(P) ; BUMP FOR SKIP RETURN SUB P,[1,,1] ; TOSS THE UUO %AOS%(P)%%; BUMP RETURN POINT ONCE AGAIN %POPJ%P,%%; RETURN END #========== CYBER I/O SYSTEM ========== #-H- CLOSE.RAT 1843 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## CLOSE -- CYBER 175 VERSION OF CLOSE # SUBROUTINE CLOSE(FD) INTEGER FD INTEGER I, JUNK, PUTCH, DMASK INTEGER CURWORD, CURBYTE, BITPBYT INCLUDE CIOSYS DATA DMASK/77777777777777000000B/ I = FDTAB(FD+1) IF (I == 0) RETURN # ALLOW CLOSE OF UNOPENED FILE I = I - LOCF(FILTAB(1)) # GET OFFSET INTO FILTAB FDTAB(FD+1) = 0 # FREE SLOT FILTAB(USECNT+I) = FILTAB(USECNT+I) - 1 IF (FILTAB(USECNT+I) <= 0) < IF (FILTAB(MODE+I) != READ) < # FLUSH ALL BUFFERS CURWORD = FILTAB(CURRENTWORD+I) CURBYTE = FILTAB(CURRENTBYTE+I) BITPBYT = FILTAB(BITSPERBYTE+I) FILTAB(BUFSTART+CURWORD+I) = FILTAB(BUFSTART+CURWORD+I) & MASK(CURBYTE*BITPBYT) # CLEAN JUNK OUT OF LAST WORD # SET NEW SIZE OF I/O BUF FILTAB(FETSTART+2+I) = FILTAB(FETSTART+1+I) + CURWORD IF (CURBYTE > 0) # INCLUDE CURWORD IN BUFFER FILTAB(FETSTART+2+I) = FILTAB(FETSTART+2+I) + 1 CALL WRITER(FILTAB(FETSTART+I),0) CALL RECALL(FILTAB(FETSTART+I)) ! IF (((DMASK & FILTAB(FETSTART+I)) != 6LOUTPUT) & ((DMASK & FILTAB(FETSTART+I)) != 5LINPUT) ) < # PROTECTED LFNS CALL REWIND(FILTAB(FETSTART+I)) # SHOULD BE SUFFICIENT CALL RECALL(FILTAB(FETSTART+I)) # ENSURE REWIND GETS DONE %IF (FILTAB(FDBLOC+I) != 0) < % IF (FILTAB(MODE+I) != READ) < % CALL QQPURG(FILTAB(FDBLOC+4+I)) % CALL QQCATLG(FILTAB(FDBLOC+4+I)) % JUNK = SHIFT(FILTAB(FDBLOC+4+I),-9) & 77B % IF (JUNK != 0) < %% CALL MESSAGE("CANNOT CATALOG FILE.",0) %% CALL MESSAGE(FILTAB(FDBLOC+I),0) %% CALL MESSAGE(JUNK,0) %% ! ! CALL QQCLOSE(FILTAB(FETSTART+I)) # LET SYSTEM DETACH PFN ! ! ! RETURN END #-H- CREATE.RAT 865 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## CREATE -- CREATE A FET FOR A FILE (CYBER 175 VERSION) # INTEGER FUNCTION CREATE(NAME,FMODE) CHARACTER NAME(ARB) INTEGER FMODE, FD, I, J, L, FTYPE INTEGER QQFPARS, QQFTBL, PFNCMD INCLUDE CIOSYS INCLUDE CPFNS FTYPE = QQFPARS(NAME) # GET PACKED FILE NAME IF (FTYPE == ERR) # FILE NAME IS ILLEGAL RETURN (ERR) FOR (FD = 1; FD <= MAXFILES; FD = FD + 1) # FIND OPEN SLOT IF (FDTAB(FD) == 0) BREAK IF (FD > MAXFILES) # ALL SLOTS USED RETURN (ERR) I = QQFTBL(FD,FMODE)%%# BUILD CYBER FILE TABLES IF (I == ERR) RETURN (ERR) IF (FTYPE == PERMFILE)%# PROCESS PERMANENT FILE IF (FBKTAB(MODE,I) == READ) < IF (PFNCMD(ATTACH,FD-1) != 0) CALL QQRQPF(TLFN) % ! ELSE CALL QQRQPF(TLFN) RETURN (FD-1) END #-H- DATE4.RAT 1687 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS # NOTE: THESE ROUTINES WILL WORK ONLY UNTIL DEC 31, 1999! # DATE4 -- GET THE TIME AND DATE FROM THE SYSTEM # SUBROUTINE DATE4(MTHDAY,YEAR,TIME,SECONDS) INTEGER MTHDAY, YEAR, TIME, SECONDS INTEGER CTMP, DTMP1, DTMP2, MONTH CVTDIG(STR) = (STR & 77B) - 33B #DISPLAY CODE TO INTEGER CVTNUM(STR,CPOS) = 10 * CVTDIG(SHIFT(STR,6*CPOS)) + %% CVTDIG(SHIFT(STR,6*(CPOS+1))) CALL GETCLCK(DTMP1,1) CALL GETCLCK(CTMP,0) CALL GETCLCK(DTMP2,1) IF (DTMP1 != DTMP2) CALL GETCLCK(CTMP,0) SECONDS = CVTNUM(CTMP,8) # CTMP IS HH:MM:SS TIME = 100 * CVTNUM(CTMP,2) + CVTNUM(CTMP,5) MONTH = CVTNUM(DTMP2,2) %# FIRST, ASSUME MM/DD/YY IF (MONTH == 0 \ MONTH > 12) < # WHOOPS, IT WAS YY/MM/DD YEAR = MONTH + 1900 MTHDAY = 100*CVTNUM(DTMP2,5) + CVTNUM(DTMP2,8) ! ELSE < YEAR = CVTNUM(DTMP2,8) + 1900 MTHDAY = 100*MONTH + CVTNUM(DTMP2,5) ! RETURN END ## GETDAT():INTEGER -- RETURN MMDD AS INTEGER VALUE INTEGER FUNCTION GETDAT(X) INTEGER DATE, YEAR, TIME, SECONDS CALL DATE4(DATE, YEAR, TIME, SECONDS) RETURN (DATE) END ## GETYER():INTEGER -- RETURN YEAR AS INTEGER VALUE INTEGER FUNCTION GETYER(X) INTEGER DATE, YEAR, TIME, SECONDS CALL DATE4(DATE, YEAR, TIME, SECONDS) RETURN (YEAR) END ## GETTIM():INTEGER -- RETURN HHMMM AS INTEGER VALUE INTEGER FUNCTION GETTIM(X) INTEGER DATE, YEAR, TIME, SECONDS CALL DATE4(DATE, YEAR, TIME, SECONDS) RETURN (TIME) END ## GETSEC():INTEGER -- RETURN SECONDS AS INTEGER VALUE (TIME OF DAY) INTEGER FUNCTION GETSEC(X) INTEGER DATE, YEAR, TIME, SECONDS CALL DATE4(DATE, YEAR, TIME, SECONDS) RETURN (SECONDS) END #-H- DELARG.RAT 447 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS # DELARG - DELETE ARGUMENT N FROM COMMAND STRING SUBROUTINE DELARG(N) INTEGER N, I, ARGPTR, NXTARG INCLUDE CARGS IF (N > NARGS \ N <= 0) RETURN ARGPTR = 1 # WALK DOWN LIST TO N - 1 ARGUMENT (NXTARG IS N) NXTARG = AMEM(ARGPTR) FOR (I =1; I < N; I = I + 1) < ARGPTR = NXTARG NXTARG = AMEM(ARGPTR) ! AMEM(ARGPTR) = AMEM(NXTARG) NARGS = NARGS - 1 RETURN END #-H- DUP.RAT 521 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS # DUP - DUPLICATE FILE DESCRIPTOR FD. (CYBER VERSION) INTEGER FUNCTION DUP(FD) INTEGER FD INTEGER I, J INCLUDE CIOSYS FOR (I = 1; I <= MAXFILES; I = I + 1) # FIND A FREE DESCRIPTOR IF (FDTAB(I) == 0) BREAK IF (I > MAXFILES) RETURN (ERR) FDTAB(I) = FDTAB(FD+1) # POINT TO SAME FILE BLOCK J = FDTAB(I) - LOCF(FILTAB(1)) # GET OFFSET INTO FILTAB FILTAB(USECNT+J) = FILTAB(USECNT+J) + 1 # BUMP REFERENCE COUNT RETURN (I-1) END #-H- ERROR.RAT 154 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## ERROR -- PRINT ERROR MESSAGE AND QUIT. # SUBROUTINE ERROR(S) INTEGER S(1) CALL REMARK(S) CALL EXIT END #-H- GETARG.RAT 743 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS # GETARG - GET ARGUMENT N FROM COMMAND STRING INTO ARRAY INTEGER FUNCTION GETARG(N, ARRAY, MAXSIZ) CHARACTER ARRAY(ARB) INTEGER N, MAXSIZ, I, ARGPTR INCLUDE CARGS ARRAY(1) = EOS IF (N == -1) GETARG = NARGS ELSE IF (N > NARGS \ N < 0) GETARG = EOF ELSE < ARGPTR = 1 # WALK DOWN LIST TO PROPER ARGUMENT FOR (I = 0; I < N; I = I + 1) ARGPTR = AMEM(ARGPTR) FOR (I = 1; I <= MAXSIZ; I = I + 1) < ARGPTR = ARGPTR + 1 ARRAY(I) = AMEM(ARGPTR) IF (ARRAY(I) == EOS) BREAK ! IF (I > MAXSIZ) ARRAY(MAXSIZ) = EOS # INSURE END OF STRING GETARG = I - 1 ! RETURN END #-H- OPEN.RAT 1014 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS # OPEN - OPEN FILE NAME ACCORDING TO MODE # (CYBER VERSION) INTEGER FUNCTION OPEN(NAME, FMODE) CHARACTER NAME(ARB) INTEGER FMODE INTEGER FD, QQFPARS, ISFILQQ, FTYPE, QQFTBL, I, PFNCMD INCLUDE CIOSYS INCLUDE CPFNS FTYPE = QQFPARS(NAME) # GET FILE NAME IF (FTYPE == ERR) # BAD FILE NAME RETURN (ERR) IF (FTYPE == LOCALFILE) IF (ISFILQQ(TLFN) == NO) # SEE IF FILE EXISTS RETURN (ERR) # AND SIGNAL IF NOT FOR (FD = 1; FD <= MAXFILES; FD = FD + 1) # FIND OPEN SLOT IF (FDTAB(FD) == 0) BREAK IF (FD > MAXFILES) # ALL SLOTS USED RETURN (ERR) I = QQFTBL(FD,FMODE)%# BUILD CYBER FILE TABLES IF (I == ERR) RETURN (ERR) IF (FTYPE == PERMFILE) < IF (PFNCMD(ATTACH,FD-1) != 0) < # FILE NOT PRESENT FDTAB(FD) = 0 FBKTAB(USECNT,I) = FBKTAB(USECNT,I) - 1 RETURN (ERR) ! ! RETURN (FD-1) END #-H- PFNCMD.RAT 735 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## PFNCMD(CMD,FD) - EXECUTE PERMANENT FILE COMMAND CMD ON FILE FD # INTEGER FUNCTION PFNCMD(CMD,FD) INTEGER CMD, FD INTEGER I, RMASK INCLUDE CIOSYS DATA RMASK/77B/ I = FDTAB(FD+1) IF (I <= 0) RETURN (ERR) I = I - LOCF(FILTAB(1)) IF (FILTAB(FDBLOC+I) == 0) RETURN (ERR) IF (CMD == ATTACH) CALL QQATTCH(FILTAB(FDBLOC+4+I)) ELSE IF (CMD == CATALOG) CALL QQCATLG(FILTAB(FDBLOC+4+I)) ELSE IF (CMD == PURGE) CALL QQPURG(FILTAB(FDBLOC+4+I)) ELSE IF (CMD == ALTER) CALL QQALTER(FILTAB(FDBLOC+4+I)) ELSE IF (CMD == EXTEND) CALL QQXTND(FILTAB(FDBLOC+4+I)) ELSE IF (CMD == RENAME) CALL QQRENAM(FILTAB(FDBLOC+4+I)) ELSE RETURN (ERR) RETURN (SHIFT(FILTAB(FDBLOC+4+I),-9) & RMASK) END #-H- QQCTOK.RAT 2029 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## QQCTOK -- GET THE NEXT COMMAND LINE TOKEN INTEGER FUNCTION QQCTOK(T,TOK) CHARACTER T, TOK(MAXARG) CHARACTER C, LLC INTEGER I, CURBYTE INCLUDE CARGS DATA CURBYTE/0/ IF (PEEK != 0) < # NEXT TOKEN IS EOF TOK(1) = NEWLINE TOK(2) = EOS RETURN (EOF) ! REPEAT < # SKIP LEADING BLANKS C = LLC(JUNK,AMEM(COMADDR+MEMOFF),CURBYTE) CURBYTE = CURBYTE + 1 ! UNTIL (C != BLANK) IF (C == 0) C = NEWLINE TOK(1) = EOS # HAVE NULL ARGUMENT INITIALLY IF (C == COMMA \ C == LPAREN) RETURN (ALPHA) IF (C == PERIOD \ C == RPAREN \ C == NEWLINE) < PEEK = C RETURN (ALPHA) ! IF (C == DQUOTE \ C == SQUOTE \ C == DOLLAR) < FOR (I = 1;LLC(TOK(I),AMEM(COMADDR+MEMOFF),CURBYTE) != 0; I = I + 1) < CURBYTE = CURBYTE + 1 IF (TOK(I) == C) BREAK ELSE IF (I >= MAXARG) CALL QQERR1("QQCTOK:ARGUMENT TOO LONG.") ! IF (TOK(I) != C) CALL QQERR1("QQCTOK:MISSING CLOSING DELIMITER.") TOK(I) = EOS T = DQUOTE C = BLANK # FORCE SKIP OF TRAILING BLANKS ! ELSE < # NORMAL ARGUMENT TOK(1) = C FOR (I = 2;LLC(C,AMEM(COMADDR+MEMOFF),CURBYTE) != 0; I = I + 1) < CURBYTE = CURBYTE + 1 IF (C == BLANK \ C == COMMA \ C == PERIOD \ C == LPAREN \ C == RPAREN) BREAK ELSE IF (I >= MAXARG) CALL QQERR1("QQCTOK:ARGUMENT TOO LONG.") ELSE TOK(I) = C ! TOK(I) = EOS T = ALPHA ! WHILE (C == BLANK) < # SKIP TRAILING BLANKS C = LLC(JUNK,AMEM(COMADDR+MEMOFF),CURBYTE) CURBYTE = CURBYTE + 1 ! IF (C == 0) C = NEWLINE IF (C == PERIOD \ C == RPAREN \ C == NEWLINE) PEEK = C ELSE IF (C != COMMA & C != LPAREN) # PUSH BACK CHAR. CURBYTE = CURBYTE - 1 RETURN (T) END #-H- QQERR1.RAT 775 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS # RUNTIME ROUTINES -- CYBER DEPENDENT FORTRAN ROUTINES TO PROVIDE # ICON WITH INFORMATION FROM MACHINE DEPENDENT SOURCES. # # - QQERR1(S): PRINT THE MESSAGE S IN THE DAYFILE, 40 CHARACTERS # PER LINE, AND ABORT THE JOB. SUBROUTINE QQERR1(S) INTEGER LLC, S(1), OUTMSG(5), JUNK INTEGER NCH, NWRD, NLIN INTEGER CWRD, CLIN # FIRST DETERMINE LENGTH OF MESSAGE S FOR (NCH = 0; LLC(JUNK,S,NCH) != 0; NCH = NCH + 1) ; NWRD = (NCH + 9) / 10 NLIN = (NCH + 39) / 40 FOR (CLIN = 0; CLIN < NLIN; CLIN = CLIN + 1) < FOR (CWRD = 1; CWRD <= MIN0(4,NWRD-4*CLIN); CWRD = CWRD + 1) OUTMSG(CWRD) = S(4*CLIN+CWRD) OUTMSG(CWRD) = 0 # EOL MARKER CALL MESSAGE(OUTMSG,0) ! CALL ABORT("ND,S") END #-H- QQEXIT.RAT 252 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## QQEXIT -- CLOSE ALL OPEN FILES, (FLUSHES OUTPUT BUFFERS) # CALLED BY FORTRAN EXECUTIVE UPON PROGRAM STOP, EXIT OR ABORT. SUBROUTINE QQEXIT INTEGER I DO I = 1, MAXFILES CALL CLOSE (I-1) RETURN END #-H- QQFPAR.RAT 4095 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## - QQFPARS -- GET FILE NAME AND SWITCHES (PACKED OR UNPACKED) # INTEGER FUNCTION QQFPARS(NAME) INTEGER NAME(1), VALFNQQ INTEGER I, JUNK, K, FBUF(10), DBUF(8), XR, TK, PW1, PW2 CHARACTER QQGNXTC, C, QQPSTR, QQMKLFN INCLUDE CMAP INCLUDE CPFNS TLFN = 0%%# ASSUME NO FILE NAME YET SWITCH = -1%# AND NO SWITCH PFN(1) = 0%# ALSO NO PERMANENT FILE NAME ID = 0%%# ... NO ID XR = 0%%# ... NO EXTEND PASSWORD TK = 0%%# ... NO TURNKEY PASSWORD RP = RPKEY%# ... NO RETENTION PERIOD CY = SHIFT(1,6) \ CYKEY% # ... CYCLE NUMBER 1 (DEFAULT) I = 0 C = QQGNXTC(JUNK,NAME,I) WHILE (C != EOS) < IF (C == SLASH) <%# HAVE A SWITCH SWITCH = -1 C = QQGNXTC(JUNK,NAME,I) WHILE (C != SLASH & C != BLANK & C != EOS) < IF (C == LETA \ C == BIGA)%# 12-BIT ASCII %SWITCH = 61 ELSE IF (C == LETD \ C == BIGD)%# DISPLAY CODE %SWITCH = 0 ELSE IF (C == LETN \ C == BIGN)%# NORMAL CODE %SWITCH = 0 ELSE IF (C == LETW \ C == BIGW)%# WORD I/O %SWITCH = 60 ELSE IF (C == LETX \ C == BIGX)%# 6/12 'ASCII' %SWITCH = 62 ELSE IF (C >= DIG0 & C <= DIG9) <%# N-BIT I/O %SWITCH = C - DIG0 %C = QQGNXTC(JUNK,NAME,I) %WHILE (C >= DIG0 & C <= DIG9) < % SWITCH = 10*SWITCH + (C-DIG0) % C = QQGNXTC(JUNK,NAME,I) % ! %IF (SWITCH > 60) % SWITCH = -1 %NEXT %! ELSE IF (C == LETI \ C == BIGI) < # ID PRESENT %C = QQGNXTC(JUNK,NAME,I) %IF ( C == LETD \ C == BIGD) < % C = QQGNXTC(JUNK,NAME,I) % IF (C == COLON) < C = QQPSTR(NAME,I,DBUF,QRIGHT) ID = (SHIFT(DBUF(1),6) & KEYMASK) \ IDKEY % ! % ! NEXT ! ELSE IF (C == LETP \ C == BIGP) < # PW PRESENT %C = QQGNXTC(JUNK,NAME,I) %IF ( C == LETW \ C == BIGW) < % C = QQGNXTC(JUNK,NAME,I) % IF (C == COLON) < C = QQPSTR(NAME,I,DBUF,QRIGHT) % XR = (SHIFT(DBUF(1),6) & KEYMASK) \ XRKEY % PW1 = (SHIFT(DBUF(1),6) & KEYMASK) \ PW1KEY % ! % ! NEXT ! ELSE IF (C == LETT \ C == BIGT) < # PW PRESENT %C = QQGNXTC(JUNK,NAME,I) %IF ( C == LETK \ C == BIGK) < % C = QQGNXTC(JUNK,NAME,I) % IF (C == COLON) < C = QQPSTR(NAME,I,DBUF,QRIGHT) % TK = (SHIFT(DBUF(1),6) & KEYMASK) \ TKKEY % PW2 = (SHIFT(DBUF(1),6) & KEYMASK) \ PW2KEY % ! % ! NEXT ! ELSE IF (C == LETR \ C == BIGR) < # RP PRESENT %C = QQGNXTC(JUNK,NAME,I) %IF ( C == LETP \ C == BIGP) < % C = QQGNXTC(JUNK,NAME,I) % IF (C == COLON) < % RP = 0 C = QQGNXTC(JUNK,NAME,I) WHILE (C >= DIG0 & C <= DIG9) < RP = 10 * RP + (C - DIG0) C = QQGNXTC(JUNK,NAME,I) ! IF (RP > 999) RP = 999 RP = SHIFT(RP,6) \ RPKEY % ! % ! NEXT ! ELSE IF (C == LETC \ C == BIGC) < # CYCLE PRESENT %C = QQGNXTC(JUNK,NAME,I) %IF ( C == LETY \ C == BIGY) < % C = QQGNXTC(JUNK,NAME,I) % IF (C == COLON) < % CY = 0 C = QQGNXTC(JUNK,NAME,I) WHILE (C >= DIG0 & C <= DIG9) < CY = 10 * CY Y+ (C - DIG0) C = QQGNXTC(JUNK,NAME,I) ! IF (CY > 999) CY = 999 CY = SHIFT(CY,6) \ CYKEY % ! % ! NEXT ! C = QQGNXTC(JUNK,NAME,I) ! ! ELSE IF (C != BLANK) <%# HAVE A FILE NAME FOR (K=1; K<=10; K=K+1) FBUF(K) = 0 I = I - 1 C = QQPSTR(NAME,I,FBUF,QLEFT) ! ELSE C = QQGNXTC(JUNK,NAME,I) ! IF (ID == 0)%# HAVE A PLAIN OLD LOCAL FILE. TLFN = FBUF(1) & LFNMASK ELSE < TLFN = QQMKLFN(JUNK) FOR (K = 1; K <= 4; K= K+1) PFN(K) = FBUF(K) K = 1 IF (TK != 0) < KEYTAB(K) = TK%%# SAVE TURNKEY PASSWORD IN FDB KEYTAB(K+1) = PW2 K = K + 2 ! IF (XR != 0) < KEYTAB(K) = XR%%# SAVE XR PASSWORD IN FDB KEYTAB(K+1) = PW1 K = K + 2 ! KEYTAB(K) = 0%%# END OF FDB MARK ! IF (VALFNQQ(TLFN) == YES) IF (ID == 0) RETURN (LOCALFILE) ELSE RETURN (PERMFILE) RETURN (ERR) END #-H- QQFTBL.RAT 3201 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS DEFINE (XFNOR,1) DEFINE (XFEXT,2) DEFINE (TXOT,3) ## QQFTBL -- CREATE A FET FOR A FILE # INTEGER FUNCTION QQFTBL(FD,FMODE) INTEGER FD, I, J, L INTEGER RWMODE, MAP, BYTSIZE, BYTPWRD, BYTE INTEGER IFTRMNL, XFMODX, FILMODE, TRMMODE INCLUDE CIOSYS INCLUDE CPFNS FOR (I = 1; I <= MAXFILES; I = I + 1) # FIND OPEN FETSPACE IF (FBKTAB(USECNT,I) == 0) BREAK IF (I > MAXFILES) # ALL FETS USED RETURN (ERR) RWMODE = FMODE & 7B IF (SWITCH < 0) BYTSIZE = SHIFT(FMODE, -3) ELSE BYTSIZE = SWITCH IF (BYTSIZE <= 0) < MAP = YES BYTSIZE = 6 ! ELSE IF (BYTSIZE == 61) < # 12-BIT ASCII MAP = -1 BYTSIZE = 12 ! ELSE IF (BYTSIZE == 62) < # 6/12 EXTENDED CHARACTER SET MAP = 2 BYTSIZE = 6 ! ELSE MAP = NO BYTPWRD = 60/BYTSIZE # BYTES/WORD FDTAB(FD) = LOCF(FBKTAB(BKSTART,I)) # INITIALIZE PTR IN FD TABLE # FILL FILE BLOCK FBKTAB(USECNT,I) = 1 FBKTAB(MODE,I) = RWMODE FBKTAB(MAPFLAG,I) = MAP FBKTAB(BUFSIZE,I) = MAXBUFSIZE - 1 # LEN. OF I/O BUF.(ZERO-BASED) FBKTAB(BYTESPERWORD,I) = BYTPWRD IF (RWMODE == WRITE) FBKTAB(CURRENTWORD,I) = 0 ELSE FBKTAB(CURRENTWORD,I) = MAXBUFSIZE # FORCE INITIAL READ FBKTAB(CURRENTBYTE,I) = 0 FBKTAB(BITSPERBYTE,I) = BYTSIZE FBKTAB(EOFFLAG,I) = NO # INITIALIZE FET FBKTAB(FETSTART,I) = TLFN \ FILENOTBUSY FBKTAB(FETSTART+1,I) = LOCF(FBKTAB(BUFSTART,I)) #FIRST FBKTAB(FETSTART+2,I) = FBKTAB(FETSTART+1,I) #IN FBKTAB(FETSTART+3,I) = FBKTAB(FETSTART+1,I) #OUT FBKTAB(FETSTART+4,I) = FBKTAB(FETSTART+1,I) + MAXBUFSIZE #LIMIT IF (RWMODE == WRITE) < IF ((TLFN == 6LOUTPUT) & (MAP == YES) & % (IFTRMNL(TLFN) == NO)) < # USE CARRIAGE CONTROL FBKTAB(CURRENTBYTE,I) = 1 FBKTAB(BUFSTART,I) = 1L1 # TOP OF PAGE FLAG FBKTAB(COL1BLANK,I) = YES ! ELSE FBKTAB(COL1BLANK,I) = NO ! # NOW, IF MODE IS UNSPECIFIED, TRY TO FIGURE OUT FILE CODE. #%(NOS/BE USERS GET DISPLAY CODE) IF (MAP == YES & SWITCH < 0) < XFMODX = FILMODE(TLFN) IF (XFMODX == XFNOR)%# NORMAL DISPLAY CODE FILE. % FBKTAB(MAPFLAG,I) = 1 ELSE IF (XFMODX == XFEXT) # EXTENDED DISPLAY CODE FILE. % FBKTAB(MAPFLAG,I) = 2 ELSE IF (TRMMODE(0) > 0)%# NULL MODE FILE, USE TERMINAL MODE % FBKTAB(MAPFLAG,I) = TRMMODE(0) ELSE%%%# USE NORMAL MODE FOR BATCH JOBS % FBKTAB(MAPFLAG,I) = 1 ! IF (ID == 0) %%# PLAIN OLD LFN FBKTAB(FDBLOC,I) = 0 ELSE%<%%%# IT'S A PERMANENT FILE FOR (J = 0; J < 4; J=J+1) FBKTAB(FDBLOC+J,I) = PFN(J+1) FBKTAB(FDBLOC+4,I) = TLFN FBKTAB(FDBLOC+5,I) = ID FBKTAB(FDBLOC+6,I) = CY FBKTAB(FDBLOC+7,I) = RP FOR (J = 1; KEYTAB(J) != 0; J = J + 1) FBKTAB(FDBLOC+7+J,I) = KEYTAB(J) IF (RWMODE == READ) < FBKTAB(FDBLOC+7+J,I) = SHIFT(1,6) \ MRKEY # ALLOW MULTI-ACCESS J = J + 1 ! FBKTAB(FDBLOC+7+J,I) = 0%# END OF FDB MARK ! RETURN (I) END #-H- QQGNXT.RAT 521 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## QQGNXTC -- RETURN NEXT CHARC FROM ARRAY, REGARDLESS OF PACKING # INCREMENT LOC AFTER GETTING CHARACTER # CHARACTER FUNCTION QQGNXTC(C,ARRAY,LOC) CHARACTER C, LLC, JUNK INTEGER ARRAY(ARB), LOC, DISPLAY DATA DISPLAY /77B/ # DISPLAY CODE CHAR. MASK IF ((SHIFT(ARRAY(1),6) & DISPLAY) != 0B) < # DISPLAY CODE C = LLC(JUNK,ARRAY,LOC) IF (C == 0 \ C == NEWLINE) C = EOS ! ELSE C = ARRAY(LOC+1) LOC = LOC + 1 RETURN (C) END #-H- QQINIT.RAT 3765 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS DEFINE (TXOT,3)%%# NOS INTERACTIVE ORIGIN JOB ## QQINIT -- INITIALIZE I/O FILES, GET ARGUMENTS TO COMMAND. # SUBROUTINE QQINIT INTEGER I, ARGLEN, ARGPTR, K, ERRFLG INTEGER OPEN, CREATE, DUP, QQLEN CHARACTER C, T, ARG(MAXARG), QQCTOK CHARACTER ONAME(7),BONAME(7) INCLUDE CARGS INCLUDE CIOSYS DATA FDTAB/MAXFILES*0/ DATA FBKTAB/FILBLK*0/ DATA ONAME/LETO,LETU,LETT,LETP,LETU,LETT,EOS/ DATA BONAME/BIGO,BIGU,BIGT,BIGP,BIGU,BIGT,EOS/ MEMOFF = 1 - LOCF(AMEM(1)) # GET ADDRESSING OFFSET INPTR = 0 OUTPTR = 0 ERRPTR = 0 NARGS = 0 ARG(1) = EOS ARGPTR = 1 PEEK = 0 IF (QQCTOK(T,ARG) == ALPHA) < # GET COMMAND NAME (CYBER VERB) ARGLEN = QQLEN(ARG) + 2 CALL QQSCPY(ARG,1,AMEM,ARGPTR+1) ! ELSE CALL QQERR1("UNRECOGNIZABLE COMMAND LINE.") I = ARGPTR + ARGLEN # POINT TO NEXT FREE SLOT IN LIST WHILE (QQCTOK(T,ARG) != EOF) < # PROCESS REMAINING ARGUMENTS IF (T == NEWLINE) BREAK ARGLEN = QQLEN(ARG) + 2 IF (I + ARGLEN > AMEMSIZE) CALL QQERR1("TOO MANY ARGUMENTS.") CALL QQSCPY(ARG,1,AMEM,I+1) IF (ARG(1) == LESS & T != DQUOTE) INPTR = I + 2 ELSE IF (ARG(1) == GREATER & T != DQUOTE) OUTPTR = I + 2 ELSE IF (ARG(1) == QMARK & T != DQUOTE) ERRPTR = I + 2 ELSE < NARGS = NARGS + 1 AMEM(ARGPTR) = I ARGPTR = I ! I = I + ARGLEN # POINT TO NEXT FREE SLOT ! AMEM(ARGPTR) = 0 # ZERO POINTER AT END OF LINKED LIST IF (INPTR == 0) < # OPEN STANDARD INPUT IF (OPEN("INPUT",READ) == ERR) IF (JOBORGN(0) == TXOT) <%# IF NOS INTERACTIVE JOB % IF (CREATE("INPUT",READ) == ERR) # MAKE FET FOR TTY % CALL QQERR1("CANNOT CREATE FILE 'INPUT'.") % ! % ELSE % CALL QQERR1("CANNOT OPEN FILE 'INPUT'.") ! ELSE # RE-DIRECT STANDARD INPUT IF (OPEN(AMEM(INPTR),READ) == ERR) CALL QQERR1("CANNOT OPEN REDIRECTED INPUT FILE.") IF (OUTPTR == 0) < # OPEN STANDARD OUTPUT IF (CREATE("OUTPUT",WRITE) == ERR) CALL QQERR1("CANNOT OPEN FILE = OUTPUT.") ! ELSE # RE-DIRECT STANDARD OUTPUT IF (CREATE(AMEM(OUTPTR),WRITE) == ERR) CALL QQERR1("CANNOT OPEN REDIRECTED OUTPUT FILE.") ERRFLG = NO # ASSUME NEED ONLY DUP STANDARD OUTPUT IF (ERRPTR != 0 & OUTPTR != 0) < K = QQLEN(AMEM(ERRPTR)) IF (K != QQLEN(AMEM(OUTPTR))) ERRFLG = YES ELSE < FOR (I = 0; I < K; I = I + 1) IF (AMEM(ERRPTR+I) != AMEM(OUTPTR+I)) BREAK IF (I != K) ERRFLG = YES ! ! ELSE IF (ERRPTR != 0 & OUTPTR == 0) < IF (QQLEN(AMEM(ERRPTR)) != 6) ERRFLG = YES ELSE < FOR (I = 0; I < 6; I = I + 1) IF(AMEM(ERRPTR+I) != ONAME(I+1) & AMEM(ERRPTR+I) != BONAME(I+1)) BREAK IF (I != 6) ERRFLG = YES ! ! ELSE IF (ERRPTR == 0 & OUTPTR != 0) < IF (QQLEN(AMEM(OUTPTR)) != 6) ERRFLG = YES ELSE < FOR (I = 0; I < 6; I = I + 1) IF (AMEM(OUTPTR+I) != ONAME(I+1) & AMEM(OUTPTR+I) != BONAME(I+1)) BREAK IF (I != 6) ERRFLG = YES ! ! IF (ERRFLG == NO) < IF (DUP(STDOUT) == ERR) CALL QQERR1("CANNOT DUP STANDARD ERROR FILE.") ! ELSE IF (ERRPTR == 0) < IF (CREATE("OUTPUT",WRITE) == ERR) CALL QQERR1("CANNOT CREATE STANDARD ERROR FILE.") ! ELSE IF (CREATE(AMEM(ERRPTR),WRITE) == ERR) CALL QQERR1("CANNOT CREATE ERROR FILE.") RETURN END #-H- QQMKLF.RAT 537 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS # QQMKLFN(JUNK) - BUILD A UNIQUE LFN INTEGER FUNCTION QQMKLFN(JUNK) INTEGER JUNK INTEGER TMP, LFN INCLUDE CMAP DATA LFN/00000014061601010100B/ TMP = LFN & 77B IF (TMP == OUTMAP(DIG9+1)) < TMP = SHIFT(LFN,-6) & 77B IF (TMP == OUTMAP(DIG9+1)) < TMP = SHIFT(LFN,-12) & 77B IF (TMP == OUTMAP(DIG9+1)) LFN = (LFN + 262144) & (!777777B) ELSE LFN = (LFN + 4096) & (!7777B) ! ELSE LFN = (LFN + 64) & (!77B) ! LFN = LFN + 1 RETURN (SHIFT(LFN,18)) END #-H- QQPSTR.RAT 674 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS # QQPSTR(NAME,I,PACK) -- BUILD DISPLAY CODE PACKED STRING FROM NAME # RETURNS THE NEXT CHARACTER IN NAME. INTEGER FUNCTION QQPSTR(NAME,I,PACK,JUSTIFY) INTEGER NAME(ARB), PACK(ARB), I, JUSTIFY INTEGER CH, WORD, C, QQGNXTC INCLUDE CMAP WORD = 0 CH = 0 C = QQGNXTC(JUNK,NAME,I) WHILE (C != BLANK & C != SLASH & C != EOS) < IF (CH == 0) < WORD = WORD + 1 PACK(WORD) = 0 ! IF (JUSTIFY == QRIGHT) PACK(WORD) = SHIFT(PACK(WORD),6) \ OUTMAP(C+1) ELSE PACK(WORD) = PACK(WORD) \ SHIFT(OUTMAP(C+1),60-6*(CH+1)) IF (CH == 9) CH = 0 ELSE CH = CH + 1 C = QQGNXTC(JUNK,NAME,I) ! RETURN (C) END #-H- REMARK.RAT 292 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS # REMARK(S:STRING) - PRINT PACKED MESSAGE TO ERROR FILE. # SUBROUTINE REMARK(S) INTEGER S(ARB),BUF(MAXLINE),LLC FOR (I = 0; LLC(BUF(I+1),S,I) != 0; I = I + 1) ; BUF(I+1) = NEWLINE BUF(I+2) = EOS CALL WRITEF(BUF,I+1,ERROUT) RETURN END #-H- REMOVE.RAT 440 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## REMOVE - REMOVE FILE # SUBROUTINE REMOVE(FNAME) CHARACTER FNAME(ARB) INTEGER QQFPARS, FTYPE, TMPFCB(16), I INCLUDE CPFNS EQUIVALENCE (PFN(1),TMPFCB(1)) FTYPE = QQFPARS(FNAME)%# GET FILE NAME AND TYPE IF (FTYPE == ERR)%%# IGNORE PROBLEMS RETURN IF (FTYPE == PERMFILE) CALL QQPURG(TMPFCB(5)) ELSE CALL REMOVQQ(TLFN)%# FORGET ABOUT LOCAL FILE NAME RETURN END #-H- RUNTIM.RAT 239 1979 1221 842 INCLUDE RATDEF INCLUDE IODEFS ## RUNTIM():INTEGER -- RETURN JOB RUNTIME IN MILLISECONDS. # VERY MACHINE DEPENDANT! # INTEGER FUNCTION RUNTIM(TMP) INTEGER TMP RETURN 1000*GETCLCK(TMP,3) #LAST DIGIT UNTRUSTWORTHY ON CYBER END #-H- ABORT.COM 1213 1979 1221 842 *DECK ABORT IDENT ABORT *** ABORT - ABORT JOB. * * CALL ABORT(OPTION) * * ENTRY (OPTION) = 0 TO DO A STANDARD ABORT. * = 2HND TO ABORT WITH NO *DMPX*. * = 1HS TO ABORT TO AN *EXIT(S)* STATEMENT. * = 4HND,S TO ABORT TO AN *EXIT(S)* WITH NO * *DMPX*. * * EXIT DOES NOT EXIT ENTRY ABORT USE DATA. TMPSAV BSS 1 ABORT BSSZ 1 SB1 1 BX7 X1 # SAVE TYPE OF ABORT SA7 TMPSAV RJ =XQQEXIT # CLOSE ALL FILES SA1 TMPSAV # RESTORE TYPE OF ABORT SA2 X1 (X2) = OPTION ZR,X2 ABORT1 IF *ABORT* IS DESIRED SA3 =0HND BX4 X2-X3 ZR,X4 ABORT2 IF *ABORT ,ND* NEEDED SA3 =0HS BX4 X2-X3 ZR,X4 ABORT3 IF *ABORT ,,S* NEEDED SA3 =H/ND,S/ BX4 X2-X3 ZR,X4 ABORT4 IF *ABORT ,ND,S* NEEDED SA1 =0LABORT ABORT1 ABORT ABORT2 ABORT ,ND ABORT3 ABORT ,,S ABORT4 ABORT ,ND,S END #-H- ARG.COM 640 1979 1221 842 *DECK ARG IDENT ARG ** ARG(AP) -- RETURN THE ADDRESS OF THE CALLING SUBPROGRAMS * AP-TH ARGUMENT * * ENTRY: A0 = ADDRESS OF ARGLIST FOR CALLING * SUBPROGRAM (SET BY FORTRAN) * * EXIT: X6 = ADDRESS OF AP-TH ARGUMENT * * USES: A2, A5, B2, X3, X4, X6 * ENTRY ARG ARG BSSZ 1 SA2 X1 # AP INTO X2 SB1 1B SB2 A0-B1 .. AND ARGLIST ADDR -1 TO B2 SA5 X2+B2 # ADDR OF ARG AP INTO X5 SX6 X5 .. AND INTO RETURN REGISTER EQ ARG # GO HOME END #-H- CFP.COM 3029 1979 1221 842 *DECK CFP IDENT CPU.CFP ENTRY CFP> *** CFP - CONVERT FLOATING POINT. * * FROM *LUNAR* EXCURSION MODULE SIMULATOR. * * CFP CONVERTS A FLOATING POINT NUMBER INTO F10.N FORMAT. *** CFP CONVERTS A BINARY FLOATING POINT NUMBER TO ITS * DISPLAY CODE REPRESENTATION (NO SCIENTIFIC NOTATION). UP * TO EIGHT DIGITS WILL BE CONVERTED, AS SELECTED BY THE CALLER. * * DO NOT TRY TO CONVERT A NUMBER WHICH WILL USE THE MOST * SIGNIFICANT OUTPUT POSITION. IT WONT WORK. DO NOT USE * NUMBERS TOO BIG, AS THE OUTPUT WILL NOT BE CORRECT EVEN * THOUGH IT MAY LOOK REASONABLE. UNDERFLOW WILL PRINT ZERO. * * ENTRY (X1) = NUMBER TO CONVERT, REAL FORMAT, CAN BE NEGATIVE. * (B1) = 1. * (B2) = NUMBER OF FRACTIONAL PLACES (0 TO 6). * * EXIT (X6) = CONVERSION. * * USES X - 0, 1, 2, 3, 4, 6, 7. * B - 2, 3, 4, 5, 6. * A - 2, 3, 4. * * CALLS CDD. CFP> BSSZ 1 ENTRY/EXIT SB1 1 SA2 CFPA+B2 READ ROUNDING FRACTION BX4 X1 SB3 B2+B2 COUNT*2 SA3 CFPB+B2 READ MAGNITUDE AX1 59 SX0 1R-&1R BX4 X4-X1 (X4) = ABS(X1) SB4 B3+B3 COUNT*4 RX4 X4+X2 ROUND NUMBER BX0 X1*X0 SET SIGN RX6 X3*X4 ADJUST MAGNITUDE SB6 B3+B4 COUNT*6 UX2,B5 X6 LX1 X2,B5 RJ =XCDD= CONVERT DECIMAL DIGITS MX1 6 CLEAR TOP CHARACTER BX6 -X1*X6 GT B2,B6,CFP1 IF AT LEAST (COUNT+1) DIGITS SA4 CFPC SB3 B6-B2 SET(B6-B2)/6+1 LEADING ZEROS SB2 B6+B4 AX2 X1,B3 LX3 X2,B2 BX4 X3*X4 BX6 X6-X4 CFP1 SB5 B6+B4 INSERT DECIMAL POINT SX2 1R. AX1 X1,B5 LX0 X0,B2 LX1 X1,B6 LX2 X2,B6 BX4 -X1*X6 INTEGER PART BX6 X1*X6 FRACTIONAL PART LX4 6 BX6 X6+X2 BX6 X6+X4 LX0 6 BX6 X6-X0 SET SIGN SB3 10 ASSURE BLANK FILL SX2 1R MX0 -6 CFP2 SB3 B3-B1 MI B3,CFP> RETURN BX1 -X0*X6 NZ X1,CFP3 BX6 X0*X6 BX6 X6+X2 CFP3 LX6 6 EQ CFP2 CFPA DATA 0.5 DATA 0.5E-1 DATA 0.5E-2 DATA 0.5E-3 DATA 0.5E-4 DATA 0.5E-5 DATA 0.5E-6 DATA 0.5E-7 CFPB DATA 1. DATA 1.E1 DATA 1.E2 DATA 1.E3 DATA 1.E4 DATA 1.E5 DATA 1.E6 DATA 1.E7 CFPC DATA 66666666666666666666B END #-H- CLRB.COM 1198 1979 1221 842 *DECK CLRB IDENT CLRB ** CLRB(A:ADDR,I:INTEGER) -- CLEAR THE I-TH BIT (ZERO-BASED) OFFSET * FROM A, RETURNING BIT'S PREVIOUS VALUE AS VALUE OF FUNCTION * ENTRY CLRB CLRB BSS 0 BSSZ 1 SB1 1B SA5 A1+1B # X5 IS BIT POSITION TO TEST SX0 74B # BITS/WORD PX7 B0,X0 # NOW COMPUTE WORD HOLDING BIT SA3 X5 NX5 B0,X7 PX7 B0,X3 FX2 X7/X5 # X2 IS I/60 (INTEGER WORD OFFSET) UX7 B2,X2 LX5 B2,X7 DX7 X5*X0 IX2 X1+X5 SA4 X2 # GET THAT WORD FROM MEMORY IX0 X3-X7 # X0 IS MOD(I,60) NOW SB2 X0+B1 # FIND BIT IN WORD SX3 B1 # ONE BIT MASK LX5 B2,X4 . AND ROTATE SO IT IS RIGHT MOST BX6 X5*X3 # MASK OFF BIT AND RETURN IT'S VALUE BX5 -X3*X5 # CLEAR THE BIT SB2 X0-73B . AND ROTATE WORD BACK AX7 B2,X5 SA7 A4 . AND STORE BACK INTO MEMORY EQ CLRB END #-H- FILEQQ.COM 4995 1979 1221 842 *DECK,FILEQQ= IDENT FILEQQ= TITLE FILEQQ= UTILITY FUNCTIONS FOR CREATE FUNCTION. URLF = 23B UFP CODE TO READ SYSTEM SECTOR TXOT = 3 TERMINAL ORIGIN JOB NO = 0 YES = 1 %IF%DEF,NOS%%# OK, HERE'S ALL THE NOS STUFF **CALL,COMSPFM **CALL,COMCMAC SYSCOM B1 ENTRY FILMODE RETURN EXTERNAL MODE OF FILE FILMODE PS , ENTRY/EXIT SB1 1 CONSTANT SA1 X1 GET FILE NAME SX6 B1 FORM FET HEADER BX6 X6+X1 SA6 FET PLUG INTO SCRATCH FET SX7 B0 CLEAR UCW IN FET SA7 FET+CFUC FMODE FET READ SYSTEM SECTOR SA2 FET+CFUC GET UCW MX0 58 CHARACTER SET IS 2 BITS AX2 18 BX6 -X0*X2 EXTRACT CHARACTER SET EQ FILMODE RETURN ENTRY JOBORGN RETURN JOB ORIGIN TYPE CODE JOBORGN PS , ENTRY/EXIT SB1 1 CONSTANT GETJO JOTX GET JOB ORIGIN SA1 JOTX RETURN IT BX6 X1 EQ JOBORGN RETURN JOTX CON *-* TEMP STORAGE ENTRY IFTRMNL RETURN 'YES' IF FILE IS TERMINAL, * 'NO' OTHERWISE. IFTRMNL PS , ENTRY/EXIT SB1 1 CONSTANT SA1 X1 GET FILE NAME SX6 B1 FORM FET HEADER BX6 X6+X1 SA6 FET SX2 A6 FET POINTER RJ STF CHECK FOR TERMINAL FILE ZR X6,IFTRMY IF TERMINAL FILE SX6 NO NOT TERMINAL FILE EQ IFTRMNL RETURN IFTRMY SX6 YES TERMINAL FILE EQ IFTRMNL RETURN **CALL,COMCSTF ENTRY TRMMODE GET CURRENT TERMINAL MODE TRMMODE PS , ENTRY/EXIT RJ JOBORGN CHECK FOR INTERACTIVE JOB SX6 X6-TXOT NZ X6,TMODB IF NOT INTERACTIVE JOB TSTATUS TMODX READ TERMINAL STATUS SA1 TMODX+1 PICK UP TERMINAL STATUS BITS SX2 4 ASCII/NORMAL BIT MASK BX6 X2*X1 0 IF NORMAL, 4 IF ASCII AX6 2 0 IF NORMAL, 1 IF ASCII SX6 X6+B1 1 IF NORMAL, 2 IF ASCII EQ TRMMODE RETURN TMODB SX6 B0 0 FOR NON-INTERACTIVE JOB EQ TRMMODE RETURN TMODX BSS 2 SCRATCH FOR TERMINAL STATUS FET FILEB BFR,101B,FET=13 SCRATCH FET BFR BSS 101B DUMMY BUFFER FOR SCRATCH FET %ELSE%%%# AND THEN THE NOS/BE VERSIONS. % ENTRY FILMODE FILMODE PS%, % SX6%1%%# ASSUME IT'S A DISPLAY CODE FILE % EQ%FILMODE % ENTRY JOBORGN JOBORGN PS%, % SX6%0%%# ASSUME IT'S NOT INTERACTIVE % EQ%JOBORGN % ENTRY IFTRMNL IFTRMNL PS%, % SX6%NO%%# ASSUME IT'S NOT A TERMINAL % EQ%IFTRMNL % ENTRY TRMMODE TRMMODE PS%, % SX6%1%%# ASSUME IT'S DISPLAY CODE % EQ%TRMMODE %ENDIF * VALFNQQ -- DETERMINE IF FILE NAME IS VALID CYBER FILE NAME * ENTRY VALFNQQ VALFNQQ EQ *+400000B SA1 X1 GET WORD MX2 7*6 SEVEN CHARACTER MASK BX3 -X2*X1 CHECK REST OF WORD NZ X3,VAL2 IF > 7 CHARACTERS MX2 -6 CHARACTER MASK IF%DEF,NOS%%.NOS ALLOWS LEADING DIGITS SX4 1R9+1 FIRST NON-ALPHANUMERIC ELSE%%%.NOS/BE DOESN'T SX4% 1RZ+1 ENDIF VAL1 LX1 6 POSITION CHARACTER BX3 -X2*X1 EXTRACT CHARACTER BX1 X2*X1 REMAINING CHARACTERS IX6 X3-X4 CHECK FOR LETTER OR DIGIT ZR X3,VAL2 IF COLON (ZERO), INVALID PL X6,VAL2 IF PUNCTUATION, INVALID SX4 1R9+1%%.ENSURE ACCEPT NON-LEADING DIGITS NZ X1,VAL1 IF NOT DONE YET SX6 1 SET FLAG FOR VALID EQ VALFNQQ RETURN VAL2 SX6 0 SET FLAG FOR INVALID EQ VALFNQQ RETURN * ISFILQQ -- RETURNS 0 IF FILE NOT PRESENT TO JOB, 1 IF IT IS * ENTRY ISFILQQ TMPFIT BSSZ 5 TLEN EQU 40000B ISFILQQ BSS 0 BSSZ 1 SB1 1B SA1 X1 PUT LFN INTO TMPFIT SX2 TLEN ..FOLLOWED BY LEN OF FIT BX6 X1+X2 .. OR THE 2 TOGETHER SA6 TMPFIT IF%DEF,NOS%%.HANDLE NOS TEST % SYSTEM LFM,R,TMPFIT,12B*100B % SA2 TMPFIT % SX6 7776B % BX6 X6*X2 % ZR X6,ISFILQQ %ELSE%%%.HANDLE NOS/BE TEST % FILINFO TMPFIT # GET FILE STATUS % SA2 B1+TMPFIT % SX6 B0 % ZR X2,ISFILQQ # FILE NOT PRESENT TO JOB %ENDIF SX6 B1 EQ ISFILQQ END #-H- GETCH.COM 1556 1979 1221 842 *DECK GETCH IDENT GETCH * GETCH(C,FD) -- RETURN NEXT CHAR C FROM FILE FD * ENTRY GETCH *CALL IODEFS USE /CIOSYS/ FDTAB BSS MAXFILE #MAXFILE FILES OPEN AT ONCE FBKTAB BSS FILBLK #MAXFILE*80 (SIZE OF ONE FILE BLOCK) USE DATA. ARGLIST BSS 2 #FAKE ARGLIST FOR READF= USE CODE. GETCH BSSZ 1 # READ ONE CHAR FROM FILE BX7 X1 # ADDRESS OF C SB1 1B SA7 ARGLIST # STORED INTO FAKE ARGLIST SX6 B1 # NUMBER OF CHARS TO READ SA6 A7+B1 .. STORED INTO FAKE ARGLIST SA3 A1+B1 # ADDRESS OF FD INTO X3 SA4 X3 .. FD INTO X4 SA5 X4+FDTAB # AND OFFSET INTO FILE BLOCK SX0 X5-1B .. SAVED IN X0 SB6 B1 # NUMBER OF CHARS TO READ SA1 ARGLIST # POINT TO NEW ARGLIST RJ =XREADF= # CALL READF= TO DO WORK SB5 X6 .. CHECK RESULT NE B1,B5,GETEOF .. FOR EOF ON READ SA2 X1-1B # GET BYTE READ BX6 X2 .. INTO RETURN REGISTER EQ GETCH # AND GO HOME GETEOF BSS 0 # DID NOT READ BYTE, RETURN CODE SX6 EOF # INSURE EOF IS RETURNED SA6 X1 .. AS C (ARG1) AND VALUE OF GETCH EQ GETCH # AND GO HOME END #-H- GETCLK.COM 2275 1979 1221 842 *DECK,GETCLCK IDENT GETCLCK TITLE GETCLCK GET CLOCK READING. ENTRY GETCLCK SPACE 4,10 *** GETCLCK -- GET CLOCK READING * * GETCLCK(N,K) IS EQUIVALENT TO ONE OF THESE ROUTINES: * * GETCLCK(N,0) == CLOCK(N) * GETCLCK(N,1) == DATE(N) * GETCLCK(N,2) == JDATE(N) * GETCLCK(N,3) == SECOND(N) * * ANY OTHER VALUE OF K IS TAKEN MODULO 4. SPACE 4,10 GCL1 SA1 X6 GET RETURN VALUE BX6 X1 INTO RESULT REGISTER GETCLCK EQ *+400000B ENTRY/EXIT SA2 A1+1 GET SECOND ARGUMENT ADDRESS SA2 X2 GET SECOND ARGUMENT VALUE MX6 -2 MASK FOR 0-3 BX2 -X6*X2 SA2 GCL2+X2 GET TRANSFER VECTOR ENTRY SB2 X2 JP B2 GO TRANSFER TO REQUIRED ROUTINE GCL2 BSS 0 TRANSFER VECTOR LOC 0 CON CLOCK 0 = CLOCK CON DATE 1 = DATE CON JDATE 2 = JDATE CON SECOND 3 = SECOND LOC *O CLOCK BSS 0 CLOCK X1 EQ GCL1 GO RETURN VALUE DATE BSS 0 DATE X1 EQ GCL1 GO RETURN VALUE JDATE BSS 0 JDATE X1 EQ GCL1 GO RETURN VALUE SECOND BSS 0 SYSTEM TIM,R,X1 READ CPU SECONDS WITH RECALL SA3 X6 RESULT LOCATION MX0 -12 MASK FOR MILLISECOND PART BX2 -X0*X3 EXTRACT MILLISECONDS PX4 B0,X2 CONVERT TO FLOATING POINT SA5 =1000.0 CONSTANT NX1 B0,X4 NORMALIZE MILLISECONDS FX7 X1/X5 MILLISECONDS / 1000.0 MX0 -24 MASK FOR SECONDS PART AX3 12 SHIFT SECONDS BX2 -X0*X3 EXTRACT SECONDS PX4 B0,X2 CONVERT TO FLOATING POINT NX1 B0,X4 NORMALIZE SECONDS FX0 X7+X1 SECONDS + MILLISECONDS / 1000.0 NX6 B0,X0 NORMALIZE RESULT SA6 A3 STORE RESULT EQ GETCLCK RETURN END #-H- LLC.COM 1980 1979 1221 842 *DECK LLC IDENT LLC ** LLC(C CHAR,A ADDR,I INTEGER) -- RETURN THE I-TH DISPLAY CODE * CHARACTER (ZERO-BASED) OFFSET FROM A AS ASCII VALUE * ENTRY LLC USE /CMAP/ INMAP BSS 100B OUTMAP BSS 200B USE CODE. LLC BSS 0 BSSZ 1 SB1 1B SET B1 TO ALWAYS BE '1' SA5 A1+2B CHAR OFFSET ADDR TO X5 SX0 12B CHARS/WORD (10) SA4 A1+B1 START ADDR TO X4 PX7 B0,X0 NOW COMPUTE WORD TO ACCESS SA3 X5 NX5 B0,X7 SX6 6B BITS/CHARACTER MX7 54 PX2 B0,X3 FX5 X2/X5 UX2 B2,X5 LX5 B2,X2 DX2 X5*X0 IX0 X4+X5 SA5 X0 IX0 X3-X2 DX4 X0*X6 SB2 X4-66B LX3 B2,X5 GET THE CHAR. FROM THAT WORD BX2 -X7*X3 EXTRACT 6-BIT CHARACTER ZR X2,LLC2 IF POSSIBLY END-OF-LINE LLC1 SA4 X2+INMAP MAP IT INTO INTERNAL CODE BX6 X4 AND STORE IT IN C AND SA6 X1 AND RETURN IT AS VALUE EQ LLC LLC2 ZR B2,LLC5 IF 9TH CHAR, TEST NEXT WORD NZ X3,LLC3 IF NOT ALL ZEROS IN THIS WORD PL X3,LLC4 IF NOT ALL SEMICOLONS LLC3 SB2 B2+66B FOR END-OF-WORD MASK MX7 6 AX7 B2,X7 BX7 -X7*X5 CHECK REST OF WORD FOR ZEROS NZ X7,LLC1 IF NOT END-OF-LINE LLC4 SX6 B0 RETURN END-OF-LINE FLAG AS RESULT SA6 X1 STORE IT IN C EQ LLC AND RETURN LLC5 SA4 A5+1 CHECK NEXT WORD NZ X4,LLC1 IF NOT END-OF-LINE PL X4,LLC4 IF +0, NOW AT END-OF-LINE EQ LLC1 10 SEMICOLONS, NOT EOL END #-H- MESSAG.COM 972 1979 1221 842 *DECK MESSAGE IDENT MESSAGE B1=1 LIST F TITLE MESSAGE - SEND MESSAGE. COMMENT SEND MESSAGE. MESSAGE SPACE 4,10 *** MESSAGE - SEND MESSAGE. * * CALL MESSAGE (TEXT,OPTION) * * ENTRY (TEXT) = MESSAGE ARRAY, TERMINATED BY ZERO BYTE * (OPTION) = 0, SEND MESSAGE TO SYSTEM DAYFILE, * LOCAL JOB DAYFILE, AND A AND B DISPLAYS * = 5HLOCAL, SEND MESSAGE TO LOCAL JOB DAYFILE * = OTHER, SEND MESSAGE TO B-DISPLAY ONLY % ENTRY%MESSAGE MESSAGE BSSZ%1 SB1 1 SA2 A1+1 ADDRESS OF OPTION SA2 X2 OPTION ZR,X2 MES1 SA3 =0HLOCAL BX4 X2-X3 ZR,X4 MES2 IF LOCAL MESSAGE X1,1,RCL % EQ%MESSAGE MES1 MESSAGE X1,,RCL % EQ%MESSAGE MES2 MESSAGE X1,3,RCL % EQ%MESSAGE END #-H- PFNQQ.COM 521 1979 1221 842 *DECK PFNQQ % IDENT PFNQQ * PFNQQ - ALL LEGAL OPERATIONS ON A PFN. %ENTRY QQALTER %ENTRY QQATTCH %ENTRY QQCATLG %ENTRY QQXTND %ENTRY QQPERM %ENTRY QQPURG %ENTRY QQRENAM QQALTER BSSZ%1 %SB1%1B %ALTER%X1,RC %EQ%QQALTER QQATTCH%BSSZ%1 %SB1%1B %ATTACH X1,RC %EQ%QQATTCH QQCATLG%BSSZ%1 %SB1%1B %CATALOG%X1,RC %EQ%QQCATLG QQXTND BSSZ%1 %SB1%1B %EXTEND X1,RC %EQ%QQXTND QQPERM%BSSZ%1 %SB1%1B %PERM%X1,RC %EQ%QQPERM QQPURG%BSSZ%1 %SB1%1B %PURGE%X1,RC %EQ%QQPURG QQRENAM%BSSZ%1 %SB1%1B %RENAME%X1,RC %EQ%QQRENAM %END #-H- PUTCH.COM 1343 1979 1221 842 *DECK PUTCH IDENT PUTCH * PUTCH(C,FD) -- WRITE CHAR C TO FILE FD * ENTRY PUTCH *CALL IODEFS USE /CIOSYS/ FDTAB BSS MAXFILE # MAXFILE FILE OPEN AT ONCE FBKTAB BSS FILBLK # MAXFILE*80 (SIZE OF ONE FILE BLOCK) USE DATA. ARGLIST BSS 2 # FAKE ARGLIST FOR WRITEF= USE CODE. PUTCH BSSZ 1 # WRITE C TO FD BX7 X1 # ADDRESS OF C SB1 1B SA7 ARGLIST .. INTO FAKE ARGLIST SX6 B1 # NUM. OF BYTES TO WRITE SA6 A7+B1 .. INTO FAKE ARGLIST SA3 A1+B1 # ADDR. OF FD INTO X3 SA4 X3 .. AND FD INTO X4 SA5 X4+FDTAB # POINTER TO FILE BLOCK SX0 X5-1B .. STORED IN X0 AS OFFSET SB6 B1 # NUM. OF BYTES TO WRITE SA1 ARGLIST # POINT TO FAKE ARGLIST RJ =XWRITEF= # CALL WRITEF= TO DO WORK SA2 X1-1B # LOAD CHAR WRITTEN TO X2 BX6 X2 .. AND RETURN IT AS VALUE EQ PUTCH # THEN GO HOME END #-H- QQCLOS.COM 154 1979 1221 842 *DECK QQCLOSE % IDENT QQCLOSE * QQCLOSE - CLOSE A FILE (DETTACHES PFNS) %ENTRY QQCLOSE QQCLOSE%BSSZ%1 %SB1%1B %CLOSE%X1,RETURN,RECALL %EQ%QQCLOSE %END #-H- QQLEN.COM 744 1979 1221 842 *DECK QQLEN IDENT QQLEN *# QQLEN(S:STRING):INTEGER -- RETURN QQLEN OF S IN CHARACTERS * ENTRY QQLEN EOS EQU 10002 QQLEN BSSZ 1 # ENTRY/EXIT SB1 1B SX5 EOS .. EOS FLAG INTO X5 SA2 X1 # FIRST CHAR. OF STRING INTO X2 SX6 B0 # NUM. OF CHARS. IN STRING TO DATE. LENLOOP BSS 0 # LOOP UNTIL HIT AN EOS BX3 X5-X2 .. CHECK FOR EOS USING XOR ZR X3,QQLEN .. AND RETURN IF DONE SX6 X6+B1 # ELSE HAVE ANOTHER CHAR. SA2 A2+B1 .. GET NEXT CHAR. OF STRING EQ LENLOOP # SEE IF STILL IN STRING END #-H- QQRQPF.COM 293 1979 1221 842 *DECK QQRQPF % IDENT QQRQPF * QQRQPF - REQUEST A LFN TO BE ON A PERMANENT FILE DEVICE %ENTRY QQRQPF %USE DATA. LFN%BSSZ%1 %VFD%28/0,1/1,31/0 %USE CODE. QQRQPF%BSSZ%1 %SB1%1B %SA2%X1%# MOVE LFN NAME INTO DATA BLOCK %BX6%X2 %SA6%LFN %REQUEST%LFN%. PROCESS THE REQUEST FOR *PF %EQ%QQRQPF %END #-H- QQSCPY.COM 1306 1979 1221 842 *DECK QQSCPY IDENT QQSCPY ** QQSCPY(ADDR1,OFFSET1,ADDR2,OFFSET2) -- COPY STRING STARTING AT * OFFSET1 OF ADDR1 (1-BASED) TO START OFFSET2 OF ADDR2 * ENTRY QQSCPY EOS EQU 10002 QQSCPY BSSZ 1 SB1 1B SX5 EOS # EOS FLAG INTO X5 SB2 X1-1B # BASE ADDR1 INTO B2 SA2 A1+B1 .. AND OFFSET1 SA4 X2 .. INTO X4, THEN SB2 X4+B2 .. STARTING ADDRESS INTO B2 SA3 A2+B1 # BASE ADDR2 INTO X3 SB7 X3-1B .. MOVE INTO B7 SA4 A3+B1 .. AND OFFSET2 SA4 X4 .. INTO X4, THEN SB7 X4+B7 .. NEW ADDRESS INTO B7 SCPLOOP BSS 0 # LOOP UNTIL HIT AN EOS SA2 B2 .. GET CHAR. FROM FIRST STRING SB2 B2+B1 .. AND POINT TO NEXT CHAR. BX7 X2 # MOVE INTO OUTPUT REGISTER SA7 B7 .. AND STORE INTO SECOND STRING SB7 B7+B1 .. AND POINT TO NEXT CHAR. IN IT. BX4 X7-X5 # CHECK FOR EOS NZ X4,SCPLOOP .. AND LOOP IF NOT FOUND EQ QQSCPY # HAVE EOS, GO HOME. END #-H- READF.COM 1076 1979 1221 842 *DECK READF IDENT READF * READF(BUF,N,FD) -- READ N BYTES FROM FILE FD INTO BUF * RETURNS NUMBER OF BYTES READ, OR EOF OR ERR AS * VALUE OF FUNCTION, AND EOF AS VALUE OF FIRST SLOT IN * USER BUFFER IF NO CHARACTERS READ. ENTRY READF *CALL IODEFS # GET THE DEFINES AND MACRO DEFS USE /CIOSYS/ # FILE TABLE AND FILE BLOCKS FDTAB BSS MAXFILE .. UPTO MAXFILE FILES OPEN AT ONCE FBKTAB BSS FILBLK .. MAXFILE * 80 (SIZE OF ONE FILE BLOCK) USE CODE. READF BSSZ 1 # READ N BYTES INTO BUF FROM FD SB1 1B GETARGS EQ B0,B6,READF .. GO HOME IF REQUEST IS EMPTY RJ =XREADF= .. AND CALL READF= TO DO WORK SB7 X6 # SEE IF 0 BYTES READ NE B0,B7,READF .. AND IF NOT, GO HOME SX6 EOF # ELSE ASSUME EOF SA6 X1 .. RETURN IN FIRST BUFFER SLOT. EQ READF # GO HOME WITH RESULTS END #-H- READX.COM 13914 1979 1221 842 *DECK READFX IDENT READF= ENTRY READF= ***READF= -- READ N BYTES FROM FILE FD INTO BUF * RETURNS NUMBER OF BYTES READ, OR EOF OR ERR AS * VALUE OF FUNCTION, RESETS N IF CON 1L5+INMX74-INMAPX ESCAPE CODE 74B CON 0#5C \ CON 1L5+INMX76-INMAPX ESCAPE CODE 76B CON 0#3B ; INMX76 BSS 0 76B-EXCAPE CHARACTERS CON 0#60 GRAVE ACCENT CON 0#61 LOWER CASE A CON 0#62 LOWER CASE B CON 0#63 LOWER CASE C CON 0#64 LOWER CASE D CON 0#65 LOWER CASE E CON 0#66 LOWER CASE F CON 0#67 LOWER CASE G CON 0#68 LOWER CASE H CON 0#69 LOWER CASE I CON 0#6A LOWER CASE J CON 0#6B LOWER CASE K CON 0#6C LOWER CASE L CON 0#6D LOWER CASE M CON 0#6E LOWER CASE N CON 0#6F LOWER CASE O CON 0#70 LOWER CASE P CON 0#71 LOWER CASE Q CON 0#72 LOWER CASE R CON 0#73 LOWER CASE S CON 0#74 LOWER CASE T CON 0#75 LOWER CASE U CON 0#76 LOWER CASE V CON 0#77 LOWER CASE W CON 0#78 LOWER CASE X CON 0#79 LOWER CASE Y CON 0#7A LOWER CASE Z CON 0#7B OPENING BRACE CON 0#7C VERTICAL LINE CON 0#7D CLOSING BRACE CON 0#7E TILDE CON 0#7F CONTROL DEL CON 0#00 CONTROL NUL CON 0#01 CONTROL SOH CON 0#02 CONTROL STX CON 0#03 CONTROL ETX CON 0#04 CONTROL EOT CON 0#05 CONTROL ENQ CON 0#06 CONTROL ACK CON 0#07 CONTROL BEL CON 0#08 CONTROL BS CON 0#09 CONTROL HT CON 0#0A CONTROL LF CON 0#0B CONTROL VT CON 0#0C CONTROL FF CON 0#0D CONTROL CR CON 0#0E CONTROL SO CON 0#0F CONTROL SI CON 0#10 CONTROL DLE CON 0#11 CONTROL DC1 CON 0#12 CONTROL DC2 CON 0#13 CONTROL DC3 CON 0#14 CONTROL DC4 CON 0#15 CONTROL NAK CON 0#16 CONTROL SYN CON 0#17 CONTROL ETB CON 0#18 CONTROL CAN CON 0#19 CONTROL EM CON 0#1A CONTROL SUB CON 0#1B CONTROL ESC CON 0#1C CONTROL FS CON 0#1D CONTROL GS CON 0#1E CONTROL RS CON 0#1F CONTROL US INMX74 BSS 0 74B-ESCAPE CHARACTERS CON 0#20 NULL CON 0#40 @ CON 0#5E ^ CON 0#20 NULL CON 0#3A CON 0#20 NULL CON 0#20 NULL CON 0#60 GRAVE ACCENT (REVERSE QUOTE) DUP 64D-8 CON 0#20 NULL ENDD OUTMAPX BSS 128 . ASCII TO EXTENDED DISPLAY CODE USE /CIOSYS/ FILE TABLE AND FILE BLOCKS FDTAB BSS MAXFILE . UPTO 16 FILES OPEN AT ONCE FBKTAB BSS FILBLK . 16 * (SIZE OF ONE FILE BLOCK) USE DATA. RDDSPSW CON *-* MAPPING SWITCH RDDSPFL CON *-* PREVIOUS CHARACTER FLAG USE CODE. READF= BSSZ 1 READ N BYTES GETPARS GET FILE DEPENDENT INFO. SA5 X0+MAPFLAG CHECK MAPPING REQUIREMENTS ZR X5,RDLOOP IF NO MAPPING PL X5,RDDSP1 IF DISPLAY CODE RDLOOP BSS 0 LOOP UNTIL REQUEST SATISFIED GE B0,B6,RDDONE (BREAK ON 0 BYTES LEFT IN REQUEST) GE B3,B2,READBUF (BRANCH TO FILL BUFFER IF NEEDED) SB7 B3+BUFSTRT GET CURRENT WORD OF I/O BUFFER SA2 X0+B7 . INTO X2 NE B1,B5,RDBYTE SKIP IF NOT WORD I/O READWRD .. ELSE READ WHOLE WORD EQ RDLOOP .AND SEE IF MORE TO DO. RDBYTE BSS 0 READ ONE BYTE SA5 X0+BTSPBYT GET BITS PER BYTE SB7 X5-1 BITS PER BYTE - 1 SX4 B4 MOVE BYTE POINTER INTO X4 IX3 X4*X5 COMPUTE ROTATE TO LEFT-JUSTIFY BYTE MX4 1 BUILD SINGLE BYTE MASK AX4 B7 . THE HARD WAY [CURSE CDC] SB7 X3 MOVE ROTATE COUNT TO B7 LX7 B7,X2 LEFT-JUSTIFY BYTE BX7 X4*X7 . AND MASK IT OUT OF WORD SB7 X5 . AND ROTATE LX7 B7 . SO IT IS RIGHT-JUSTIFIED SA5 X0+MAPFLAG CHECK MAPPING REQUIREMENTS ZR X5,NOMAP SKIP IF NO NEED TO MAP ZR X7,NLCHK SKIP IF MIGHT BE NEW LINE (0 BYTE) EQ NOMAP THEN BRANCH TO STORE BYTE NXTBYTE BSS 0 IGNORE THE CURRENT BYTE SB4 B4+B1 . LT B4,B5,RDLOOP STILL IN SAME WORD SB4 B0 MUST GET NEXT WORD SB3 B3+B1 EQ RDLOOP NLCHK BSS 0 POSSIBLE ASCII NEWLINE SB7 B5-B1 . BUT ONLY IF AT LAST BYTE NE B4,B7,NXTBYTE IF NOT, BRANCH TO IGNORE NULL CHAR. SX7 NEWLINE . IF SO, RETURN NEWLINE SB4 B5 . POINT OFF END OF WORD NOMAP BSS 0 STORE THE BYTE SA7 X1 . INTO USER BUFFER SX1 X1+B1 . UPDATE USER BUFFER POINTER SB4 B4+B1 . INCREMENT CURRENT BYTE POINTER LT B4,B5,SAMWRD SKIP IF STILL IN CURRENT WORD SB4 B0 . RESET BYTE POINTER SB3 B3+B1 . INCREMENT CURRENT WORD POINTER SAMWRD SB6 B6-B1 DECREMENT BYTES LEFT IN REQUEST EQ RDLOOP AND SEE IF MORE TO DO. READBUF BSS 0 FILL I/O BUFFER FROM FILE LOADBUF LOAD INPUT BUFFER EQ RDLOOP IF NONE, GO BACK TO START OF LOOP RDDONE BSS 0 RETURN FROM READ SAVPARS .. BY SAVING WHAT MIGHT HAVE CHANGED EQ READF= . AND GOING HOME ** MOVE DISPLAY CODE CHARACTERS FROM BUFFER RDDSP1 SX7 X5-1 SET STANDARD/EXTENDED MODE SWITCH SA7 RDDSPSW SAVE SWITCH SX5 X7 INITIAL VALUE SX7 B0 SA7 RDDSPFL CLEAR PREVIOUS CHAR EXTENDED FLAG RDDSP2 GE B0,B6,RDDONE IF REQUEST SATISFIED WITH ENOUGH CHAR LT B3,B2,RDDSP3 IF WORD IS IN BUFFER LOADBUF LOAD INPUT BUFFER SA5 RDDSPSW RELOAD STANDARD/EXTENDED SWITCH RDDSP3 SB7 B3+BUFSTRT GET WORD FROM BUFFER SA2 X0+B7 NZ X2,RDDSP5 IF NOT EOL NG X2,RDDSP5 IF TEN SEMICOLONS RDDSP4 SX7 NEWLINE ON EOL, RETURN VALUE SB4 B5 INDICATE DONE WITH WORD EQ RDDSP7 GO STORE EOL CHARACTER RDDSP5 SX3 B4+B4 PREPARE SHIFT #BYTE*2 IX4 X3+X3 *4 IX3 X3+X4 *6 SB7 X3+6 ROTATE COUNT MX7 -6 ONE CHARACTER MASK LX3 B7,X2 ROTATE CHARACTER BX7 -X7*X3 EXTRACT CHARACTER NZ X7,RDDSP6 IF NOT ZERO (COLON OR EOL) EQ B4,B0,RDDSP6 MUST BE COLON IN FIRST CHAR POSITION SX3 B4-9 CHECK FOR LAST CHARACTER OF WORD ZR X3,RDDSP9 IF LAST CHARACTER OF WORD, PEEK AT NEXT MX3 1 FORM MASK TO CHECK REST OF WORD SB7 B7-B1 AX3 B7,X3 BX3 -X3*X2 CHECK REST OF WORD ZR X3,RDDSP4 EOL FOUND RDDSP6 NZ X5,RDDSP12 IF EXTENDED CHARACTER SET SA3 X7+INMAP GET CHARACTER TRANSLATION BX7 X3 RDDSP7 SA7 X1 STORE CHARACTER IN BUFFER SX1 X1+B1 INCREMENT BUFFER POINTER SB4 B4+B1 BYTE NUMBER SB6 B6-B1 REMAINING CHARACTER COUNT LT B4,B5,RDDSP8 IF STILL IN SAME WORD SB4 B0 SET FOR NEXT WORD SB3 B3+B1 EQ RDDSP2 GO PROCESS NEW WORD RDDSP8 GE B0,B6,RDDONE IN WORD, IF DONE, GO EXIT EQ RDDSP5 ELSE GO GET NEXT CHAR FROM WORD RDDSP9 SB7 B3+B1 PEEK AT NEXT WORD LT B7,B2,RDDSP10 IF WORD IS IN BUFFER LOADBUF MUST RELOAD INPUT BUFFER SA5 RDDSPSW RELOAD STANDARD/EXTENDED SWITCH SX7 B0 RELOAD ZERO CHARACTER SB7 B3+BUFSTRT GET WORD FROM BUFFER SA3 X0+B7 SB3 B3-B1 BACK UP POINTERS SB4 B5 EQ RDDSP11 GO PEEK AT WORD RDDSP10 SA3 A2+B1 GET NEXT WORD RDDSP11 NZ X3,RDDSP6 NEXT WORD NOT EOL, INSERT COLON NG X3,RDDSP6 IF ALL SEMICOLONS SB4 B0 SET TO IGNORE NULL, NEXT WORD IS EOL SB3 B3+B1 EQ RDDSP2 GO GET EOL WORD RDDSP12 SA3 RDDSPFL CHECK FOR PREVIOUS FLAG NZ X3,RDDSP14 IF 74B OR 76B WAS JUST READ SA3 X7+INMAPX GET EXTENDED MAPPING NG X3,RDDSP13 IF 74B OR 76B BX7 X3 OTHERWISE TREAT AS STANDARD CHARACTER EQ RDDSP7 GO STORE IT RDDSP13 SX7 X3 STORE FLAG (WHICH IS TABLE OFFSET) SA7 RDDSPFL SB4 B4+B1 UPDATE BYTE NUMBER LT B4,B5,RDDSP5 IF STILL IN SAME WORD SB4 B0 SET FOR NEXT WORD SB3 B3+B1 EQ RDDSP2 GO BACK FOR NEXT CHARACTER RDDSP14 IX3 X3+X7 ADD FLAG OFFSET TO CHAR MX7 0 CLEAR FLAG SA7 RDDSPFL SA3 X3+INMAPX GET EXTENDED MAPPING BX7 X3 EQ RDDSP7 GO STORE IT END #-H- RECALL.COM 214 1979 1221 842 *DECK RECALL IDENT RECALL * RECALL -- WAITS FOR I/O TO COMPLETE * ENTRY RECALL RECALL BSS 0 BSSZ 1 BX2 X1 RJ =XWNB= EQ RECALL END #-H- REMOVQ.COM 450 1979 1221 842 *DECK,REMOVQQ IDENT REMOVQQ TITLE REMOVQQ RETURN FILE FOR REMOVE SUBR. ENTRY REMOVQQ ** CALL REMOVQQ(LFN) REMOVQQ PS , ENTRY/EXIT SA1 X1 FORM FET HEADER SX6 1 BX6 X6+X1 SA6 FET STORE IN DUMMY FET % RETURN FET,R EQ REMOVQQ EXIT FET FILEB CBUF,65 DUMMY FET CBUF% BSSZ% 65 END #-H- REWIND.COM 364 1979 1221 842 *DECK REWIND IDENT REWIND B1=1 TITLE REWIND - REWIND FILE. COMMENT REWIND FILE. REWIND SPACE 4,10 *** REWIND - REWIND FILE. * * CALL REWIND (FILE) * * ENTRY (FILE) = FIRST WORD OF THE FET % ENTRY REWIND REWIND BSSZ%1 SB1 1 REWIND X1 % EQ%REWIND END #-H- RTC.COM 2463 1979 1221 842 *DECK RTC IDENT CPU.RTC ENTRY RTC> *** RTC - REPLACE TRAILING CHARACTERS. * * R. O. ANDERSON, * M. D. OLSON. 75/12/09. * * RTC REPLACES ALL OCCURRENCES OF ONE CHARACTER AT THE END * OF A STRING WITH ANOTHER CHARACTER. *** ENTRY (A1) = FWA OF STRING. * (B1) = 1. * (B2) = LENGTH OF STRING, IN WORDS. * (X2) = TEN OCCURRENCES OF SEARCH CHARACTER. * (X3) = TEN OCCURRENCES OF REPLACEMENT CHARACTER. * * EXIT STRING MODIFIED IN PLACE. * (X6) = ADDRESS OF LAST WORD MODIFIED. * (X7) = NUMBER OF CHARACTERS CHANGED IN THAT WORD. * * USES X - 1, 4, 6, 7. * B - NONE. * A - 1, 4, 6. RTC1 SA1 A1-B1 GET THE NEXT WORD; 47 55 77 55 55 BX4 X1-X2 ASSUME X2 = SPACES; 12 00 22 00 00 MX6 -1 77 77 77 77 76 IX6 X4+X6 12 00 21 77 77 BX6 X6+X4 12 00 23 77 77 BX6 X6-X4 00 00 01 77 77 SA4 RTCA 40 40 40 40 40 BX6 X6*X4 00 00 00 40 40 CX7 X6 FIND OUT HOW MANY CHARS WE ZAPPED ZR X6,RTC2 IF NO MORE TRAILING CHARACTERS LX6 -5 00 00 00 01 01 BX4 X6 00 00 00 01 01 LX4 6 00 00 01 01 00 IX4 X6-X4 77 77 77 00 00 BX6 X4*X1 X6 = C(X1) WITH TRAILING C(X2) GONE BX4 -X4*X3 X4 = C(X3) WITH ONLY TRAILING CHARS BX6 X6+X4 X6 = C(X1) WITH TRAILING C(X2) SA6 A1 REPLACED BY C(X3) SB2 B2-B1 DECREMENT COUNTER SX6 X7-10 SEE IF TEN CHARACTERS ZAPPED NZ X6,RTC2 IF NOT, WE ARE DONE GT B2,RTC1 LOOP TILL DONE RTC2 SX6 A1 X6 = ADDRESS OF LAST WORD LOOKED AT SA1 RTCB RESTORE SB2 X1 WORD LENGTH RTC> BSSZ 1 ENTRY/EXIT SB1 1 SX6 B2 SAVE THE FWA SA6 RTCB OF THE OUTPUT AREA SA1 A1+B2 POINT TO END OF STRING + 1 WORD EQ RTC1 TO START CRUNCHING RTCA DATA 40404040404040404040B CONSTANT FOR MASK GENERATION RTCB DATA 0 TO SAVE OUTPUT AREA FWA END #-H- SETB.COM 1192 1979 1221 842 *DECK SETB IDENT SETB ** SETB(A:ADDR,I:INTEGER) -- SET THE I-TH BIT (ZERO-BASED) OFFSET * FROM A, RETURN BIT'S PREVIOUS VALUE AS VALUE OF FUNCTION. * ENTRY SETB SETB BSS 0 BSSZ 1 SB1 1B SA5 A1+1B # X5 IS BIT POSITION TO TEST SX0 74B # BITS/WORD PX7 B0,X0 # NOW COMPUTE WORD HOLDING BIT SA3 X5 NX5 B0,X7 PX7 B0,X3 FX2 X7/X5 # X2 IS I/60 (INTEGER WORD OFFSET) UX7 B2,X2 LX5 B2,X7 DX7 X5*X0 IX2 X1+X5 SA4 X2 # GET THAT WORD FROM MEMORY IX0 X3-X7 # X0 IS MOD(I,60) NOW SB2 X0+B1 # FIND BIT IN WORD SX3 B1 # ONE BIT MASK LX5 B2,X4 . AND ROTATE SO IT IS RIGHT MOST BX6 X5*X3 # MASK OFF BIT AND RETURN IT'S VALUE BX5 X5+X3 # SET THE BIT SB2 X0-73B . AND ROTATE WORD BACK AX7 B2,X5 SA7 A4 . AND STORE BACK INTO MEMORY EQ SETB END #-H- SYSLIB.COM 442 1979 1221 842 *DECK SYSLIB IDENT SYSLIB SYSCOM ENTRY CDD= ENTRY WOD= ENTRY WTW= ENTRY DCB= ENTRY WTX= ENTRY WTC= ENTRY CIO= ENTRY SYS= ENTRY RCL= ENTRY MSG= ENTRY WNB= PURGMAC CODE CODE OPSYN NIL *CALL COMCCDD *CALL COMCWOD *CALL COMCWTW *CALL COMCWTC *CALL COMCCIO *CALL COMCSYS CDD EQU CDD= WOD EQU WOD= END #-H- TSTB.COM 841 1979 1221 842 *DECK TSTB IDENT TSTB ** TSTB(A:ADDR,I:INTEGER) -- RETURN THE I-TH BIT (ZERO-BASED) OFFSET * FROM A AS THE VALUE OF THE FUCTIONN * ENTRY TSTB TSTB BSS 0 BSSZ 1 SB1 1B SA5 A1+1B # X5 IS BIT POSITION TO TEST SX0 74B # BITS/WORD PX7 B0,X0 # NOW COMPUTE WORD HOLDING BIT SX6 B1 SA3 X5 NX5 B0,X7 PX7 B0,X3 FX2 X7/X5 UX7 B2,X2 LX5 B2,X7 DX7 X5*X0 IX2 X1+X5 SA4 X2 IX0 X3-X7 SB2 X0-73B # FIND BIT IN WORD LX5 B2,X4 . AND ROTATE SO IT IS RIGHT MOST BX6 X5*X6 # MASK OFF BIT AND RETURN IT'S VALUE EQ TSTB END #-H- WRITEF.COM 2254 1979 1221 843 *DECK WRITEF IDENT WRITEF * WRITEF(BUF,N,FD) -- WRITE N BYTES FROM BUF TO FILE FD * RETURNS NUMBER OF BYTES WRITTEN ENTRY WRITEF *CALL IODEFS # GET THE DEFINES AND MACRO DEFS USE /CMAP/ INMAP BSS 64 OUTMAP BSS 128 USE /CIOSYS/ FDTAB BSS MAXFILE # UP TO MAXFILE FILES OPEN AT ONCE FBKTAB BSS FILBLK # MAXFILE * 80(SIZE OF ONE FILE BLOCK) USE DATA. BUFFER BSS 256 # BUFFER IF NEED TO UNPACK INBUF USE CODE. WRITEF BSSZ 1 # WRITE N BYTES FROM BUF TO FILE FD SB1 1B GETARGS GETBPB SB2 55 # IF BITS/BYTE > 54, THEN MUST GE B7,B2,UNPACKD .. ASSUME UNPACKED USER BUFFER MX4 6 # BUILD DISPLAY CODE MASK IN X4 SA3 X1 # GET FIRST WORD OF USER BUFFER BX7 X3*X4 .. AND MASK OFF LEFT 6 BITS ZR X7,UNPACKD .. AND ASSUME UNPACKED IF ALL 0 SB3 10 # 10 BYTES/DISPLAY CODE WORD LX4 6 # RIGHT JUSTIFY BYTE MASK SB4 B0 # INITIAL LOOP CONTROL SB5 B0 .. REGISTERS SB2 BUFFER .. AND POINTER TO START OF TMP BUF. UNPKLP BSS 0 # LOOP UNTIL DONE GE B5,B6,UNPDONE .. BREAKING WHEN HAVE N BYTES LT B4,B3,NXTBYTE # SKIP IF STILL IN SAME WORD SB4 B0 SA3 A3+B1 .. ELSE GET NEXT WORD NXTBYTE LX3 6 # ROTATE WORD 1 BYTE BX2 X3*X4 .. AND MASK OFF BYTE ON RIGHT SA2 X2+INMAP # MASK TO INTERNAL ASCII BX7 X2 .. MOVE TO OUTPUT REGISTER SA7 B2+B5 .. AND STORE INTO TMP BUFFER SB5 B5+B1 SB4 B4+B1 # INCREMENT COUNTERS EQ UNPKLP .. AND SEE IF MORE TO DO UNPDONE BSS 0 # POINT TO NEW BUFFER LOCATION SX1 BUFFER .. SO WRITEF= IS FOOLED INTO WORKING UNPACKD BSS 0 RJ =XWRITEF= # AND CALL WRITEF= TO DO THE WORK EQ WRITEF END #-H- WRITER.COM 590 1979 1221 843 *DECK WRITER IDENT WRITER % ENTRY WRITER B1=1 TITLE WRITER - WRITE END OF RECORD. COMMENT WRITE END OF RECORD. WRITER SPACE 4,10 *** WRITER - WRITE END OF RECORD. * * CALL WRITER (FILE,LEVEL) * * ENTRY (FILE) = FIRST WORD OF THE FET * (LEVEL) = RECORD LEVEL WRITER BSSZ%1 SB1 1 SA3 A1+B1 ADDRESS OF LEVEL SA3 X3 LEVEL % SX3% X3-17B%%CHECK FOR EOF % ZR% X3,WEOR1 % WRITER X1 % EQ%WRITER WEOR1% BSS% 0 % WRITEF X1 % EQ%WRITER % END #-H- WRITEX.COM 12811 1979 1221 843 *DECK WRITEFX IDENT WRITEF= ENTRY WRITEF= *** WRITEF=(BUF,N,FD) -- WRITE N BYTES FROM BUF TO FILE FD * RETURNS NUMBER OF BYTES WRITTEN * * ENTRY (X1) = START OF DATA BUFFER * (B6) = NUMBER OF BYTES TO WRITE * (X6) = (B6) * (X0) = BASE POINTER FOR FILE BLOCK * * EXIT (X6) = NUMBER OF BYTES WRITTEN *CALL IODEFS * EXTCH -- DEFINE ONE EXTENDED CHARACTER SET CHARACTER EXTCH MACRO C1,C2 IFC EQ,/C1// CON C2 ELSE VFD 1/1,23/0,18/C1,18/C2 ENDIF ENDM END OF MACRO EXTCH USE /CMAP/ MAP COMMON INMAP BSS 64 . DISPLAY CODE TO ASCII OUTMAP BSS 128 . ASCII TO DISPLAY CODE USE /CMAPX/ MAP COMMON FOR EXTENDED CHARACTER SET INMAPX BSS 3*64 . EXTENDED DISPLAY CODE TO ASCII OUTMAPX BSS 0 . ASCII TO EXTENDED DISPLAY CODE DUP 32 EXTCH 76B,40B+*-OUTMAPX ENDD CON 1R CON 1R! CON 1R" CON 1R# CON 1R$ CON 1R: CON 1R& CON 1R' CON 1R( CON 1R) CON 1R* CON 1R+ CON 1R, CON 1R- CON 1R. CON 1R/ CON 1R0 CON 1R1 CON 1R2 CON 1R3 CON 1R4 CON 1R5 CON 1R6 CON 1R7 CON 1R8 CON 1R9 EXTCH 74B,04B CON 1R; CON 1R< CON 1R= CON 1R> CON 1R? EXTCH 74B,01B @ CON 1RA CON 1RB CON 1RC CON 1RD CON 1RE CON 1RF CON 1RG CON 1RH CON 1RI CON 1RJ CON 1RK CON 1RL CON 1RM CON 1RN CON 1RO CON 1RP CON 1RQ CON 1RR CON 1RS CON 1RT CON 1RU CON 1RV CON 1RW CON 1RX CON 1RY CON 1RZ CON 1R[ CON 1R\ CON 1R] EXTCH 74B,02B ^ CON 65B UNDERSCORE (COMPASS PROBLEM) EXTCH 74B,07B GRAVE ACCENT EXTCH 76B,1RA LOWER CASE LETTERS EXTCH 76B,1RB EXTCH 76B,1RC EXTCH 76B,1RD EXTCH 76B,1RE EXTCH 76B,1RF EXTCH 76B,1RG EXTCH 76B,1RH EXTCH 76B,1RI EXTCH 76B,1RJ EXTCH 76B,1RK EXTCH 76B,1RL EXTCH 76B,1RM EXTCH 76B,1RN EXTCH 76B,1RO EXTCH 76B,1RP EXTCH 76B,1RQ EXTCH 76B,1RR EXTCH 76B,1RS EXTCH 76B,1RT EXTCH 76B,1RU EXTCH 76B,1RV EXTCH 76B,1RW EXTCH 76B,1RX EXTCH 76B,1RY EXTCH 76B,1RZ EXTCH 76B,33B OPENING BRACE EXTCH 76B,34B VERTICAL STROKE EXTCH 76B,35B CLOSING BRACE EXTCH 76B,36B TILDE EXTCH 76B,37B CONTROL DEL USE /CIOSYS/ FILE TABLE AND FILE BLOCKS FDTAB BSS MAXFILE . UPTO 16 FILES OPEN AT ONCE FBKTAB BSS FILBLK . 16 * (SIZE OF ONE FILE BLOCK) USE DATA. LOCAL DATA AEOLWRD DATA 00400040004000400000B ASCII WORD FOR EOL WRTNRCH CON *-* NUMBER OF CHARACTERS TRANSMITTED WRDSPSW CON *-* DISPLAY CODE NORMAL/EXTENDED SWITCH USE CODE. WRITEF= BSSZ 1 WRITE N BYTES FROM BUF TO FD GETPARS GET FILE DEPENDENT INFO SA6 WRTNRCH STORE CHARACTER COUNT SA5 X0+MAPFLAG CHECK MAPPING FLAG ZR X5,WRTLOOP IF NO MAPPING PL X5,WRDSP1 IF DISPLAY CODE WRTLOOP BSS 0 LOOP UNTIL REQUEST SATISFIED GE B0,B6,WRTDONE (BREAK IF ZERO BYTES IN REQUEST GE B3,B2,WRTBUF BRANCH TO EMPTY BUFFER, IF FULL SA2 X1 GET WORD FROM USER BUFFER SX1 X1+B1 . AND INCREMENT USER BUFFER PTR SB7 B3+BUFSTRT GET CURRENT WORD OFFSET INTO BUFFER WRTWORD NE B1,B5,WRTBYTE SKIP IF NOT WORD I/O BX7 X2 MOVE WORD TO OUTPUT REGISTER SA7 X0+B7 . AND STORE INTO I/O BUFFER SB3 B3+B1 . INCREMENT CURRENT WORD PTR SB6 B6-B1 . DECREMENT BYTES LEFT IN REQUEST EQ WRTLOOP SEE IF ANY MORE TO DO WRTBYTE BSS 0 WRITE BYTE INTO I/O BUFFER SA3 X0+B7 LOAD CURRENT WORD FROM I/O BUFFER SA5 X0+MAPFLAG CHECK MAPPING FLAG ZR X5,NOTCHAR . AND SKIP IF NO NEED TO CHECK FOR NL SX4 NEWLINE CHECK FOR NEWLINE (ASCII 10) IX4 X2-X4 ZR X4,HAVNL . AND BRANCH IF WE HAVE A NEWLINE NOTCHAR BSS 0 STORE BYTE INTO BUFFER SA5 X0+BTSPBYT MOVE BITS/BYTE INTO X5 SB7 X5-1B . AND BITS/BYTE -1 INTO B7 MX4 1B BUILD ONE-BYTE MASK IN X4 AX4 B7 . THE HARD WAY [CURSE CDC] SB7 X5 PUT BITS/BYTE INTO B7 LX4 B7 . AND RIGHT-JUSTIFY BYTE MASK SX7 B4+B1 CURRENT BYTE PTR + 1 INTO X7 IX7 X5*X7 ROTATE CNT TO RIGHT-JUSTIFY I/O WORD SB7 X7 . AND LOAD ROTATE COUNT INTO B7 LX7 B7,X3 RIGHT-JUSTIFY BYTE POSITION BX7 -X4*X7 . CLEAN OUT BYTE POSITION BX7 X2+X7 . OR IN NEW BYTE SB7 B7-60 COMPUTE REVERSE SHIFT COUNT AX7 B7,X7 SHIFT WORD TO ORIGINAL POS. (B7 NEG.) SA7 A3 STORE WORD BACK INTO I/O BUFFER SB4 B4+B1 INCREMENT CURRENT BYTE PTR LT B4,B5,SAMWRD . AND SKIP IF IN CURRENT WORD STILL SB4 B0 . ELSE RESET CURRENT BYTE SB3 B3+B1 . RESET CURRENT WORD PTRS SAMWRD SB6 B6-B1 DECREMENT BYTES LEFT IN REQUEST EQ WRTLOOP AND SEE IF MORE TO DO HAVNL BSS 0 OK, NEED TO WRITE CYBER EOL SX5 12 12-BITS/ASCII CHAR (SHEESH) SX4 B4 NUM OF VALID BYTES IN WORD IX4 X4*X5 NUM OF VALID BITS SB7 X4 . STORED INTO B7 SA5 AEOLWRD GET ASCII EOL WORD NE B0,B7,NOTASOW SPECIAL CASE START-OF-WORD BX7 X5 EQ ASTORE1 . BECAUSE OF LIMITED INST. SET. NOTASOW MX4 1 BUILD MASK OF VALID BITS SB7 B7-B1 . THE HARD WAY AX4 B7 . (CURSE CDC) BX7 X3*X4 CLEAR OUT DIRTY BITS IN BUFFER WORD BX5 -X4*X5 . AND IN END-OF-LINE WORD BX7 X5+X7 OR THE TWO TOGETHER ASTORE1 SA7 A3 REWRITE BUFFER WORD TO MEMORY SB4 B0 . POINT TO FIRST BYTE SB3 B3+B1 . IN THE NEXT WORD SB6 B6-B1 DECREMENT NUM. OF BYTES LEFT EQ WRTLOOP . AND SEE IF MORE TO DO WRTBUF BSS 0 WRITE BUFFER TO FILE WRITOUT .. EMPTY BUFFER EQ WRTLOOP AND SEE IF MORE TO DO WRTDONE BSS 0 CLEAN UP BEFORE GOING HOME SAVPARS SAVE PARAMETERS WHICH MAY CHANGE SA4 WRTNRCH RESTORE NUMBER OF CHARACTERS TRANSMITTED BX6 X4 AS RESULT OF FUNCTION EQ WRITEF= AND GO HOME ** MOVE DISPLAY CODE TO BUFFER WRDSP1 SX7 X5-1 SET NORMAL/EXTENDED SWITCH SA7 WRDSPSW SAVE IT SX5 X7 AND PLACE IT IN WORKING REGISTER MX6 1 SET SWITCH FOR NO 2ND HALF AT THE MOMENT WRDSP2 GE B0,B6,WRTDONE IF REQUEST SATISFIED LT B3,B2,WRDSP3 IF BUFFER NOT FULL WRITOUT FLUSH BUFFER SA5 WRDSPSW RELOAD NORMAL/EXTENDED SWITCH WRDSP3 SB7 B3+BUFSTRT FIND OUTPUT BUFFER WORD SA3 X0+B7 GET WORD FROM OUTPUT BUFFER BX7 X3 IN CASE ADDING CHARACTER TO IT GT B4,B0,WRDSP4 IF NOT AT START OF WORD BX7 X7-X7 CLEAR BUFFER WORD IF AT START WRDSP4 SA2 X1 GET NEXT CHARACTER FROM USER BUFFER SX1 X1+B1 INCREMENT POINTER SB6 B6-B1 DECREMENT CHAR REMAINING COUNTER SX3 B4+B4 COMPUTE CHARACTER SHIFT (CHAR#*2) IX4 X3+X3 *4 IX4 X4+X3 *6 SB7 X4-54 ADJUST FOR SHIFT FROM RIGHT SX4 X2-NEWLINE CHECK FOR END OF LINE ZR X4,WRDSP10 IF END-OF-LINE ZR X5,WRDSP5 IF NORMAL DISPLAY CODE SA4 X2+OUTMAPX TRANSLATE EXTENDED DISPLAY CODE PL X4,WRDSP6 IF 6-BIT CHARACTER SX6 X4 SAVE 2ND 6 BITS OF 12-BIT CHARACTER AX4 18 GET 1ST 6 BITS SX4 X4 EXTRACT IT EQ WRDSP6 GO MERGE IT WRDSP5 SA4 X2+OUTMAP TRANSLATE WORD TO NORMAL DISPLAY CODE WRDSP6 AX4 B7,X4 POSITION CHARACTER BX7 X7+X4 INSERT CHARACTER SB4 B4+B1 BUMP CHARACTER NUMBER LT B4,B5,WRDSP8 IF NOT AT END OF WORD SA7 A3 STORE COMPLETED WORD SB4 B0 RESET FOR NEXT WORD SB3 B3+B1 NG X6,WRDSP2 IF NO 2ND HALF OF CHAR LT B3,B2,WRDSP7 IF BUFFER NOT FULL WRITOUT WRITE OUT BUFFER SA5 WRDSPSW RELOAD NORMAL/EXTENDED SWITCH WRDSP7 SX7 X6 START NEW WORD WITH 2ND HALF OF CHAR LX7 59-5 POSITION CHAR SB4 B1 CHARACTER COUNT IN WORD MX6 1 CLEAR LOWER 6-BIT FLAG SB7 B3+BUFSTRT SA7 X0+B7 EQ WRDSP2 CONTINUE WRDSP8 PL X6,WRDSP9 IF 2ND HALF TO ADD GT B6,B0,WRDSP4 IF NOT DONE WITH REQUEST SA7 A3 STORE PARTIAL WORD AT END OF REQUEST EQ WRTDONE GO EXIT FROM PROGRAM WRDSP9 SX4 X6 LOW 6 BITS OF 12-BIT CHARACTER SB7 B7+6 ADJUST SHIFT AMOUNT MX6 1 CLEAR LAST HALF EQ WRDSP6 GO MERGE CHARACTER WRDSP10 EQ B4,B0,WRDSP13 ON EOL, IF AT START OF WORD SX4 B4 CHECK FOR EVEN OR ODD POSITION IN WORD LX4 59-0 PL X4,WRDSP11 IF EVEN NUMBER OF CHARACTERS IN WORD SX3 1R ADD A BLANK AX3 B7,X3 POSITION IT BX7 X7+X3 MERGE INTO RESULT WORD SB7 B7+6 ADJUST BIT SHIFT EQ WRDSP12 NOW WE HAVE BLANK AS LAST CHAR WRDSP11 SX3 7700B CHECK FOR COLON AS LAST CHARACTER AX3 B7,X3 BX4 X3*X7 NZ X4,WRDSP12 IF NOT COLON (00B) SB7 B7+6 ADD 2 SPACES SX3 2R AX3 B7,X3 BX7 X7+X3 WRDSP12 SA7 A3 STORE WORD BACK INTO BUFFER SB4 B0 SET POINTERS FOR NEXT WORD SB3 B3+B1 MX3 -12 CHECK FOR EOL IN FINAL WORD ALREADY BX3 -X3*X7 ZR X3,WRDSP15 IF EOL OUT THERE ALREADY WRDSP13 LT B3,B2,WRDSP14 IF BUFFER NOT FULL WRITOUT FLUSH BUFFER SA5 WRDSPSW RELOAD NORMAL/EXTENDED SWITCH WRDSP14 SB7 B3+BUFSTRT SET UP BUFFER POINTER SX7 2R FORM WORD OF 2 SPACES IN LEFTMOST CHARS LX7 59-11 SA7 X0+B7 STORE IN BUFFER SB3 B3+B1 INCREMENT BUFFER POINTER WRDSP15 SA2 X0+COL1BLK CHECK IF BLANK CARRIAGE CONTROL NEEDED ZR X2,WRDSP2 IF NOT NEEDED, CONTINUE LT B3,B2,WRDSP16 IF SPACE IN BUFFER WRITOUT FLUSH BUFFER SA5 WRDSPSW RELOAD NORMAL/EXTENDED SWITCH WRDSP16 SX7 1R SET UP BLANK CARRIAGE CONTROL LX7 59-5 POSITION IT SB7 B3+BUFSTRT PLACE IT IN OUTPUT BUFFER SA7 X0+B7 SB4 B1 SET CHARACTER COUNT EQ WRDSP2 CONTINUE END #-H- XAFX.COM 24368 1979 1221 843 *DECK XAFX IDENT XAFX MACHINE 6,I SYSCOM B1 XAFX TITLE XAFX - ABBREVIATED FTN EXECUTIVE. COMMENT ABBREVIATED FTN EXECUTIVE. XAFX SPACE 4,10 ***** XAFX - ABBREVIATED FTN EXECUTIVE. * * R. O. ANDERSON. 77-JAN-14. * B. L. TRUMBO. 78-MAY-13. * * SMALL FTN RUNTIME SYSTEM TO AVOID THE CYBER RECORD MANAGER * AND THE FORTRAN FORMATTED I/O SYSTEM. * * THIS MODULE IS BASED ON PIECES OF CODE FROM THE CONTROL DATA * ROUTINES *FORSYS=*, *OVERLAY*, AND OTHERS, AS WELL AS CODE * FROM *COMCFOR* BY R. A. HOLMES. *XAFX* IS INTENDED FOR USE * IN SYSTEM APPLICATIONS WHERE SPACE CONSIDERATIONS MAKE * EXCLUSION OF THE CYBER RECORD MANAGER AND/OR THE FORTRAN RUN * TIME SYSTEM DESIRABLE. XAFX SPACE 4,10 *CALL FCLMAC ** KEYWD MACRO - DEFINE A TABLE ENTRY FOR XAFX. * * KEYWD STR,ADDR * * ENTRY STR IS A 1 TO 7 CHARACTER STRING DENOTING THE * OPTION. * ADDR ADDRESS TO DISPATCH TO IF THE OPTION IS * FOUND. * KEYWD MACRO STR,ADDR VFD 42D/0H_STR,18D/ADDR ENDM XAFX SPACE 4,10 ** GLOBAL DATA AREAS. * XAFXA DATA 0 CP STARTING TIME XAFXB DATA 0 CP ENDING TIME FLLCM. ENTRY. 0 ECS FL SAVED HERE FLSCM. ENTRY. 0 CM FL SAVED HERE USE /CMAP/ MAP COMMON INMAP BSS 0 . DISPLAY CODE TO ASCII IF DEF,IO64 CON 0#3A . ASCII COLON ELSE CON 0#00 . ASCII NULL ENDIF CON 0#41 UPPER CASE A CON 0#42 UPPER CASE B CON 0#43 UPPER CASE C CON 0#44 UPPER CASE D CON 0#45 UPPER CASE E CON 0#46 UPPER CASE F CON 0#47 UPPER CASE G CON 0#48 UPPER CASE H CON 0#49 UPPER CASE I CON 0#4A UPPER CASE J CON 0#4B UPPER CASE K CON 0#4C UPPER CASE L CON 0#4D UPPER CASE M CON 0#4E UPPER CASE N CON 0#4F UPPER CASE O CON 0#50 UPPER CASE P CON 0#51 UPPER CASE Q CON 0#52 UPPER CASE R CON 0#53 UPPER CASE S CON 0#54 UPPER CASE T CON 0#55 UPPER CASE U CON 0#56 UPPER CASE V CON 0#57 UPPER CASE W CON 0#58 UPPER CASE X CON 0#59 UPPER CASE Y CON 0#5A UPPER CASE Z CON 0#30 0 CON 0#31 1 CON 0#32 2 CON 0#33 3 CON 0#34 4 CON 0#35 5 CON 0#36 6 CON 0#37 7 CON 0#38 8 CON 0#39 9 CON 0#2B + CON 0#2D - CON 0#2A * CON 0#2F / CON 0#28 ( CON 0#29 ) CON 0#24 $ CON 0#3D = CON 0#20 SPACE CON 0#2C , CON 0#2E . CON 0#23 # CON 0#7B [ (TRANSLATE AS OPEN BRACE) CON 0#7D ] (TRANSLATE AS CLOSE BRACE) IF DEF,IO64 CON 0#25 . ASCII PERCENT ELSE CON 0#3A . ASCII COLON ENDIF CON 0#22 " CON 0#5F _ CON 0#21 ! CON 0#26 & CON 0#27 ' CON 0#3F ? CON 0#3C < CON 0#3E > CON 0#40 @ CON 0#7C \ (TRANSLATE AS VERTICAL BAR FOR OR) CON 0#7E ^ (TRANSLATE AS TILDE FOR NOT) CON 0#3B ; OUTMAP BSS 0 . ASCII TO DISPLAY CODE DUP 10 CON 1R BLANK FOR CONTROL ENDD CON 0 NEW LINE DUP 21 CON 1R BLANK FOR CONTROL ENDD CON 1R CON 1R! CON 1R" CON 1R# CON 1R$ CON 0#33 . COLON IN 63 CH. SET, PERCENT IN 64 CON 1R& CON 1R' CON 1R( CON 1R) CON 1R* CON 1R+ CON 1R, CON 1R- CON 1R. CON 1R/ CON 1R0 CON 1R1 CON 1R2 CON 1R3 CON 1R4 CON 1R5 CON 1R6 CON 1R7 CON 1R8 CON 1R9 IF DEF,IO64 CON 0#00 . COLON IN 64 CH. SET ELSE CON 0#33 . COLON IN 63 CH. SET ENDIF CON 1R; CON 1R< CON 1R= CON 1R> CON 1R? CON 1R@ CON 1RA CON 1RB CON 1RC CON 1RD CON 1RE CON 1RF CON 1RG CON 1RH CON 1RI CON 1RJ CON 1RK CON 1RL CON 1RM CON 1RN CON 1RO CON 1RP CON 1RQ CON 1RR CON 1RS CON 1RT CON 1RU CON 1RV CON 1RW CON 1RX CON 1RY CON 1RZ CON 1R[ CON 1R\ CON 1R] CON 1R^ CON 65B UNDERSCORE (COMPASS PROBLEM) CON 1R@ FOLD IN COLUMNS 6 AND 7 CON 1RA CON 1RB CON 1RC CON 1RD CON 1RE CON 1RF CON 1RG CON 1RH CON 1RI CON 1RJ CON 1RK CON 1RL CON 1RM CON 1RN CON 1RO CON 1RP CON 1RQ CON 1RR CON 1RS CON 1RT CON 1RU CON 1RV CON 1RW CON 1RX CON 1RY CON 1RZ CON 1R[ CON 1R\ CON 1R] CON 1R^ CON 1R USE CODE. RANDOM. ENTRY. 17171274321477413155B SEED FOR RANF() ENTRY. 20000000000000553645B MULTIPLIER FOR RANF() ABNORM. SPACE 4,10 *** ABNORM. - ABORT AN FTN PROGRAM. * * ENTRY NONE. * * EXIT JOB WILL BE ABORTED TO AN *EXIT.* CARD. * * CALLS AFX.CET, MSG=, SYS=, QQEXIT. ABNORM. ENTRY. ENTRY/EXIT SB1 1 ALWAYS RJ =XQQEXIT CLOSE ALL FILES RJ AFX.CET COMPUTE AND PRINT ELAPSED TIME MESSAGE ABNORM.A,,RCL PRINT ABORT MESSAGE ABORT ,ND KILL THE RUN WITH NO DMPX ABNORM.A DATA C* JOB ABORTED.* XAFX SPACE 4,10 *** XAFX - PROCESS USER REQUESTS. * * CALL XAFX(OPT) * * ENTRY *OPT* IS A LIST OF DISPLAY CODE OPTIONS IN *H* * FORMAT, WITH A MAXIMUM OF 7 CHARACTERS PER * OPTION. THIS LIST MUST BE TERMINATED BY A * FULL WORD OF BINARY ZEROS. * * EXIT RETURNS AFTER PROCESSING ALL OPTIONS, EXCEPT THE * ABORT OPTIONS. THESE OPTIONS CAUSE IMMEDIATE JOB * TERMINATION IN THE SPECIFIED MANNER. * * CALLS SYSERR., SYS=. XAFX TRACE XAFX,XAFX TRACEBACK LINK XAFX ENTRY. ENTRY/EXIT SB1 1 ALWAYS SA1 X1-1 INITIALIZE INDEX TO OPTION LIST XAFX1 SB2 XAFXE B2 = FWA OF TABLE SB3 B2+XAFXF B3 = LWA + 1 OF TABLE SA1 A1+B1 GET THE USER'S OPTION ZR X1,XAFX RETURN AT END OF LIST XAFX2 SA3 B2 GET THE FIRST TABLE ENTRY BX6 X3-X1 COMPARE WITH USER'S CHOICE MX0 42 EDIT MASK FOR 7 CHARACTER COMPARE BX6 X0*X6 ZAP EXTRA DATA CX6 X6 TEST FOR ZERO ZR X6,XAFX3 IF A MATCH SB2 B2+B1 BUMP POINTER LT B2,B3,XAFX2 IF MORE TO CHECK BX1 X0*X1 ISOLATE 7 CHARACTERS SA2 XAFXC+2 GET MESSAGE SLOT LX1 -18 POSITION BAD OPTION MX6 18 BX6 X6*X2 BX6 X6+X1 ADD IN BAD OPTION SA6 A2 PLACE IN MESSAGE SX1 52 ERROR NUMBER (USER DEFINED / FATAL) SX2 XAFXC ERROR MESSAGE RJT SYSERR.,,XAFX PULL THE PLUG (WITH TRACEBACK) EQ XAFX IN THE (UNLIKELY) EVENT WE RETURN XAFX3 SB2 X3 GET THE TRANSFER ADDRESS JP B2 ENTER PROCESSING ROUTINE XAFX4 ABORT USER SAID *ABORT* XAFX5 ABORT ,ND USER SAID *ABORTN* XAFX6 ABORT ,,S USER SAID *ABORTS* XAFX7 ABORT ,ND,S USER SAID *ABORTNS* XAFX8 SX6 B0 CLEAR THE GAG BIT (*DAY* SPECIFIED) SA6 XAFXD EQ XAFX1 GO GET NEXT OPTION XAFX9 SX6 B1 SET THE GAG BIT (*NODAY* SPECIFIED) SA6 XAFXD EQ XAFX1 GO GET NEXT OPTION XAFXC DATA C* UNKNOWN XAFX OPTION = XXXXXXX* XAFXD DATA 0 GAG / NOGAG FLAG WORD XAFXE KEYWD ABORT,XAFX4 ABORT WITH DUMP TO *EXIT.* KEYWD ABORTN,XAFX5 ABORT WITH NO DUMP TO *EXIT.* KEYWD ABORTS,XAFX6 ABORT WITH DUMP TO *EXIT(S)* KEYWD ABORTNS,XAFX7 ABORT WITH NO DUMP TO *EXIT(S)* KEYWD DAY,XAFX8 DAYFILE MESSAGES ALLOWED KEYWD NODAY,XAFX9 NO DAYFILE MESSAGES ALLOWED XAFXF EQU *-XAFXE LENGTH OF TABLE END. SPACE 4,10 *** END. - PERFORM FTN NORMAL TERMINATION. * * THIS MODULE PROVIDES TERMINATION PROCESSING FOR FORTRAN * PROGRAMS. IF THE NODAY OPTION HAS NOT BEEN SELECTED, AN * APPROPRIATE DAYFILE MESSAGE IS ISSUED WITH THE EXECUTION * TIME. * * ENTRY (X1) = THE FTN TRACEBACK WORD FOR THE MODULE TO BE * TERMINATED. IF THE WORD POINTED TO BY THE TRACEBACK * WORD IS A *JP*, THE MODULE DOING THE *END* IS AN * OVERLAY, AND CONTROL IS RETURNED TO THE ADDRESS GIVEN * BY THE *JP*. * * EXIT EITHER TERMINATES THE JOB, OR RETURNS TO THE CALLING * OVERLAY AS NEEDED. * * CALLS AFX.CET, MSG=, SYS=. END. ENTER * FOR *END* STATEMENTS SB1 1 ALWAYS END.1 MX6 42 EXTRACT BX6 X6*X1 THE MODULE NAME SA6 END.B PLACE IN MESSAGE SB2 END.A PICK UP MESSAGE ADDRESS END.2 SA1 XAFXD SEE IF WE SHOULD KEEP QUIET NZ X1,END.3 IF SO MESSAGE B2,,RCL TELL EVERYONE WE ARE DONE RJ AFX.CET COMPUTE AND PRINT ELAPSED TIME END.3 RJ =XQQEXIT CLOSE ALL OPEN FILES, THEN ENDRUN LEAVE QUIETLY END.C DATA 0 FAKE ADDRESS LIST FOR QQEXIT END.A DATA A*END -- * END.B DATA C*XXXXXXX* MODULE NAME GOES HERE EXIT SPACE 4,10 *** EXIT - EXIT A FORTRAN PROGRAM. * * CALL EXIT * * ENTRY NONE. * * EXIT THE JOB STEP IS TERMINATED NORMALLY. * * CALLS NONE. EXIT ENTRY. FOR *CALL EXIT* STATEMENTS SB1 1 ALWAYS SB2 EXITA PICK UP MESSAGE ADDRESS EQ END.2 TO FINISH UP EXITA DATA C* EXIT.* STOP. SPACE 4,10 *** STOP. - STOP PROGRAM EXECUTION. * * ENTRY (X1) = THE ADDRESS OF THE *L* FORMAT *STOP* MESSAGE. * THIS MESSAGE WILL BE TRUNCATED TO A MAXIMUM * OF 70 CHARACTERS. * * EXIT THE MESSAGE IS PRINTED, UNLESS GAG IS SET, AND THE * JOB STEP IS TERMINATED NORMALLY. * * CALLS NONE. STOP. ENTER * FOR *STOP* STATEMENTS SB1 1 ALWAYS SA1 A1-B1 BACK UP FOR A RUNNING START SB2 B1 INITIAL OFFSET INTO STOP MESSAGE SB3 7 LONGEST MESSAGE FOR FTN IS 7 WORDS MX2 -12 TO TEST FOR EOL STOP.1 SA1 A1+B1 GET A WORD BX6 X1 ADD IT SA6 STOP.A+B2 TO MESSAGE SB2 B2+B1 INCREMENT POINTER SB3 B3-B1 DECREMENT COUNT BX6 -X2*X6 SEE IF EOL ZR X6,STOP.2 IF SO GT B3,B0,STOP.1 LOOP IF COUNT NOT EXHAUSTED STOP.2 SB2 STOP.A PICK UP MESSAGE POINTER EQ END.2 TO FINISH UP STOP.A DATA A*STOP * BSSZ 8 70 CHAR MESSAGE + EOL GOTOER. SPACE 4,10 *** GOTOER. - HANDLE COMPUTED GO TO ERRORS. * * ENTRY NONE. * * EXIT JOB IS ABORTED TO AN *EXIT* CARD. * * CALLS SYSERR.. GOTOER. TRACE GOTOER.,GOTOER. TRACEBACK WORD GOTOER. ENTRY. ENTRY/EXIT SB1 1 ALWAYS SX1 B1 ERROR NUMBER NUMBER 1 SX2 GOTOER.A ERROR FOR INVALID GOTO INDEX RJT SYSERR.,,GOTOER. PULL THE PLUG (WITH TRACEBACK) EQ GOTOER. WE SHOULD NOT RETURN, BUT... GOTOER.A DATA C* INVALID INDEX IN A COMPUTED GOTO.* FECOPE. SPACE 4,10 *** FECOPE. - INTERCEPT FTN I/O FROM SORT/MERGE. * * ENTRY NONE. * * EXIT JOB IS ABORTED. * * CALLS SYSERR.. FECOPE. TRACE FECOPE.,FECOPE. TRACEBACK WORD FECOPE. ENTRY. ENTRY/EXIT SX1 52 ERROR NUMBER (USER DEFINED / FATAL) SX2 FECOPE.A ERROR MESSAGE RJT SYSERR.,,FECOPE. PULL THE PLUG (WITH TRACEBACK) EQ FECOPE. WE SHOULD NOT COME BACK, BUT... FECOPE.A DATA 40H FORMATTED I/O NOT SUPPORTED BY XAFX. DATA C* RELOAD USING CDC ROUTINES.* Q8NTRY. SPACE 4,10 *** Q8NTRY. - INITIALIZE FTN RUN-TIME CELLS. * Q1NTRY. - INITIALIZE FTN RUN-TIME CELLS. * Q2NTRY. - INITIALIZE FTN RUN-TIME CELLS. * Q8NTR= - INITIALIZE MNF RUN-TIME CELLS. * * ENTRY (X0) = THE *ECS* FL. * (A0) = THE *CM* FL. * * EXIT CELLS *FLLCM.* AND *FLSCM.* ARE INITIALIZED. * * CALLS SYS=. Q1NTRY. ENTER * FTN ENTRY FOR CRM 1.5 Q2NTRY. ENTER * FTN ENTRY FOR CRM 1.5 Q8NTR= ENTER * MNF ENTRY Q8NTRY. ENTRY. ENTRY/EXIT SB1 1 ALWAYS BX6 X0 SAVE LCM SA6 FLLCM. FIELD LENGTH SX6 A0 SAVE SCM SA6 FLSCM. FIELD LENGTH TIME XAFXA GET CP STARTING TIME RJ =XQQINIT OPEN STANDARD INPUT AND OUTPUT EQ Q8NTRY. RETURN SYSERR. SPACE 4,10 *** SYSERR. - PRINT ERROR NUMBER AND ABORT THE JOB. * * ENTRY (X1) = THE ADDRESS OF AN ERROR MESSAGE. * (X2) = THE ASSOCIATED ERROR NUMBER. * * EXIT MESSAGE IS PRINTED AND JOB IS ABORTED. * * CALLS CDD=, MSG=, TRACER., ABNORM.. SYSERR. ENTRY. ENTRY/EXIT SB1 1 ALWAYS BX5 X2 PRESERVE MESSAGE ADDR. ACROSS CDD RJ =XCDD= CONVERT ERROR NUMBER TO DISPLAY CODE LX6 -18 ISOLATE THREE DIGITS MX7 18 BX7 X7*X6 SA7 SYSERR.B PLACE RESULT IN ERROR NUMBER SLOT MESSAGE SYSERR.A,LOCAL,RCL PRINT ERROR NUMBER MESSAGE X5,LOCAL,RCL AND NASTY MESSAGE SX1 SYSERR. (X1) = ENTRY POINT ADDRESS SX2 B0 TELL *TRACER.* TO USE DAYFILE MX3 0 GIVE INFINTE TRACEBACK SX4 B1 USE *DETECTED BY* RJ TRACER. GET TRACEBACK RJ ABNORM. TO BLOW OFF THE RUN EQ SYSERR. WE SHOULD NOT COME BACK, BUT... SYSERR.A DATA 20H FTN - FATAL ERROR SYSERR.B DATA C*999* ERROR NUMBER GOES HERE TRACER. SPACE 4,10 *** TRACER. - PROVIDE TRACEBACK PROCESSING FOR FTN. * * ENTRY (X1) = THE ADDRESS OF THE ENTRY POINT OF THE MODULE * ONE LEVEL BELOW WHERE TRACEBACK SHOULD START. * (X2) = 0 IF TRACE MESSAGES SHOULD GO TO DAYFILE. * (X2) = A FET ADDRESS IF MESSAGES SHOULD GO TO A FILE. * (X3) = 0 FOR INFINITE TRACEBACK. * (X3) = N FOR *N* LEVELS OF TRACEBACK. * (X4) = 1 TO GET THE FIRST MESSAGE TO START *DETECTED * BY*. * (X4) = 0 TO GET THE FIRST MESSAGE TO START *CALLED * FROM*. * * EXIT RETURNS AFTER TRACING BACK TO A MAIN PROGRAM. * * CALLS WOD=, MSG=, CDD=, WTC=. TRACER.1 SX1 A1 GET ADDRESS OF BAD LINK WORD RJ =XWOD= CONVERT TO OCTAL DISPLAY CODE MX6 -36 EXTRACT THE RIGHT MOST 6 DIGITS BX7 -X6*X7 LX7 12 MX6 12 MASK TO CLEAN OLD MESSAGE SA1 TRACER.B+3 GET MESSAGE WORD BX6 X6*X1 CLEAR OLD INFO BX6 X6+X7 ADD IN NEW SA6 A1 PLACE IN MESSAGE MESSAGE TRACER.B,LOCAL,RCL TELL THE WORLD ABOUT IT TRACER. ENTRY. ENTRY/EXIT SX6 X3 SAVE THE TRACEBACK LIMIT SA6 TRACER.G SB7 X2 GET THE FET ADDRESS (OR 0) SB1 1 ALWAYS SA2 TRACER.D GET TEST WORD FOR *RJ* CREATED *EQ* TRACER.2 LX4 1 CONVERT CALL TYPE TO OFFSET SA4 TRACER.F+X4 GET MESSAGE WITH CALL TYPE BX6 X4 MOVE TO TRACE BUFFER SA6 TRACER.C SA4 A4+B1 GET NEXT WORD BX6 X4 MOVE INTO BUFFER SA6 A6+B1 SA1 X1 GET THE *EQ* WORD BX2 X1-X2 TEST FOR AN *RJ* CREATED *EQ* LX2 12 AFTER DELETING THE ADDRESS FIELD MX6 18 BX6 -X6*X2 NZ X6,TRACER. RETURN IF A MAIN PROGRAM AX1 30 MOVE ADDRESS INTO LOW BITS SA1 X1-1 GET WORD WITH *RJ* / TRACEBACK LINK MX6 12 ISOLATE OPCODE BX6 X6*X1 SA2 TRACER.H TEST WORD FOR *RJ* INSTRUCTION BX6 X2-X6 SEE IF AN *RJ* NZ X6,TRACER.1 IF NOT, SOMEBODY BLEW IT MX6 -30 EDIT MASK TO ISOLATE LINE NUMBER AND LINK BX6 -X6*X1 SA2 TRACER.I GET TEST WORD NUMBER 2 BX2 X6-X2 SEE IF NO-OPS IN LOW ORDER BITS SX5 X6 SAVE POINTER TO TRACEBACK WORD ZR X2,TRACER.1 IF WE FOUND NO-OPS, USER BLEW IT AX6 18 MOVE LINE NUMBER DOWN SX1 X6 (X1) = LINE NUMBER (CONVENIENCE) ZR X1,TRACER.3 IF A COMPASS CALL RJ =XCDD= CONVERT LINE NUMBER TO DISPLAY CODE MX7 -24 ISOLATE 4 DIGITS BX7 -X7*X6 LX7 -24 MOVE TO TOP OF WORD, THUS MAKING EOL SA7 TRACER.C+3 PLACE IN BUFFER SA4 TRACER.E GET * AT LINE * BX6 X4 PLACE IN BUFFER SA6 A7-B1 EQ TRACER.4 JOIN COMMON PROCESSING TRACER.3 SX1 A1 PICK UP ADDRESS WHERE *RJ* IS IX1 X1-X5 SUBTRACT ADDRESS OF TRACEBACK WORD MX6 0 ASSUME DIFFERENCE WILL BE NEG. SB5 X5 SAVE POINTER TO TRACEBACK WORD SA6 TRACER.C+2 PLACE EOL MARKER MI X1,TRACER.4 IF ADDRESS TO BE SUPPRESSED RJ =XWOD= CONVERT RELATIVE ADDRESS TO OCTAL DISPLAY MX6 -36 BX7 -X6*X7 ISOLATE 6 DIGITS SA1 TRACER.A+1 GET *S 777777* LX7 12 POSITION DIGITS MX6 12 MASK TO PRESERVE PART OF MESSAGE BX6 X6*X1 DELETE OLD ADDRESS BX6 X6+X7 ADD IN NEW ADDRESS SA6 TRACER.C+3 SA1 A1-B1 GET * AT ADDRES* BX6 X1 PLACE IN BUFFER SA6 A6-B1 SX5 B5 RESTORE TRACEBACK WORD POINTER TRACER.4 SA5 X5 GET THE TRACEBACK WORD IN X5 MX6 42 EDIT MASK FOR GETTING NAME BX7 X6*X5 GET THE NAME LX7 -18 RIGHT JUSTIFY IT MX6 18 TO PRESERVE UPPER PART OF MESSAGE SA1 TRACER.C+1 GET THE WORD TO PUT NAME IN BX6 X6*X1 CLEAR OLD NAME BX6 X6+X7 ADD IN NEW NAME SA6 A1 PLACE IN MESSAGE LE B7,B0,TRACER.5 IF MESSAGES GO TO DAYFILE WRITEC B7,A1-B1 OUTPUT THE LINE EQ TRACER.6 TO REJOIN COMMON CODE TRACER.5 MESSAGE A1-B1,LOCAL,RCL DISPLAY THE LINE TRACER.6 SA1 TRACER.G GET MAX TRACEBACK LIMIT SX6 B1 DECREMENT BY 1 IX6 X1-X6 ZR X6,TRACER. IF LIMIT REACHED SA6 A1 UPDATE REMAINDER SX1 X5 X1 IS ENTRY POINT ADDRESS SA2 TRACER.D GET ENTRY POINT TEST WORD MX4 0 INSURE WE GET * CALLED FROM* EQ TRACER.2 LOOP TILL DONE TRACER.A DATA C* AT ADDRESS 777777* TRACER.B DATA C* BAD TRACEBACK LINK AT ABS ADDR 777777* TRACER.C BSSZ 4 MESSAGE BUFFER FOR TRACEBACK TRACER.D EQ ** TEST WORD - VFD 30/0 FOR AN *EQ* CREATED BY AN *RJ* TRACER.E DATA C* AT LINE 9999* TRACER.F DATA 20H CALLED FROM XXXXXXX DATA 20H DETECTED BY XXXXXXX TRACER.G DATA 0 MAXIMUM TRACEBACK LIMIT STORED HERE TRACER.H RJ ** TEST FOR AN *RJ* IN TOP 30 BITS - VFD 30/0 OF A WORD TRACER.I VFD 30/0 TEST FOR STANDARD - SB0 B0+46000B NO-OP IN LOW ORDER BITS AFX.CET SPACE 4,10 ** AFX.CET - COMPUTE ELAPSED CP TIME AND DAYFILE IT. * * ENTRY NONE. * * EXIT RETURNS AFTER ISSUING DAYFILE MESSAGE. * * CALLS SYS=, CFP>, MSG=. AFX.CET SUBR ENTRY/EXIT TIME XAFXB STOP THE CLOCK SA1 XAFXA GET START TIME MX0 -24 LX0 12 MASK FOR MSEC (MIDDLE 24 BITS) MX4 -12 MASK FOR MSEC (LOWER 12 BITS) BX2 -X4*X1 (X2) = MSEC BX1 -X0*X1 LX1 -12 (X1) = SEC SX3 1000D TO CONVERT SEC TO MSEC IX6 X1*X3 CONVERT SEC TO MSEC IX6 X6+X2 (X6) = START TIME IN MSEC SA1 XAFXB GET STOP TIME BX2 -X4*X1 (X2) = MSEC BX1 -X0*X1 LX1 -12 (X1) = SEC IX7 X1*X3 CONVERT SEC TO MSEC IX7 X7+X2 (X7) = STOP TIME IN MSEC SB2 3 SAY 3 AS IN F10.3 IX1 X7-X6 TOTAL ELAPSED CP TIME IN MSEC PX3 GET FLOATING POINT 1000D PX1 CONVERT CP TIME TO FLOATING POINT NX3 NX1 RX1 X1/X3 RJ =XCFP> CONVERT F.P. SECONDS TO DISPLAY SA6 AFX.CETA PLACE IN MESSAGE MESSAGE A6,LOCAL,RCL ISSUE IT EQ AFX.CET RETURN AFX.CETA DATA 10H 99999.999 DATA C* CP SECONDS EXECUTION TIME.* END #-H- CARGS 608 1979 1221 844 DEFINE (AMEMSIZE,100)%# MAX. SIZE OF ARGLIST MEMORY (BYTES) COMMON /CARGS/ TTYFLG, RUNPTR, INPTR, OUTPTR, ERRPTR, NARGS, MEMOFF, AMEM(AMEMSIZE), PEEK INTEGER TTYFLG%# NO IF NO COMMAND LINE WAS TYPED INTEGER RUNPTR%# POINTER TO NAME OF NEXT PROGRAM OR 0 INTEGER INPTR%# POINTER TO STANDARD INPUT NAME OR 0 INTEGER OUTPTR%# POINTER TO STANDARD OUTPUT NAME OR 0 INTEGER ERRPTR%# POINTER TO STANDARD ERROR NAME OR 0 INTEGER NARGS%# NUMBER OF ARGUMENTS INTEGER MEMOFF%# OFFSET FOR ADDRESSING MEMORY INTEGER AMEM%%# USE TO ADDRESS MEMORY CHARACTER PEEK%# LOOKAHEAD CHARACTER FOR ATOK #-H- CMAP 138 1979 1221 844 COMMON /CMAP/ INMAP(64), OUTMAP(128) CHARACTER INMAP # DISPLAY CODE TO ASCII MAP CHARACTER OUTMAP # ASCII TO DISPLAY CODE MAP #-H- CPFNS 360 1979 1221 844 # CPFNS -- PERMANENT FILE INFORMATION COMMON /CPFNS/ SWITCH, PFN(4),TLFN,ID,CY,RP,KEYTAB(8) INTEGER SWITCH%# FILE BYTE SIZE SWITCH INTEGER PFN%%# PERMANENT FILE NAME INTEGER TLFN%%# LOGICAL FILE NAME INTEGER ID%%# PERMANENT FILE ID INTEGER CY%%# CYCLE NUMBER INTEGER RP%%# RETENTION PERIOD INTEGER KEYTAB%# OTHER PERMANENT FILE ATTRIBUTES #-H- CIOSYS 229 1979 1221 844 COMMON /CIOSYS/ FDTAB(MAXFILES),FBKTAB(FBLEN,MAXFILES) INTEGER FDTAB%# POINTERS TO FILE BLOCKS INTEGER FBKTAB%# FILE BLOCKS INTEGER FILTAB(1)%# FOR SINGLE-DIMENSION ACCESS TO FBKTAB EQUIVALENCE (FBKTAB(1), FILTAB(1)) #-H- IODEFS 2281 1979 1221 845 # WARNING: IF YOU CHANGE THESE, YOU MUST CHANGE CORRESPONDING # MNEMONICS IN COMPASS ROUTINES OR YOU # WILL CAUSE THE APOCALYPSE! DEFINE(MAXFILES,16)%# NUMBER OF OPENED FILES PERMITTED DEFINE (FETLEN,5)%# LENGTH OF CYBER FET DEFINE (MAXBUFSIZE,65)%# LENGTH OF CIRCULAR BUFFER DEFINE (BINARYFILE,2B)%# BIT 1 IN FET, SET TO INDICATE BINARY FILE DEFINE (FILENOTBUSY,1B) # BIT 0 IN FET, MUST BE SET WHEN OPEN # FILE BLOCK FORMAT DEFINE (BKSTART,1)%# START OF A FILE BLOCK DEFINE (USECNT,1)%# USE COUNT DEFINE (MODE,2)%%# OPEN MODE DEFINE (MAPFLAG,3)%# -1 IF ASCII, 1 IF DISPLAY, 0 OTHERWISE DEFINE (BUFSIZE,4)%# VALID SIZE OF I/O BUFFER DEFINE (BYTESPERWORD,5) # NO. OF BYTES / WORD DEFINE (CURRENTWORD,6)%# POINTER TO CURRENT WORD IN I/O BUFFER DEFINE (CURRENTBYTE,7)%# POINTER TO CURRENT BYTE IN CURRENT WORD DEFINE (BITSPERBYTE,8)%# NO. OF BITS / BYTE DEFINE (EOFFLAG,9)%# NON-ZERO IF EOF ON LAST READ DEFINE (COL1BLANK,10)%# NON-ZERO IF NEED CARRIAGE CONTROL DEFINE (FETSTART,11)%# FIRST WORD OF FET (5 WORDS LONG) DEFINE (BUFSTART,16)%# FIRST WORD OF I/O BUFFER (65 WORDS LONG) DEFINE (FDBLOC,82)%# POINTER TO FDB IF PERMANENT FILE DEFINE (FBLEN,100)%# LENGTH OF ONE FILE BLOCK DEFINE (FDBLEN,17)%# LENGTH OF ONE FILE CONTROL BLOCK DEFINE (FILBLK,1600)%# MAXFILES * FBLEN DEFINE (IDKEY,14B)%# FDB CODE FOR ID DEFINE (XRKEY,13B)%# FDB CODE FOR EXTEND PASSWORD DEFINE (TKKEY,4B)%# FDB CODE FOR TURNKEY PASSWORD DEFINE (PW1KEY,20B)%# FDB CODE FOR PASSWORD DEFINE (PW2KEY,21B)%# FDB CODE FOR PASSWORD DEFINE (RPKEY,2B)%# FDB CODE FOR RETENTION PERIOD DEFINE (CYKEY,3B)%# FDB CODE FOR CYCLE NUMBER DEFINE (MRKEY,11B)%# FDB CODE FOR MULTI-READ ACCESS DEFINE (RDKEY,10B)%# FDB CODE FOR READ PASSWORD DEFINE (ATTACH,1)%# PFN CMD IS AN ATTACH DEFINE (CATALOG,2)%# PFN CMD IS A CATALOG DEFINE (PURGE,3)%# PFN CMD IS PURGE DEFINE (ALTER,4)%# PFN CMD IS ALTER DEFINE (EXTEND,5)%# PFN CMD IS EXTEND DEFINE (RENAME,6)%# PFN CMD IS RENAME DEFINE(LFNMASK,77777777777777000000B) DEFINE(KEYMASK,77777777777777777700B) DEFINE(QRIGHT,1)%# IF WANT PACK AND RIGHT-JUSTIFIED DEFINE(QLEFT,2)%%# IF WANT PACK AND LEFT-JUSTIFIED DEFINE (MAXARG, 60) DEFINE (COMADDR, 70B) # ADDRESS OF COMMAND LINE STORAGE DEFINE (LOCALFILE,1)%%# FILENAME IS LFN DEFINE (PERMFILE,2)%%# FILENAME IS PFN #-H- IODEFS.C 7700 1979 1221 845 *COMDECK IODEFS * THE FOLLOWING DEFINED CONSTANTS ARE USED BY THE COMPASS PROGRAMS * IN THE RATFOR IO SYSTEM MAXFILE EQU 16 . NUMBER OF FILES OPEN AT ONCE FILBLK EQU 1600 . SIZE OF FILE BLOCK TABLE EOF EQU 10003 .EOF FLAG USED IN RATFOR ERR EQU 10001 .ERR FLAG USED IN RATFOR EOFVAL EQU 20B .MASK FOR EOF STATUS IN FET BLANK EQU 55B .DISPLAY CODE BLANK NEWLINE EQU 10 .ASCII NEW LINE * THE FOLLOWING DEFINED CONSTANTS ARE THE OFFSETS INTO THE * FILE BLOCK. THESE MUST MATCH EQUIVALENT ONES IN * IODEFS. MAPFLAG EQU 3 .- IF ASCII,+ IF DISPLAY, 0 OTHERWISE BUFSIZE EQU 4 .SIZE OF I/O BUFFER (WORDS) BYTPWRD EQU 5 .# OF BYTES/WORD CURWORD EQU 6 .WORD POINTER INTO IO BUFFER CURBYTE EQU 7 .BYTE POINTER INTO CURWORD BTSPBYT EQU 8 .# OF BITS/BYTE EOFFLG EQU 9 .NON-ZERO IF EOF ENCOUNTERED COL1BLK EQU 10 .NON-ZERO IF CARRIAGE CONTROL NEEDED FETSTRT EQU 11 .START OF FET (5 WORDS LONG) BUFFRST EQU 12 .ADDR. OF FIRST WORD IN I/O BUFFER BUFIN EQU 13 .ADDR. OF FIRST FREE WORD IN I/O BUFFER BUFOUT EQU 14 .ADDR. OF LAST WORD USED IN I/O BUFFER BUFLMIT EQU 15 .ADDR. OF LAST WORD IN I/O BUFFER BUFSTRT EQU 16 .STARTOF I/O BUFFER (65 WORDS LONG) FDBLOC EQU 82%%.POINTER TO FDB BLOCK, IF PFN FBEND EQU 100 .LAST WORD IN FILE BLOCK * GETARGS -- MOVE ARGUMENTS OF READF/WRITEF INTO REGISTERS GETARGS MACRO SA2 A1+B1 .MOVE ADDRESS OF N INTO X2 SA3 A2+B1 .MOVE ADDRESS OF FD INTO X3 SA2 X2 .MOVE N INTO X2 SB6 X2 .. AND THEN TO B6 BX6 X2 .. AND COPY INTO X6 (RETURNED VALUE) SA4 X3 .MOVE FD INTO X4 SA5 X4+FDTAB .LOAD ADDR OF FILE BLOCK INTO X5 SX0 X5-1B ..AND STORE BASE POINTER INTO X0 ENDM # END OF MACRO GETARGS * GETPARS -- MOVE FILE DEPENDANT INFO. INTO B REGISTERS GETPARS MACRO SA2 X0+BUFSIZE .MOVE SIZE OF IO BUFFER INTO X2 SB2 X2 .. AND STORE IN B2 SA3 A2+B1 .MOVE BYTES/WORD INTO X3 SB5 X3 .. AND STORE IN B5 SA4 A3+B1 .MOVE CURRENT WORD PTR INTO X4 SB3 X4 .. AND STORE IN B3 SA5 A4+B1 .MOVE CURRENT BYTE PRT INTO X5 SB4 X5 .. AND STORE IN B4 ENDM # END OF MACRO GETPARS * SAVPARS -- SAVE BUFFER PARAMETERS WHICH MIGHT HAVE CHANGED SAVPARS MACRO SX7 B3 .MOVE CURRENT WORD PTR INTO X7 SA7 X0+CURWORD .. AND SAVE IN FILE BLOCK SX7 B4 .MOVE CURRENT BYTE PTR INTO X7 SA7 A7+B1 .. AND SAVE IN FILE BLOCK ENDM # END OF MACRO SAVPARS * GETBPB -- LOAD BITS/BYTE INTO X5 AND BITS/BYTE-1 INTO B7 GETBPB MACRO SA5 X0+BTSPBYT .MOVE BITS/BYTE INTO X5 SB7 X5-1B .. AND BITS/BYTE -1 INTO B7 ENDM # END OF MACRO GETBPB * GETMAP -- LOAD MAPFLAG INTO X5 GETMAP MACRO SA5 X0+MAPFLAG .MOVE MAP FLAG INTO X5 ENDM # END OF MACRO GETMAP * SAVBUF -- SAVE CURRENT BUFFER SIZE INTO FILE BLOCK SAVBUF MACRO SX7 B2 .MOVE BUFSIZE INTO X7 SA7 X0+BUFSIZE .. AND STORE INTO FILE BLOCK ENDM # END OF MACRO SAVBUF * SAVLIST -- SAVE A1 AND X1 IN A4 AND X4 (FOR PP CALL) SAVLIST MACRO SA4 A1 .MOVE A1 TO A4 BX4 X1 .MOVE X1 TO X4 (NOT = TO M[A4]) BX5 X6 .MOVE N TO X6 ENDM # END OF MACRO SAVLIST * GETLIST -- RESTOR A1 AND X1 FROM A4 AND X4 (AFTER PP CALL) GETLIST MACRO SA1 A4 .MOVE A4 TO A1 BX1 X4 .MOVE X4 TO X1 (NOT = TO M[A1]) BX6 X5 .MOVE N BACK TO X6 (RETURN REG.) ENDM # END OF MACRO GETLIST * RDPRU -- ISSUE PP CALL TO READ PRU INTO I/O BUFFER RDPRU MACRO SB7 X0+FETSTRT #ADDRSS OF FET TO B7 READ B7,RECALL #CALL PP WITH RECALL ENDM # END OF MACRO RDPRU * WRTPRU -- ISSUE PP CALL TO WRITE I/O BUFFER TO FILE WRTPRU MACRO SB7 X0+FETSTRT #ADDRESS OF FET INTO B7 WRITE B7,RECALL #CALL PP WITH RECALL ENDM # END OF MACRO WRTPRU * EOFCHK -- CHECK FOR EOF, IF SO, RESET # OF BYTES READ, RETURN EOFCHK MACRO LOCAL NOEOF SA5 X0+EOFFLG .GET EOFFLG INTO X5 ZR X5,NOEOF .SKIP IF NO EOF ON LAST READ SX3 B6 .LOAD # OF BYTES LEFT TO READ INTO X3 IX6 X6-X3 .LOAD BYTES READ INTO X6 SAVPARS .SAVE THE WORLD EQ READF= .. AND GO HOME NOEOF BSS 0 .ELSE JUST CONTINUE ENDM # END OF MACRO EOFCHK * READCHK -- CHECK READ FOR EOF OR ERROR READCHK MACRO LOCAL READEOF,NOEOI SA2 X0+FETSTRT .GET FET STATUS WORD SX3 EOFVAL .GET VALUE OF EOF STATUS BX7 X2*X3 .SEE IF EOF FLAG IS SET ZR X7,NOEOI ..AND SKIP IF NOT SET READEOF BSS 0 .OK, DEFINITELY HAVE EOF SX7 EOF .PLACE FLAG INTO SA7 X0+EOFFLG .. FILE BLOCK SA3 X0+BUFIN .LOAD BUFFERIN ADDR. INTO X3 SA4 A3+B1 .LOAD BUFFEROUT ADDR. INTO X4 IX7 X3-X4 .COMPUTE NEW BUFFER LENGTH SB2 X7 .RESET BUFSIZE REGISTER SA7 X0+BUFSIZE .SAVE NEW BUFFER LENGTH NOEOI BSS 0 .FINISHED WITH READCHK ENDM # END OF MACRO READCHK * CLRBUF -- CLEAR I/O BUFFER BEFORE READ OR AFTER WRITE CLRBUF MACRO SA4 X0+BUFFRST .GET START ADDRESS OF BUFFER BX7 X4 .. MOVE TO X7 SA7 A4+B1 .RESET IN FIELD OF FET SA7 A7+B1 .RESET OUT FIELD OF FET SB4 B0 .RESET CURRENT BYTE SB3 B0 .RESET CURRENT WORD ENDM # END OF MACRO CLRBUF * WRITOUT -- EMPTY I/O BUFFER INTO FILE WRITOUT MACRO SA4 X0+BUFLMIT .GET LIMIT ADDR OF BUFFER INTO X4 SX7 X4-1B .. AND LIMIT INTO X7 SA7 X0+BUFIN .MARK BUFFER AS FULL SAVLIST .SAVE ARG LIST ADDR BEFORE WRITE WRTPRU .ISSUE WRITE AND WAIT FOR COMPLETION GETLIST .RESTORE ARG LIST ADDR CLRBUF .RESET BUFFER PTRS ENDM # END OF MACRO WRITOUT * READWRD -- MOVE FULL WORD FROM I/O BUFFER INTO USER BUFFER READWRD MACRO BX7 X2 .MOVE WORD TO BE RETURNED SA7 X1 .STORE INTO USER BUFFER SX1 X1+B1 .UPDATE USER BUFFER POINTER SB3 B3+B1 .INCREMENT CURRENT WORD PTR SB6 B6-B1 .DECREMENT BYTES LEFT TO READ ENDM # END OF MACRO READWRD #-H- RATDEF 3143 1979 1221 845 #========== STANDARD RATFOR DEFINITIONS ========== DEFINE(ALPHA,10100) DEFINE(AND,38) DEFINE(ANDIF,IF) DEFINE(ARB,100) DEFINE(ATSIGN,64) DEFINE(BACKSLASH,92) DEFINE(BACKSPACE,8) DEFINE(BANG,33) DEFINE(BAR,124) DEFINE(BIGA,65) DEFINE(BIGB,66) DEFINE(BIGC,67) DEFINE(BIGD,68) DEFINE(BIGE,69) DEFINE(BIGF,70) DEFINE(BIGG,71) DEFINE(BIGH,72) DEFINE(BIGI,73) DEFINE(BIGJ,74) DEFINE(BIGK,75) DEFINE(BIGL,76) DEFINE(BIGM,77) DEFINE(BIGN,78) DEFINE(BIGO,79) DEFINE(BIGP,80) DEFINE(BIGQ,81) DEFINE(BIGR,82) DEFINE(BIGS,83) DEFINE(BIGT,84) DEFINE(BIGU,85) DEFINE(BIGV,86) DEFINE(BIGW,87) DEFINE(BIGX,88) DEFINE(BIGY,89) DEFINE(BIGZ,90) DEFINE(BLANK,32) DEFINE(CARET,94) DEFINE(COLON,58) DEFINE(COMMA,44) DEFINE(DIG0,48) DEFINE(DIG1,49) DEFINE(DIG2,50) DEFINE(DIG3,51) DEFINE(DIG4,52) DEFINE(DIG5,53) DEFINE(DIG6,54) DEFINE(DIG7,55) DEFINE(DIG8,56) DEFINE(DIG9,57) DEFINE(DIGIT,2) DEFINE(DOLLAR,36) DEFINE(DQUOTE,34) DEFINE(EOF,10003) DEFINE(EOS,10002) DEFINE(EQUALS,61) DEFINE(ERR,10001) DEFINE(ERROUT,2) DEFINE(GREATER,62) DEFINE(HUGE,30000) DEFINE(LBRACE,123) DEFINE(LBRACK,91) DEFINE(LESS,60) DEFINE(LETA,97) DEFINE(LETB,98) DEFINE(LETC,99) DEFINE(LETD,100) DEFINE(LETE,101) DEFINE(LETF,102) DEFINE(LETG,103) DEFINE(LETH,104) DEFINE(LETI,105) DEFINE(LETJ,106) DEFINE(LETK,107) DEFINE(LETL,108) DEFINE(LETM,109) DEFINE(LETN,110) DEFINE(LETO,111) DEFINE(LETP,112) DEFINE(LETQ,113) DEFINE(LETR,114) DEFINE(LETS,115) DEFINE(LETT,116) DEFINE(LETTER,1) DEFINE(LETU,117) DEFINE(LETV,118) DEFINE(LETW,119) DEFINE(LETX,120) DEFINE(LETY,121) DEFINE(LETZ,122) DEFINE(LPAREN,40) DEFINE(MAXCHARS,10) DEFINE(MAXLINE,120)%# TYPICAL LINE LENGTH DEFINE(MAXNAME,30) %# TYPICAL FILE NAME SIZE DEFINE(MINUS,45) DEFINE(NEWLINE,10) DEFINE(NO,0) DEFINE(NOERR,0) DEFINE(NOT,126) # SAME AS TILDE DEFINE(OK,-2) DEFINE(OR,BAR) # SAME AS BAR DEFINE(PERCENT,37) DEFINE(PERIOD,46) DEFINE(PLUS,43) DEFINE(QMARK,63) DEFINE(RBRACE,125) DEFINE(RBRACK,93) DEFINE(READ,0) DEFINE(READWRITE,2) DEFINE(RPAREN,41) DEFINE(SEMICOL,59) DEFINE(SHARP,35) DEFINE(SLASH,47) DEFINE(SQUOTE,39) DEFINE(STAR,42) DEFINE(STDIN,0) DEFINE(STDOUT,1) DEFINE(STDERR,ERROUT) DEFINE(TAB,9) DEFINE(TILDE,126) DEFINE(UNDERLINE,95) DEFINE(WRITE,1) DEFINE(YES,1) DEFINE(CHARACTER,INTEGER) DEFINE(ABS,IABS) DEFINE(MIN,MIN0) DEFINE(MAX,MAX0) # HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE DEFINE(BPI,36)%%# BITS PER INTEGER DEFINE(BPC,7)%%# BITS PER CHARACTER DEFINE(CPI,5)%%# CHARACTERS PER INTEGER DEFINE(LIMIT,134217728)%# LARGEST POSITIVE INTEGER DEFINE(LIM1,28)%%# MAXIMUM EXPONENT (POWER OF TEN) DEFINE(LIM2,-28)%# MINIMUM EXPONENT (POWER OF TEN) DEFINE(PRECISION,7)%# DIGITS ACCURATE IN REAL # THE FOLLOWING ARE CYBER-DEPENDANT DEFINITIONS DEFINE(BPI,60)%%# BITS PER INTEGER DEFINE(BPC,12)%%# BITS PER CHARACTER DEFINE(CPI,5)%%# CHARACTERS PER INTEGER DEFINE(LIMIT,140737488355327)%# LARGEST POSITIVE INTEGER DEFINE(LIM1,322)%%# MAXIMUM EXPONENT (POWER OF TEN) DEFINE(LIM2,-293)%%# MINIMUM EXPONENT (POWER OF TEN) DEFINE(PRECISION,14)%%# DIGITS ACCURATE IN REAL DEFINE(MAXLINE,200)%%# LINE LENGTH ON CYBER OUTPUT (TYPICAL) DEFINE(MAXCHARS,30)%%# HANDY-DANDY BUFFER SIZE FOR INTEGERS #========== LIBRARY OF USEFUL RATFOR ROUTINES ========== #-H- ADDSET.RAT 289 1980 103 2153 INCLUDE MDEF # ADDSET - PUT C IN SET(J) IF IT FITS, INCREMENT J INTEGER FUNCTION ADDSET(C, SET, J, MAXSIZ) INTEGER J, MAXSIZ CHARACTER C, SET(ARB) IF (J > MAXSIZ) ADDSET = NO ELSE < SET(J) = C J = J + 1 ADDSET = YES ! RETURN END #-H- ADDSTR.RAT 352 1980 103 2153 INCLUDE MDEF # ADDSTR - ADD S TO STR(J) IF IT FITS, INCREMENT J INTEGER FUNCTION ADDSTR(S, STR, J, MAXSIZ) CHARACTER S(ARB), STR(ARB) INTEGER J, MAXSIZ INTEGER I, ADDSET FOR (I = 1; S(I) ^= EOS; I = I + 1) IF (ADDSET(S(I), STR, J, MAXSIZ) == NO) < ADDSTR = NO RETURN ! ADDSTR = YES RETURN END #-H- ALLDIG.RAT 318 1980 103 2153 INCLUDE RATDEF # ALLDIG - RETURN YES IF STR IS ALL DIGITS INTEGER FUNCTION ALLDIG(STR) CHARACTER TYPE CHARACTER STR(ARB) INTEGER I ALLDIG = NO IF (STR(1) == EOS) RETURN FOR (I = 1; STR(I) ^= EOS; I = I + 1) IF (TYPE(STR(I)) ^= DIGIT) RETURN ALLDIG = YES RETURN END #-H- AMATCH.RAT 1455 1980 103 2153 INCLUDE MDEF # AMATCH (NON-RECURSIVE) - LOOK FOR MATCH STARTING AT LIN(FROM) INTEGER FUNCTION AMATCH(LIN, FROM, PAT) CHARACTER LIN(MAXLINE), PAT(MAXPAT) INTEGER OMATCH, PATSIZ INTEGER FROM, I, J, K, OFFSET, STACK INCLUDE CSUBS STACK = 0 OFFSET = FROM # NEXT UNEXAMINED INPUT CHARACTER FOR (J = 1; J <= MAXSUBS; J = J + 1) <%# CLEAR PARTIAL MATCH RESULTS BPOS(J) = OFFSET EPOS(J) = OFFSET ! FOR (J = 1; PAT(J) ^= EOS; J = J + PATSIZ(PAT, J)) IF (PAT(J) == CLOSURE) < # A CLOSURE ENTRY STACK = J J = J + CLOSIZE # STEP OVER CLOSURE FOR (I = OFFSET; LIN(I) ^= EOS; ) # MATCH AS MANY AS IF (OMATCH(LIN, I, PAT, J) == NO) # POSSIBLE BREAK PAT(STACK+COUNT) = I - OFFSET PAT(STACK+START) = OFFSET OFFSET = I # CHARACTER THAT MADE US FAIL ! ELSE IF (OMATCH(LIN, OFFSET, PAT, J) == NO) < # NON-CLOSURE FOR ( ; STACK > 0; STACK = PAT(STACK+PREVCL)) IF (PAT(STACK+COUNT) > 0) BREAK IF (STACK <= 0) < # STACK IS EMPTY AMATCH = 0 # RETURN FAILURE RETURN ! PAT(STACK+COUNT) = PAT(STACK+COUNT) - 1 J = STACK + CLOSIZE OFFSET = PAT(STACK+START) + PAT(STACK+COUNT) ! # ELSE OMATCH SUCCEEDED EPOS(1) = OFFSET AMATCH = OFFSET RETURN # SUCCESS END #-H- CANT.RAT 187 1980 103 2153 INCLUDE RATDEF # CANT - PRINT CANT OPEN FILE MESSAGE AND DIE SUBROUTINE CANT(BUF) INTEGER BUF(MAXLINE) CALL PUTLIN(BUF, ERROUT) CALL REMARK(": CAN'T OPEN.") STOP END #-H- CATSUB.RAT 674 1980 103 2153 INCLUDE MDEF # CATSUB - ADD REPLACEMENT TEXT TO END OF NEW SUBROUTINE CATSUB(LIN, FROM, TO, SUB, NEW, K, MAXNEW) INTEGER ADDSET INTEGER FROM, I, J, JUNK, K, MAXNEW, TO CHARACTER LIN(MAXLINE), NEW(MAXNEW), SUB(MAXPAT) INCLUDE CSUBS FOR (I = 1; SUB(I) ^= EOS; I = I + 1) IF (SUB(I) == DITTO) FOR (J = FROM; J < TO; J = J + 1) JUNK = ADDSET(LIN(J), NEW, K, MAXNEW) ELSE IF (SUB(I) == DITTO1) < L = SUB(I+1) FOR (J = BPOS(L); J < EPOS(L); J = J + 1) JUNK = ADDSET(LIN(J), NEW, K, MAXNEW) I = I + 1 ! ELSE JUNK = ADDSET(SUB(I), NEW, K, MAXNEW) RETURN END #-H- COMPAR.RAT 130 1980 103 2153 # COMPAR - RETURN <0 IF X < Y, 0 IF X == Y, >0 IF X > Y INTEGER FUNCTION COMPAR(X, Y) INTEGER X, Y RETURN(X - Y) END #-H- CSUBS 144 1980 103 2153 COMMON /CSUBS/ BPOS(MAXSUBS), EPOS(MAXSUBS) INTEGER BPOS%%# BEGINNING OF PARTIAL MATCH INTEGER EPOS%%# END OF CORRESPONDING PARTIAL MATCH #-H- CTOF.RAT 1290 1980 103 2153 INCLUDE RATDEF # CTOF - CONVERT STRING AT IN(I) TO REAL, INCREMENT I REAL FUNCTION CTOF(IN, I) CHARACTER IN(ARB) INTEGER CTOI INTEGER I, A, E, S REAL TEN, FLOAT WHILE (IN(I) == BLANK \ IN(I) == TAB) I = I + 1 IF (IN(I) == MINUS \ IN(I) == PLUS) < S = IN(I) I = I + 1 ! ELSE S = NO E = 0 FOR (A = 0; IN(I) ^= EOS; I = I + 1) < # COLLECT INTEGER PORTION IF (IN(I) < DIG0 \ IN(I) > DIG9) # NON-DIGIT BREAK IF (A < LIMIT) A = 10*A + IN(I) - DIG0 ELSE E = E + 1 # JUST BUMP EXPONENT ! IF (IN(I) == PERIOD) FOR (I = I + 1; IN(I) ^= EOS; I = I + 1) < # COLLECT FRACTION IF (IN(I) < DIG0 \ IN(I) > DIG9) # NON-DIGIT BREAK IF (A < LIMIT) < A = 10*A + IN(I) - DIG0 E = E - 1 ! ! IF (IN(I) == LETE \ IN(I) == BIGE) < I = I + 1 # COLLECT EXPONENT E = E + CTOI(IN, I) ! IF (E < LIM2) CTOF = 0.0 ELSE IF (E > LIM1) CTOF = TEN(LIM1) ELSE < IF (S == MINUS) A = -A IF (E < 0) CTOF = FLOAT(A)/TEN(-E) ELSE IF (E > 0) CTOF = FLOAT(A)*TEN(E) ELSE CTOF = FLOAT(A) ! RETURN END #-H- CTOI.RAT 520 1980 103 2153 INCLUDE RATDEF # CTOI - CONVERT STRING AT IN(I) TO INTEGER, INCREMENT I INTEGER FUNCTION CTOI(IN, I) CHARACTER IN(ARB) INTEGER I, S WHILE (IN(I) == BLANK \ IN(I) == TAB) I = I + 1 IF (IN(I) == MINUS \ IN(I) == PLUS) < S = IN(I) I = I + 1 ! ELSE S = NO FOR (CTOI = 0; IN(I) ^= EOS; I = I + 1) < IF (IN(I) < DIG0 \ IN(I) > DIG9) # NON-DIGIT BREAK CTOI = 10 * CTOI + IN(I) - DIG0 ! IF (S == MINUS) CTOI = -CTOI RETURN END #-H- CTOO.RAT 391 1980 103 2153 INCLUDE RATDEF # CTOO - CONVERT STRING AT IN(I) TO OCTAL INTEGER, INCREMENT I INTEGER FUNCTION CTOO(IN, I) CHARACTER IN(ARB) INTEGER I, S WHILE (IN(I) == BLANK \ IN(I) == TAB) I = I + 1 FOR (CTOO = 0; IN(I) ^= EOS; I = I + 1) < IF (IN(I) < DIG0 \ IN(I) > DIG7) # NON OCTAL DIGIT BREAK CTOO = 8 * CTOO + IN(I) - DIG0 ! RETURN END #-H- DATE.RAT 179 1980 103 2153 INCLUDE RATDEF # DATE - RETURN DATE IN N AND AS FUNCTION VALUE INTEGER FUNCTION DATE(N) INTEGER N INTEGER JUNK CALL DATE4(N, JUNK, JUNK, JUNK) RETURN(N) END #-H- DODASH.RAT 371 1980 103 2153 INCLUDE MDEF # DODASH - EXPAND ARRAY(I-1)-ARRAY(I+1) INTO SET(J)... SUBROUTINE DODASH(ARRAY, I, SET, J, MAXSET) CHARACTER ESC INTEGER ADDSET INTEGER I, J, JUNK, K, LIM, MAXSET CHARACTER ARRAY(ARB), SET(ARB) I = I + 1 J = J - 1 LIM = ESC(ARRAY, I) FOR (K = SET(J); K <= LIM; K = K + 1) JUNK = ADDSET(K, SET, J, MAXSET) RETURN END #-H- DTOC.RAT 689 1980 103 2153 INCLUDE RATDEF # DTOC - CONVERT DATE, YEAR TO CHARACTER STRING A(1)...A(SIZE) INTEGER FUNCTION DTOC(DATE, YEAR, A, SIZE) INTEGER DATE, YEAR, SIZE CHARACTER A(ARB) INTEGER I, LENGTH, ITOC STRING MONTHS "JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC" A(1) = EOS IF (SIZE >= 4) <%# INSERT MONTH I = 3*(DATE/100 - 1) A(1) = MONTHS(I+1) A(2) = MONTHS(I+2) A(3) = MONTHS(I+3) A(4) = EOS ! IF (SIZE >= 7) <%# INSERT DAY A(4) = BLANK I = ITOC(MOD(DATE, 100), A(5), 3) + 5 ! IF (SIZE >= 13) <%# INSERT YEAR A(I) = COMMA A(I+1) = BLANK I = ITOC(YEAR, A(I+2), 5) ! DTOC = LENGTH(A) RETURN END #-H- EQUAL.RAT 319 1980 103 2153 INCLUDE RATDEF # EQUAL - COMPARE STR1 TO STR2; RETURN YES IF EQUAL, NO IF NOT INTEGER FUNCTION EQUAL(STR1, STR2) CHARACTER STR1(ARB), STR2(ARB) INTEGER I FOR (I = 1; STR1(I) == STR2(I); I = I + 1) IF (STR1(I) == EOS) < EQUAL = YES RETURN ! EQUAL = NO RETURN END #-H- ESC.RAT 794 1980 103 2153 INCLUDE MDEF # ESC - MAP ARRAY(I) INTO ESCAPED CHARACTER IF APPROPRIATE CHARACTER FUNCTION ESC(ARRAY, I) CHARACTER ARRAY(ARB) INTEGER I IF (ARRAY(I) ^= ESCAPE) ESC = ARRAY(I) ELSE IF (ARRAY(I+1) == EOS) # NOT SPECIAL AT END ESC = ESCAPE ELSE < I = I + 1 IF (ARRAY(I) == LETN \ ARRAY(I) == BIGN) ESC = NEWLINE ELSE IF (ARRAY(I) == LETT \ ARRAY(I) == BIGT) ESC = TAB ELSE IF (ARRAY(I) == LETB \ ARRAY(I) == BIGB) ESC = BACKSPACE ELSE IF (ARRAY(I) >= DIG0 & ARRAY(I) <= DIG7) < FOR (ESC = 0; ARRAY(I) >= DIG0 & ARRAY(I) <= DIG7; I = I + 1) ESC = 8*ESC + ARRAY(I) - DIG0 I = I - 1%# SO LIKE OTHER CASES ! ELSE ESC = ARRAY(I) ! RETURN END #-H- FCOPY.RAT 199 1980 103 2154 INCLUDE RATDEF # FCOPY - COPY FILE IN TO FILE OUT SUBROUTINE FCOPY(IN, OUT) CHARACTER C, GETCH INTEGER IN, OUT WHILE (GETCH(C, IN) ^= EOF) CALL PUTCH(C, OUT) RETURN END #-H- FILSET.RAT 644 1980 103 2154 INCLUDE MDEF # FILSET - EXPAND SET AT ARRAY(I) INTO SET(J), STOP AT DELIM SUBROUTINE FILSET(DELIM, ARRAY, I, SET, J, MAXSET) CHARACTER ESC INTEGER ADDSET INTEGER I, J, JUNK, MAXSET CHARACTER ARRAY(ARB), DELIM, SET(ARB) FOR ( ; ARRAY(I) ^= DELIM & ARRAY(I) ^= EOS; I = I + 1) IF (ARRAY(I) == ESCAPE) JUNK = ADDSET(ESC(ARRAY, I), SET, J, MAXSET) ELSE IF (ARRAY(I) ^= DASH) JUNK = ADDSET(ARRAY(I), SET, J, MAXSET) ELSE IF (J <= 1 \ ARRAY(I+1) == EOS) # LITERAL - JUNK = ADDSET(DASH, SET, J, MAXSET) ELSE CALL DODASH(ARRAY, I, SET, J, MAXSET) RETURN END #-H- FOLD.RAT 470 1980 103 2154 INCLUDE RATDEF # FOLD - CONVERT ALPHABETIC TOKEN TO SINGLE CASE SUBROUTINE FOLD(TOKEN) CHARACTER TOKEN(ARB) INTEGER I # WARNING - THIS ROUTINE DEPENDS HEAVILY ON THE # FACT THAT LETTERS HAVE BEEN MAPPED INTO INTERNAL # RIGHT-ADJUSTED ASCII. GOD HELP YOU IF YOU # HAVE SUBVERTED THIS MECHANISM. FOR (I = 1; TOKEN(I) ^= EOS; I = I + 1) IF (TOKEN(I) >= BIGA & TOKEN(I) <= BIGZ) TOKEN(I) = TOKEN(I) - BIGA + LETA RETURN END #-H- FSIZEC.RAT 357 1980 103 2154 INCLUDE RATDEF # FSIZEC - SIZE OF FILE IN CHARACTERS INTEGER FUNCTION FSIZEC(NAME) CHARACTER GETCH CHARACTER C, NAME(ARB) INTEGER OPEN INTEGER FD FD = OPEN(NAME, READ) IF (FD == ERR) FSIZEC = -1 ELSE < FOR (FSIZEC = 0; GETCH(C, FD) ^= EOF; FSIZEC = FSIZEC + 1) ; CALL CLOSE(FD) ! RETURN END #-H- FTOC.RAT 1485 1980 103 2154 INCLUDE RATDEF # FTOC - CONVERT REAL X TO STRING IN STR USING PRECISION P INTEGER FUNCTION FTOC(X, STR, P, SIZE) CHARACTER STR(ARB) REAL X INTEGER P, SIZE INTEGER I, J, N, ITOC, NDIGS, IFIX, IABS, MOD, EFLAG, E, LEN REAL XVAL, TEN, FLOAT, ALOG10 XVAL = X IF (XVAL < 0.0) XVAL = -XVAL LEN = SIZE IF (XVAL > 1.0E5 \ XVAL > 0.0 & XVAL < 1.0E-4 \ P < 0) < E = IFIX(ALOG10(XVAL))%%# FORCE E FORMAT IF (E > 0) XVAL = XVAL/TEN(E) ELSE XVAL = XVAL*TEN(-E) FOR ( ; XVAL < 1.0; E = E - 1) XVAL = 10.0*XVAL FOR ( ; XVAL > 10.0; E = E + 1) XVAL = 0.1*XVAL EFLAG = YES LEN = LEN - 4 # GUARANTEE ENOUGH SPACE ! ELSE EFLAG = NO NDIGS = IABS(P) IF (NDIGS > PRECISION) NDIGS = PRECISION ELSE IF (NDIGS < 1) NDIGS = 1 XVAL = XVAL + 0.5/TEN(NDIGS)%# ROUND IF (X < 0.0) < STR(1) = MINUS I = 2 ! ELSE I = 1 I = I + ITOC(IFIX(XVAL), STR(I), LEN) IF (P ^= 0) < STR(I) = PERIOD I = I + 1 N = IFIX(TEN(NDIGS)*(XVAL-FLOAT(IFIX(XVAL)))) FOR (J = I + NDIGS - 1; J >= I; J = J - 1) < # CONVERT FRACTION IF (J < LEN) STR(J) = MOD(N, 10) + DIG0 N = N/10 ! I = I + NDIGS ! IF (EFLAG == YES) < # NEED TO ADD EXPONENT STR(I) = LETE I = I + 1 + ITOC(E, STR(I+1), LEN-I-1) ! STR(I) = EOS FTOC = I - 1 RETURN END #-H- GETC.RAT 169 1980 103 2154 INCLUDE RATDEF # GETC - GET NEXT CHARACTER FROM STANDARD INPUT CHARACTER FUNCTION GETC(C) CHARACTER C, GETCH C = GETCH(C, STDIN) GETC = C RETURN END #-H- GETCCL.RAT 631 1980 103 2154 INCLUDE MDEF # GETCCL - EXPAND CHAR CLASS AT ARG(I) INTO PAT(J) INTEGER FUNCTION GETCCL(ARG, I, PAT, J) CHARACTER ARG(MAXARG), PAT(MAXPAT) INTEGER ADDSET INTEGER I, J, JSTART, JUNK I = I + 1 # SKIP OVER [ IF (ARG(I) == TILDE \ ARG(I) == CARET) < JUNK = ADDSET(NCCL, PAT, J, MAXPAT) I = I + 1 ! ELSE JUNK = ADDSET(CCL, PAT, J, MAXPAT) JSTART = J JUNK = ADDSET(0, PAT, J, MAXPAT) # LEAVE ROOM FOR COUNT CALL FILSET(CCLEND, ARG, I, PAT, J, MAXPAT) PAT(JSTART) = J - JSTART - 1 IF (ARG(I) == CCLEND) GETCCL = OK ELSE GETCCL = ERR RETURN END #-H- GETLIN.RAT 463 1980 103 2154 INCLUDE RATDEF # GETLIN - GET NEXT LINE FROM F INTO LINE INTEGER FUNCTION GETLIN(LINE, F) CHARACTER LINE(MAXLINE), C, GETCH INTEGER F FOR (GETLIN = 0; GETCH(C, F) ^= EOF; ) < IF (C == 0) BREAK IF (GETLIN < MAXLINE - 1) < GETLIN = GETLIN + 1 LINE(GETLIN) = C ! IF (C == NEWLINE) BREAK ! LINE(GETLIN+1) = EOS IF (GETLIN == 0 & C == EOF) GETLIN = EOF RETURN END #-H- GETPAT.RAT 202 1980 103 2154 INCLUDE MDEF # GETPAT - CONVERT ARGUMENT INTO PATTERN INTEGER FUNCTION GETPAT(ARG, PAT) INTEGER ARG(MAXARG), PAT(MAXPAT) INTEGER MAKPAT GETPAT = MAKPAT(ARG, 1, EOS, PAT) RETURN END #-H- GETSUB.RAT 208 1980 103 2154 INCLUDE MDEF # GETSUB - GET SUBSTITUTION PATTERN INTO SUB INTEGER FUNCTION GETSUB(ARG, SUB) CHARACTER ARG(MAXARG), SUB(MAXPAT) INTEGER MAKSUB GETSUB = MAKSUB(ARG, 1, EOS, SUB) RETURN END #-H- GETWRD.RAT 413 1980 103 2154 INCLUDE RATDEF # GETWRD - GET NON-BLANK WORD FROM IN(I) INTO OUT, INCREMENT I INTEGER FUNCTION GETWRD(IN, I, OUT) INTEGER IN(ARB), OUT(ARB) INTEGER I, J WHILE (IN(I) == BLANK \ IN(I) == TAB) I = I + 1 J = 1 WHILE (IN(I)^=EOS & IN(I)^=BLANK & IN(I)^=TAB & IN(I)^=NEWLINE) < OUT(J) = IN(I) I = I + 1 J = J + 1 ! OUT(J) = EOS GETWRD = J - 1 RETURN END #-H- INDEX.RAT 251 1980 103 2154 INCLUDE RATDEF # INDEX - FIND CHARACTER C IN STRING STR INTEGER FUNCTION INDEX(STR, C) CHARACTER C, STR(ARB) FOR (INDEX = 1; STR(INDEX) ^= EOS; INDEX = INDEX + 1) IF (STR(INDEX) == C) RETURN INDEX = 0 RETURN END #-H- INDEXS.RAT 393 1980 103 2154 INCLUDE RATDEF # INDEXS - FIND FIRST OCCURRENCE OF STR IN LIN INTEGER FUNCTION INDEXS(LIN, STR) CHARACTER LIN(ARB), STR(ARB) INTEGER J FOR (INDEXS = 1; LIN(INDEXS) ^= EOS; INDEXS = INDEXS + 1) < FOR (J = 1; STR(J) == LIN(J+INDEXS-1); J = J + 1) IF (STR(J) == EOS) RETURN IF (STR(J) == EOS) RETURN ! INDEXS = 0 RETURN END #-H- ITOC.RAT 675 1980 103 2154 INCLUDE RATDEF DEFINE(ABS,IABS) # ITOC - CONVERT INTEGER INT TO CHAR STRING IN STR INTEGER FUNCTION ITOC(INT, STR, SIZE) INTEGER ABS, MOD INTEGER I, INT, INTVAL, J, K, SIZE CHARACTER STR(ARB) INTVAL = ABS(INT) STR(1) = EOS I = 1 REPEAT < # GENERATE DIGITS I = I + 1 STR(I) = DIG0 + MOD(INTVAL,10) INTVAL = INTVAL / 10 ! UNTIL (INTVAL == 0 \ I >= SIZE) IF (INT < 0 & I < SIZE) < # THEN SIGN I = I + 1 STR(I) = MINUS ! ITOC = I - 1 FOR (J = 1; J < I; J = J + 1) < # THEN REVERSE K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 ! RETURN END #-H- LENGTH.RAT 194 1980 103 2154 INCLUDE RATDEF # LENGTH - COMPUTE LENGTH OF STRING INTEGER FUNCTION LENGTH(STR) INTEGER STR(ARB) FOR (LENGTH = 0; STR(LENGTH+1) ^= EOS; LENGTH = LENGTH + 1) ; RETURN END #-H- LOCATE.RAT 378 1980 103 2154 INCLUDE MDEF # LOCATE - LOOK FOR C IN CHAR CLASS AT PAT(OFFSET) INTEGER FUNCTION LOCATE(C, PAT, OFFSET) CHARACTER C, PAT(MAXPAT) INTEGER I, OFFSET # SIZE OF CLASS IS AT PAT(OFFSET), CHARACTERS FOLLOW FOR (I = OFFSET + PAT(OFFSET); I > OFFSET; I = I - 1) IF (C == PAT(I)) < LOCATE = YES RETURN ! LOCATE = NO RETURN END #-H- MAKPAT.RAT 2009 1980 103 2154 INCLUDE MDEF # MAKPAT - MAKE PATTERN FROM ARG(FROM), TERMINATE AT DELIM INTEGER FUNCTION MAKPAT(ARG, FROM, DELIM, PAT) CHARACTER ESC CHARACTER ARG(MAXARG), DELIM, PAT(MAXPAT) INTEGER ADDSET, GETCCL, STCLOS INTEGER FROM, I, J, JUNK, LASTCL, LASTJ, LJ, NSUBS, SP, SUBSTK(MAXSUBS) J = 1 # PAT INDEX LASTJ = 1 LASTCL = 0 NSUBS = 0%# COUNTS NUMBER OF @(@) PAIRS SP = 0%# STACK POINTER FOR SUBSTK FOR (I = FROM; ARG(I) ^= DELIM & ARG(I) ^= EOS; I = I + 1) < LJ = J IF (ARG(I) == ANY) JUNK = ADDSET(ANY, PAT, J, MAXPAT) ELSE IF (ARG(I) == BOL & I == FROM) JUNK = ADDSET(BOL, PAT, J, MAXPAT) ELSE IF (ARG(I) == EOL & ARG(I + 1) == DELIM) JUNK = ADDSET(EOL, PAT, J, MAXPAT) ELSE IF (ARG(I) == CCL) < IF (GETCCL(ARG, I, PAT, J) == ERR) BREAK ! ELSE IF (ARG(I) == CLOSURE & I > FROM) < LJ = LASTJ IF (PAT(LJ)==BOL \ PAT(LJ)==EOL \ PAT(LJ)==CLOSURE \ PAT(LJ-1) == BOSS \ PAT(LJ-1) == EOSS) BREAK LASTCL = STCLOS(PAT, J, LASTJ, LASTCL) ! ELSE IF (ARG(I) == ESCAPE & ARG(I+1) == LPAREN) < NSUBS = NSUBS + 1 IF (NSUBS >= MAXSUBS) BREAK JUNK = ADDSET(BOSS, PAT, J, MAXPAT) JUNK = ADDSET(NSUBS, PAT, J, MAXPAT) SP = SP + 1 SUBSTK(SP) = NSUBS I = I + 1 ! ELSE IF (ARG(I) == ESCAPE & ARG(I+1) == RPAREN) < IF (SP <= 0) BREAK JUNK = ADDSET(EOSS, PAT, J, MAXPAT) JUNK = ADDSET(SUBSTK(SP), PAT, J, MAXPAT) SP = SP - 1 I = I + 1 ! ELSE < JUNK = ADDSET(CHAR, PAT, J, MAXPAT) JUNK = ADDSET(ESC(ARG, I), PAT, J, MAXPAT) ! LASTJ = LJ ! IF (ARG(I) ^= DELIM \ SP ^= 0) # TERMINATED EARLY MAKPAT = ERR ELSE IF (ADDSET(EOS, PAT, J, MAXPAT) == NO) # NO ROOM MAKPAT = ERR ELSE MAKPAT = I RETURN END #-H- MAKSUB.RAT 834 1980 103 2154 INCLUDE MDEF # MAKSUB - MAKE SUBSTITUTION STRING IN SUB INTEGER FUNCTION MAKSUB(ARG, FROM, DELIM, SUB) CHARACTER ESC CHARACTER ARG(MAXARG), DELIM, SUB(MAXPAT) INTEGER ADDSET INTEGER FROM, I, J, JUNK J = 1 FOR (I = FROM; ARG(I) ^= DELIM & ARG(I) ^= EOS; I = I + 1) IF (ARG(I) == AND) JUNK = ADDSET(DITTO, SUB, J, MAXPAT) ELSE IF (ARG(I) == ESCAPE & (ARG(I+1) >= DIG0 & ARG(I+1) <= DIG9)) < K = ARG(I+1) - DIG0 JUNK = ADDSET(DITTO1, SUB, J, MAXPAT) JUNK = ADDSET(K + 1, SUB, J, MAXPAT) I = I + 1 ! ELSE JUNK = ADDSET(ESC(ARG, I), SUB, J, MAXPAT) IF (ARG(I) ^= DELIM) # MISSING DELIMITER MAKSUB = ERR ELSE IF (ADDSET(EOS, SUB, J, MAXPAT) == NO) # NO ROOM MAKSUB = ERR ELSE MAKSUB = I RETURN END #-H- MATCH.RAT 489 1980 103 2154 INCLUDE MDEF # MATCH - FIND MATCH ANYWHERE ON LINE INTEGER FUNCTION MATCH(LIN, PAT) CHARACTER LIN(MAXLINE), PAT(MAXPAT) INTEGER AMATCH INTEGER I IF (PAT(1) == BOL) <%%# ANCHORED MATCH IF (AMATCH(LIN, 1, PAT) > 0) < MATCH = YES RETURN ! ! ELSE%%# UNANCHORED FOR (I = 1; LIN(I) ^= EOS; I = I + 1) IF (AMATCH(LIN, I, PAT) > 0) < MATCH = YES RETURN ! MATCH = NO RETURN END #-H- MDEF 427 1980 103 2154 INCLUDE RATDEF DEFINE(MAXPAT,128) DEFINE(MAXARG,128) DEFINE(MAXSUBS,10) DEFINE(COUNT,1) DEFINE(PREVCL,2) DEFINE(START,3) DEFINE(CLOSIZE,4) DEFINE(BOL,PERCENT) DEFINE(ANY,QMARK) DEFINE(EOL,DOLLAR) DEFINE(CLOSURE,STAR) DEFINE(CCL,LBRACK) DEFINE(CCLEND,RBRACK) DEFINE(NCCL,LETN) DEFINE(CHAR,LETA) DEFINE(ESCAPE,ATSIGN) DEFINE(DASH,MINUS) DEFINE(BOSS,LBRACE)%# < DEFINE(EOSS,RBRACE)%# ! DEFINE(DITTO,(-3)) DEFINE(DITTO1,(-4)) #-H- OMATCH.RAT 1149 1980 103 2154 INCLUDE MDEF # OMATCH - TRY TO MATCH A SINGLE PATTERN AT PAT(J) INTEGER FUNCTION OMATCH(LIN, I, PAT, J) CHARACTER LIN(MAXLINE), PAT(MAXPAT) INTEGER LOCATE INTEGER BUMP, I, J INCLUDE CSUBS OMATCH = NO IF (LIN(I) == EOS) RETURN BUMP = -1 IF (PAT(J) == CHAR) < IF (LIN(I) == PAT(J + 1)) BUMP = 1 ! ELSE IF (PAT(J) == BOL) < IF (I == 1) BUMP = 0 ! ELSE IF (PAT(J) == ANY) < IF (LIN(I) ^= NEWLINE) BUMP = 1 ! ELSE IF (PAT(J) == EOL) < IF (LIN(I) == NEWLINE \ LIN(I) == EOS) BUMP = 0 ! ELSE IF (PAT(J) == CCL) < IF (LOCATE(LIN(I), PAT, J + 1) == YES) BUMP = 1 ! ELSE IF (PAT(J) == NCCL) < IF (LIN(I) ^= NEWLINE & LOCATE(LIN(I), PAT, J + 1) == NO) BUMP = 1 ! ELSE IF (PAT(J) == BOSS) < K = PAT(J+1) BPOS(K+1) = I BUMP = 0 ! ELSE IF (PAT(J) == EOSS) < K = PAT(J+1) EPOS(K+1) = I BUMP = 0 ! ELSE CALL ERROR("IN OMATCH: CAN'T HAPPEN.") IF (BUMP >= 0) < I = I + BUMP OMATCH = YES ! RETURN END #-H- PATSIZ.RAT 504 1980 103 2154 INCLUDE MDEF # PATSIZ - RETURNS SIZE OF PATTERN ENTRY AT PAT(N) INTEGER FUNCTION PATSIZ(PAT, N) CHARACTER PAT(MAXPAT) INTEGER N IF (PAT(N) == CHAR \ PAT(N) == BOSS \ PAT(N) == EOSS) PATSIZ = 2 ELSE IF (PAT(N) == BOL \ PAT(N) == EOL \ PAT(N) == ANY) PATSIZ = 1 ELSE IF (PAT(N) == CCL \ PAT(N) == NCCL) PATSIZ = PAT(N + 1) + 2 ELSE IF (PAT(N) == CLOSURE) # OPTIONAL PATSIZ = CLOSIZE ELSE CALL ERROR("IN PATSIZ: CAN'T HAPPEN.") RETURN END #-H- PUTC.RAT 145 1980 103 2154 INCLUDE RATDEF # PUTC - PUT CHARACTER C TO STANDARD OUTPUT FILE SUBROUTINE PUTC(C) INTEGER C CALL PUTCH(C, STDOUT) RETURN END #-H- PUTDEC.RAT 172 1980 103 2154 INCLUDE RATDEF # PUTDEC - PUT DECIMAL INTEGER N IN FIELD WIDTH >= W TO STDOUT SUBROUTINE PUTDEC(N, W) INTEGER N, W CALL PUTINT(N, W, STDOUT) RETURN END #-H- PUTINT.RAT 272 1980 103 2154 INCLUDE RATDEF # PUTINT - WRITE DECIMAL INTEGER N IN FIELD WIDTH >= W TO F SUBROUTINE PUTINT(N, W, F) INTEGER N, W, F CHARACTER CHARS(MAXCHARS) INTEGER ITOC INTEGER JUNK JUNK = ITOC(N, CHARS, MAXCHARS) CALL PUTSTR(CHARS, W, F) RETURN END #-H- PUTLIN.RAT 220 1980 103 2154 INCLUDE RATDEF # PUTLIN - WRITE STRING LINE TO FILE F SUBROUTINE PUTLIN(LINE, F) CHARACTER LINE(MAXLINE) INTEGER F, I FOR (I = 1; LINE(I) ^= EOS; I = I + 1) CALL PUTCH(LINE(I), F) RETURN END #-H- PUTSTR.RAT 446 1980 103 2154 INCLUDE RATDEF # PUTSTR - WRITE STRING STR TO FILE F IN FIELD WIDTH >= W SUBROUTINE PUTSTR(STR, W, F) CHARACTER STR(MAXLINE) INTEGER W, F, LEN, I, LENGTH LEN = LENGTH(STR) FOR (I = LEN; I < W; I = I + 1)%# OUTPUT LEFT PADDING CALL PUTCH(BLANK, F) FOR (I = 1; STR(I) ^= EOS; I = I + 1) CALL PUTCH(STR(I), F) FOR (I = LEN; I < -W; I = I + 1)%# OUTPUT RIGHT PADDING CALL PUTCH(BLANK, F) RETURN END #-H- QSORT.RAT 1421 1980 103 2154 INCLUDE RATDEF # QSORT - SORTS A INTO ASCENDING ORDER; COMPARISONS ARE DONE BY COMPAR # COMPAR(X,Y) MUST RETURN <0 IF X < Y, 0 IF X == Y, AND >0 IF X > Y. SUBROUTINE QSORT(N, A, COMPAR) INTEGER N, A(ARB) EXTERNAL COMPAR INTEGER COMPAR INTEGER I, J, LV(20), P, PIVOT, UV(20), T LV(1) = 1 UV(1) = N P = 1 WHILE (P > 0) IF (LV(P) >= UV(P)) # ONLY ONE ELEMENT IN THIS SUBSET P = P - 1 # POP STACK ELSE < I = LV(P) - 1 J = UV(P) PIVOT = A(J) # PIVOT ELEMENT WHILE (I < J) < FOR (I=I+1; COMPAR(A(I), PIVOT) < 0; I=I+1) ; FOR (J = J - 1; J > I; J = J - 1) IF (COMPAR(A(J), PIVOT) <= 0) BREAK IF (I < J) < # OUT OF ORDER PAIR T = A(I)%%# EXCHANGE A(I) AND A(J) A(I) = A(J) A(J) = T ! ! J = UV(P) # MOVE PIVOT TO POSITION I T = A(I)%# EXCHANGE A(I) AND A(J) A(I) = A(J) A(J) = T IF (I-LV(P) < UV(P)-I) < # STACK SO SHORTER DONE FIRST LV(P+1) = LV(P) UV(P+1) = I - 1 LV(P) = I + 1 ! ELSE < LV(P+1) = I + 1 UV(P+1) = UV(P) UV(P) = I - 1 ! P = P + 1 # PUSH ONTO STACK ! RETURN END #-H- RATDEF 2690 1980 103 2154 #========== STANDARD RATFOR DEFINITIONS ========== DEFINE(ACCENT,96) DEFINE(ALPHA,10100) DEFINE(AND,38) DEFINE(ANDIF,IF) DEFINE(ARB,100) DEFINE(ATSIGN,64) DEFINE(BACKSLASH,92) DEFINE(BACKSPACE,8) DEFINE(BANG,33) DEFINE(BAR,124) DEFINE(BIGA,65) DEFINE(BIGB,66) DEFINE(BIGC,67) DEFINE(BIGD,68) DEFINE(BIGE,69) DEFINE(BIGF,70) DEFINE(BIGG,71) DEFINE(BIGH,72) DEFINE(BIGI,73) DEFINE(BIGJ,74) DEFINE(BIGK,75) DEFINE(BIGL,76) DEFINE(BIGM,77) DEFINE(BIGN,78) DEFINE(BIGO,79) DEFINE(BIGP,80) DEFINE(BIGQ,81) DEFINE(BIGR,82) DEFINE(BIGS,83) DEFINE(BIGT,84) DEFINE(BIGU,85) DEFINE(BIGV,86) DEFINE(BIGW,87) DEFINE(BIGX,88) DEFINE(BIGY,89) DEFINE(BIGZ,90) DEFINE(BLANK,32) DEFINE(CARET,94) DEFINE(COLON,58) DEFINE(COMMA,44) DEFINE(DIG0,48) DEFINE(DIG1,49) DEFINE(DIG2,50) DEFINE(DIG3,51) DEFINE(DIG4,52) DEFINE(DIG5,53) DEFINE(DIG6,54) DEFINE(DIG7,55) DEFINE(DIG8,56) DEFINE(DIG9,57) DEFINE(DIGIT,2) DEFINE(DOLLAR,36) DEFINE(DQUOTE,34) DEFINE(EOF,10003) DEFINE(EOS,10002) DEFINE(EQUALS,61) DEFINE(ERR,10001) DEFINE(ERROUT,2) DEFINE(GREATER,62) DEFINE(HUGE,30000) DEFINE(LBRACE,123) DEFINE(LBRACK,91) DEFINE(LESS,60) DEFINE(LETA,97) DEFINE(LETB,98) DEFINE(LETC,99) DEFINE(LETD,100) DEFINE(LETE,101) DEFINE(LETF,102) DEFINE(LETG,103) DEFINE(LETH,104) DEFINE(LETI,105) DEFINE(LETJ,106) DEFINE(LETK,107) DEFINE(LETL,108) DEFINE(LETM,109) DEFINE(LETN,110) DEFINE(LETO,111) DEFINE(LETP,112) DEFINE(LETQ,113) DEFINE(LETR,114) DEFINE(LETS,115) DEFINE(LETT,116) DEFINE(LETTER,1) DEFINE(LETU,117) DEFINE(LETV,118) DEFINE(LETW,119) DEFINE(LETX,120) DEFINE(LETY,121) DEFINE(LETZ,122) DEFINE(LPAREN,40) DEFINE(MAXCHARS,20) DEFINE(MAXLINE,120)%# TYPICAL LINE LENGTH DEFINE(MAXNAME,30) %# TYPICAL FILE NAME SIZE DEFINE(MINUS,45) DEFINE(NEWLINE,10) DEFINE(NO,0) DEFINE(NOERR,0) DEFINE(NOT,126) # SAME AS TILDE DEFINE(OK,-2) DEFINE(OR,BAR) # SAME AS BAR DEFINE(PERCENT,37) DEFINE(PERIOD,46) DEFINE(PLUS,43) DEFINE(QMARK,63) DEFINE(RBRACE,125) DEFINE(RBRACK,93) DEFINE(READ,0) DEFINE(READWRITE,2) DEFINE(RPAREN,41) DEFINE(SEMICOL,59) DEFINE(SHARP,35) DEFINE(SLASH,47) DEFINE(SQUOTE,39) DEFINE(STAR,42) DEFINE(STDIN,0) DEFINE(STDOUT,1) DEFINE(STDERR,ERROUT) DEFINE(TAB,9) DEFINE(TILDE,126) DEFINE(UNDERLINE,95) DEFINE(WRITE,1) DEFINE(YES,1) DEFINE(ESCAPE,ATSIGN) DEFINE(CHARACTER,INTEGER) DEFINE(ABS,IABS) DEFINE(MIN,MIN0) DEFINE(MAX,MAX0) # HANDY MACHINE-DEPENDENT PARAMETERS, CHANGE FOR A NEW MACHINE DEFINE(BPI,36)%%# BITS PER INTEGER DEFINE(BPC,7)%%# BITS PER CHARACTER DEFINE(CPI,5)%%# CHARACTERS PER INTEGER DEFINE(LIMIT,134217728)%# LARGEST POSITIVE INTEGER DEFINE(LIM1,28)%%# MAXIMUM EXPONENT (POWER OF TEN) DEFINE(LIM2,-28)%# MINIMUM EXPONENT (POWER OF TEN) DEFINE(PRECISION,7)%# DIGITS ACCURATE IN REAL #-H- SCOPY.RAT 293 1980 103 2154 INCLUDE RATDEF # SCOPY - COPY STRING AT FROM(I) TO TO(J) SUBROUTINE SCOPY(FROM, I, TO, J) CHARACTER FROM(ARB), TO(ARB) INTEGER I, J, K1, K2 K2 = J FOR (K1 = I; FROM(K1) ^= EOS; K1 = K1 + 1) < TO(K2) = FROM(K1) K2 = K2 + 1 ! TO(K2) = EOS RETURN END #-H- SECS.RAT 182 1980 103 2154 INCLUDE RATDEF # SECS - RETURN SECONDS IN N AND AS FUNCTION VALUE INTEGER FUNCTION SECS(N) INTEGER N INTEGER JUNK CALL DATE4(JUNK, JUNK, JUNK, N) RETURN(N) END #-H- SKIPBL.RAT 219 1980 103 2154 INCLUDE RATDEF # SKIPBL - SKIP BLANKS AND TABS AT LIN(I)... AND INCREMENT I SUBROUTINE SKIPBL(LIN, I) CHARACTER LIN(ARB) INTEGER I WHILE (LIN(I) == BLANK \ LIN(I) == TAB) I = I + 1 RETURN END #-H- STCLOS.RAT 619 1980 103 2154 INCLUDE MDEF # STCLOS - INSERT CLOSURE ENTRY AT PAT(J) INTEGER FUNCTION STCLOS(PAT, J, LASTJ, LASTCL) CHARACTER PAT(MAXPAT) INTEGER ADDSET INTEGER J, JP, JT, JUNK, LASTCL, LASTJ FOR (JP = J - 1; JP >= LASTJ; JP = JP - 1) < # MAKE A HOLE JT = JP + CLOSIZE JUNK = ADDSET(PAT(JP), PAT, JT, MAXPAT) ! J = J + CLOSIZE STCLOS = LASTJ JUNK = ADDSET(CLOSURE, PAT, LASTJ, MAXPAT) # PUT CLOSURE IN IT JUNK = ADDSET(0, PAT, LASTJ, MAXPAT) # COUNT JUNK = ADDSET(LASTCL, PAT, LASTJ, MAXPAT) # PREVCL JUNK = ADDSET(0, PAT, LASTJ, MAXPAT) # START RETURN END #-H- STRCAT.RAT 362 1980 103 2154 INCLUDE RATDEF # STRCAT - APPEND COPY OF STR1 ONTO THE END OF STR2 SUBROUTINE STRCAT(STR1, STR2) CHARACTER STR1(ARB), STR2(ARB) INTEGER I, J FOR (J = 1; STR2(J) ^= EOS; J = J + 1)%%# FIND END OF STR2 ; FOR (I = 1; STR1(I) ^= EOS; I = I + 1) <%# APPEND STR1 STR2(J) = STR1(I) J = J + 1 ! STR2(J) = EOS RETURN END #-H- STRCMP.RAT 498 1980 103 2154 INCLUDE RATDEF # STRCMP - RETURN <0 IF STR1 < STR2, 0 IF STR1 == STR2, >0 IF STR1 > STR2 INTEGER FUNCTION STRCMP(STR1, STR2) CHARACTER STR1(ARB), STR2(ARB) INTEGER I FOR (I = 1; STR1(I) == STR2(I); I = I + 1) IF (STR1(I) == EOS) < STRCMP = 0 RETURN ! IF (STR1(I) == EOS)%%# STR1 IS SHORTEST STRCMP = -1 ELSE IF (STR2(I) == EOS)%# STR2 IS SHORTEST STRCMP = +1 ELSE%%%%# NOT EQUAL STRCMP = STR1(I) - STR2(I) RETURN END #-H- STRCPY.RAT 226 1980 103 2154 INCLUDE RATDEF # STRCPY - COPY STR1 TO STR2 SUBROUTINE STRCPY(STR1, STR2) CHARACTER STR1(ARB), STR2(ARB) INTEGER I FOR (I = 1; STR1(I) ^= EOS; I = I + 1) STR2(I) = STR1(I) STR2(I) = EOS RETURN END #-H- TEN.RAT 376 1980 103 2154 INCLUDE RATDEF # TEN - RETURN 10^N FOR 0 <= N <= LIM1 REAL FUNCTION TEN(N) INTEGER N, M, I, MOD REAL TENS(9) DATA TENS /1.0E1, 1.0E2, 1.0E4, 1.0E8, 1.0E16, % 1.0E32, 1.0E64, 1.0E128, 1.0E256/ M = N I = 0 TEN = 1.0 REPEAT < IF (MOD(M, 2) == 1) TEN = TEN*TENS(I+1) M = M/2 I = I + 1 ! UNTIL (M == 0) RETURN END #-H- TIME.RAT 179 1980 103 2154 INCLUDE RATDEF # TIME - RETURN TIME IN N AND AS FUNCTION VALUE INTEGER FUNCTION TIME(N) INTEGER N INTEGER JUNK CALL DATE4(JUNK, JUNK, N, JUNK) RETURN(N) END #-H- TTOC.RAT 721 1980 103 2154 INCLUDE RATDEF # TTOC - CONVERT TIME TO CHARACTER STRING A(1)...A(SIZE) INTEGER FUNCTION TTOC(TIME, A, SIZE) INTEGER TIME, SIZE CHARACTER A(ARB) INTEGER I, J, ITOC A(1) = EOS IF (SIZE < 9) <%# TOO SHORT TTOC = 0 RETURN ! J = TIME/100 # GET THE HOUR IF (J == 12 \ J == 0) I = ITOC(12, A, 3) + 1 ELSE IF (J > 12) I = ITOC(J - 12, A, 3) + 1 ELSE I = ITOC(J, A, 3) + 1 A(I) = COLON I = I + 1 IF (MOD(TIME, 100) < 10) < A(I) = DIG0 I = I + 1 ! I = I + ITOC(MOD(TIME, 100), A(I), 3) A(I) = BLANK IF (J < 12) A(I+1) = LETA ELSE A(I+1) = LETP A(I+2) = LETM A(I+3) = EOS TTOC = I + 2 RETURN END #-H- TYPE.RAT 295 1980 103 2154 INCLUDE RATDEF # TYPE - RETURN TYPE OF CHARACTER C INTEGER FUNCTION TYPE(C) CHARACTER C IF (C >= BIGA & C <= BIGZ) TYPE = LETTER ELSE IF (C >= LETA & C <= LETZ) TYPE = LETTER ELSE IF (C >= DIG0 & C <= DIG9) TYPE = DIGIT ELSE TYPE = C RETURN END #-H- XTOC.RAT 751 1980 103 2154 INCLUDE RATDEF DEFINE(ABS,IABS) # XTOC - CONVERT INTEGER INT TO CHAR STRING IN STR IN BASE B INTEGER FUNCTION XTOC(INT, STR, SIZE, B) INTEGER ABS, MOD INTEGER I, INT, INTVAL, J, K, SIZE, B CHARACTER STR(ARB) INTVAL = ABS(INT) STR(1) = EOS I = 1 REPEAT < # GENERATE DIGITS I = I + 1 STR(I) = DIG0 + MOD(INTVAL, B) IF (B > 10) STR(I) = STR(I) + LETA - DIG9 - 1 INTVAL = INTVAL / B ! UNTIL (INTVAL == 0 \ I >= SIZE) IF (INT < 0 & I < SIZE) < # THEN SIGN I = I + 1 STR(I) = MINUS ! XTOC = I - 1 FOR (J = 1; J < I; J = J + 1) < # THEN REVERSE K = STR(I) STR(I) = STR(J) STR(J) = K I = I - 1 ! RETURN END #-H- YEAR.RAT 179 1980 103 2154 INCLUDE RATDEF # YEAR - RETURN YEAR IN N AND AS FUNCTION VALUE INTEGER FUNCTION YEAR(N) INTEGER N INTEGER JUNK CALL DATE4(JUNK, N, JUNK, JUNK) RETURN(N) END #========== END OF TAPE ==========