Columbia Kermit

home *** CD-ROM | disk | FTP | other *** search

/ Columbia Kermit / kermit.zip / cdccyber / cdcazl.asm < prev next >

Wrap

Assembly Source File | 2020-01-01 | 64KB | 1,894 lines

*comdeck cdkcbtz convert blanks to zeroes in a word. btz ctext cdkcbtz - convert blanks to zeroes in a word. btz space 4,10 if -def,qual$,1 qual cdkcbtz base d btz space 4,10 *** btz - convert blanks to zeroes in a word. * * g. m. townsend. 83/08/22. code based on *comcztb*. * * btz converts all blanks in a word to 00 characters. btz space 4,10 *** btz converts all blanks in a word to 00 characters. * * entry (x1) = word to be converted. * (b1) = 1. * * exit (x6) = converted word. * (x7) = final character mask. * * uses x - 3, 6, 7. * b - none. * a - 3. * * calls none. btz> subr entry/exit sa3 btza bx7 x1-x3 convert blanks to 00, others to misc sa3 a3+b1 bx6 x3*x7 remove upper bit from all characters bx7 -x3*x7 isolate upper bits ix6 x6+x3 any non-zero character produces carry bx6 x6+x7 merge upper bits and carries bx7 -x3*x6 all non-zero characters = 40b bx6 x7 lx7 -5 ix7 x6-x7 bx7 x6+x7 now have mask bx6 x7*x1 clear spaces from original word eq btz> and return btza con 10h con 37373737373737373737b btz space 4,10 base * qual$ if -def,qual$ qual * btz> equ /cdkcbtz/btz> qual$ endif btz endx *comdeck cdkcmfs move fortran string. mfs ctext cdkcmfs - move fortran string. mfs space 4,10 if -def,qual$,1 qual cdkcmfs base d mfs space 4,10 *** mfs - move fortran string. * * g. m. townsend. 83/05/31. * * mfs moves a (possibly unaligned) ftn5 character string * into a word-aligned buffer. mfs space 4,10 *** mfs moves a ftn5 character string into a buffer. this is * particularly useful for subroutines which need their data * word-aligned. if the string is too long for the buffer, it * is truncated; if too short, it is padded with zeroes. * * mfs also works for ftn4 or ftn5 hollerith strings (characters * stored in variables of other types); since such strings * have no associated length they will be copied until the * buffer is filled. * * strings must be in cm (not ecs/lcm) and must not exceed * 777777b characters in length. * * entry (x1) = aplist entry specifying string in cm * (see ftn5 reference manual) or address * of hollerith string. * (b1) = 1. * (b6) = fwa of output buffer. * (b7) = size of output buffer, in words. * * exit (b6) = lwa+1 of buffer. * * uses x - 1, 2, 6, 7. * b - 3, 4, 5, 6, 7. * a - 2, 6. * * calls none. mfs> subr entry/exit sa2 x1 (a2/x2) = current input word mx7 -6 (x7) = one-character mask ax1 24 bx6 -x1+x7 -(beginning char position) ax1 6 sb3 x1 (b3) = number of chars left (0 = unknown). sb4 x6+10 (b4) = number of chars left in x2 ix1 x6+x6 -2 * bcp ix1 x6+x1 -3 * bcp lx1 1 -6 * bcp (0 to -54) sb5 x1 ax2 b5 position x2 to first input character mx6 0 (x6) = output word in progress sb5 54 (b5) = shift count for stuffing output nz b3,mfs2 if input char count provided sb3 -1 no, use huge count eq mfs2 join main loop mfs1 sa2 a2+1 get next input word sb4 10 indicate 10 chars available mfs2 zr b3,mfs4 if input string exhausted zr b4,mfs1 if need to load new input word mfs3 lx2 6 no, position to next character sb3 b3-b1 count character from string bx1 -x7*x2 isolate it sb4 b4-b1 count character from x2 lx1 b5 position it sb5 b5-6 adjust shift count for next time bx6 x6+x1 add into output word pl b5,mfs2 if output word not full sa6 b6 yes, save output word sb7 b7-b1 count it sb6 b6+b1 bump store address sb5 54 reset shift count mx6 0 clear output word gt b7,mfs2 if output buffer not full eq mfs> if full, return mfs4 mx2 0 use zeroes for remaining characters sb4 b0 indicate huge number left eq mfs3 rejoin loop mfs space 4,10 base * qual$ if -def,qual$ qual * mfs> equ /cdkcmfs/mfs> qual$ endif mfs endx *comdeck cdkcmvc move characters. mvc ctext cdkcmvc - cm string move. mvc space 4,10 if -def,qual$,1 qual cdkcmvc base d mvc space 4,10 *** mvc - move character string. * * r. o. anderson, * w. r. sears 75/05/21. * * r. o. anderson. 80/07/03. handle char offsets .gt. 9. * * mvc moves character strings. mvc space 4,10 *** mvc moves strings from one location to another on what * appears to be a character by character basis. mvc does not * change characters in the destination area that lie beyond the * space covered by the string that was moved. * * entry (a1) = source address. * (a2) = destination address. * (b1) = 1. * (b2) = source character offset (0 to 131071). * (b3) = destination character offset (0 to 131071). * (b4) = number of characters to move (0 to 131071). * * exit string moved. * * uses x - 1, 2, 3, 4, 5, 6, 7. * b - 2, 3, 4, 5. * a - 1, 2, 3, 4, 6, 7. mvc.csiz equ 6 bits per character mvc.cpw equ 60/mvc.csiz characters per word mvc4 bx7 x2 set up sa2 a2-b1 for first bx6 x2 iteration sa6 a2 of loop mvc5 bx5 -x3*x1 -123456789 bx2 x4*x7 abc------- sa1 a1+b1 klmnopqrst bx7 x3*x1 k--------- bx7 x5+x7 k123456789 lx7 b2,x7 89k1234567 bx6 -x4*x7 ---1234567 bx6 x6+x2 abc1234567 sb4 b4-mvc.cpw decrement characters left le b4,mvc6 if done sa6 a6+b1 store this word eq mvc5 loop till done mvc6 sa2 mvca+mvc.cpw-1+b4 get proper edit mask sb3 b3-60 set up right circular shift of mask lx2 -b3,x2 ---******- bx1 x4+x2 *********- bx3 x4*x2 ---------- bx7 x4*x7 890------- sa2 a6+b1 abcdefghij sa4 a2+b1 klmnopqrst bx2 -x1*x2 ---------j bx4 -x3*x4 klmnopqrst bx6 x1*x6 abc123456- bx7 x3*x7 --------- bx6 x6+x2 abc123456j bx7 x7+x4 klmnopqrst sa6 a2 update sa7 a4 last words mvc> subr entry/exit le b4,mvc> quit if nothing to do sx6 mvc.csiz x6 = bits per character mvc0 sb2 b2-10 compute source word address mi b2,mvc0a if word address ok sa1 a1+b1 advance 1 word eq mvc0 mvc0a sb2 b2+10 compute corrected source offset mx5 1 for mask generation sb5 b2 save source offset for later mvc0b sb3 b3-10 compute destination word address mi b3,mvc0c if word address ok sa2 a2+b1 advance 1 word eq mvc0b mvc0c sb3 b3+10 compute corrected destination offset sx7 b2 convert ix7 x7*x6 source offset sb2 x7 to bits sx7 b3 convert ix7 x7*x6 destination offset sb3 x7 to bits ax3 x5,b2 build source and ax4 x5,b3 destination masks lx5 b1,x3 compensate bx3 x5*x3 for lx5 b1,x4 extra bx4 x5*x4 bit sx6 a1 get fwa of source area sb2 b2-b3 b2 is offset difference pl b2,mvc1 skip if positive sb2 b2+60 else make it positive mvc1 sx7 a2 get destination fwa ix5 x6-x7 see if fwa source .ge. fwa dest. pl x5,mvc4 if so sx5 b5+b4 get character offset of lwa source sx7 mvc.cpw compute mx6 -1 characters per word ix6 x6+x7 minus one ix5 x5+x6 x5 = offset + rounding value * ix7 x5/x7,b5 word offset of lwa + 1 source ix7 x5/x7 word offset of lwa + 1 source sx6 a1 compute lwa + 1 ix5 x6+x7 of source sx6 a2 see if lwa + 1 source ix6 x6-x5 .le. fwa destination pl x6,mvc4 if so sa1 x5-1 a1 = lwa source sx6 a2 compute ix5 x6+x7 lwa + 1 destination sa2 x5-1 a2 = lwa destination sx7 mvc.cpw compute sx6 b4 remainder of px6 x6,b0 integer divide px7 x7,b0 nx7 x7,b0 fx5 x6/x7 ux6,b5 x6 restore registers lx6 x6,b5 ux7,b5 x7 lx7 x7,b5 ux5,b5 x5 lx5 x5,b5 ix5 x5*x7 number of characters / chars per word ix5 x6-x5 then get ix5 x5-x7 index into mask table sb5 mvca+mvc.cpw-1+x5 b5 = pointer to mask bx6 x3 save sa6 mvcb both bx7 x4 masks sa7 a6+b1 for later lx6 x1,b2 ^!+"*/[]() bx5 x4*x6 ^!+------- bx6 x3*x1 +--------- sa1 a1-b1 0123456789 bx1 -x3*x1 -123456789 bx6 x6+x1 +123456789 lx7 x6,b2 89+1234567 bx6 x4*x7 89+------- sa1 a1+b1 +"*/[]()^! lx1 x1,b2 ^!+"*/[]() bx1 -x4*x1 ---"*/[]() bx6 x6+x1 89+"*/[]() sa3 b5 get the edit mask sb5 b3-60 get mask rotation value lx3 -b5,x3 **-******* bx1 x4+x3 ********** bx3 x4*x3 **-------- sa4 a2+b1 %%%%%%%%%% bx4 -x3*x4 --%%%%%%%% bx5 x3*x5 ^!-------- bx5 x5+x4 ^!%%%%%%%% bx2 -x1*x2 ---------- bx4 x1*x6 89+"*/[]() bx6 x5 ^!%%%%%%%% sa6 a4 update last word in dest. area bx6 x4+x2 89+"*/[]() sa6 a2 update the next to last word cx1 x1 see cx3 x3 how many ix3 x3+x1 characters sx1 mvc.csiz were * ix3 x3/x1,b5 used ix3 x3/x1 used sb5 x3 and decrement sb4 b4-b5 the total le b4,mvc> if done sa1 a1-b1 0123456789 sa3 mvcb recover sa4 a3+b1 masks mvc2 bx5 x3*x1 0--------- bx2 -x4*x7 ---1234567 sa1 a1-b1 abcdefghij bx7 -x3*x1 -bcdefghij bx7 x7+x5 0bcdefghij lx7 b2,x7 ij0bcdefgh bx6 x4*x7 ij0------- bx6 x6+x2 ij01234567 sb4 b4-mvc.cpw decrement characters left le b4,mvc3 if done sa6 a6-b1 store this word eq mvc2 loop till done mvc3 bx6 -x4*x6 ---bcdefgh sa1 a6-b1 klmnopqrst bx1 x4*x1 klm------- bx6 x1+x6 klmbcdefgh sa6 a1 store last word eq mvc> return mvca vfd mvc.csiz/-0,*p/0 mask table .mvcif ifgt mvc.cpw,2 .mvcset set mvc.csiz .mvc1up dup mvc.cpw-2 .mvcset set .mvcset+mvc.csiz vfd .mvcset/-0,*p/0 .mvc1up endd .mvcif endif data -0 mvcb bss 2 to save masks mvc space 4,10 base * qual$ if -def,qual$ qual * mvc> equ /cdkcmvc/mvc> qual$ endif mvc endx *comdeck cdkcscs select character set. scs ctext cdkcscs - select character set. scs space 4,10 if -def,qual$,1 qual cdkcscs base d scs space 4,10 *** scs - select character set. * * g. m. townsend. 81/02/17. * * scs determines the character set of a file by inspecting the * first buffer full of data. scs space 4,10 *** scs looks at a portion of a file to determine whether it is * display code or 7-in-12 ascii. it does this by seeing if * there are zero bits where they should be for an ascii file; * if not, the file is assumed to be in display code. the * algorithm is not foolproof -- it can falsely diagnose a file * as ascii if it contains only the display code characters * a, 5, and 6 (also *:* in 64-character set) in odd-numbered * columns. despite this, the method works well in practice. * * scs looks at all the data in a circular buffer, as indicated * by the fet. the caller should first issue a read, then call * scs. * * entry (x2) = fet address. * (b1) = 1. * * exit (x6) = 1 if display code. * (x6) = 0 if buffer is empty. * (x6) = -1 if nos 812 ascii. * (x6) = -2 if ut 812 ascii. * * uses x - 1, 3, 6. * b - 2, 3, 4, 5. * a - 1, 3. scs> subr entry/exit recall x2 wait for read to finish sa1 x2+b1 sb2 x1 (b2) = first sa1 a1+b1 sb3 x1 (b3) = in sa1 a1+b1 sb4 x1 (b4) = out sa1 a1+b1 sb5 x1 (b5) = limit sx6 b0 eq b3,b4,scs> if empty buffer, return sa3 scsa (x3) = mask sx6 b1 assume display code scs1 sa1 b4 fetch word bx1 -x3*x1 zr x1,scs2 if ok ascii so far, check more sa1 b4 check against ut 812 ascii sa3 scsb bx1 -x3*x1 nz x1,scs> if display code, return scs2 sb4 b4+b1 bump pointer eq b4,b3,scs3 if no more in buffer lt b4,b5,scs1 if not yet to limit sb4 b2 go back to first ne b4,b3,scs1 if more to check scs3 sx6 -b1 indicate ascii sa1 scsa bx1 x1-x3 zr x1,scs> if nos 812 ascii sx6 -2 indicate ut 812 ascii eq scs> return scsa data 41774177417741774177b mask for bits in ascii chars scsb data 43774377437743774377b mask for ut 812 chars scs space 4,10 base * qual$ if -def,qual$ qual * scs> equ /cdkcscs/scs> qual$ endif scs endx *comdeck cdkcsxt convert characters, sixbit to twelvebit. sxt ctext cdkcsxt - sixbit to twelve bit character mapping. sxt space 4,10 if -def,qual$,1 qual cdkcsxt base d sxt space 4,10 *** sxt - sixbit to twelve bit character mapping. * * r. o. anderson. 75/01/27. * * sxt converts a 6-bit character set into a 12-bit character * set. sxt space 4,10 *** sxt performs a character mapping operation using a conversion * table of 1 character per word, right justified, binary zero * filled. the table is assumed to be long enough to allow * mapping of any character encountered in the input string. * * entry (b1) = 1. * (b2) = address of input string. * (b3) = length of input string, in words. * (b4) = address of output string. * (b5) = address of conversion table. * * exit string converted. * * uses x - 1, 2, 6, 7. * b - none. * a - 1, 2, 6. sxt> subr entry/exit sx6 b3 save input sa6 sxta string length sx6 b4 save output sa6 a6+b1 start address sb3 b2+b3 compute lwa + 1 of input area mx7 -6 set up a one byte mask sxt1 sa1 b2 read up the next word to convert mx6 0 clear assembly register .sxt dup 5 lx1 6 get one character bx2 -x7*x1 in x2 sa2 b5+x2 get replacement lx6 12 make room for new character bx6 x6+x2 add in new character .sxt endd sa6 b4 store output word mx6 0 clear assembly register .sxt dup 5 lx1 6 get one character bx2 -x7*x1 in x2 sa2 b5+x2 get replacement lx6 12 make room for new character bx6 x6+x2 add in new character .sxt endd sa6 a6+b1 store output word sb2 b2+b1 increment in pointer sb4 a6+b1 increment out pointer lt b2,b3,sxt1 loop till done sa1 sxta recover input sb3 x1 string length sa1 a1+b1 recover output sb4 x1 start address sb2 b2-b3 restore input starting address eq sxt> return sxta bss 2 to save length and out start addr sxt space 4,10 base * qual$ if -def,qual$ qual * sxt> equ /cdkcsxt/sxt> qual$ endif sxt endx *comdeck cdkctxs convert characters, twelvebit to sixbit. txs ctext cdkctxs - twelve bit to sixbit character mapping. txs space 4,10 if -def,qual$,1 qual cdkctxs base d txs space 4,10 *** txs - twelve bit to sixbit character mapping. * * r. o. anderson. 75/01/27. * * txs converts a 12-bit character set into a 6-bit character * set. txs space 4,10 *** txs performs a character mapping operation using a conversion * table of 1 character per word, right justified, binary zero * filled. the table is assumed to be long enough to allow * mapping of any character encountered in the input string. * * entry (b1) = 1. * (b2) = address of input string. * (b3) = length of input string, in words. * (b4) = address of output string. * (b5) = address of conversion table. * * exit string converted. * * uses x - 1, 2, 6, 7. * b - none. * a - 1, 2, 6. txs> subr entry/exit sx6 b3 save input sa6 txsa string length sx6 b4 save output sa6 a6+b1 start address sb3 b2+b3 compute lwa + 1 of input area mx7 -12 set up a one byte mask txs1 sa1 b2 read up the next word to convert mx6 0 clear assembly register .txs dup 5 lx1 12 get one character bx2 -x7*x1 in x2 sa2 b5+x2 get replacement lx6 6 make room for new character bx6 x6+x2 add in new character .txs endd sb2 b2+b1 increment in pointer ge b2,b3,txs3 store word if input length odd sa1 b2 else get next word and continue .txs dup 5 lx1 12 get one character bx2 -x7*x1 in x2 sa2 b5+x2 get replacement lx6 6 make room for new character bx6 x6+x2 add in new character .txs endd sa6 b4 store output word sb2 b2+b1 increment in pointer sb4 b4+b1 increment out pointer lt b2,b3,txs1 loop till done txs2 sa1 txsa recover input sb3 x1 string length sa1 a1+b1 recover output sb4 x1 start address sb2 b2-b3 restore input starting address eq txs> return txs3 lx6 30 position partial word sa6 b4 save it eq txs2 to complete exit txsa bss 2 to save length and out start addr txs space 4,10 base * qual$ if -def,qual$ qual * txs> equ /cdkctxs/txs> qual$ endif txs endx *comdeck cdkcvfn validate file name. vfn ctext cdkcvfn - validate file name. vfn space 4,10 if -def,qual$,1 qual cdkcvfn base d vfn space 4,10 *** vfn - validate file name. * * g. m. townsend. 78/02/02. * * vfn checks that a string is a legal file name. vfn space 4,10 *** entry (x1) = file name, l format. * (b1) = 1. * * exit (x1) = 0 if legal. * * uses x - 1, 2, 6. * b - 2. * a - none. vfn> subr entry/exit mi x1,vfn> if negative, return immediately bx2 x1 ax2 54 sx2 x2-1r0 pl x2,vfn> if first char numeric, return sb2 7 (b2) = character counter mx2 -6 (x2) = character mask vfn1 lx1 6 bx6 -x2*x1 (x6) = character zr x6,vfn> if zero character, return sx6 x6-1r9-1 pl x6,vfn> if illegal character, return bx1 x2*x1 clear out last char, it is legal sb2 b2-b1 nz b2,vfn1 if more characters to test eq vfn> return vfn space 4,10 base * qual$ if -def,qual$ qual * vfn> equ /cdkcvfn/vfn> qual$ endif vfn endx *deck rel ident cpu.btz entry btz> btz title btz - convert blanks to zeroes in a word. comment convert blanks to zeroes in a word. *call cdkcbtz end ident cpu.mfs entry mfs> mfs title mfs - move fortran string. comment move fortran string. *call cdkcmfs end ident cpu.mvc entry mvc> mvc title mvc - move characters. comment move characters. *call cdkcmvc end ident cpu.scs entry scs> scs title scs - select character set. comment select character set. *call cdkcscs end ident cpu.sxt entry sxt> sxt title sxt - convert characters, sixbit to twelvebit. comment convert characters, sixbit to twelvebit. *call cdkcsxt end ident cpu.txs entry txs> txs title txs - convert characters, twelvebit to sixbit. comment convert characters, twelvebit to sixbit. *call cdkctxs end ident cpu.vfn entry vfn> sst vfn title vfn - validate file name. comment validate file name. *call cdkcvfn end *deck macrel ident macrel entry macrel.,macrel=,macwal= sst b1=1 list f title macrel - system macro interface routines. comment system macro interface routines. macrel space 4,10 *** macrel - system macro interface routines. * * t. r. ramsey. 76/08/08. * * copyright control data corporation. 1976. macrel space 4,10 *** macrel is a collection of relocatable modules that * provide the interface between higher level language modules * and the system macros. * * fortran calling sequences are shown in each module along with * other pertinent information, e.g., entry, exit. title macrel - system macro interface routines. macrel space 4,10 ** macrel modules translate parameters in higher level * language calling sequences into macro calling sequences. * fortran calling sequences mentioned are equivalent to * cobol (enter using), sympl, etc. * * entry fortran *call* and function reference calling * sequences use the actual parameter list, call by * reference calling sequence where - * (a1) = fwa of aplist * ((a1)) # first parameter * ((a1+1)) # second parameter * . . * . . * . . * ((a1+n)) # n-th parameter * ((a1+n+1)) = 0 (zero) (nominally) (un-needed herein) * (x1) # first parameter * * exit for *call*, typically none, but see individual modules. * for function references, * (x6) = function result * (x7) = second word of two word result, e.g., complex * * uses preserves a0 * * calls macrel. if macro undefined or not coded yet * macrel= if argument error * * needs each module contains a call to a macro whose name is * the same as the module (except where noted). these * macros are defined in systext (kronos nos) and cputext * (scope nos/be) and also in jettext. jettext is the * preferred system text. * * note b1 is set to one upon entry to each module * * other macrel is a collection of relocatable modules combined * into one *update* deck entity named macrel. the * modules are arranged in the same order as the macros * in jettext. macrel. space 4,10 ** macrel. - undefined macro processor. * * entry (x1) = macro name in 0l format * * exit does not exit * * uses a6 b1 x6 * * calls none * * needs macros abort, message macrel. subr entry/exit sb1 1 bx6 x1 sa6 maca+3 message maca,,rcl abort eq macrel. maca data c* macrel - undefined macro - fill-in.* macrel= space 4,10 ** macrel= - illegal argument processor. * * entry (x1) = macro name in 0l format * (x2) = illegal argument * * exit does not exit * * uses a6 b1 x0,x1,x2,x6 * * calls ztb= * * needs macros abort, message macrel= subr entry/exit sb1 1 bx0 x2 save second argument lx1 -6 sx2 1r- bx1 x1+x2 rj =xztb= bx1 x0 sa6 macb rj =xztb= sa6 macb+3 message macb,,rcl abort ,nd eq macrel= macb data c* fill-in - illegal argument >fill-it-in<.* macwal= space 4,10 ** macwal= - word align a 10 or less character parameter. * * entry (x1) = ftn/ftn5 argument list item. * * exit (x2) = value from argument list, left justified, with * space fill, unless value was 0b or all spaces, in * which case, 0b returned. * * uses a2,a3,a6 b1,b3,b4,b5,b6,b7 x1,x2,x3,x6,x7 * * calls mfs>, ztb=. macwal= subr entry/exit sb1 1 sb6 macc where mfs can stash the result sb7 b1 length of mfs buffer rj =xmfs> move the option sa2 macc get the result zr x2,macwal= if nothing specified, return binary zero bx1 x2 for ztb rj =xztb= blank out the 00b characters sa2 macd spaces bx2 x2-x6 zr x2,macwal= map spaces to zero for ftn5 bx2 x6 for most of our callers, this is best eq macwal= return macc bss 1 buffer for mfs macd data 10h end ident excst entry excst sst syscom b1 excst title excst - execute control statement for ftn. comment (ftn) execute control statement. excst space 4,10 ***** excst - execute control statement for ftn. * * r. o. anderson. 83/10/31. * * allow ftn program to execute a control statement. excst space 4,10 *** excst allows an ftn program to execute a control * statement at termination. * * call excst(string) * * entry *string* is a hollerith string (ftn4), including * a line terminator, or a character variable (ftn5). * in either case, the maximum length is 80 characters. * * exit does not return. * * calls mfs>, sys=. excst subr = entry (only) sb1 1 always sb6 ccdr where to put the image sb7 8 maximum buffer length rj =xmfs> move the string excst ccdr execute image * system pcc,r,ccdr execute image (does not return) endrun in case we did a 1aj command end ident close entry close sst b1=1 title close - close file. comment close file. close space 4,10 *** close - close file. * * call close (file,option) * * entry (file) = first word of the fet * (option) = a hollerith string or character variable * with any of the following values. * = 0 or blanks, close with rewind * = ^nr^, close without rewind * = ^reel^, close reel with rewind * = ^reelnr^, close reel without rewind * = ^reelun^, close reel with rewind, unload * = ^return^, close with rewind, return * = ^rewind^, close with rewind * = ^unload^, close with rewind, unload * * exit to argument-error processor if option is unrecognized * else none close subr sb1 1 sa1 a1+b1 point to option rj =xmacwal= word align option sa1 a1-b1 reset x1 to be fet address zr,x2 clo1 sa3 =0hnr bx4 x2-x3 zr,x4 clo2 if nr sa3 =0hreel bx4 x2-x3 zr,x4 clo3 if reel sa3 =0hreelnr bx4 x2-x3 zr,x4 clo4 if reelnr sa3 =0hreelun bx4 x2-x3 zr,x4 clo5 if reelun sa3 =0hreturn bx4 x2-x3 zr,x4 clo6 if return sa3 =0hrewind bx4 x2-x3 zr,x4 clo7 if rewind sa3 =0hunload bx4 x2-x3 zr,x4 clo8 if unload sa1 =0lclose rj =xmacrel= diagnose illegal argument eq close clo1 close x1 eq close clo2 close x1,nr eq close clo3 closer x1 eq close clo4 closer x1,nr eq close clo5 closer x1,unload eq close clo6 close x1,return eq close clo7 close x1 eq close clo8 close x1,unload eq close end ident open entry open sst b1=1 title open - open file for processing. comment open file for processing. open space 4,10 *** open - open file for processing. * * call open (file,option) * * entry (file) = first word of the fet * (option) = a hollerith string or character variable * with any of the following values. * = 0 or blanks, same as ^alter^ * = ^alter^, open with rewind for i-o * = ^alternr^, open for i-o * = ^nr^, open * = ^read^, open with rewind for input * = ^readnr^, open for input * = ^reel^, open reel with rewind * = ^reelnr^, open reel * = ^write^, open with rewind for output * = ^writenr^, open for output * * exit to argument-error processor if option is unrecognized * else none open subr sb1 1 sa1 a1+b1 point to option rj =xmacwal= word align option sa1 a1-b1 reset x1 to be fet address zr,x2 ope1 sa3 =0halter sa4 =0halternr sa5 =0hnr bx3 x2-x3 bx4 x2-x4 zr,x3 ope2 if alter bx5 x2-x5 zr,x4 ope3 if alternr zr,x5 ope4 if nr sa3 =0hread sa4 =0hreadnr sa5 =0hreel bx3 x2-x3 bx4 x2-x4 zr,x3 ope5 if read bx5 x2-x5 zr,x4 ope6 if readnr zr,x5 ope7 if reel sa3 =0hreelnr sa4 =0hwrite sa5 =0hwritenr bx3 x2-x3 bx4 x2-x4 zr,x3 ope8 if reelnr bx5 x2-x5 zr,x4 ope9 if write zr,x5 ope10 if writenr sa1 =0lopen rj =xmacrel= diagnose illegal argument eq open ope1 open x1 eq open ope2 open x1,alter eq open ope3 open x1,alternr eq open ope4 open x1,nr eq open ope5 open x1,read eq open ope6 open x1,readnr eq open ope7 open x1,reel eq open ope8 open x1,reelnr eq open ope9 open x1,write eq open ope10 open x1,writenr eq open end ident read entry read sst b1=1 title read - read file to cio buffer. comment read file to cio buffer. read space 4,10 *** read - read file to cio buffer. * * call read (file) * * entry (file) = first word of the fet read subr sb1 1 read x1 eq read end ident writer entry writer sst 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 subr sb1 1 sa3 a1+b1 address of level sa3 x3 level writer x1,x3 eq writer end ident readc entry readc sst b1=1 title readc - read coded line in *c* format. comment read coded line in *c* format. readc space 4,10 *** readc - read coded line in *c* format. * * call readc (file,buf,n,status) * * transfers data until the end of line byte (0000) is sensed. * * entry (file) = first word of the fet * (buf) = first word of the working buffer * (n) = word count of the working buffer * * exit (status) = 0, transfer complete * = -1, end-of-file detected on file * = -2, end-of-information detected on file * = lwa, end-of-record detected on file before * transfer was complete * lwa = address + 1 of last word transferred to * working buffer readc subr sb1 1 sa3 a1+b1 fwa of working buffer sa4 a3+b1 address of word count sa5 a4+b1 (x5) = address of status word bx6 x5 sa4 x4 word count readc x1,x3,x4 bx6 x1 sa6 x5 eq readc end ident readw entry readw sst b1=1 title readw - read data to working buffer. comment read data to working buffer. readw space 4,10 *** readw - read data to working buffer. * * call readw (file,buf,n,status) * * entry (file) = first word of the fet * (buf) = first word of the working buffer * (n) = word count of the working buffer * * exit (status) = 0, transfer complete * = -1, end-of-file detected on file * = -2, end-of-information detected on file * = lwa, end-of-record detected on file before * transfer was complete * lwa = address + 1 of last word transferred to * working buffer readw subr sb1 1 sa3 a1+b1 fwa of working buffer sa4 a3+b1 address of word count sa5 a4+b1 (x5) = address of status word sa4 x4 word count readw x1,x3,x4 bx6 x1 sa6 x5 eq readw end ident writew entry writew sst b1=1 title writew - write data from working buffer. comment write data from working buffer. writew space 4,10 *** writew - write data from working buffer. * * call writew (file,buf,n) * * entry (file) = first word of the fet * (buf) = first word of the working buffer * (n) = word count of the working buffer writew subr sb1 1 sa3 a1+b1 fwa of working buffer sa4 a3+b1 address of word count sa4 x4 word count writew x1,x3,x4 eq writew end ident mtr entry mtr sst b1=1 mtr title mtr - issue monitor calls from ftn. comment issue monitor calls from ftn. mtr space 4,10 ***** mtr - issue monitor calls from ftn. * * b. l. trumbo. 78-aug-31 * * mtr allows monitor calls to be issued from an ftn program, * either as a 60-bit request, or in the same format as * the *system* macro. mtr space 4,10 *** mtr - issue monitor calls from ftn. * * call mtr (ppcall) * call mtr (ppname,recall) * call mtr (ppname,recall,arg) * call mtr (ppname,recall,arg1,arg2) * * entry *ppcall* is a 60-bit (integer) quantity, and is * issued as a monitor call without modification. * *ppname* is the name of the pp routine to be called, * left justified. only the upper 18 bits are used. * *recall* is either zero or non-zero. if it is zero, * no recall bit is inserted. * *arg* is an argument to be passed to the pp routine * called. the lower 36 bits are passed as the lower * 36 bits of the ra+1 call. * *arg1* is an argument to be passed to the pp routine * called. the lower 18 bits are passed as the lower * 18 bits of the ra+1 call. * *arg2* is an argument to be passed to the pp routine * called. the lower 18 bits are passed as bits 18 * thru 35 of the ra+1 call. * * exit all input arguments preserved, monitor call issued. * if recall bit was set in call, ra+1 will be clear. * * uses a1,a2,a3,a4, a6 * b1 * x1,x2,x3,x4, x6,x7 * * calls sys=. mtr space 4,10 mtr2 bx4 -x6*x4 strip *arg* to 36 bits, assuming no *arg2* lx3 40d position recall bit bx2 x2+x4 combine pp name and arg(s) bx2 x2+x3 or in recall bit mtr1 bx6 x2 system issue the monitor call in x6 mtr subr = entry/exit sb1 1 11th commandment sa2 x1 pick up pp name sa1 a1+b1 pick up address of *recall* arg zr x1,mtr1 if only one arg, issue it as is mx7 18 sa3 x1 pick up *recall* arg mx4 0 assume zero *arg* cx3 x3 convert *recall* to a bit sa1 a1+b1 pick up address of *arg* cx3 x3 bx2 x7*x2 strip pp name down to 3 chars cx3 x3 mx6 -36d mask for use at mtr2 cx3 x3 now have only one recall bit zr x1,mtr2 if no *arg* supplied, use zero sa4 x1 if *arg* supplied, use it sa1 a1+b1 pick up address of *arg2* zr x1,mtr2 if no *arg2* sa1 x1 mx7 -18d bx4 -x7*x4 strip *arg1* down to 18 bits bx1 -x7*x1 strip *arg2* down to 18 bits lx1 18d bx4 x4+x1 x4 contains composite arg eq mtr2 end ident endrun entry endrun sst b1=1 list f title endrun - end central program. comment endrun. endrun space 4,10 *** endrun - end central program. * * call endrun * * entry none * * exit does not exit endrun subr sb1 1 endrun end ident recall entry recall sst b1=1 list f title recall - place program in recall status. comment place program in recall status. recall space 4,10 *** recall - place program in recall status. * * call recall (status) * * entry (status) = 0, one system periodic recall is issued * = other, program is recalled when bit 0 is set * * exit none if (status) =0 * else bit 0 of status is set recall subr sb1 1 sa2 x1 status word zr,x2 rec1 if single recall recall x1 else, auto-recall eq recall rec1 recall eq recall end ident rtime entry rtime sst b1=1 list f title rtime - obtain real time clock reading. comment obtain real time clock reading. rtime space 4,10 *** rtime - obtain real time clock reading. * * call rtime (status) * * entry none * * exit (status) = response * kronos response - **t 24/ seconds,36/ milliseconds * * scope response - **t 24/ junk,24/ seconds,12/ qm * * time is system software clock time since deadstart * qm = 1/4096 of a second rtime subr sb1 1 bx5 x1 rtime x1 sa1 x5 bx6 x1 return response as function result eq rtime end ident movech entry movech sst syscom b1 movech title movech - mvc> interface for ftn. comment (ftn) move character strings. movech space 4,10 ***** movech - mvc> interface for ftn. * * r. o. anderson. 02/17/76. * * ftn interface to the character move subroutine. movech space 4,10 *** movech - move character strings. * * movech source,offsets,destination,offsetd,nchars * * moves *nchars* from *source* to *destination*. * * entry *source* = the address of the first word of the * source string. * *offsets* = the character offset (0 - 131071) into * *source*. * *destination* = the address of the first word of * the destination area. * *offsetd* = the character offset (0 - 131071) into * *destination*. * *nchars* = the number of characters to move. * (b1) = 1. * * exit the string has been moved. * * uses x - 1, 2, 3, 4, 5, 6, 7. * b - 2, 3, 4, 5. * a - 1, 2, 3, 4, 5, 6, 7. * * calls mvc>. purgmac movech movech macro source,offsets,dest,offsetd,nchars r= a1,source r= b2,offsets r= a2,dest r= b3,offsetd r= b4,nchars rj =xmvc> endm movech space 4,10 *** movech provides an ftn callable interface to the university * or arizona character string move subroutine. * * call movech(src,bcps,dest,bcpd,nchr) * * entry *src* is the variable or array containing the first * character of the source string. * *bcps* is the beginning character position for the * string starting in *src* (0 - 131071). * *dest* is the variable or array containing the first * character of the destination string. * *bcpd* is the beginning character position for the * string starting in *dest* (0 - 131071). * *nchr* is the number of characters to move. * * exit movech will return after moveing *src* to *dest*. * * calls mvc>. movech subr entry/exit sb1 1 and b1 shall be 1 bx2 x1 mx0 -6 also used below ax2 24 bx2 -x0*x2 sb2 x2 get character variable offset or zero sa2 a1+b1 sa1 x1 (a1) = address of source string sa3 a2+b1 sa2 x2 sb2 b2+x2 (b2) = bcp of source string sa2 x3 (a2) = address of destination string ax3 24 bx3 -x0*x3 sb3 x3 get character variable offset or zero sa3 a3+b1 sa4 x3 sb3 b3+x4 (b3) = bcp of destination string sa3 a3+b1 sa4 x3 sb4 x4 (b4) = number of characters to move movech a1,b2,a2,b3,b4 move the strings eq movech return end ident xcon entry xcon sst syscom b1 xcon title xcon - connect/disconnect terminal files. xcon space 4,10 ** xcon - connect a file to a terminal. * * call xcon(fet,code) * * entry (fet) = fet address * (code) = <0, disconnect (return) file * 0, dpc connect * 1, 128 character ascii connect * 2, 256 character ascii connect * * exit file connected to the terminal * xcon subr = sb1 1 sx2 x1 (x2) = fet address sa1 a1+b1 sa1 x1 bx3 x1 (x3) = function code ng x3,xcon2 if only disconnect status x2 check if local mx0 11 lx0 1 sa4 x2 get fet+0 bx4 -x0*x4 zr x4,xcon3 if not local xcon1 open x2,nr,r check device type sa4 x2 clear all but fn+complete mx0 43 lx0 1 bx6 x0*x4 sa6 x2 sa4 x2+b1 check for ct device ax4 48 sx4 x4-2rtt nos * sx4 x4-2rct-774000b nos/be zr x4,=xxcon if already ct device, return xcon2 evict x2,r return local copy ng x3,=xxcon if only disconnect, return xcon3 sa1 x2 set filename for assign mx0 48 bx6 x0*x1 sa6 xconb sx3 b1 set complete bx6 x6+x3 sa6 x2 sx4 x2 save fet address * system pcc,ar,xcona create the ct file sx2 x4 xcon4 sa1 x2 get fet+0 mx0 43 keep fn+complete lx0 1 bx1 x0*x1 mx7 1 ascii bit mask lx7 43 nz x3,xcon5 if not dpc char set bx6 x1 store fet+0 sa6 x2 sa1 x2+b1 clear ascii bit bx6 -x7*x1 sa6 a1 eq =xxcon xcon5 sa4 x2+b1 set ascii bit in fet+1 bx6 x4+x7 sb3 x3 sb3 b3-b1 nz b3,xcon6 if 256 char ascii sa6 a4 bx6 x1 set fet+0 sa6 x2 eq =xxcon xcon6 sb3 b3-b1 nz b3,=xxcon if invalid mode sa6 a4 bx6 x1+x3 set odd bit for 256 char ascii sa6 x2 set fet+0 eq =xxcon xcona data h*.assign,ct,* xconb data 0 end ident xscs entry xscs sst b1=1 xscs title xscs - scs interface for ftn. comment (ftn) sense character set. xscs space 4,10 ***** xscs - scs interface for ftn. * * s. h. jay 83/02/04. * * ftn interface to the sense character set routine. xscs space 4,10 *** xscs provides an ftn callable link to the university * of arizona sense character set subroutine. * * n = xscs(fet) * * entry *fet* is array containing an fet. a read should * be done on this fet before calling xscs. * * exit *n* = 1 for display code, * 0 if buffer empty, * -1 if ascii. * * calls scs> xscs subr entry/exit sb1 1 sx2 x1 (x2) = fet address rj =xscs> eq xscs return end ident xsxt entry xsxt syscom b1 xsxt title xsxt - sxt> interface for ftn. comment (ftn) convert sixbit to twelvebit. xsxt space 4,10 ***** xsxt - sxt> interface for ftn. * * r. o. anderson. 02/17/76. * * l. n. shipp. 80/05/09. fix mcs parameter typo. * * ftn interface to the sixbit to twelvebit character conversion * routine. mcs space 4,10 *** mcs - map character sets into other character sets. * * mcs in=,inlen=,inbs=,out=,outbs=,table= * * converts the characters in *in* via *table* placing them * in *out*. * * entry *in=* the address of the first word of the input * character string. * *inlen=* the length of the input string in words. * *inbs=* the byte size (6 or 12) of the input chars. * *out=* the address of the first word of the output * character string buffer. if *outbs* is .le. * *inbs*, *out* and *in* may point to the same * area. * *outbs=* the byte size (6 or 12) of the output chars. * *table=* the address of the character set mapping * table. this table has 1 entry per word, * right justified with binary zero fill. * (b1) = 1. * * exit the characters have been mapped. * * uses x - 1, 2, 6, 7. * b - 2, 3, 4, 5. * a - 1, 2, 6. * * calls sxs>, sxt>, txs>, or txt>. purgmac mcs mcs macroe in,inlen,out,inbs,outbs,table r= b2,in r= b3,inlen r= b4,out r= b5,table ifeq inbs,6,2 ^%s"mcs1 micro 1,, s skip 4 ifeq inbs,12d,2 ^%s"mcs1 micro 1,, t skip 1 err input byte size must be 6 or 12. ifeq outbs,6,2 ^%s"mcs2 micro 1,, s skip 4 ifeq outbs,12d,2 ^%s"mcs2 micro 1,, t skip 1 err output byte size must be 6 or 12. rj =x'^%s"mcs1'x'^%s"mcs2'> endm xsxt space 4,10 *** xsxt provides an ftn callable link to the university of * arizona sixbit to twelvebit character conversion routine. * * call xsxt(in,len,out,tbl) * * entry *in* is a variable or array containing the * characters to be converted (10 per word). * *len* is the word length of the array *in*. * *out* is the variable or array to receive the * converted characters (5 per word). * *tbl* is an array containing the conversion table. * this table contains 1 character per word, * right justified, with binary zero fill. * * exit xsxt will return after doing the conversion. * * calls sxt>. xsxt subr entry/exit sb1 1 and b1 shall be 1 sb2 x1 (b2) = input area address sa1 a1+b1 sa2 x1 sb3 x2 (b3) = word length of input sa1 a1+b1 sb4 x1 (b4) = output area address sa1 a1+b1 sb5 x1 (b5) = conversion table address mcs in=b2,inlen=b3,out=b4,table=b5,inbs=6,outbs=12 eq xsxt return end ident xtxs entry xtxs syscom b1 xtxs title xtxs - txs> interface for ftn. comment (ftn) convert twelvebit to sixbit. xtxs space 4,10 ***** xtxs - txs> interface for ftn. * * r. o. anderson. 02/17/76. * * l. n. shipp. 80/05/09. fix mcs parameter typo. * * ftn interface to the twelvebit to sixbit character conversion * routine. mcs space 4,10 *** mcs - map character sets into other character sets. * * mcs in=,inlen=,inbs=,out=,outbs=,table= * * converts the characters in *in* via *table* placing them * in *out*. * * entry *in=* the address of the first word of the input * character string. * *inlen=* the length of the input string in words. * *inbs=* the byte size (6 or 12) of the input chars. * *out=* the address of the first word of the output * character string buffer. if *outbs* is .le. * *inbs*, *out* and *in* may point to the same * area. * *outbs=* the byte size (6 or 12) of the output chars. * *table=* the address of the character set mapping * table. this table has 1 entry per word, * right justified with binary zero fill. * (b1) = 1. * * exit the characters have been mapped. * * uses x - 1, 2, 6, 7. * b - 2, 3, 4, 5. * a - 1, 2, 6. * * calls sxs>, sxt>, txs>, or txt>. purgmac mcs mcs macroe in,inlen,out,inbs,outbs,table r= b2,in r= b3,inlen r= b4,out r= b5,table ifeq inbs,6,2 ^%s"mcs1 micro 1,, s skip 4 ifeq inbs,12d,2 ^%s"mcs1 micro 1,, t skip 1 err input byte size must be 6 or 12. ifeq outbs,6,2 ^%s"mcs2 micro 1,, s skip 4 ifeq outbs,12d,2 ^%s"mcs2 micro 1,, t skip 1 err output byte size must be 6 or 12. rj =x'^%s"mcs1'x'^%s"mcs2'> endm xtxs space 4,10 *** xtxs provides an ftn callable link to the university of * arizona twelvebit to sixbit character conversion routine. * * call xtxs(in,len,out,tbl) * * entry *in* is a variable or array containing the * characters to be converted (5 per word). * *len* is the word length of the array *in*. * *out* is the variable or array to receive the * converted characters (10 per word). * *tbl* is an array containing the conversion table. * this table contains 1 character per word, * right justified, with binary zero fill. * * exit xtxs will return after doing the conversion. * * calls txs>. xtxs subr entry/exit sb1 1 and b1 shall be 1 sb2 x1 (b2) = input area address sa1 a1+b1 sa2 x1 sb3 x2 (b3) = word length of input sa1 a1+b1 sb4 x1 (b4) = output area address sa1 a1+b1 sb5 x1 (b5) = conversion table address mcs in=b2,inlen=b3,out=b4,table=b5,inbs=12,outbs=6 eq xtxs return end ident xvfn entry xvfn sst syscom b1 title xvfn - validate file name. comment (ftn) validate file name. xvfn space 4,10 *** xvfn - validate file name. * * ans = xvfn (lfn) * * entry *lfn* = logical file name. trailing spaces will be * deleted before name is validated. * * exit *ans* = 0 if file name is valid. xvfn subr entry/exit sb1 1 sb6 xvfna sb7 b1 rj =xmfs> word align the lfn sa1 xvfna rj =xbtz> convert blanks to 00b bx1 x6 rj =xvfn> check out the name bx6 x1 set function value eq xvfnx return xvfna bss 1 end ident retfile sst entry retfile,unlfile syscom b1 retfile title retfile - return/unload a file. comment return/unload a file. space 4,10 *** retfile - return/unload a file. * * call retfile(lfn) * call unlfile(lfn) * * entry lfn = a hollerith string or a character string * containing the name of the file to be returned * (retfile) or unloaded (unlfile). spaces are * removed from lfn before processing. * * exit file is gone. retfile space 4,10 ** retfile - close/return a file. retfile subr entry/exit sb1 1 b1=1 rj sff set file name in fet close retfilea,unload,rcl eq retfilex return unlfile space 4,10 ** unlfile - close/unload a file. unlfile subr entry/exit sb1 1 b1=1 rj sff set file name in fet close retfilea,unload,rcl eq unlfilex return sff space 4,10 ** sff - set file name in fet. * * entry (x1) = ftn parameter pointer for lfn. * * exit (retfilea) contains lfn + complete bit. * * uses x - 1, 2, 6, 7. * b - 2, 3, 4, 5, 6, 7. * a - 2, 6. * * calls btz>, macwal=. sff subr entry/exit rj =xmacwal= get the file name bx1 x2 rj =xbtz> delete any spaces sa1 retfilea sx1 b1 bx6 x6+x1 add complete bit sa6 retfilea stash in fet eq sffx return retfilea vfd 42/**,18/1 con 100b first con 100b in con 100b out con 101b limit end