rAEu#;b~.`2+r t0\UG?99&@quH`n+%&QY?.`M&f="<|T{s5H`YM-&\BycYH`YM\*P1$CH`_W "Q(V"`XD.`_W "] hppH.`iL/LR.`l=3"H-C#6H`kV~0"I8)C#6H`This archive directory contains the sources for old generations of various things, mostly related to the old UUO package. Nothing should use them any more, but they are preserved for (1) posterity, and (2) in case an old-generation program which uses them is unearthed. --KLH  SUBTTL Core management documentation ; ; These routines are adapted from very similar ones used in ; SAIL for core management; in particular, the format of a data block ; is nearly identical. Core comes in chunks called "blocks" and ; each block has the following format: ; ; HEAD: PREV,,NEXT ;pointers to other free blocks in list, if block is free. ; SIZE ; (size negative if block is active) ; ; LAST: ,,HEAD ; is 0 if block is free, 400000 if block is active. ; ; ; Free blocks are strung together in a freelist rooted in FRELST; ; PREV is 0 if the block is first one in freelist, and NEXT is 0 if it is ; the last. When necessary, new blocks are created at the top of core ; and split up into active and free blocks; there is no such thing as ; two adjacent free blocks since whenever a block is released, it is ; merged with any adjacent free blocks. ; An "active" block is marked by a negative SIZE and the sign bit set ; in the last word; such blocks are understood to be in use by the main ; program and are "hands off" for the core routines. A "loose" block ; only exists within the core routines, and is similar to a free block with the ; exception that it is not on the freelist. The distinction is important ; since some routines assume their argument is already loose, or already free, ; etc. and don't check the size or . SUBTTL CORINI, CORGET and CORREL - Core block management routines ; CORINI - Initializes core block manager. U1 should specify an ;area of core to hack, in the form -<# pages in area>,, CORINI: PUSHAE P,[U1,U2] MOVE U2,U1 ;save before CORBLKing SYSCAL CORBLK,[CIMM 0 ;free pages CIMM %JSELF ;from us U1] ;as many as specified. JSR AUTPSY ;should never fail... if so, bad args. HLRE U1,U2 ;get -# of pgs avail MOVM U1,U1 ;positify HRRZ U2,U2 ;and # of page we can start at MOVEM U2,FFPAGE ;store as first free MOVEM U2,FUPAGE ;also as first used (this one is static) ADD U1,U2 ;add to # avail MOVEM U1,NXMPAG ;and store as # of first unavailable page. LSH U2,10. ;get word addr of first free pg MOVEM U2,FFWORD ;store (can also call it first NXM addr) MOVEM U2,FUWORD ;analogous counterpart to FUPAGE SETZM FRELST ;clear freelist, MOVEI U1,2000 ;and ask for initial 1K free block PUSHJ P,CREATE ;get it PUSHJ P,FLINK ;and put on freelist. POPAE P,[U2,U1] ;and that's all folks! POPJ P, BVAR FUPAGE: 0 ; # of first page in manager area (first used) FUWORD: 0 ; FUPAGE*2000 - first legal address FFPAGE: 0 ; holds # of first free page FFWORD: 0 ; FFPAGE*2000 - first NXM address. NXMPAG: 0 ; # of first illegal page #. i.e. (FFPAGE)<(NXMPAG) always. FRELST: 0 ; ptr to first block of linked free blocks. EVAR WASTE==10 ; # wds which are OK to waste when getting core for user. ; CORGET - given in U1 the # wds storage the user wants, ;routine gets it somehow and returns in U2 the address of a block ;containing at least that many words. U1 will be adjusted to length. ; CORGT is internal routine doing same thing but with standard ; U1 = real block size, U2 = real block ptr. CORGET: ADDI U1,3 ;extra for header and trailer words. PUSHJ P,CORGT ;get the core block PUSHJ P,CORACT ;make it active block MOVEI U2,2(U2) ;now return RH addr of actual start of data... SUBI U1,3 ;and length of data area only. POPJ P, CORGT: PUSH P,U3 PUSHJ P,CORFND ;look for existing free block of this size CAIA ;fooey JRST [PUSHJ P,UNLNK ;aha, found one. make it loose, and proceed. JRST CORGT5] MOVE U2,FFWORD ;none found... must gobble new core. SKIPL U3,-1(U2) ;get pointer to uppermost block and skip unless free. SUB U1,1(U3) ;aha, it's free, can count on this many words off. PUSHJ P,CREATE ;hew a new loose block out of wilderness JUMPGE U3,[ADD U1,1(U3) ;if previously top block was free, then restore cnt EXCH U2,U3 ;swap ptrs PUSHJ P,UNLNK ;take previously top off freelist, PUSHJ P,MERGE ;merge with new block, and JRST CORGT5] ;return triumphantly. ; Have block pointed to by U2 with perhaps more than enough core. Check size... CORGT5: PUSHJ P,CORADJ ;adjust size if necessary (desired size in U1) POP P,U3 POPJ P, ;return with ptr in U2 to it. ; CORREL - takes ptr in U1 to data area of an active block to release... ;inverse of CORGET. Clobbers U1. ; CORRL is internal CORREL, takes U2 (clobbers) as ptr to block. CORREL: PUSH P,U2 MOVEI U2,-2(U1) ;get ptr to block header PUSHJ P,CORRL POP P,U2 POPJ P, CORRL: PUSHAE P,[U1,U3] MOVM U1,1(U2) ;get size (should be negative, so get magnitude) MOVEM U1,1(U2) ;store magnitude back ADD U1,U2 ;find addr of last word+1 HRRZS -1(U1) ;clear LH to remove 400000 'active' flag. CAMG U2,FUWORD ;is there any core below this block? JRST CORRL1 ;no! don't try to check! SKIPL U3,-1(U2) ;is block above just-loosed one also free? JRST [ EXCH U2,U3 ;yes! merge them... PUSHJ P,UNLNK ;take above off freelist PUSHJ P,MERGE ;and merge them JRST .+1] CORRL1: MOVE U3,U1 ;now get ptr to succeeding block CAML U3,FFWORD ;is there any core above current block? JRST CORRL3 ;no! don't check and get MPV! SKIPL 1(U3) ;succeeding block free? JRST [ EXCH U2,U3 PUSHJ P,UNLNK PUSHJ P,MERGE ;hooray! JRST .+1] CORRL3: PUSHJ P,FLINK ;and finally, freed/reduced block winds up on freelist. PUSHJ P,CORGC ;see if anything can be taken off top end. CORRL9: POPAE P,[U3,U1] POPJ P, ; COREXP - expands an active block. ptr in U2 to first data wd of block, ;amount to expand by in U1. Returns new ptr in U2 -- may be same block ;or may have been copied over into a larger block. U1 is adjusted to ;new total data size. COREXP: PUSH P,U3 MOVEI U2,-2(U2) ;adjust to point at header. MOVM U3,1(U2) ;get its current size MOVEM U3,1(U2) ;make it a loose block with pos. size ADDI U3,(U2) ;get last+1 addr HRRZS -1(U3) ;and zero flag to make loose there too. CAMG U2,FUWORD ;any core below? JRST CORXP3 ;nope, don't check it SKIPGE -1(U2) ;core exists. is it free? JRST CORXP3 ;sigh, nope ;aha! free block below this one, always gobble it. ADD U1,1(U2) ;find tot # wds needed in final area MOVE U3,U2 ;save U2 ptr to old block MOVE U2,-1(U2) ;get ptr to free one below PUSHJ P,UNLNK ;unfree it PUSH P,U3 PUSHJ P,MERGE ;merge blocks, saving ptr. POP P,U3 PUSHJ P,CORCPY ;copy U3 (old) block data to U2 block. overlap is OK. CAMG U1,1(U2) ;still need more core? (required GE new length) JRST CORXP5 ;no, won!. adjust length, maybe make free blk of excess SUB U1,1(U2) ;need more core. reset U1 to # more wds needed MOVE U3,1(U2) ADDI U3,(U2) ;get U3 = addr of first wd after this blk CORXP3: CAML U3,FFWORD ;make sure we don't try to read a NXM location JRST [ MOVE U3,U2 ;save ptr PUSHJ P,CREATE ;we are top block, get some free core. ADD U1,1(U3) ;total # wds desired PUSHJ P,MERGE ;combine the two JRST CORXP5] ;and make active, and return. SKIPL 1(U3) ;not at top, is succeeding block active? JRST [ CAMLE U1,1(U3) ;no, is free... enough room? JRST .+1 ;nope, must get new block. ADD U1,1(U2) ;ah, enough room - get total size desired EXCH U2,U3 PUSHJ P,UNLNK ;unhook free block PUSHJ P,MERGE ;merge them JRST CORXP5] ADD U1,1(U2) ;successor is active, must get completely new block. get size needed MOVE U3,U2 ;save ptr PUSHJ P,CORGT ;get a block of that size PUSHJ P,CORCPY ;copy U3 ptr'd block into U2 ptr'd block. PUSHJ P,CORACT ;make active so CORRL doesn't gobble if contiguous to old! EXCH U2,U3 PUSHJ P,CORRL ;release old block. MOVE U2,U3 ;and restore ptr to our fresh new block. JRST CORXP6 ;have expanded block pointed to by U2. Make active again. CORXP5: PUSHJ P,CORADJ ;adjust length, maybe make free block of excess PUSHJ P,CORACT ;there it is... CORXP6: MOVM U1,1(U2) ;get size SUBI U1,3 ;cvt to size of actual data area MOVEI U2,2(U2) ;and return RH ptr to first data word. POP P,U3 POPJ P, SUBTTL Core block not-so-primitives ; CREATE - creates new block on top of core. In U1 takes # wds (at least) ;desired, returns ptr in U2 to a loose block. Size will be multiple of ;2000 wds since it gobbles a page at a time. CREATE: PUSH P,U3 MOVEI U2,1777(U1) ;get size+<2000-1> LSH U2,-10. ;divide by 2000 to get rounded-up # pages necessary MOVE U3,U2 ;save ADD U3,FFPAGE ;find how high this will go CAMLE U3,NXMPAG JSR AUTPSY ;ugh! too high, can't get that much. IMUL U2,[-1,,0] ;make AOBJN out of # pages HRR U2,FFPAGE ;starting at currently first free. SYSCAL CORBLK,[ CIMM %CBNDR+%CBNDW ;get a page CIMM %JSELF ;for us U2 ;at specified pages CIMM %JSNEW] ;fresh core only, please! IFNDEF CORLOS,JSR AUTPSY ;can lose for lack of core... IFDEF CORLOS, JSR CORLOS ;if CORLOS error handler defined, go there. MOVEM U3,FFPAGE ;store back what's now # of first free LSH U3,10. ;mult. by 2000 to get first NXM addr MOVE U2,FFWORD ;get previous value before clobbering MOVEM U3,FFWORD ;store new value HRRZM U2,-1(U3) ;set up last word ptr. SUB U3,U2 ;get # wds in block MOVEM U3,1(U2) ;and store that to finish loose block. POP P,U3 POPJ P, ; CORGC - takes a look at block on top of core; if free, tries to ;flush as many pages as possible and either truncate or flush the ;block. CORGC: PUSHAE P,[U1,U2,U3,U4] MOVE U3,FFWORD ;get first NXM addr SKIPGE U2,-1(U3) ;get trailer for top block JRST CORGC9 ;and exit if not free MOVE U3,1(U2) ;free, get size. CAME U2,FUWORD ;don't flush very last block, would expose bugs CAIGE U3,2000 ;a page or more waiting? JRST CORGC9 ;nope, exit. IDIVI U3,2000 ;get # pages in U3, # wds remainder in U4 JUMPE U4,[PUSHJ P,UNLNK ;if no remainder, must flush whole block. JRST CORGC4] CAIGE U4,3 ;ensure enough for header/trailer wds. JRST [ ADDI U4,2000 SOJA U3,.+1] MOVE U1,U4 ;else truncate the free block to this # wds PUSHJ P,MAKBLK ;by making block at that addr w/o touching link ptrs. CORGC4: JUMPE U3,CORGC9 ;exit if no pages to be freed. MOVE U4,FFPAGE ;ah, some to free. find # of first free SUB U4,U3 ;get future first free page # MOVEM U4,FFPAGE ;and store in advance of big flush IMUL U3,[-1,,0] ;get AOBJN with right # HRR U3,U4 ;and right start SYSCAL CORBLK,[CIMM 0 ;free these pages CIMM %JSELF ;from us U3] ;as so ordered. JSR AUTPSY ;should never fail... if so, bad args. LSH U4,10. ;now mult. ffpage by 2000 MOVEM U4,FFWORD ;to get current first NXM. CORGC9: POPAE P,[U4,U3,U2,U1] ;all done. POPJ P, ; CORADJ - ptr to loose block in U2, adjusts size to actual desired ;size (in U1) and forms a freelist block of leftover core. Doesn't split ;block if difference in real size-desired size is less than trivial amount. CORADJ: PUSH P,U3 MOVE U3,1(U2) ;get wds avail in block SUB U3,U1 ;sub by am't we needed CAIG U3,WASTE ;if less than trivial amount, give user the whole thing. JRST CORDJ3 ;small, don't split. PUSHJ P,SPLIT ;ach, too much, split block up EXCH U2,U3 HRROS -1(U2) ;Don't let CORRL think this block is free! PUSHJ P,CORRL ;free up the leftovers MOVE U2,U3 ;get back addr of precisely-the-right-size block. CORDJ3: POP P,U3 POPJ P, SUBTTL Core block primitives ; UNLNK - addr in U2 to freelist block, makes it loose. UNLNK: PUSH P,U3 MOVE U3,(U2) ;get prev,,next. TRNE U3,-1 ;if next=0 don't try to store prev in it. HLLM U3,(U3) ;else do. make next blk point to previous. MOVS U3,U3 ;get next,,prev TRNN U3,-1 HRRI U3,FRELST ;if prev=0 then it is 1st block; store next in FRELST HLRM U3,(U3) ;else store next-ptr in previous blk. POP P,U3 POPJ P, ; FLINK - addr in U2 to loose block, puts on freelist. FLINK: PUSH P,U3 MOVE U3,FRELST ;get addr of first block on freelist HRRZM U3,(U2) ;store as 1st wd in new block... points to next blk. TRNE U3,-1 ;and if there really was a 'next blk', HRLM U2,(U3) ;make next blk point back to this blk. HRRZM U2,FRELST ;and addr of this blk becomes first in freelist. POP P,U3 POPJ P, ; MAKBLK - forms loose block given ptr in U2, size in U1. MAKBLK: PUSH P,U1 MOVEM U1,1(U2) ;store size in block ADDI U1,(U2) ;get addr to last+1 wd HRRZM U2,-1(U1) ;set it up POP P,U1 POPJ P, ; CORACT - ptr to loose block in U2, makes it active. CORACT: PUSH P,U3 SETZM (U2) ;clear 1st word so block has no freelist pointers. MOVE U3,1(U2) ;get size so that MOVNM U3,1(U2) ;after negating it to declare block active, ADDI U3,(U2) ;we can access last word in block. HRLI U2,400000 ;must store 400000,, in last word of active blk. MOVEM U2,-1(U3) ;there it goes! POP P,U3 POPJ P, ; CORFND - searches freelist blocks and skips with addr in U2 if it finds ;a block with at least as many wds free as specified in U1. CORFND: MOVEI U2,FRELST ;begin at beginning CORFN0: MOVE U2,(U2) ;get ptr to next block TRNN U2,-1 ;is it non-zero? POPJ P, ;fail if reached end of list. CAMLE U1,1(U2) ;compare # desired with size avail for this block JRST CORFN0 ;not enough, keep looking. AOS (P) ;ah, enough room! skip on return POPJ P, ; CORCPY - ptrs in U2, U3 to loose blocks, copies U3 block into U2 block. ;This will of course lose horribly unless size of U2 is .GE. that of U3!! CORCPY: PUSHAE P,[U2,U3] HRLI U2,2(U3) ;source addr is first data wd of U3's blk. HRRI U2,2(U2) ;dest addr is first data wd of U2's blk. MOVE U3,1(U3) ;find size of U3's blk SUBI U3,3 ;less the 3 header/trailer wds. ADDI U3,(U2) ;plus dest addr, to get last addr+1 for moving. BLT U2,-1(U3) ;move! POPAE P,[U3,U2] POPJ P, SUBTTL Core merging and splitting ; MERGE - ptrs in U2, U3 to contiguous loose blocks, merges them ;into one block (ptr left in U2). U3 clobbered. MERGE: CAMLE U2,U3 ;find which is lower EXCH U2,U3 ;and make sure it's in U2. MOVE U3,1(U3) ;get size of higher block ADDB U3,1(U2) ;add into size of lower to get total size ADDI U3,(U2) ;add addr of lower to get addr of last+1 wd in new block HRRZM U2,-1(U3) ;now have last wd set up. POPJ P, ; MERGF - like MERGE but munches 2 freelist blocks into another freelist block. MERGF: PUSHJ P,UNLNK EXCH U2,U3 PUSHJ P,UNLNK ;loosen both PUSHJ P,MERGE ;then merge PJRST FLINK ;and put result back on freelist. ; SPLIT - takes ptr in U2 to loose block, cnt in U1 of # wds to use from ;it for a new loose block; ptr to leftover 2nd block put in U3. SPLIT: PUSH P,U4 MOVE U3,U2 ADDI U3,(U1) ;find addr for 2nd block MOVE U4,1(U2) ;get size for whole block, and SUB U4,U1 ;derive size of 2nd from it. MOVEM U4,1(U3) ;store size of 2nd ADD U4,U3 ;get end addr for 2nd HRRZM U3,-1(U4) ;set up last wd for 2nd block. HRRZM U2,-1(U3) ;now store last wd for 1st block also MOVEM U1,1(U2) ;and size for it, and we're done! POP P,U4 POPJ P, :;;;----------------------------------------------------- ;;; necessary external defs for uuos ;;; ;;; U1,U2,U3,U4 ;sequential accs which uuo rtns clobber. ;;; P ;pdl acc ;;; AUTPSY ;routine jsr'd to if fatal uuo error ;;; ;and file containing wonderful "fwrite" macro and etc. .INSRT KSC;MSTAT > ;;;---------------------------------------------------- ;;; external references from prgms to uuos are usually to ;;; ;;; ARTAB,WARTAB,RARTAB ;tables of pointers to and into areas ;;; ;(only if area hackery enabled) ;;;---------------------------------------------------- ;;; assembly switches (for optional features and hacks) ;;; default uuos are byte-ptr and string output operations (450 wds). IFNDEF UBONES,UBONES==0 ;if set, assemble nothing but dispatcher (120 wds) IFNDEF UAREAS,UAREAS==0 ;if set, assembles area hackery (1400 wds) IFNDEF USTRGS,USTRGS==0 ;if set, assembles string hackery (requires uareas) IFNDEF ULISTS,ULISTS==0 ;if set, assembles list hackery IFNDEF UFLOAT,UFLOAT==0 ;if set, assemble floating pt. output uuo IFNDEF USCALL,USCALL==0 ;if set, assembles special .call execution uuo. IFN ULISTS,UAREAS==1 ;list hackery needs area hackery. IFN USTRGS,UAREAS==1 ;ditto string variable hackery IFNDEF $OPCOD,$OPCOD==331100 ;instr. op-code byte ptr IFNDEF $ACFLD,$ACFLD==270400 ;instr. ac field IFNDEF $ERRCD,$ERRCD==220600 ;error code from .status wd ;;;---------------------------------------------------- UUOH: 0 LDB U1,[330600,,40] ;get bottom 6 bits of opcode (0 - 77) JRST @UUOTAB(U1) ;dispatch (safely due to full table) IF2 IFNDEF AUTPSY, AUTPSY=. ;if fatal error trap not defined externally, do so here. 0 ;(called via jsr autpsy) .VALUE ;;; uuo dispatch table, indexed by uuo opcode. unused entries go to ;;; illegal uuo routine. UUOTAB: REPEAT 100,ILUUO ;;; illegal uuo trap. ILUUO: EXCH U1,40 ;illegal uuo. save info for debugging. MOVEM U1,ILU40 ;save illegal uuo being xct'd EXCH U1,40 ;restore u1 EXCH U1,UUOH MOVEM U1,ILULOC ;save location+1 of illegal uuo EXCH U1,UUOH ;restore uuoh JSR AUTPSY ;fatal error. ILU40: 0 ILULOC: 0 ;;; macro to define uuo's. defines name and deposits routine addr in table. ;;; typical use is ;;; uuodef outstr,outrtn ;defines "outstr" uuo and jrsts to outrtn when xct'd. DEFINE UUODEF NAME,HANDLR IF1 [IFNDEF %%UCNT,%%UCNT==0 %%UCNT==%%UCNT+1 IFE 40-%%UCNT,%%UCNT==50 IFL 77-%%UCNT,PRINTC /TOO MANY UUOS... NO KIDDING!/ NAME=%%UCNT_27. ] %%SAV==. LOC UUOTAB+NAME_-27. HANDLR LOC %%SAV TERMIN ;;; Now define two subclasses of UUOs - those which use their AC field ;;; only, and those which use E only. The former all use the U.OPER ;;; opcode (after the similar ITS call named .OPER) and are indexed ;;; by E. The number of such UUO's is effectively infinite. ;;; The latter are indexed by the AC field and thus up to 16. can be ;;; defined for each opcode used this way; currently only one, U.CALL, ;;; is needed. UUODFA defines a UUO that uses AC only, and UUODFE ;;; a UUO which uses E only. UUODFN will define UUO's that use neither, ;;; but this is just another U.OPER. UUODEF U.OPER,U.OPR ; UUO to handle UUODFA's and UUODFN's, which don't use ;their E field. These UUO's are thus indexed by E. U.OPR: HRRZ U3,40 CAIGE U3,UOPMAX ;check index high end, and skip if illegal. JRST @UOPTAB(U3) JRST ILUUO ;sigh... ; Dispatch table for U.OPER UUO's. UOPMAX==20. ;can vary at will. UOPTAB: REPEAT UOPMAX,ILUUO ; Macro for UUODFA (defining U.OPER's) DEFINE UUODFA NAME,HANDLR IF1 [IFNDEF %%UOPC,%%UOPC==-1 %%UOPC==%%UOPC+1 IFGE %%UOPC-UOPMAX,PRINTC /Too many U.OPER's, increment UOPMAX!/ NAME=U.OPER %%UOPC ] %%SAV==. LOC UOPTAB+NAME HANDLR LOC %%SAV TERMIN EQUALS UUODFN,UUODFA ;UUO's not using E are dispatched in same way. ;;; U.CALL routine and UUODFE macro UUODEF U.CALL,U.CAL ; UUO to handle UUODFE's, which don't use their AC field. ;These UUO's are thus indexed by AC. U.CAL: LDB U2,UACFLD ;get ac field JRST @UCLTAB(U2) ;dispatch (safely since table is full) UCLTAB: REPEAT 20,ILUUO DEFINE UUODFE NAME,HANDLR IF1 [IFNDEF %%UCLC,%%UCLC==-1 %%UCLC==%%UCLC+1 IFGE %%UCLC-20,PRINTC /TOO MANY U.CALL'S!!/ NAME=U.CALL %%UCLC, ] %%SAV==. LOC UCLTAB+<17&> HANDLR LOC %%SAV TERMIN ;;; standard macros used by UUO's DEFINE UIOINIT ;put at beg of every i/o uuo LDB U2,UACFLD ;(at moment, just gets ac field) TERMIN DEFINE UUORET ;standard return loc. jrst'd to @UUOH!TERMIN DEFINE UIORET ;standard i/o uuo return loc. @UUOH!TERMIN ;(currently same as uuoret) UACFLD: $ACFLD,,40 ;byte ptr to uuo acc field (used often) IFN UBONES,[ ;if only want bones (dispatcher), ignore rest of file. CONSTANTS VARIABLES ] IFN UBONES,.INEOF ;halt input to get just bones. ; byte pointer hacking uuos. decbpt works for any size byte, ;the rest assume byte size = 7 (ascii char) ;should round out in future to ; dbp, ddpb,dldb, and "7" variations thereof. ;also add generality to ptskip, ptrdif wrt general bytes? ;macro to decrement 7-bit byte ptr in ac (no checking) DEFINE MDBPT AC,FOO ADD AC,[70000,,0] ;increase p CAIG AC,0 ;skip, SUB AC,[430000,,1] ;unless went off edge, in which case reset. TERMIN ; D7BPT [ptr] decrements 7-bit byte ptr at E. UUODFE D7BPT,U7DBPT U7DBPT: MOVE U1,@40 ;get c(e) LDB U2,[360600,,U1] ;to check for a beginning ptr. CAIN U2,44 JRST UUORET ;if an initialized ptr, don't decr. MDBPT U1, ;decrement. (macro) MOVEM U1,@40 ;store result JRST UUORET ; DECBPT [byte ptr] General-purpose byte ptr decrement. Works for ; any size byte. UUODFE DECBPT,UDBPT UDBPT: MOVE U1,@40 ;get c(e) LDB U3,[300600,,U1] ;get byte size LDB U2,[360600,,U1] ;get offset within word ADD U2,U3 ;move offset back up CAIL U2,44 ;still within word? JRST UDBPT1 ;no. DPB U2,[360600,,U1] ;yes, put new offset back in; MOVEM U1,@40 ;store result JRST UUORET UDBPT1: MOVEI U2,44 ;outside word. get # bits in wd. IDIV U2,U3 ;get u2=#bytes in wd.,u3=remainder, i.e.# bits remaining DPB U3,[360600,,U1] ;at low end. store as new offset. HRRI U1,-1(U1) ;get addr-1 pointed to, and store in result. MOVEM U1,@40 ;and store result JRST UUORET ;and return ; PTSKIP AC,[byte ptr] Skips (increments) byte ptr in E by ; # of chars specified in AC. Assumes 7-bit bytes. Works for ; both positive and negative skip values. UUODEF PTSKIP,U7SKP U7SKP: MOVE U1,@40 ;get c(e) LDB U2,[$ACFLD,,40] ;get ac MOVEI U3,(U1) ;get rh of ptr IMULI U3,5 LDB U4,[360300,,U1] ADD U3,U7BPTB(U4) ;convert to canonical form ADD U3,(U2) ;add in desired change IDIVI U3,5 ;now change back from canonical HRR U1,U3 ;store new addr TLZ U1,770000 ;mask off old p SUB U1,U7BPT2(U4) ;put in new p (with maybe a -1 corr to the addr) MOVEM U1,@40 ;store new ptr. JRST UUORET U7BPT2: 770000,,1 ;0 chs left in wd, produce 5 chs in this addr-1 (p=01) 430000,,0 ;produce p=35 520000,,0 ;p=26 610000,,0 ;p=17 700000,,0 ;p=10 (4 chs in wd) ; PTRDIF AC,[byte ptr] Pointer difference. Takes two byte ptrs, ; one in E and the other from AC, and returns in AC the character position ; difference (E ptr)-(AC ptr). Assumes 7-bit bytes. Can return positive ; or negative values. Don't clobber U4 before reading args. UUODEF PTRDIF,U7PTDF U7PTDF: LDB U3,[$ACFLD,,40] MOVE U1,(U3) ;get c(ac) (1st ptr) MOVE U2,@40 ;get c(e) (2nd ptr) PUSHJ P,U7PDIF ;mung them MOVEM U1,(U3) ;store result back in ac JRST UUORET ; UUO handler internal routine. ;takes two byte ptrs in u1,u2 and returns difference u2-u1 in u1. ;clobbers U4!! U7PDIF: LDB U4,[360300,,U1] ;get low 3 bits of p (4,5,6,7,0,1) MOVEI U1,(U1) ;get rh IMULI U1,5 ADD U1,U7BPTB(U4) ;add in proper # chars as indicated by p LDB U4,[360300,,U2] MOVEI U2,(U2) IMULI U2,5 ADD U2,U7BPTB(U4) ;both ptrs now in 'canonical' form (# chs from 0) SUBM U2,U1 ;get diff u2-u1 into u1 POPJ P, ;and return that. ; # chs in wd p (index is lower 3 bits) U7BPTB: 4 ;10 5 ;01 0 0 0 ;44 1 ;35 2 ;26 3 ;17 IFN USCALL,[ UUODEF .ECALL,UCALL ;performs special .call error hacking DEFINE ECALL LOC,LIST .ECALL [LOC IRP ITEM,,[LIST] IRP ERRCOD,VECTOR,[ITEM] IFSN ERRCOD,*, ERRCOD,,VECTOR .ELSE [IRP EC,VC,[VECTOR] EC,,VC(400000) ? .ISTOP ? TERMIN ] .ISTOP ? TERMIN TERMIN 0] TERMIN UCMAXR: 10 ;holds max. no. of times to re-try call (for '*' spec) UCSLEP: 30.*30. ;holds time to sleep between re-tries (for '*' spec) UCECOD: 0 ;holds error code from ucall UCECNT: 0 ;holds a retry count for whatever wants to use it. ecall clears ;whenever it wins. UCALL: SETOM UCLFLG' ;clear flag to indicate from outside UCALL1: MOVE U1,@40 ;get ptr to call .CALL (U1) ;execute the call CAIA ;aha, failed...go do our stuff JRST UCALWN ;won, return straightaway HRRZ U2,40 ;get ptr-1 to errlist AOJ U2, .SUSET [.RBCHN,,U1] ;get chan # MOVE U3,[.STATUS U3] ;set up instr DPB U1,[$ACFLD,,U3] ;put in chan # XCT U3 ;and get status word into u3 LDB U1,[$ERRCD,,U3] ;and isolate error code. MOVEM U1,UCECOD ;store code UCALL2: MOVE U1,(U2) ;get errlist entry JUMPE U1,UCALSE HLRZ U3,U1 ;get lh into u3 ANDI U3,777 ;take 3.9-3.1 as error field CAME U3,UCECOD ;matches .call error? AOJA U2,UCALL2 ;no match, keep searching errlist JUMPL U1,UCALL3 ;ah, match! if 4.9 bit set, use repeat hackery JRST (U1) ;else just go to specified neutral place. UCALL3: AOSE UCLFLG ;set flag and skip if wasn't set already JRST UCALL4 ;if it was, just repeat MOVE U3,UCMAXR ;first time...get repeat count MOVEM U3,UCECNT ;store in countdown reg UCALL4: SOSGE UCECNT JRST (U1) ;counted out. go to addr specified. MOVE U3,UCSLEP ;get sleep time .SLEEP U3, JRST UCALL1 ;now try again. UCALWN: SETZM UCECOD ;clear error code AOS UUOH ;to win, skip UCALSE: SETZM UCECNT ;zero loss count JRST UUORET ;return ] ;end of ifn uscall UUODEF OUTOPN,UCHOPN ;opens output 'channel' (byte or real) UUODEF OUTPTV,UCHPTV ;returns chan. ptr value (.access) in e UCOPTB: BLOCK 20 ;holds operation for channel UCOP2: BLOCK 20 ;holds auxiliary op for channel UCHSTB: BLOCK 20 ;holds state (byte ptr) or area # UCHCNT: BLOCK 20 ;holds countdown of chars outputted UCHTYP: BLOCK 20 ;holds type of chan (0=.iot, 1=byte, 2=area byte) ; (3 = xct) ;formats: ; outopn ch, ;uses .iot ch, ; outopn ch,[2,,[byte ptr]] ;uses idpb starting at ptr ; outopn ch,[1,,[instr]] ;xct's the instr (arg will lie in u1) ; outopn ch,[0,,[area #]] ;uses byte ptr into specified area ; outopn ch,[setz [area #]] ;as above, but clears area (ptr- & cnt-wise) UCHOPN: LDB U3,[$ACFLD,,40] ;get ac field HRRZ U1,40 ;get e JUMPE U1,UCOPN0 ;hack type = .iot MOVE U1,(U1) ; c(e) JUMPL U1,UCOPN4 ;area, but reinit. HLRZ U2,U1 ;get type code JUMPE U2,UCOPN3 ;area, no reinit. CAIN U2,1 JRST UCOPN1 ;type xct CAIN U2,2 JRST UCOPN2 ;type idpb ptr JSR AUTPSY ;if here, called with bad arg. ;type .iot UCOPN0: MOVE U2,[.IOT U1] ;get operation DPB U3,[$ACFLD,,U2] ;store ch # into instr MOVEM U2,UCOPTB(U3) ;store SETZM UCHTYP(U3) ;set type= .iot MOVE U2,[SETZ-1] ;max positive # MOVEM U2,UCHCNT(U3) ;as char countdown. JRST UUORET ;type xct UCOPN1: MOVEI U2,3 MOVEM U2,UCHTYP(U3) MOVE U2,(U1) ;get instr to xct MOVEM U2,UCOPTB(U3) MOVE U2,[SETZ-1] MOVEM U2,UCHCNT(U3) JRST UUORET ;type idpb UCOPN2: MOVE U1,(U1) ;get byte ptr MOVEM U1,UCHSTB(U3) MOVE U2,[IDPB U1,UCHSTB] ;use idpb ADD U2,U3 ;make point to right ptr MOVEM U2,UCOPTB(U3) MOVEI U2,1 MOVEM U2,UCHTYP(U3) ;set type= 1 = byte ptr MOVE U2,[SETZ-1] MOVEM U2,UCHCNT(U3) JRST UUORET IFE UAREAS,[ ;if no area hackery assembled and tried to UCOPN3: JSR AUTPSY ;open channel with areas, lose. UCOPN4: JSR AUTPSY ] IFN UAREAS,[ ;type area, no reinit. UCOPN3: SETZM UCISW' CAIA ;type area, reinit it. UCOPN4: SETOM UCISW MOVE U1,(U1) ;get area # MOVEM U1,UCHSTB(U3) ;store area #, instead of a ptr MOVE U2,[IDPB U1,WARTAB] ;get operation for area-type chan ADDI U2,(U1) ;point to right area slot MOVEM U2,UCOPTB(U3) SKIPE UCISW SKIPA U2,ARTAB(U1) ;if reiniting use start addr of area instead of MOVE U2,WARTAB(U1) ;current write ptr for area TLNN U2,-1 ;do byte-ptr bits already exist in it? HRLI U2,440700 ;if not, insert to make it pt to beg of wd MOVEM U2,WARTAB(U1) ;store back HRRZ U2,U2 ;now get wd addr ADDI U2,1 ;round up in case PUSH P,U2 MOVE U2,ARTAB(U1) ;get start addr of area ADD U2,LARTAB(U1) ;add length to get addr of last+1 wd. MOVE U1,U2 POP P,U2 SUB U1,U2 ;find size available to chan IMULI U1,5. ;# chars worth of room MOVEM U1,UCHCNT(U3) ;store as countdown # MOVEI U2,2 MOVEM U2,UCHTYP(U3) ;set type= 2 = area byte JRST UUORET ] ;end of ifn uareas ; return to e the cnt of chars outputted on channel since ;opened. for chan open on area, returns total chars in area. UCHPTV: LDB U2,[$ACFLD,,40] ;get channel IFN UAREAS,[ MOVE U3,UCHTYP(U2) ;get channel type CAIN U3,2 ;area byte? JRST UCHPT2 ;ugh, go hack ] MOVE U1,[SETZ-1] ;get max. pos. integer SUB U1,UCHCNT(U2) ;subtract current countdown MOVEM U1,@40 JRST UUORET IFN UAREAS,[ UCHPT2: MOVE U3,UCHSTB(U2) ;get area # MOVE U1,ARTAB(U3) ;get starting addr of area HRLI U1,440700 ;form a ptr to start MOVE U2,WARTAB(U3) ;get write ptr into area PUSHJ P,U7PDIF ;find diff between the 2 ptrs MOVEM U1,@40 ;store result JRST UUORET ] ;end of ifn uareas ;all these uuos should not clobber U4 before reading args ;since "FWRITE" macro may be using U4 to set up uuo calls. UUODEF OUTI,U7I ;outputs e as char (immediate) UUODEF OUTZ,U7Z ;outputs asciz string starting at e UUODEF OUTC,U7C ;outputs e=> # chars,,string-addr UUODEF OUTPZ,U7PZ ;thinks byte ptr to asciz string is at e UUODEF OUTPC,U7PC ;thinks e=> # chars,,[byte-ptr] UUODEF OUT6F,U6F ;f for files. types out 6bit wd at e, without trailing blanks UUODEF OUT6W,U6W ;outputs full 6-bit wd at E UUODEF OUN10,UN10 ;outputs decimal value at E, with point. UUODEF OUN9,UN9 ;outputs like OUN10 but without decimal point UUODEF OUN8,UN8 ;outputs octal value at e UUODEF OUNRH,UNRH ;outputs rh as 6 octal chars. UUODFA CRLF,UCRLF ;outputs a cr-lf, ignores E. ;standard output sequence for a byte (char, wd, etc) IFN UAREAS,[ DEFINE STDOUT SOSGE UCHCNT(U2) PUSHJ P,UCHMP XCT UCOPTB(U2) TERMIN ] IFE UAREAS,[ DEFINE STDOUT XCT UCOPTB(U2) TERMIN ] U7I: UIOINIT ;set up HRRZ U1,40 ;get e STDOUT ;output JRST UIORET U7Z: UIOINIT ;entry pt for outz MOVE U3,40 ;get addr of string HRLI U3,440700 ;form byte ptr JRST U7Z2 U7PZ: UIOINIT ;entry pt for outpz MOVE U3,@40 ;get byte ptr JRST U7Z2 U7Z1: IFN UAREAS,[ ;output char. SOSGE UCHCNT(U2) JRST [ MOVEM U3,UBMPSP ;must check ptr for bumpage PUSHJ P,UCHMP MOVE U3,UBMPSP JRST .+1] XCT UCOPTB(U2) ] IFE UAREAS, XCT UCOPTB(U2) U7Z2: ILDB U1,U3 ;get input char JUMPN U1,U7Z1 ;loop til asciz end JRST UIORET U7PC: UIOINIT ;entry pt for outpc MOVE U3,@40 ;get cnt,,[bptr] HLRZ U4,U3 ;get cnt MOVE U3,(U3) ;get the bptr JRST U7C1 U7C: UIOINIT ;entry pt for outc MOVE U3,@40 ;get cnt,,stringloc U7C0: HLRZ U4,U3 ;get cnt HRLI U3,440700 ;form ptr in u3 ;bptr in u3, cnt in u4 U7C1: MOVN U1,U4 ;get neg of cnt ADDM U1,UCHCNT(U2) ;add to countdown for chan IFN UAREAS,[ SKIPGE UCHCNT(U2) ;skip if ok JRST [ MOVEM U3,UBMPSP ;else bump. must check ptr for bumpage PUSHJ P,UCHMP MOVE U3,UBMPSP JRST .+1] ] JRST U7C3 ;jump into loop U7C2: ILDB U1,U3 ;get char XCT UCOPTB(U2) ;output U7C3: SOJGE U4,U7C2 JRST UIORET UCRLF: UIOINIT MOVEI U1,^M STDOUT MOVEI U1,^J STDOUT JRST UIORET UN10: UIOINIT MOVE U3,@40 ;get # MOVEI U4,10. PUSHJ P,UNTYP MOVEI U1,". STDOUT ;output decimal pt. JRST UIORET UN8: UIOINIT MOVE U3,@40 ;get arg before clobbering u4 MOVEI U4,8. PUSHJ P,UNTYP JRST UIORET UN9: UIOINIT MOVE U3,@40 MOVEI U4,10. ; " " 10 PUSHJ P,UNTYP JRST UIORET UNTYP: MOVEM U4,URADIX JUMPGE U3,UNTYP1 MOVM U3,U3 ;if negative MOVEI U1,"- STDOUT ;output minus sign UNTYP1: IDIV U3,URADIX JUMPE U3,UNTYP2 PUSH P,U4 PUSHJ P,UNTYP1 POP P,U4 UNTYP2: MOVEI U1,"0(U4) ;put char in u1 STDOUT POPJ P, U6W: UIOINIT MOVE U4,@40 ;get 6bit wd MOVEI U3,6 ;count MOVEM U3,U6WCNT' U6W1: SETZ U3, LSHC U3,6 ;get 6bit char MOVEI U1,40(U3) ;cvt into u1 STDOUT ;output SOSLE U6WCNT JRST U6W1 JRST UIORET URADIX: 0 ;holds radix for # output U6F: UIOINIT MOVE U4,@40 ;get 6bit wd JUMPE U4,U6F2 ;jump if nothing (ie ignore trailing blanks) U6F1: SETZ U3, LSHC U3,6 MOVEI U1,40(U3) STDOUT JUMPN U4,U6F1 U6F2: JRST UIORET UNRH: UIOINIT HRLZ U4,@40 MOVEI U3,6 ;cnt of chars to output MOVEM U3,U6WCNT UNRH1: SETZ U3, LSHC U3,3 MOVEI U1,"0(U3) STDOUT SOSLE U6WCNT JRST UNRH1 JRST UIORET IFN UAREAS,[ ; routine executed when run out of room in area being written into. UCHMP: PUSHAE P,[U1,U3,U4] IFN USTRGS,[ CAIE U2,STRC ;string output channel? JRST UCHMP2 ;nope, proceed normally PUSHJ P,USTRGC ;ugh, yes. Go see about GC'ing. JRST UCHMP2 ;didn't GC, proceed normally and expand ADDB U1,UCHCNT(U2) ;GC'd! Add in cnt of chars now available JUMPGE U1,UCHMP7 ;and exit if have enough now ;else drop thru to normal expansion. UCHMP2:] MOVM U3,UCHCNT(U2) ;get # chars needed ADDI U3,4 IDIVI U3,5 ;round up to # wds needed (clobbers u4) MOVEM U3,ARUNIT ;insert # as arg to uabump MOVE U1,UCHSTB(U2) ;get area # to add core to MOVE U4,LARTAB(U1) ;save old length of area PUSHJ P,UABUMP ;go bumpit ;now find new char countdown value MOVE U3,LARTAB(U1) ;get new length of area SUB U3,U4 ;find how much more we have now SKIPG U3 JSR AUTPSY IMULI U3,5 ;convert into # more chars ADDB U3,UCHCNT(U2) ;add into countdown SKIPGE U3 ;skip if have exact or surplus am't JSR AUTPSY ;and fail if it didn't work. UCHMP7: POPAE P,[U4,U3,U1] POPJ P, ] ;end of ifn uareas IFN UFLOAT,[ UUODEF OUNFLT,UNFL10 ;outputs floating decimal value at e UNFL10: .BEGIN FLOAT T==1 ;t,tt,d must be sequential TT==T+1 D==TT+1 C==4 F==5 UIOINIT MOVE U3,@40 PUSHAE P,[T,TT,C,D,F] PUSHJ P,UNFO POPAE P,[F,D,C,TT,T] JRST UIORET ;this routine stolen from maclisp. UNFO: MOVE T,U3 JUMPGE T,UFP1 MOVEI U1,"- STDOUT MOVN T,U3 UFP1: SETZB TT,C ;at fp3, tt will hold possibly additional CAMGE T,[.01] ;significant binary digits of number JRST UFP4 ;at this time, c is indicator to fp4 CAML T,[1.0^8] ;c=0 => negative exponent [x < 1.0e-2] AOJA C,UFP4F0 ;c=1 => positive exponent [x > 1.0e+8 - 1] CAMGE T,[1.0] JRST UFP3B PUSHJ P,UFPL10 ;<# of digits to left of .>+1 will now be in f SUBI F,9 UFP3: SETZB TT,D ASHC T,-27. ;split exponent part off ASHC TT,-243(T) ;split number into integral and fractional part MOVNS F ;f now holds # of digits to print to right of . PUSH P,F MOVSI F,200000 ;compute position of last significant bits ASH F,-243+1+<43-27.>(T) PUSH P,F MOVEM TT+1,UFPTEM MOVE U3,TT MOVEI U4,10. PUSHJ P,UNTYP MOVEI U1, ". STDOUT POP P,TT EXCH TT,UFPTEM POP P,C UFP3A: MOVE T,TT MULI T,12 MOVE F,UFPTEM IMULI F,10. CAMGE TT,F JRST UFPX0 MOVN D,F TLZ D,400000 CAMLE TT,D AOJA T,UFPX0 ;last sig digit, but round upwards CAIN C,2 ;on ninth output digit, use only half a digit ASH F,-1 ;for end-of-precision test MOVEM F,UFPTEM PUSHJ P,UFPX0 SOJG C,UFP3A POPJ P, ;last significant digit, so stop UFPTEM: 0 UFPX0: MOVEI U1,"0(T) STDOUT POPJ P, UFP3B: MOVNI F,10. CAML T,[.1] ;.1 .le. x < 1.0 JRST UFP3 SOJA F,UFP3 ;.01 .le. x < .1 UFP4: JUMPN T,UFP4F ;floating point "e" format PUSHJ P,UFP4A ;clever way to print out 0.0 quickly MOVEI U1,". STDOUT UFP4A: MOVEI U1,"0 STDOUT POPJ P, UFP4F0: MOVEI C,UFP4B2-UFP4B1 ;positive exponent UFP4F: MOVEI F,1 JUMPE C,UFP4E UFP4E0: FDVL T,UFP10.0 FDVRI T+1,(10.0) FADL T,T+1 CAML T,UFP10.0 AOJA F,UFP4E0 JRST UFP4B UFP4E: FMPRI T+1,(10.0) MOVEM T+1,T+2 ;double-precision mul by 10.0 until FMPL T,UFP10.0 ;product is .ge. 1.0 UFA T+1,T+2 ;keeping count in f FADL T,T+2 CAMGE T,UFP1.0 AOJA F,UFP4E UFP4B: PUSH P,F ;f has "e" type exponent ADDI C,UFP4B1 PUSH P,C ;"+" or "-" for output SETZ TT, MOVNI F,8 PUSHJ P,UFP3 ;number has been normalized for 1.0 .le. x < 10.0 MOVEI U1,"E STDOUT POPJ P, ;go to fb4b1 or fp4b2 UFP4B1: MOVEI U1,"- STDOUT JRST UFP4B3 UFP4B2: MOVEI U1,"+ STDOUT UFP4B3: POP P,TT ;exponent value MOVE U3,TT MOVEI U4,10. PJRST UNTYP ;off to popj-return UFPL10: MOVEI F,8 CAMGE T,UFP1.0-1(F) SOJG F,.-1 POPJ P, UFP1.0: REPEAT 8,1.0^.RPCNT UFP10.0=UFP1.0+1 .END FLOAT ];end of ifn ufloat IFN USTRGS,[ ; Strings are represented by a 2 descriptor words in the following ;SAIL-type format: ; : ,,<# chars> ; (ILDB gets 1st char) ; For constant strings, whose descriptors can be stored anywhere, ; should be 0. Variable string descriptors are stored in a table ;beginning at STRNGS and containing NSTRS string variables. ;The macro STRNAM creates an entry in this area at assemble ;time with the label , and will be some unique index ;when the string is not null. Initializing the string hackery with ;a PUSHJ P,USINIT has the side effect of setting all variable strings null. ;(NOTE: References to a variable string should be by address of its descriptors, i.e. ; its name, since it is possible for the byte pointer to change ; unexpectedly due to expansion or shifting of the core area containing ; the strings, as well as to GC'ing of the stringspace!!) ;BCONC is used to begin forming a string; output operations on ;channel STRC will then be accumulated into a string which is ;formally stored by ECONC. ; The string variable table must be declared, anytime after ; all STRNAM's have been processed, as ; STRNGS: SBLOCK ; ; NSTRS==<.-STRNGS>/2 IFNDEF STRC,STRC==0 ;standard output channel for forming strings STRNAM UCNCST ;string descriptor used during concatenation. NULSTR: 0 ? 0 ;standard null string. USTRAR: -1 ; # of area with actual strings USTRWA: 0 ;addr of wartab entry for string area (easier lookup) USTIDX: 0 ;AOS'd to produce gensym index for new string. ; routine to initialize string hackery. USINIT: PUSH P,U1 UARCLS USTRAR ;close any previous string area. UAROPN U1, ;open string area MOVEM U1,USTRAR ;store # ADDI U1,WARTAB ;get addr of wartab entry for this area MOVEM U1,USTRWA ;and store for easier lookup OUTOPN STRC,[SETZ USTRAR] ;open standard string channel SETZM USTIDX ;clear gensym counter for string index SETZM STRNGS ; zero 1st wd of string var table, and MOVE U1,[STRNGS,,STRNGS+1] ;propagate to BLT U1,STRNGS+-1 ;nullify entire string var table. MOVE U1,@USTRWA ;get current bp to stringspace MOVEM U1,UCNCST+1 ;and store to initialize conc string; also, SETOM UCNCST ;make 1st desc. wd unequal to any other string's. POP P,U1 POPJ P, ; BCONC starts composing new string, beginning with given one ; (if E zero, null string used.) UUODFE BCONC,UBCONC UBCONC: HRRZ U1,40 ;get addr of string to begin with CAIN U1,0 ;if creating fresh string, MOVEI U1,NULSTR ;use null string as initial. MOVE U2,(U1) ;get 1st wd of string descriptor CAMN U2,UCNCST ;initial string same as one last written on top? JRST UUORET ;yes, nothing to do. ;must copy initial string over again -- first set up new temp string MOVE U4,@USTRWA ;get current byte ptr to top MOVEM U4,UCNCST+1 ;store as beginning ptr AOS U4,USTIDX ;increment and get unique index # HRLZM U4,UCNCST ;and store as 1st wd of descriptor, char cnt=0 ;now copy string over TRNN U2,-1 ;skip if count non-zero JRST UBCNC4 ;else skip write-over since it's nullish string. PUSHAE P,[40,UUOH] ;save since we want to execute UUO within UUO handler OUTS STRC,(U1) ;write over POPAE P,[UUOH,40] UBCNC4: JRST UUORET ;all done ; ECONC makes describe the string concatenated thus far UUODFE ECONC,UECONC UECONC: MOVE U2,@USTRWA ;get byte ptr to top MOVE U1,UCNCST+1 ;compare with ptr to beginning of string PUSHJ P,U7PDIF ;get # chars in string in U1 MOVE U2,UCNCST ;get 1st wd of descriptor MOVE U3,UCNCST+1 ;and 2nd HRR U2,U1 ;insert char cnt MOVE U4,40 ;get addr of string var to store in MOVEM U2,(U4) ;store the 2 descriptor wds. MOVEM U3,(U4)+1 JRST UUORET UUODEF OUTS,U7S ;outputs stringvar at e U7S: UIOINIT MOVE U1,40 ;get addr to string descriptor MOVE U3,(U1)+1 ;get byte ptr HRRZ U4,(U1) ;get char cnt JUMPN U4,U7C1 ;jump into output rtn JRST UIORET ;return if null string. ; string garbage collector; determines if strings should ;actually be GC'd or not, and does dirty work if necessary. USTRGC: PUSHAE P,[U1,U2,U3] MOVSI U3,-NSTRS SETZ U2, ;zero cumulative # of chars USGC2: MOVE U1,STRNGS(U3) ;get 1st descriptor for string ADDI U2,(U1) ;add in char cnt. ADDI U3,1 AOBJN U3,USGC2 ;U2 now has # chars actually used in string space... ;must determine whether or not to munch. POPAE P,[U3,U2,U1] ;for time being, don't. POPJ P, ] ;end of ifn ustrgs IFN UAREAS,[ ; uuo routines for hairy new storage allocation experiment UUODEF UAINIT,UXINIT ;initializes area tables and defines space available. UUODEF UAROPN,UXOPN ;open area UUODEF UARCLS,UXCLS ;close area UUODEF UAREXP,UXEXP ;expand area MAXARS==40 ;max # areas ARBLK==100 ;100 wds minimum per area ARHIGH: 0 ;index of infinity area-- holds all free wds in top core space ARUNIT: 0 ; arg to expansion rt, amt to expand area by. ARTAB: BLOCK MAXARS+1 ;starting addr of area LARTAB: BLOCK MAXARS+1 ;length of area (wds) 0=null, -#=free (# is wds free) RARTAB: BLOCK MAXARS ;ptrs to read from area WARTAB: BLOCK MAXARS ;ptrs to write into area TARTAB: BLOCK MAXARS ;type of area ( + ascii, - wds, 0 undef) |type|>1 = zapit LARTBS==.-ARTAB ;# wds in tables ;the output uuo's which use ac as a channel number will ;have another type of channel in addition to actual ;i/o and general byte; the outopn uuo will accept the format ; outopn ch,[area #] ;and output by idpb'ing the wartab pointer. this is the most useful mode. ;uainit [-<# pgs>,,] defines space available for area hackery, ;and initializes tables thusly. UXINIT: MOVE U1,@40 PUSHJ P,CORINI ;initialize core blocks. SETZM ARTAB MOVE U1,[ARTAB,,ARTAB+1] BLT U1,ARTAB+LARTBS-1 ;zero all tables SETZM ARHIGH ;initial index HRRZ U2,@40 ;get first page # MOVEM U2,USTPAG ;store as first page in core space MOVEM U2,UFFPAG ;and currently first free page. MOVEM U2,UNXPAG ;and add later to upgnum to get # of 1st nxm page LSH U2,10. ; *2000 to get addr of first wd. MOVEM U2,UFFPGW ;and store as currently first free page addr HLRE U2,@40 ;get -<# pgs> MOVNS U2 MOVEM U2,UPGNUM ;store # pages in core space ADDM U2,UNXPAG ;store ustpag+upgnum JRST UUORET ;done USTPAG: 0 ;holds # of first page in core space UPGNUM: 0 ;holds # of pages in core space UNXPAG: 0 ;holds ustpag+upgnum. uffpag should never exceed this. UFFPAG: 0 ;holds current # of first free page UFFPGW: 0 ;holds current addr of first free page (uffpag*2000) UCBLKE: 0 ;holds err code for failing corblk ;uaropn ac,[type,,[foo]] creates area with at least foo words of storage, ; puts area # in ac. type is 0 for char (ascii) or 4 for wd (image) ; uaropn ac, is eqv. to uaropn ac,[0,,[arblk]] %ARTYP==4 ;flag bit UXOPN: HRRZ U4,40 ;get e CAIN U4,0 ;if zero, SKIPA U4,[0,,[ARBLK]] ;furnish default arg. of char-type, 100 wds MOVE U4,(U4) ;else just get c(e) = type,,[# wds desired] HRRZ U1,(U4) ;get # wds (at least) desired for storage area ADDI U1,ARBLK-1 IDIVI U1,ARBLK ;round up to blks of minimum length SKIPG U1 ;if nonsense or zero arg, MOVEI U1,1 ;use 1 block of minimum length IMULI U1,ARBLK MOVE U2,U1 MOVEM U1,ARUNIT ;store as # wds storage needed for area MOVSI U3,-MAXARS UXOPN1: SKIPG ARTAB(U3) ;area free? JRST UXOPN2 ;yup, found one. AOBJN U3,UXOPN1 JSR AUTPSY ;out of areas?!?! UXOPN2: MOVE U1,ARUNIT ;get # wds needed PUSHJ P,CORGET ;get block of that much MOVEM U2,ARTAB(U3) ;store starting addr MOVEM U1,LARTAB(U3) ;store length MOVE U1,U3 ;put artab index in U1. SETOM TARTAB(U1) ;make type=wds TLNE U4,10 ;is bit set for zappage? JRST [ SOS TARTAB(U1) ;yes, make -2 MOVE U2,ARTAB(U1) ;and clear area. get start addr HRLS U2 AOJ U2, ;get ,, as ,, HLRZ U3,U2 ADD U3,LARTAB(U1) ;get last+1 addr. SETZM -1(U2) ;clear first BLT U2,-1(U3) ;now clear all. JRST .+1] TLNN U4,4 ;is bit set for type=wds? skip if so MOVNS TARTAB(U1) ;unless specified char, in which case make pos. MOVE U2,ARTAB(U1) ;get start addr of area for ptr SKIPLE TARTAB(U1) ;if char type, HRLI U2,440700 ;then make it byte ptr MOVEM U2,RARTAB(U1) ;set r/w ptrs. MOVEM U2,WARTAB(U1) LDB U2,UACFLD ;now to return value, get ac field HRRZM U1,(U2) ;return index JRST UUORET ; uarcls [area #] - close area, free it up UXCLS: MOVE U1,@40 ;get area desired to close CAIL U1,0 ;check index. CAILE U1,MAXARS JRST [CAMN U1,[-1] ;bad arg, but ignore quietly if JRST UUORET ;-1 is the arg. JSR AUTPSY] ;else die so can debug SETOM @40 ;clear area # SKIPG LARTAB(U1) ;skip if open JRST UUORET ;and do nothing if already nil or free. MOVE U2,U1 ;save idx MOVE U1,ARTAB(U1) ;get start addr of area PUSHJ P,CORREL ;release it! SETZM ARTAB(U2) SETZM LARTAB(U2) ;zero table info. JRST UUORET UUODEF UARTYP,UXTYP ;uartyp [type,,[#]] changes to that type. ;later, may want to add zappage bit handling. UXTYP: MOVE U2,@40 ;get type,,[#] MOVE U1,(U2) ;get area # HLRZ U2,U2 ;type into rh JUMPE U2,UXTYP5 ;jump if type = ascii CAIE U2,4 ;skip if type = bin JSR AUTPSY ;neither?? ;type desired = bin SKIPGE U2,TARTAB(U1) ;already binary? JRST UUORET ;yes SETOM TARTAB(U1) ;set new type MOVE U2,WARTAB(U1) ;get current write ptr TLNN U2,-1 ;anything in lh? JRST UXTYP2 ;if not, don't mung write ptr LDB U3,[360600,,U2] ;isolate the p field of ptr CAIE U3,44 ;is it pointing to beg of wd? ADDI U2,1 ;no, use addr+1. HRRZM U2,WARTAB(U1) ;then store addr above last char. UXTYP2: MOVE U2,RARTAB(U1) TLNN U2,-1 JRST UUORET LDB U3,[360600,,U2] CAIE U3,44 ADDI U2,1 HRRZM U2,RARTAB(U1) JRST UUORET ;done ;type desired = char UXTYP5: SKIPLE U2,TARTAB(U1) ;already ascii? JRST UUORET ;yes SETOM TARTAB(U1) MOVNS TARTAB(U1) ;set new type (pos.) HRRZ U2,WARTAB(U1) ;get current write addr SUB U2,ARTAB(U1) ;find # wds IMULI U2,5 ;find upper limit of chars HRRZ U3,WARTAB(U1) HRLI U3,350700 ;form ptr to first after last possible char position ;now loop til find true end of area (disregard nulls, ^c's, ^l's) UXTYP6: MDBPT U3, ;decrement ptr LDB U4,U3 ;get a char CAIE U4,0 ;^@? CAIN U4,^C ;or ^c? SKIPA ;go to sojg if so CAIN U4,^L ;or ^l? SOJG U2,UXTYP6 ;ignore char, loop unless counted out. JUMPLE U2,[SETZ U2, ;if no chars, make things ok MOVE U3,ARTAB(U1) HRLI U3,440700 JRST .+1] MOVEM U3,WARTAB(U1) ;now store correct write ptr MOVE U3,ARTAB(U1) HRLI U3,440700 MOVEM U3,RARTAB(U1) JRST UUORET ;and all done. ;expand area by c(e) words UXEXP: LDB U1,[$ACFLD,,40] ;get ac MOVE U1,(U1) ;get area # MOVE U2,@40 ;get c(e) MOVEM U2,ARUNIT PUSHJ P,UABUMP ;bump up the area dutifully JRST UUORET ; "uabump" - very important routine that does the actual ;expanding of areas which need more room. ;takes index in u1 for area that needs more room; no. of words it ;wants is in arunit. arunit should be some multiple of arblk! ;if |tartab| for area is .gt. 1, clears any core added. UABUMP: SKIPG ARUNIT POPJ P, PUSHAE P,[U1,U2,U3,U4] MOVE U2,ARUNIT ADDI U2,ARBLK-1 IDIVI U2,ARBLK IMULI U2,ARBLK MOVEM U2,ARUNIT MOVE U3,U1 MOVE U1,ARUNIT ;# wds needed MOVE U2,ARTAB(U3) ;start addr of area that needs it PUSHJ P,COREXP ;expand the area. MOVEM U1,UANSIZ' ;save new size CAMN U2,ARTAB(U3) ;is area in same place? JRST UABMP4 ;yes, good... don't have to worry about anything bumped. ;fooey, area was moved, must figure out what sort of BLT did it. ;guaranteed not to overlap, at least. PUSHAE P,[U1,U2,U3] ;save returned size and ptr SUB U2,ARTAB(U3) ;get difference in locations MOVEM U2,UBMPDF' ;save ADDM U2,RARTAB(U3) ;update R/W pointers ADDM U2,WARTAB(U3) MOVE U2,ARTAB(U3) ;now update special stuff. get original addr MOVE U3,LARTAB(U3) ;and original size ADD U3,U2 ;get last+1 of original area. U2, U3 now delimit it. PUSHJ P,UBMPP ;and go bump accding to special stuff table. POPAE P,[U3,U2,U1] UABMP4: MOVEM U2,ARTAB(U3) ;store new beg addr EXCH U1,LARTAB(U3) ;store new size, and recover old length MOVM U4,TARTAB(U3) ;get area type CAIG U4,1 ;if greater than 1, must zero new core. JRST UABMP7 ;nope, just return. ADD U1,U2 ;get addr that new core starts at HRL U1,U1 ADDI U1,1 ;get ,, ADD U2,LARTAB(U3) ;get last addr+1 SETZM -1(U1) BLT U1,-1(U2) ;clear new core. UABMP7: POPAE P,[U4,U3,U2,U1] POPJ P, ;does special 'bumping'. ;takes in U2 the original addr, in U3 the original last+1 addr. ;updates stuff in UBPSTB like the ARTAB tables if addr falls ;within range defined by U2 and U3. UBMPP: PUSHAE P,[U1,U4] MOVSI U4,-NSPCAS ;aobjn thru table of special locs to bump UBMPP5: MOVE U1,UBPSTB(U4) ;get place of addr to check MOVE U1,(U1) ;get addr to check SKIPGE UBPSTB(U4) ;see if must increment a byte ptr IBP U1 ;yes (see comments below) HRRZ U1,U1 ;want only RH CAML U1,U2 ;not inside if ptr less than start CAML U1,U3 ;not inside if ptr ge than first non-block addr JRST UBMPP6 ;not inside ; Note possibility of lossage if one tries to check a ILDB/IDPB byte ptr of form ; 010700,,ADDR since while it really refers to something in ADDR+1, it will be ;seen here as belonging to ADDR, and if U2 or U3 contains ADDR+1 then the ;pointer will respectively not get updated, or clobbered by unnecessary ;'updating'. Solution is to do a temporary IBP on such things if ;they are known to be ILDB/IDPB ptrs. HRRZ U1,UBPSTB+1(U4) ;inside! get addr of routine to do PUSHJ P,(U1) ;do it. UBMPP6: ADDI U4,1 AOBJN U4,UBMPP5 UBMPP9: POPAE P,[U4,U1] POPJ P, ;bumpage check table UBPSTB: SETZ UBMPSP [MOVE U1,UBMPDF ? ADDM U1,UBMPSP ? POPJ P,] IFN USTRGS,[ SETZ UCNCST+1 USTBMP ;check for stringspace getting bumped. ] IFN ULISTS,[ SETZ UQBMPP [MOVE U1,UBMPDF ? ADDM U1,UQBMPP ? POPJ P,] QSARST [MOVE U1,UBMPDF ? ADDM U1,QSARST ? POPJ P,] ISARST [MOVE U1,UBMPDF ? ADDM U1,ISARST ? POPJ P,] QLARTB [MOVEI U1,QLARTB ? PJRST LSARBP] ILARTB [MOVEI U1,ILARTB ? PJRST LSARBP] ] NSPCAS==<.-UBPSTB>/2 UBMPSP: 0 ;holds special ptr for output uuos IFN ULISTS,[ UQBMPP: 0 ;holds byte ptr for uqstor uuo LSARBP: PUSH P,U2 MOVE U2,UBMPDF ;diffference to be added HRLI U1,-2*17 ;length of list/string table ADDM U2,(U1) AOBJN U1,.-1 POP P,U2 POPJ P, ] IFN USTRGS,[ ;stringspace bumped, adjust all byte ptr addrs. USTBMP: PUSH P,U2 MOVE U1,UBMPDF MOVSI U2,-NSTRS ADDM U1,STRNGS+1(U2) ;bump up addr of string's byte ptr ADDI U2,1 AOBJN U2,.-2 POP P,U2 POPJ P, ] IFN 0,[ ; single-wd unconstrained-addressing access of area. IRP N,,[1,2]L,,[A,B] UUODEF ARSET!L,UXINI!N UUODEF L!MOVE,UX!N!E UUODEF L!MOVEM,UX!N!EM UUODEF L!MOVEI,UX!N!EI UXINI!N: MOVE U1,@40 ;get area # MOVEM U1,UXAR!N MOVE U2,ARTAB(U1) ;get its loc. HLL U2,[MOVE-!L!MOVE] ;get complete add-in MOVEM U2,UXIDX!N HLL U2,[MOVEM-!L!MOVEM] MOVEM U2,UXODX!N HLL U2,[MOVEI-!L!MOVEI] MOVEM U2,UXADX!N MOVE U2,LARTAB(U1) ;get rel start addr of next higher area MOVEM U2,UXARL!N JRST UUORET UXADX!N: 0 ;add-in for "movei" UXIDX!N: 0 ;add-in for "move" UXODX!N: 0 ;add-in for "movem" UXAR!N: 0 ;area # UXARL!N: 0 ;area length UX!N!EI: MOVE U1,40 ;get instr ADD U1,UXADX!N XCT U1 JRST UUORET UX!N!E: MOVE U1,40 ;get instr ADD U1,UXIDX!N ;add stuff in to form "move ac,right-addr" XCT U1 JRST UUORET UX!N!EM: HRRZ U2,40 ;get address about to write into CAML U2,UXARL!N ;compare with length of area JRST [MOVE U1,UXAR!N SUB U2,LARTAB(U1) MOVEM U2,ARUNIT PUSHJ P,UABUMP JRST .+1] ;ugh, must bump MOVE U2,40 ADD U2,UXODX!N XCT U2 JRST UUORET TERMIN ] ;end of IFN 0. ] ;at long last, end of ifn uareas. IFN UAREAS, .INSRT DSK:KSC;CORSER > IFN ULISTS, .INSRT DSK:KSC;ulists > CONSTANTS ;so uuo stuff doesn't muck up anything else VARIABLES [SUBTTL HAIRY LIST HANDLING UUO'S - description ; Well, maybe later I'll explain some more. ; special macro to simulate start addr of current list area. ;note must say listar(0) instead of listar, and listar(x)+1 ;instead of listar+1(x) better than nothing tho. DEFINE LISTAR ?IDX @2*IDX(L)TERMIN DEFINE QLSTAR ?IDX @2*IDX(Q)TERMIN DEFINE LITSTR STRING [ASCNT [STRING]]TERMIN SUBTTL QB copying routines - QCOPY, QBCOPY, QXCOPY, QZCOPY ; QCOPY AC,[ptr] ptr points to a list which is to be completely ; copied in the L-area; a ptr to the new list ; is left in AC. UUODEF QCOPY,UQCOPY UQCOPY: MOVE U1,@40 ;get ptr PUSH P,Q MOVE Q,L PUSHJ P,UQCPY ;copy it, leave ptr in u1 POP P,Q LDB U2,UACFLD MOVEM U1,(U2) ;store JRST UUORET ; QBCOPY AC,[ptr] like QCOPY, but ignores the CDR; i.e., ; copies only the CAR of list pointed to. L-area to L-area. UUODEF QBCOPY,UBCPY UBCPY: HRRZ U1,@40 JUMPE U1,UUORET PUSH P,LISTAR(U1) PUSH P,U1 HLLZS LISTAR(U1) PUSH P,Q MOVE Q,L PUSHJ P,UQCPY POP P,Q LDB U2,UACFLD MOVEM U1,(U2) POP P,U1 POP P,LISTAR(U1) JRST UUORET ; QXCOPY AC,[ptr] like QCOPY, but new list is copied in Q-area ; instead of the L-area (which original list must be in) UUODEF QXCOPY,UIQCPY UIQCPY: MOVE U1,@40 PUSHAE P,[L,Q] MOVE L,ILARPT MOVE Q,QLARPT PUSHJ P,UQCPY POPAE P,[Q,L] LDB U2,UACFLD MOVEM U1,(U2) JRST UUORET ; QZCOPY AC,[ptr] also like QCOPY, but from Q-area to L-area. UUODEF QZCOPY,UZQCPY UZQCPY: MOVE U1,@40 PUSHAE P,[L,Q] MOVE L,QLARPT MOVE Q,ILARPT PUSHJ P,UQCPY POPAE P,[Q,L] LDB U2,UACFLD MOVEM U1,(U2) JRST UUORET ; UQCPY - internal general purpose list copier used by all of ;above copying UUOs. ;given ptr in u1, copies and leaves new ptr in u1. Thinks it is ;supposed to copy from L-area to Q-area, but base indexes to ;these areas are munged as necessary by the individual UUOs ;before the call. UQCPY: TRNN U1,-1 POPJ P, ;if nil ptr MOVE U2,LISTAR(U1) MOVE U3,LISTAR(U1)+1 ;get both wds of qb EXCH L,Q PUSHJ P,QBPOP ;get free qb, leaves ptr in u1 EXCH L,Q TLNE U2,%QTLST ;list? JRST [ PUSH P,U1 PUSH P,U2 HRRZ U1,U3 PUSHJ P,UQCPY ;recurse MOVE U3,U1 ;get returned ptr POP P,U2 POP P,U1 JRST UQCPY6] TLNE U2,%QTSTR JRST UQCPY8 ;store string, go to uqcpy7 ;consider it a value. UQCPY6: MOVEM U3,QLSTAR(U1)+1 ;store UQCPY7: HLLZM U2,QLSTAR(U1) ;store lh PUSH P,U1 HRRZ U1,U2 PUSHJ P,UQCPY MOVE U2,U1 POP P,U1 HRRM U2,QLSTAR(U1) ;finally store rh POPJ P, ;copy string. auxiliary part of UQCPY. ; u2 and u3 have wds 1 and 2 of qb to be copied. u1 has ptr to free qb to copy into. ;dont clobber u1 or u2. UQCPY8: PUSH P,U2 PUSH P,U3 HRRZ U2,U3 ;get ptr to string MOVE U4,-4(Q) ;get area # writing into. HRR U3,WARTAB(U4) ;form wd 2 of new qb (cnt,,addr) SUB U3,ARTAB(U4) ;make relative MOVEM U3,QLSTAR(U1)+1 ;store it HRR U3,WARTAB(U4) ;make abs again ADD U2,-3(L) ;get abs. addr of string HRL U2,U3 ;store dest. addr in lh MOVSS U2 ;now have source addr,,dest addr HLRZS U3 ;cnt in rh ADDI U3,4 IDIVI U3,5 ;get # wds to xfer ADDM U3,-5(Q) ;add to cnt of wds in string area MOVE U4,-4(Q) ;get area # again ADDM U3,WARTAB(U4) ;and update write ptr now (not after xfer) ADDI U3,(U2) ;add dest addr HRRZS U3 PUSH P,U2 MOVE U2,ARTAB(U4) ADD U2,LARTAB(U4) ;get first non-area addr CAML U3,U2 ;make sure final addr is within area bounds JRST [ EXCH U1,U4 SUB U3,U2 POP P,U2 MOVMM U3,ARUNIT PUSHJ P,UABUMP EXCH U1,U4 POP P,U3 POP P,U2 JRST UQCPY8] POP P,U2 BLT U2,-1(U3) ;and now xfer POP P,U3 POP P,U2 JRST UQCPY7 ;and go hack 1st wd now. SUBTTL List String Comparision UUO's - QSTRE, QUSTRE, LUSTRE ; QSTRE AC,[ptr to string QB] AC must also hold a ptr to a string QB; ; the two strings are compared, and the UUO skips if they're equal. ; Fails to skip if strings are different, of different lengths, or ; if a QB is not string type. ; QUSTRE AC,[ptr to string QB] same, but forces both to upper case during compare. UUODEF QSTRE,UQSTRE UUODEF QUSTRE,UQUSTR UQSTRE: SETZM UQSTRF' ;clear flag (no uppercase force) SKIPA UQUSTR: SETOM UQSTRF' ;set flag for uppercase forcing LDB U1,UACFLD MOVE U1,(U1) ;get acc = ptr MOVE U2,@40 ;get addr = ptr MOVE U3,LISTAR(U1) MOVE U4,LISTAR(U2) TLNN U3,%QTSTR ;be sure type is string JRST UQSTR9 ;lose TLNN U4,%QTSTR JRST UQSTR9 ;ditto MOVE U3,LISTAR(U1)+1 ;get string vals (# cnt,,addr) MOVE U4,LISTAR(U2)+1 ADD U3,-3(L) ;make abs. ADD U4,-3(L) UQSTR4: HLRZ U1,U3 HLRZ U2,U4 ;try comparing cnts first CAME U1,U2 JRST UQSTR9 ;can't be eq if different lengths! MOVEM U1,UQSTRC' ;store cnt to loop on HRLI U3,440700 HRLI U4,440700 UQSTR5: SOSGE UQSTRC JRST UQSTR7 ;through, we've won! ILDB U1,U3 ILDB U2,U4 CAIN U1,(U2) ;skip if fail JRST UQSTR5 SKIPN UQSTRF ;failed, but skip to try uppercase if flag set JRST UQSTR9 CAIL U1,"a CAILE U1,"z CAIA SUBI U1,40 CAIL U2,"a CAILE U2,"z CAIA SUBI U2,40 CAMN U1,U2 ;now that they're forced, try again. JRST UQSTR5 ;win! UQSTR9: JRST UUORET ;return w/o skipping UQSTR7: AOS UUOH JRST UUORET ;won, skip ; LUSTRE AC,[ASCNT /string/] AC must have ptr to a string QB, as for QUSTRE; ; however, comparision is done with the specified string. The advantage ; is that a template string need not be stored in a list-area. ; N.B.: this is uppercase compare!! UUODEF LUSTRE,ULUSTR ULUSTR: SETOM UQSTRF ;uppercase compare LDB U1,UACFLD MOVE U1,(U1) ;get ptr MOVE U2,LISTAR(U1) TLNN U2,%QTSTR ;string type? JRST UUORET ;no, fail. MOVE U3,LISTAR(U1)+1 ;get stringval ADD U3,-3(L) ;make abs MOVE U4,@40 ;get literal stringval(already abs) JRST UQSTR4 ;jump into normal routine. SUBTTL Wonderful Super QB-Creation UUO - MAKEQA !! ; MAKEQA AC,[ ,,[[list-ptr]] make a QB according to args, and leave ; ,,[[QB-value]]] ptr to it in AC. ; ; The nesting of brackets may be confusing, but is less so in practice; ; using the RH to point at a full @(X)E address field allows arguments to ; be indexed and indirected to, and thus list-area addresses can be given. ; - is an arbitrary value which is put in the ATTRIB field of the QB. ; list-ptr - will be inserted in RH of the QB, i.e. what list-ptr points to becomes ; the CDR of that QB. ; - tells the routine what type of QB it is (value, list, string) and how ; to gobble the given QB-value. The defined types are: ; %QTVAL - type VAL, stores QB-val as the value of QB (2nd word). ; %QTLST - type LIST, stores QB-val as a ptr to a list. ; %QTSTR - type STRING, takes QB-val as being ASCNT /string/ and stores. ; %QTBPT - type STRING, takes QB-val as <# chars>,,[b.p. to string] ; %QTSAR - type STRING, takes QB-val as an area # and forms a QB string ; value from the text in that area. ; The right thing is done when various fields are left zero, e.g. saying ; MAKEQA A,[$IARCP,,0 is legal and produces a VAL-type QB with attribute of $IARCP. ; %QTVAL,,0] Its CDR is 0 and its value is 0, because neither arg is accessible. ; STORQA AC,[..etc...] has a format exactly like MAKEQA's, but rather than creating ; a new QB, AC should have a ptr to an existing QB which is clobbered as specified. ; Obviously anything in the QB previous to call is lost. This is actually not a ; very useful UUO. UUODEF MAKEQA,UMAKEQ UUODEF STORQA,USTORQ UMAKEQ: SETOM UMKSTF' ;set flag to create qb to store in. JRST USTOQ1 USTORQ: SETZM UMKSTF ;set flag to use qb ptr given in acc field LDB U1,UACFLD MOVE U1,(U1) ;get qb ptr to store in USTOQ1: MOVE U4,40 MOVE U3,(U4) ;get lh,,[loc-of-cdr-ptr] MOVE U4,1(U4) ;get type,,[loc-of-val] TRNE U3,-1 ;keep cdr nil if already is HRR U3,@(U3) ;else get cdr ptr. TRNN U4,-1 ;ditto for loc-of-val SKIPA U2,[0] ;substitute 0 if no address. MOVE U2,@(U4) ;else get val. TLNN U4,%QTSTR+%QTBPT+%QTSAR ;skip if type is string JRST USTOQ7 ;isn't string. store value/list TLZ U3,%QTALL TLO U3,%QTSTR ;force type to string EXCH U3,U4 ;save 1st wd in u4 TLNE U3,%QTBPT ;is type=byte ptr to string? JRST [ MOVE U3,(U2) JRST USTOQ5] ;yes, get the byte ptr TLNE U3,%QTSAR ;type =string area? JRST [ MOVE U3,ARTAB(U2) HRLI U3,440700 PUSHAE P,[U1,U4] MOVE U1,U3 MOVE U2,WARTAB(U2) ;set up args for ptrdif PUSHJ P,U7PDIF ;compute difference in ptrs MOVE U2,U1 ;save result in U2 POPAE P,[U4,U1] JRST USTOQ6] HRRZ U3,U2 ;no, just form a 440700,,addr HRLI U3,440700 USTOQ5: HLRZ U2,U2 ;count in rh USTOQ6: SKIPE UMKSTF ;alreday have qb ptr? JRST [ MOVEM U3,UQBMPP ;kludgery necessary to ensure ptr correct PUSHJ P,QBPOP ;even if qbpop bumps areas. get ptr in u1 to free qb. MOVE U3,UQBMPP JRST .+1] PUSHJ P,USSTRG ;do it MOVEM U4,LISTAR(U1) ;store 1st wd (usstrg does 2nd) SKIPE UMKSTF JRST USTOQ9 ;last thing to do: return ptr in acc JRST UUORET USTOQ7: HLLZ U4,U4 ;get type,,0 IOR U3,U4 ;put type flag into 1st qb lh SKIPE UMKSTF ;skip if already have qb ptr PUSHJ P,QBPOP ;if not, get one. MOVEM U3,LISTAR(U1) ;store 1st qb wd MOVEM U2,LISTAR(U1)+1 ;store 2nd SKIPE UMKSTF JRST USTOQ9 JRST UUORET USTOQ9: LDB U2,UACFLD ;get # acc (again) MOVEM U1,(U2) ;return ptr in it. JRST UUORET ; USSTRG - auxiliary rtn for MAKEQA. given ;QB ptr in u1, chr cnt in u2, byte ptr in u3, actually writes string ;in string half of L-area and puts relative ASCNT word in the QB. USSTRG: PUSHAE P,[U1,U2,U3,U4] MOVEM U2,USSTT1' ;temp storage for cnt MOVEM U3,USSTT2' ;for byte ptr ADDI U2,4 IDIVI U2,5 ;round up ADDM U2,-5(L) ;add to cnt of wds used in string area. MOVE U4,U1 ;save ptr in u4 MOVE U1,-4(L) ;get # of string area MOVE U3,WARTAB(U1) HRLI U3,440700 MOVEM U3,WARTAB(U1) HRRZ U3,U3 SUB U3,ARTAB(U1) ;make addr rel to start of area HRL U3,USSTT1 ;form #chars,,ptr to be stuck in qb MOVEM U3,LISTAR(U4)+1 ;store in qb MOVE U2,USSTT1 ;char cnt MOVE U3,USSTT2 ;byte ptr PUSHJ P,UXCBLR ;xfer! HLRZ U2,WARTAB(U1) ;check resulting ptr CAIE U2,440700 ;if nothing, skip bump of byte ptr. AOS WARTAB(U1) ;must bump ptr to avoid overwrite next time. POPAE P,[U4,U3,U2,U1] POPJ P, UXCBLR: JUMPE U2,APOPJ PUSHAE P,[U2,U3,U4] MOVE U4,ARTAB(U1) ADD U4,LARTAB(U1) SUBI U4,@WARTAB(U1) ;get # wds left in area ADDI U2,4 IDIVI U2,5 MOVE U3,-1(P) ;restore bpt SUB U4,U2 SKIPG U4 JRST [MOVEM U3,UBMPSP MOVNM U4,ARUNIT PUSHJ P,UABUMP MOVE U3,UBMPSP ;restore possibly bumped ptr. JRST .+1] MOVE U4,-2(P) ;restore cntmo to u4 UXCBL1: PUSH P,U1 MOVE U2,WARTAB(U1) ;get ptr to area ILDB U1,U3 ;get char IDPB U1,U2 ;dep. SOJG U4,.-2 UXCBL3: POP P,U1 MOVEM U2,WARTAB(U1) ;store updated write ptr POPAE P,[U4,U3,U2] POPJ P, SUBTTL List Searching UUO's - FINDQA and FINDAL ; FINDQA AC,[,,[[list-ptr]] ; Searches list pointed to by list-ptr for a QB containing the ; given attribute type, and immediately skips with ptr to it in AC if found. ; Else doesn't skip and AC is meaningless. ; Note that this only searches the "top" of a list, i.e. each CAR. To ; search the whole tree by tracing down through all LIST type QB's, use ; FINDAL. Also note that FINDQA merely returns the first matching ; QB it finds, and there could be more further on in the list. UUODEF FINDQA,UFINDQ UFINDQ: MOVE U3,@40 ;get c(e)= $attr,,[loc] HRRZ U1,@(U3) ;get c(loc)=ptr to first node HLRZ U3,U3 ;put attrib in rh SKIPA UFNDQ1: HRRZ U1,LISTAR(U1) ;get cdr JUMPE U1,UUORET ;stop when reach end of list LDB U2,[$QFLD$,,LISTAR(U1)] ;get attrib of qb pointed to CAIE U2,(U3) ;equal to one we want? JRST UFNDQ1 ;nope, get cdr and continue LDB U2,[$ACFLD,,40] ;get result acc MOVEM U1,(U2) ;store ptr. AOS UUOH ;skip on return JRST UUORET ; FINDAL AC,[,,[[list-ptr]] ; Like FINDQA above, but searches through the entire tree pointed ; to. UUODEF FINDAL,UQFNDA UQFNDA: MOVE U4,@40 ;get c(e)= $attr,,[loc] HRRZ U1,@(U4) ;get c(loc)=ptr to first node HLRZ U4,U4 ;put attrib in rh ;ptr in u1, attrib searched for in u4. SETZM UQFNRT' ;clear loc where result stored PUSHJ P,UQFND ;get um. SKIPG U1,UQFNRT ;get result into u1 if found JRST UUORET ;no. blah. LDB U2,UACFLD ;aha! must store MOVEM U1,(U2) ;in uuo acc AOS UUOH ;and skip JRST UUORET UQFND: TRNN U1,-1 ;skip unless rh=0 POPJ P, MOVE U3,LISTAR(U1) LDB U2,[$QFLD$,,U3] ;get attrib of qb pointed to CAIN U2,(U4) ;equal to one we want? JRST [ HRRZM U1,UQFNRT POPJ P,] ;if so, store tr and return TLNN U3,%QTLST ;still hope if list JRST [ HRRZ U1,U3 JRST UQFND] ;nope PUSH P,U3 HRRZ U1,LISTAR(U1)+1 ;get ptr to list PUSHJ P,UQFND POP P,U3 SKIPLE UQFNRT ;skip unless found something POPJ P, ;if found, return HRRZ U1,U3 ;nope, try cdr. JRST UQFND ; FNDSTR - special macro to search for a QB with specified attribute AND ; having a string value matching the one being sought. Leaves ptr in AC to ;it and skips if found; list-ptr to list is taken from PTRLOC arg. DEFINE FNDSTR AC,PTRLOC,ATTRIB,STRING MOVE AC,PTRLOC FINDQA AC,[ATTRIB,,[AC]] JRST .+4 ;lose, didn't find LUSTRE AC,LITSTR [STRING] JRST [HRRZ AC,LISTAR(AC) ? JRST .-3] CAIA ;found and matches TERMIN SUBTTL Randomness - APPEND UUO ; APPEND [[[list-ptr-A]],,[[list-ptr-B]]] ; (yech!) appends the list pointed to by list-ptr-B to end of the ; list specified by list-ptr-A. Simply stuffs list-ptr-B in as the CDR of ; the last item in list A. UUODFE APPEND,UAPND UAPND: MOVE U1,@40 HLRZ U2,U1 HRRZ U2,@(U2) ;get ptr to list append onto HRRZ U1,@(U1) ;get ptr to qb to tack on it JUMPE U2,[HLRZ U2,@40 ;if nil list, HRRM U1,@(U2) ;store ptr to qb in nil half. JRST UUORET] UAPND1: MOVE U3,U2 HRRZ U2,LISTAR(U3) JUMPN U2,UAPND1 HRRM U1,LISTAR(U3) JRST UUORET SUBTTL Free-list Manipulation Primitives - QBPOP and friends. ; QBPOP - called when want a free qb from list area. ;Returns ptr in U1 to a free qb. QBPOP: PUSH P,U2 QBPOP1: HRRZ U1,-2(L) ;get freelist ptr JUMPE U1,QBPOP2 ;ptr=nil, get more qb's HLRZ U2,-2(L) ;get cnt SOSGE U2 ;decrement JSR AUTPSY ;no more, but error...ptr shoulda been nil! HRL U2,LISTAR(U1) ;get cdr of popped qb MOVSM U2,-2(L) ;store new freelist ptr POP P,U2 POPJ P, ;freelist ptr is nil, see if count also 0 (else error) QBPOP2: HLRZ U2,-2(L) SKIPE U2 JSR AUTPSY ;foo, inconsistency. ;okay, get some more qb's MOVE U1,-1(L) ;get area # MOVEI U2,100*QBLEN MOVEM U2,ARUNIT MOVE U2,LARTAB(U1) ;get rel ptr to new core = length of area. PUSHJ P,UABUMP MOVE U1,U2 ;get back ptr to first new qb PUSHJ P,QBINIT ;initialize rest of area plus freelist ptr JRST QBPOP1 ;now go back and get a qb. ; QBINIT - takes qb ptr in a to be first wd of a section of qb's ;that are to be linked together. it thinks section stops at ;end of list area. should be called only when freelist count = 0 QBINIT: PUSHAE P,[U1,U2,U3] HRRZM U1,-2(L) ;store ptr to first qb of soon-to-be freelist MOVE U3,-1(L) ;get area # MOVE U2,LARTAB(U3) ;get # wds in area SUB U2,U1 ;less ptr IDIVI U2,QBLEN ;find # qb's in remaining wds. MOVE U3,U2 ;save # in c CAIN U2,0 ;check just in case JSR AUTPSY ;shouldn't try to initialize nothing. MOVN U2,U2 HRL U1,U2 ;make aobjn QBINI1: MOVEI U2,QBLEN(U1) ;get ptr to next qb MOVEM U2,LISTAR(U1) ;insert ptr in current qb ADDI U1,QBLEN-1 AOBJN U1,QBINI1 SUBI U1,2 ;point to last qb SETZM LISTAR(U1) ;zap last qb to indicate end. HRLM U3,-2(L) ;store new count (qbinit only called when cnt=0) POPAE P,[U3,U2,U1] POPJ P, SUBTTL More Freelist manipulators (externally called) - QBDEL, QBFREE ; QBDEL - takes ptr in a to a qb, ptr in b to ql having list the qb is on. ;searches for and deletes that qb from that list, putting ;it on freelist. Perhaps make it a UUO somewhen. QBDEL: PUSH P,B MOVEI B,LISTAR(B)+1 ;get abs addr PUSHJ P,QBPLCK PUSHJ P,QBFREE POP P,B POPJ P, QBPLCK: PUSHAE P,[A,B,C] SUB B,(L) ;kludge to use abs adr as loc of ptr to list. HRRZ A,A QBDEL1: MOVE C,B HRRZ B,LISTAR(B) ;get next qb ptr JUMPE B,QBDEL7 ;lossage, end of list CAME A,B ;this it? JRST QBDEL1 ;no, continue MOVE B,LISTAR(B) ;get what dying qb points to HRRM B,LISTAR(C) ;put it in qb above dying one HLLZS LISTAR(A) ;kill qb's cdr so it doesn7t point to rest of list. POPAE P,[C,B,A] POPJ P, QBDEL7: JSR AUTPSY ;QBPLCK called with bad args. ; QBFREE - hairy routine to ;track down everything pointed to by a qb and flush it into freelist. ;takes ptr in A to first node. QBFREE: TRNN A,-1 POPJ P, ;do nothing if ptr 0 PUSHAE P,[A,B] QBFRE1: MOVE B,LISTAR(A) ;get tree wd. TLNN B,%QTLST ;is data a list? JRST QBFRE5 ;no, continue ;flush list PUSH P,A HRRZ A,LISTAR(A)+1 ;put list ptr in as arg CAIE A,0 ;(but skip if nil) PUSHJ P,QBFREE ;to a recursion! POP P,A JRST QBFRE7 ;now go flush node like a value. QBFRE5: TLNN B,%QTSTR ;data a string? JRST QBFRE7 ;no, cont. ;string...bleah HLRZ B,LISTAR(A)+1 ;get char cnt ADDI B,4 PUSH P,C IDIVI B,5 ;get # wds MOVN B,B ;negate ADDM B,-5(L) ;get new total # wds used so far in string area POP P,C MOVE B,LISTAR(A) ;get tree wd again. ;value. flush current qb and go after its cdr QBFRE7: PUSH P,C MOVE C,-2(L) ;get freelist ptr HRRZM C,LISTAR(A) ;zap ptr into freed qb SETZM LISTAR(A)+1 ;zap data wd too(helps debug) HRR C,A ;make freelist pt to freed qb ADD C,[1,,0] ;incrment cnt MOVEM C,-2(L) ;store freelist back POP P,C HRRZ A,B ;get cdr of deear departed JUMPN A,QBFRE1 ;pass cdr away if exists POPAE P,[B,A] POPJ P, SUBTTL ULSOPN - external routine to initialize a list area. ;; this is externally called routine... not a uuo proper, but a kludge ;; pending invention of a decent opening mechanism. ;; opens list/string stuff given lsarsw. ULSOPN: PUSHAE P,[A,B,C] MOVE L,ILARPT SKIPN LSARSW ;do input list/string? MOVE L,QLARPT ;no, do qdir. UAROPN A,[4,,[2000]] UAROPN B,[4,,[2000]] MOVEM A,-1(L) ;store larno MOVEM B,-4(L) ;store sarno SETZM -5(L) ;clear sarnu MOVE C,ARTAB(B) MOVEM C,-3(L) ;store sarst MOVE C,L ;set up index table HRLI C,-20 HRRZ A,ARTAB(A) ;start addr of list area MOVEI B,1(A) ;a+1 HRRM A,(C) HRRM B,1(C) ;store ptrs in index table AOJ C, AOBJN C,.-3 MOVEI U1,$QFQB PUSHJ P,QBINIT ;set up freelist, larfp (qb freelist) POPAE P,[C,B,A] POPJ P, LSARSW: 0 ;when -1 use input, when 0 use qdir (kludge) QLARPT: QLARTB ;ptr to talbe (what acc l should have) ILARPT: ILARTB QSARNU: 0 ;-5(l) is wds actually used for string storage QSARNO: 0 ;-4(l) is # of string area QSARST: 0 ;-3(l) is abs addr of string area QLARFP: 0 ;freelist ptr for area QLARNO: 0 ;# of list area QLARTB: REPEAT 20,[.RPCNT,,0 ? .RPCNT,,1 ] ISARNU: 0 ;# wds actually used in string area ISARNO: 0 ; # of string area ISARST: 0 ;abs addr of string area ILARFP: 0 ;freelist ptr for area ILARNO: 0 ILARTB: REPEAT 20,[.RPCNT,,0 ? .RPCNT,,1 ] ; This is stuff that used to be in COMSAT, long long ago when it ; was still a many-colored dragon. Basically these routines hacked ; the ITS binary file directory format in an attempt to optimize ; file references, etc. ; They are retained here for... posterity? Use(ful/less)ness? Sentiment? IFN 0,[ SUBTTL File directory inspection routines FILIDX: 0 ;holds index to file (in SATDIR dir) being examined ; 0=first, 1=second, etc. ; FDGET -- gets binary file dir into core. FDGET: ECALL OFDIR,[[*,17,MNHIDE]] ;open .file. (dir) in binary JSR FILBUG PUSH P,A SKIPE FDIRIN ;is file-dir page in core? JRST FDGET1 ;yup ;No, get single page into FDIRPG page SYSCAL CORBLK,[CIMM %CBRED+%CBNDW CIMM %JSELF ? CIMM FDIRPG ? CIMM %JSNEW] JSR CORLOS FDGET1: MOVE A,[-2000,,FDRLOC] .IOT DKIC,A .CLOSE DKIC, POP P,A POPJ P, FDIRIN: 0 ;non-z when file-dir page exists OFDIR: SETZ ? SIXBIT /OPEN/ [6,,DKIC] ['DSK,,0] [SIXBIT /.FILE./] [SIXBIT /(DIR)/] SETZ SATDIR ; "fdfsek" - given fn1/fn2 in a/b, looks for that file in ;directory currently in core, and skips if it finds it, ;leaving the file's 5 wd block in regs a-e. ;doesn't skip if fails. ;understands "*", "<" and ">" (ugh bleah) as fn2's. ;ignores files marked as to be deleted. FDFSEK: SKIPN FDIRIN PUSHJ P,FDGET SETZM FDFST1' ;best number (for < or >) SETZM FDFST3' ;best anything SETZM FDFST4' ;index to best number SETZM FDFST5' ;index to best name MOVE C,FDRLOC+1 ;get ptr to name area FDFSK1: CAMN A,FDRLOC(C) ;check fn1 JRST FDFSK3 ;a match... FDFSK2: ADDI C,5 CAIGE C,2000 ;end of dir? JRST FDFSK1 ;loop SKIPE C,FDFST4 ;number gets priority if exists JRST FDFSKW SKIPE C,FDFST5 ;then try plain fn2 JRST FDFSKW POPJ P, ;lost. ;matched fn1, check out fn2. FDFSK3: SKIPE E,FDRLOC+4(C) ;check 5th wd to see if should ignore CAMN E,[-1] JRST FDFSK2 ;hmm, yes. ignore it. CAME B,FDRLOC+1(C) ;fn1 matches, check fn2. JRST FDFSK4 ;nope, look a little farther ;found match, store and return info FDFSKW: PUSH P,C SUB C,FDRLOC+1 ;subtract offset IDIVI C,5 ;get # of file (0=first, 1=second...) MOVEM C,FILIDX POP P,C MOVE E,FDRLOC+4(C) ;xfer 5-wd block into accs MOVE D,FDRLOC+3(C) MOVE B,FDRLOC+1(C) MOVE A,FDRLOC(C) MOVE C,FDRLOC+2(C) ;finally, clobber index AOS (P) POPJ P, FDFSK4: CAMN B,[SIXBIT /*/] ;wildcard? JRST FDFSKW ;anything wins if so. CAMN B,[SIXBIT />/] ;special fn2? JRST FDFSK5 ;hack ">" CAMN B,[SIXBIT /" FDFSK5: MOVE E,FDRLOC+1(C) ;get the fn2 EXCH B,E PUSHJ P,FDFCVT ;cvt fn2 (skip if number) returns # in d if exists JRST [ CAMG B,FDFST3 ;no #, compare w/best fnm JRST FDFSK8 MOVEM C,FDFST5 ;save index MOVEM B,FDFST3 ;and replace if better. JRST FDFSK8] CAMG D,FDFST1 ;compare with # so far JRST FDFSK8 ;no good MOVEM D,FDFST1 ;ah, store info MOVEM C,FDFST4 JRST FDFSK8 ;hack "<" FDFSK7: MOVE E,FDRLOC+1(C) EXCH B,E PUSHJ P,FDFCVT ;convert fn2 into #, don't skip if not number. JRST [ CAML B,FDFST3 JRST FDFSK8 MOVEM C,FDFST5 MOVEM B,FDFST3 JRST FDFSK8] CAML D,FDFST1 ;numerical, compare. JRST FDFSK8 MOVEM D,FDFST1 MOVEM C,FDFST4 JRST FDFSK8 FDFSK8: EXCH B,E JRST FDFSK2 ;convert sixbit in b to number in d and skip ;else don't skip if not number FDFCVT: PUSHAE P,[A,B] SETZ D, FDFCV1: SETZ A, LSHC A,6 ;shift char into a CAIL A,20 CAILE A,20+9. JRST POPBAJ ;lose, not a # IMULI D,10. ;power up ADDI D,-20(A) JUMPN B,FDFCV1 POPAE P,[B,A] AOS (P) POPJ P, ; "fdfget"- takes arg in filidx as a file # (0=first ;file, 1=second...) and returns its 5-wd block in regs a-e ;and skips; fails if no such file (# neg. or too large) FDFGET: SKIPGE A,FILIDX ;fail if # negative POPJ P, IMULI A,5 ;get offset of desired file within name area ADD A,FDRLOC+1 ;get offset of name area CAIL A,2000 ;too big? POPJ P, ;too big! MOVE E,FDRLOC+4(A) ;get 5th wd MOVE D,FDRLOC+3(A) ;4th, etc. MOVE C,FDRLOC+2(A) MOVE B,FDRLOC+1(A) MOVE A,FDRLOC(A) AOS (P) ;skip POPJ P, ; "fdfset" - takes file # in filidx, effect is to set the ; 5th word (date last ref'd) of its block to -1, indicating ; it has been assimilated and is to be deleted later. FDFSET: PUSH P,A MOVE A,FILIDX IMULI A,5 ;get offset within name area ADD A,FDRLOC+1 ;get offset within dir SETOM FDRLOC+4(A) ;zap 5th wd. POP P,A POPJ P, ; "fdflsh"-- deletes all files in dir that have 5th wd ;set to -1, indicating they've been assimilated. FDFLSH: PUSHAE P,[A,B,C,D,E,FILIDX] SETZM FILIDX ;work from top down FDFLS1: PUSHJ P,FDFGET ;get block into a-e JRST FDFLS2 ;when it fails, have reached end. CAME E,[-1] ;zap this one? JRST [ AOS FILIDX JRST FDFLS1] ;no ECALL DELFIL,[[4,.+2]] ;zap JSR FILBUG ;if it's not there, fine with us AOS FILIDX JRST FDFLS1 FDFLS2: POPAE P,[FILIDX,E,D,C,B,A] POPJ P, DELFIL: SETZ ? 'DELETE ? ['DSK,,0] A ? B ? SETZ SATDIR ;deletes file pointed to by filidx and clears its 5th wd in dir ;so that any searches ignore it. FDFCLR: PUSH P,A MOVE A,FILIDX IMULI A,5 ADD A,FDRLOC+1 ;add offset to get ptr to 5 wd blk SETZM FDRLOC+4(A) ;zap 5th wd ECALL CLRFIL,[[4,.+2]] ;delete it JSR FILBUG POP P,A POPJ P, CLRFIL: SETZ ? 'DELETE ? ['DSK,,0] FDRLOC(A) ? FDRLOC+1(A) ? SETZ SATDIR ; "fdflen" - given file block in acs, (as returned by fdfsek) ; finds how long file is... ;returns in a, size in wds; in b, size in blocks. FDFLEN: PUSH P,D LDB A,[1500,,C] ;get byte address (must compute ptr) IDIVI A,6 ;get word addr (rel) ADDI A,FDRLOC+11. ;get word addr (abs) MOVNI B,-6(B) ;get # of bytes from end of wd. IMULI B,6 ;get # bits from end ('p' field of ptr) HRLI B,060000 ;set up 's' field at other side of reg ROT B,-6 ;rotate p field into front HRR B,A ;insert addr. to complete byte pointer ;now must interpret bytes to find # blocks in file. SETZ D, ;zero block count FDFLN1: ILDB A,B ;get byte CAIE A,0 ;end of desc. segment? CAIN A,31. ;31.=37 JRST FDFLN4 ;yup CAIG A,12. ;byte 1-12. ? (1-14) JRST FDFLN2 CAIG A,30. ;byte 13.-30.? (15-36) JRST FDFLN3 ;byte 40-77 means lower 5 bits + next 2 bytes = loc of next blk IBP B IBP B AOJA D,FDFLN1 ;byte 1-14 means this many consecutive blocks FDFLN2: ADD D,A ;so, add that many in. JRST FDFLN1 ;byte 15-36 means skip this many blocks to reach next block FDFLN3: AOJA D,FDFLN1 ;byte 0 or 37 means previous byte was last descriptor. FDFLN4: MOVE B,D ;# blocks used LDB A,[301200,,C] ;get # words in last block CAIE A,0 ;if "2000" wds in last block, don't subtr. last SOJ D, ;get # blocks except last, IMULI D,2000 ;multiply by # wds/blk, ADD A,D ;and get total # wds in file. POP P,D POPJ P, ];IFN 0  SUBTTL INQUIR Data Crunching (LSR file mapping, sorting, searching) ; this is the file to gobble.... LSROPN: SETZ ? SIXBIT/OPEN/ MOVE [.BII,,DKIC] MOVE ['DSK,,] MOVE ['LSR,,] MOVE [SIXBIT/>/] ;lsr > guaranteed good. SETZ ['INQUIR] LS2IPN: SETZ ? SIXBIT /OPEN/ ? [.BII,,DKIC] ['DSK,,] ? LS2FN1 ? LS2FN2 ? SETZ LS2DIR ;Map in the inquir data base, and construct the pointer tables. on return, ;iff mpiunm and mpifnm are nonzero then they contain aobjn ptrs to the ;two pointer tables, sorted by uname and full-name respectively. ;each entry in one of those tables corresponds to one user; ;the rh points to the start of his uname (in asciz) ; and the lh points to the start of his full-name (in asciz). LS2MAP: PUSHAE P,[A,B] ECALL LS2IPN,[[*,10,MNHIDE],[*,17,MNHIDE],[*,23,MNHIDE]] JRST POPBAJ ;can't access, permanent-type error SYSCAL FILLEN,[CIMM DKIC ? CRET A] ;find # wds in file JSR AUTPSY CAIG A,0 JSR AUTPSY ;and complain if 0 MOVEM A,LS2LEN ;save len MOVEI A,1777(A) ;(round up) LSH A,-10. MOVEM A,LS2PGS ;save # of pages LSR file needs CAILE A,100 ;if outrageous figure, JSR AUTPSY ;die. later perhaps shout for help. SETZM MPIUNM ;we are about to clobber any previously snarfed SETZM MPIFNM ;tables, so mark them as invalid. MOVE B,SYSFPG ;get # of first sys-mapped page. LSR must fit under it. SUBI B,(A) ;get page # for start of mapping in core below sys pgs MOVEM B,LS2PAG ;store it LSH B,10. ;get loc in wds. MOVEM B,LS2ORG MOVN A,LS2PGS ;get back neg. of # pgs needed HRLZ A,A HRR A,LS2PAG ;form AOBJN page ptr for CORBLK SYSCAL CORBLK,[ CIMM 010000 ;Read-Only. CIMM -1 ;into self A ;as specified CIMM DKIC] ;from file open on channel. JSR AUTPSY .CLOSE DKIC, MOVE B,LS2PAG MOVEM B,LS2FPG SKIPN LS2BPG ;has buffering limit been set? JRST [ MOVEI C,-LS2BLM(B) ; no, set it - this gets done on first gobble. MOVEM C,LS2BPG JRST .+1] CAMGE B,LS2BPG ;if set up, make sure current LSR doesn't exceed. JSR AUTPSY MOVE A,LS2ORG MOVE B,(A) ADD B,A MOVEM B,MPIUNM MOVE B,1(A) ADD B,A MOVEM B,MPIFNM POPAE P,[B,A] ;all done with LSR mapping! POPJ P, LS2LEN: 0 ; length in words of LS2 file LS2PGS: 0 ; length in pages (rounded up) LS2PAG: 0 ; beginning page # LSR file mapped into in core LS2ORG: LS2LOC: 0 ; addr of first data wd c(LSRPAG)*2000 LS2BPG: 0 ; # of page below which LSR stuff must never go. set on first gobble. LS2BLM==10 ; 10 pages to save as buffer between LSRBPG and LSRFPG LS2FPG: ; 2 names for LS2TPG: 0 ; page # sorted tables start at LS2TAB: 0 ; addr they start at, c(LSRTPG)*2000 LSRLEN: 0 ; length in wds of LSR file LSRLOC: 0 ; loc stored at LSRTAB: 0 ; addr of tables ;Scan the data base and make a table of pointers. LSRMNG: PUSHAE P,[A,B,C,D,E] ECALL LSROPN,[[*,10,MNHIDE],[*,17,MNHIDE],[*,23,MNHIDE]] JSR AUTPSY SYSCAL FILLEN,[CIMM DKIC ? CRET A] JSR AUTPSY MOVEM A,LSRLEN UAROPN B,[4,,LSRLEN] MOVEM B,LSRAR' MOVE A,ARTAB(B) MOVEM A,LSRLOC MOVN A,LSRLEN HRLZS A HRR A,LSRLOC .IOT DKIC,A .CLOSE DKIC, ;Now have LSR file, must gobble some core for tables. Find how much... MOVN D,LSRLEN HRLZ D,D HRR D,LSRLOC ;fix up word AOBJN thru LSR HRREI C,-2 ;search for # occurences of this wd (# lusers) SETZ B, ;clear cnt CAMN C,(D) ;search ADDI B,1 ;and count AOBJN D,.-2 ;fast LSH B,1 ;when done, mult result by 2 (need 2 tables) ADDI B,10 ;and add a few just in case UAROPN A,[4,,B] MOVEM A,LSRTAR' MOVE B,ARTAB(A) MOVEM B,LSRTAB UAROPN A,[4,,[2000]] MOVEM A,LNSAR ;open area to store lastname strings in. MOVE B,LARTAB(A) MOVEM B,LNSMAX' SETZM LNSTOP' ADDI A,ARTAB MOVEM A,LNSARA' ;indirect access ptrs MOVN A,LSRLEN ;get back -# wds HRLZ A,A HRR A,LSRLOC ;make AOBJN ptr into LSR data MOVE B,LSRTAB SOJA B,MPISC1 ;subtract 1 since it's now a PDL ptr. MPISCN: PUSH B,A ;we're at start of a user's entry; make a pointer. PUSHJ P,LNSAD ;xfer full name & return rel ptr in C HRLM C,(B) ;complete the entry. MPISC1: MOVE C,(A) ;look at next word. ASH C,-1 ;ignore low bit. AOBJP A,[ADDI C,2 ;reached end without an eof word? JUMPE C,MPISC2 ;complain if so JSR AUTPSY] ;else did have EOF wd, loop done. AOJE C,MPISCN ;-2 => next word starts another user. AOJN C,MPISC1 ;-4 => end of file; otherwise keep going. MPISC2: MOVE A,LSRTAB ;set up for sort (LSR supposed to be, but make sure.) PUSH P,B MOVEI B,1(B) ;last entry+1 MOVSI C,400000 ;most signif. bit to sort on PUSHJ P,SORT POP P,B MOVE D,B MOVEI A,1(D) ;get current PDL addr + 1 SUB A,LSRTAB ;and subtract starting addr, to get HRLZ D,A ;# of words in the newly constructed table. MOVNS D HRR D,LSRTAB ;aobjn -> constructed table. MOVEM D,MPIUNM ;this is sorted by uname since the original file is. MOVEI C,1(B) ;start of second copy. HLL C,MPIUNM ;length of second copy same as first's. now have MPIFNM. MOVE D,MPIUNM MPICV2: MOVS A,(D) ;swap halves so fnm addr in RH. ADD A,@LNSARA ;make FNM addr absolute PUSH B,A AOBJN D,MPICV2 MOVEM C,MPIFNM ;store aobjn -> copy to be sorted by real name. HRRZ A,MPIFNM HLRE B,MPIFNM ;a has address of start of mpifnm table SUBM A,B ;b has address of end of mpifnm table (+1) MOVSI C,400000 ;c has most significant bit to sort on. PUSHJ P,SORT ;quickly get the mpifnm table almost sorted. ;the table now consists of many small unordered bunches, with all ;the bunches in the right place. ;then bubble-sort the table the rest of the way. MPIBUB: PUSH P,[0] ;get a place to count # exchanges done each pass. MOVE D,MPIFNM MPIBU3: AOBJN D,MPIBU1 POP P,A JUMPN A,MPIBUB AOS -5(P) ;skip on winning return PUSHJ P,MPIOUT ;write out file MPILOS: UARCLS LSRAR UARCLS LSRTAR POPAE P,[E,D,C,B,A] POPJ P, MPIBU1: MOVE B,(D) ;get fullname pointer of next table entry MOVE C,-1(D) ;and that of previous entry. HRLI C,444400 MPIBU2: ILDB A,C ;get the next word of each full-name MOVE E,(B) LSH A,-1 ;we want to do unsigned comparisons, but cam does signed LSH E,-1 ;ones, so fake it out. CAMGE A,E JRST MPIBU3 ;these 2 entries are properly ordered; move on. CAMG A,E AOJA B,MPIBU2 ;fullnames identical so far; look at next word. MOVE C,-1(D) EXCH C,(D) ;exchange this entry with the previous one. MOVEM C,-1(D) AOS (P) ;indicate an exchange was done this pass JRST MPIBU3 ;sort the mpifnm table by the 1st word of the full-name only, ;using a radix-exchange sort. ;a points to first entry ;b points to last entry + 1 ;c has one bit set, that bit most significant bit to sort on SWPS==1 ;length of a table entry SORT: HRLM B,(P) ;save upper bound CAIL A,-SWPS(B) JRST SORT7 ;one or zero entries PUSH P,A ;save lower bound SORT3: MOVE D,(A) TDNN C,(D) ;bit set in lower entry? JRST SORT4 ;no, increment to next and maybe try again SUBI B,SWPS ;yes, now back up upper point MOVE D,(B) TDNE C,(D) ;bit clear in upper entry? JRST SORT5 ;no, check for end, decrement b, and try again REPEAT SWPS,[ ;bit set in lower entry and clear in upper => exchange entries MOVE D,.RPCNT(A) EXCH D,.RPCNT(B) MOVEM D,.RPCNT(A) ] SORT4: ADDI A,SWPS ;increment lower bound pointer to next entry SORT5: CAME A,B ;any more entries left? JRST SORT3 ;yes, go process them ;a and b now both point to first entry with bit set ROT C,-1 ;rotate bit indicator to next (less significant) bit POP P,A ;restore lower bound of entire sort JUMPL C,SORT6 ;jump if no more key to sort on PUSHJ P,SORT ;sort bottom part of table HLRZ B,(P) ;restore upper bound (sort clobbered a to middle) PUSHJ P,SORT ;sort top part of table SORT6: ROT C,1 ;back up key again so as too "not clobber c" SORT7: HLRZ A,(P) ;make a point above table entries sorted POPJ P, ;A has addr to uname entry; return rel addr in C to lastname string ;in LNS area. clobber nothing else. LNSAD: PUSHAE P,[A,B,D] ADDI A,2 ;get abs addr of fname (where it starts) HRLI A,440700 MOVEM A,LNSPT1' ; save ptr to start of fname SETZ C, LNSAD1: ILDB B,A CAIN B,", JRST LNSAD2 CAIE B,0 CAIN B,^M CAIA AOJA C,LNSAD1 SETZ A, ;if no comma, no pointer. ;C has cnt of chars to xfer into LNS buffer LNSAD2: MOVEM A,LNSPT2' ;this points to rest of string after comma MOVEI A,1+4(C) IDIVI A,5 ;get # wds needed for this lastname MOVE B,LNSTOP MOVEM B,LNSRET' HRLI B,440700 MOVE D,LNSAR ADDB A,LNSTOP CAML A,LNSMAX JRST [ SUB A,LNSMAX ADDI A,100 UAREXP D,A MOVE A,LARTAB(D) MOVEM A,LNSMAX JRST .+1] ;get more core ADD B,ARTAB(D) MOVEM B,LNSPT3' ;save new ptr to last name. MOVE A,LNSPT1 JRST LNSAD5 LNSAD4: ILDB D,A IDPB D,B LNSAD5: SOJGE C,LNSAD4 SETZ D, IDPB D,B ;make asciz ;Now mung LSR full name. MOVE C,LNSPT1 ;ptr to start of name MOVE D,LNSPT2 ;get ptr to rest of name JUMPE D,LNSA15 ;don't swap if not in last, first form. ILDB A,D CAIN A,40 JRST .-2 ;until find nonblank (start of first name) LNSAD6: CAIE A,0 CAIN A,^M JRST LNSAD7 ;now, until find end of item CAIN A,", ;or comma denoting end of first name, JRST LNSAD7 IDPB A,C ;deposit at start of name. ILDB A,D ;get next JRST LNSAD6 ;first name now put into start of string, D points to first char ;after terminating comma or CR. LNSAD7: MOVEM A,LNSATC' ;save terminating char MOVEM D,LNSPT4' ;and ptr to succeeding stuff in case twas a comma. MOVEI A,40 IDPB A,C ;put space between first and last names. LNSAD8: MOVE D,LNSPT3 ;ptr to start of lastname LNSAD9: ILDB A,D JUMPE A,LNSA10 ;copy lastname back into string. IDPB A,C JRST LNSAD9 LNSA10: MOVE A,LNSATC ;retrieve char terminating firstname CAIE A,", ;comma? (ugh) JRST LNSA20 ;nope, just zap rest of string to spaces. MOVE D,LNSPT4 ;comma, must shift rest of string up. get ptr to it. LNSA17: IDPB A,C ;deposit comma back initially, then rest of string. ILDB A,D CAIL A,40 ;if cntl char of any sort, stop. JRST LNSA17 ;now fill up all remaining space in string with blanks. LNSA20: ILDB A,C ;fill up rest with spaces. CAIE A,0 CAIN A,^M JRST LNSA15 MOVEI A,40 DPB A,C JRST LNSA20 ;now, make full-name string, stored safely in aux. table, uppercase. LNSA15: MOVE D,LNSPT3 ;AGAIN LNSA11: ILDB A,D JUMPE A,LNSA12 CAIL A,"a CAILE A,"z CAIA SUBI A,40 DPB A,D JRST LNSA11 LNSA12: HRRZ C,LNSRET POPAE P,[D,B,A] POPJ P, LS2HED==2 MPIOUT: PUSHAE P,[A,B] MOVE A,LNSAR MOVN A,ARTAB(A) ;start addr of lastname string area MOVE B,MPIFNM ADDM A,(B) ;get addr rel to start of area. AOBJN B,.-1 MOVE A,LSRLOC SUBI A,LS2HED MOVNS A PUSH P,A MOVE B,MPIUNM ADDM A,(B) AOBJN B,.-1 POP P,A HRLZS A MOVE B,MPIFNM ADDM A,(B) AOBJN B,.-1 MOVE A,LSRLEN ADDI A,LS2HED ;add # header wds in file (2 currently) MOVEM A,LS2UNM' ;to get file location of unm table. HLRE B,MPIUNM MOVNS B ADD A,B ; get loc of fnm table. MOVEM A,LS2FNM' ADD A,B ; and of lastname strings. MOVEM A,LS2LNS' MOVE B,MPIFNM ADDM A,(B) AOBJN B,.-1 ;turn from rel-area to rel-file HRLZ A,LS2LNS MOVE B,MPIUNM ADDM A,(B) AOBJN B,.-1 ECALL LS2OPN,[[*,17,MNHIDE]] JSR AUTPSY MOVE A,MPIUNM HRR A,LS2UNM HRROI B,A .IOT DKOC,B ; -<# entries>,, MOVE A,MPIFNM HRR A,LS2FNM HRROI B,A .IOT DKOC,B ; ditto, FNM table MOVN B,LSRLEN HRLZ B,B HRR B,LSRLOC .IOT DKOC,B ; LSR file itself MOVE B,MPIUNM .IOT DKOC,B MOVE B,MPIFNM .IOT DKOC,B MOVE A,LNSAR MOVN B,LARTAB(A) HRLZ B,B HRR B,ARTAB(A) .IOT DKOC,B ;output lastname strings SYSCAL RENMWO,[CIMM DKOC ? LS2FN1 ? LS2FN2] JSR AUTPSY .CLOSE DKOC, UARCLS LNSAR POPAE P,[B,A] POPJ P, LNSAR: 0 LS2OPN: SETZ ? SIXBIT /OPEN/ ? [.BIO,,DKOC] ? ['DSK,,] [SIXBIT /_LS2_/] ? [SIXBIT /OUTPUT/] ? SETZ LS2DIR LS2DIR: SIXBIT /INQUIR/ LS2FN1: SIXBIT /LSRTAB/ LS2FN2: SIXBIT /REF/ ;uses mpifnm - see "mpi" ;lh(a) is # real characters in the asciz string to which rh(a) points. ;the string must be padded with 0's to a word boundary. ;search mpifnm for entries with full-names matched by our argument, ;and return in b a pointer to the mpifnm entry of the first such. ;if there are none, 0 is returned. ;entry point "lsrchu" hacks uname searching. LSRCHU: SKIPN B,MPIUNM POPJ P, ;return arg = 0 if no table SETZM SRCHSW' ;look for unames JRST LSRCHX LSRCHF: SKIPN B,MPIFNM ;val = 0 if no table POPJ P, SETOM SRCHSW ;look for full names LSRCHX: PUSHAE P,[A,C,D,E] PUSHJ P,LSRCH POPAE P,[E,D,C,A] POPJ P, LSUNM1: 0 LSUNM2: 0 LSRCH: PUSH P,B SKIPE SRCHSW JRST LSRC20 HLRZ B,A CAILE B,6 JRST [POP P,B ? SETZ B, ? POPJ P,] PUSH P,B SETZM LSUNM1 SETZM LSUNM2 HRLI A,440700 MOVE C,[440700,,LSUNM1] JRST LSRC16 LSRC15: ILDB D,A IDPB D,C LSRC16: SOJGE B,LSRC15 ;copy uname into local buffer MOVEI A,^M IDPB A,C MOVEI A,^J IDPB A,C ;add ^M and ^J (reason for said lcl buffer) POP P,A ;get char cnt back ADDI A,2 ;add 2 for crlf HRLZS A HRRI A,LSUNM1 ;make new ascnt ptr POP P,B JRST LSRC30 LSRC20: MOVE B,A ;first, make sure string has zeros in last word. HRLI B,440700 HLRZ C,A ;get # chars in string PTSKIP C,B ;make ptr point to last char IDIVI C,5 JUMPE D,LSRCH0 MOVNS D ADDI D,5 ;get # chars left in word (# to be zeroed) SETZ C, IDPB C,B ;dep a zero SOJG D,.-1 LSRCH0: POP P,B LSRC30: MOVE D,(A) ;get 1st word of our string rg, to search for. LSH D,-1 ;we want to do unsigned comparisons. PUSH P,A HLRE C,B HRLI B,C ;b's index field has c; b's address field has ptr so far. MOVNS E,C ;b -> inside area, idx of c. ;c = size of last step. ;e = # wds left in part of area after b. ;leaves b pointing to last (in core) word whose value is .le. desired value. LSRCH1: CAILE C,(E) ;c_max(last step,space left) MOVEI C,(E) CAIN C,1 ;only 1 entry to search thru => done. JRST LSRCH2 LSH C,-1 ;step = .5* size of stuff to search. ; HLRZ A,@B ; SKIPN SRCHSW HRRZ A,@B ;if searching for unames, get ptr from rh. ADD A,LS2ORG MOVE A,(A) LSH A,-1 ;0 in sign bit CAMG D,A ;e.a. is rh(b)+step. JRST LSRCH1 ;that's too far, don't move b. HRRI B,@B ;not too far, set ptr there. SUBI E,(C) ;we're closer to end now. JRST LSRCH1 ;b -> last mpifnm entry whose fullname's 1st word is less than the desired one. ;now advance slowly through mpifnm until find an entry whose whole fullname ;is right, or is too large. ;stack has the arg to flnm. LSRCH2: ; hllz d,mpifnm ;get adequate cnt for scanning rest of table MOVE A,MPIFNM ;must get adequate cnt for scanning rest of table. get its aobjn ptr SKIPN SRCHSW MOVE A,MPIUNM ;(if searching unames table, use its ptr) HLRE D,A ;get - ADDI D,(B) ;add # of entry currently pointing to, which is current addr SUBI D,(A) ;less starting addr. HRLZS D ;now have -<# entries left in table>,,0 HRR D,B ;add ptr to entry which is .le. desired one HRRZ A,(P) HRLI A,440700 HLRZ B,(P) ;get bp to last char of the arg to flnm IBP A SOJG B,.-1 ;and push it. PUSH P,A ;then scan through what's left of mpiunm till find an entry that's big enough. LSRCH6: AOBJN D,LSRCH4 LSRCH9: SETZ B, ;exhausted table without finding an entry large enough. SUB P,[2,,2] POPJ P, LSRCH4: ; HLRZ C,(D) ; SKIPN SRCHSW HRRZ C,(D) ;if hacking unames, pull ptr from rh. ADD C,LS2ORG HRRZ B,-1(P) HRLI B,440700 HRLI C,440700 LSRCH5: ILDB A,C ;get the next word of each full-name ILDB E,B CAMGE A,E JRST LSRCH6 ;this entry is too small; keep looking. CAME A,E JRST LSRCH9 ;this entry is too large; there's no match. CAME B,(P) ;have we exhausted the argument? JRST LSRCH5 ;no; fullnames identical so far; look at next char. LSRCH7: SKIPN SRCHSW JRST [ILDB A,C ;if hacking unames, must hve exact match.(table name exhausted) JUMPN A,LSRCH6 JRST LSRCH8] ;aha, exact match for uname. win ;full name, arg is exhausted. if next char in full name is comma or ;space (or something like that), win, since last names match exactly. ILDB A,C ;get next CAIE A,", ;for comma CAIN A,40 ;or space, JRST LSRCH8 ;win!. CAIN A,0 JRST LSRCH8 ;null, win. JRST LSRCH6 ;char is loser as fullname terminator, find another name LSRCH8: SUB P,[2,,2] ;argument matches as far as it goes; we win! MOVE B,(D) MOVE A,LS2ORG HRL A,A ADD B,A ;make addrs absolute POPJ P, ;given ,, in a, looks for item specified in B ; (by item #) of that person and skips with addr to asciz item in b if found, ;else doesn't skip. LSR%UN==1 ;item # for uname LSR%FN==3 ;item # for full name LSR%NT==18. ;item # for netadr LSRITM: PUSH P,C ADDI A,2 ;fname item starts at .+2 from uname item. SUBI B,LSR%FN ; counting starts from fullname item. JUMPLE B,[HRRZ B,A ? JRST LSRIT4] MOVN B,B HRLZ B,B HRR B,A ; now have -<# items to skip>,, LSRIT1: MOVE C,(B) ;get wd TRNN C,377 ;test for last char in wd JRST LSRIT3 ;none, end of item, get another! CAME C,[-2] ;is wd end-of-user? CAMN C,[-4] ;or eof? JRST LSRIT8 ;fail if either. AOJA B,LSRIT1 ;just text, get next wd of item. LSRIT3: AOBJN B,LSRIT1 ;b now points to 1st wd of item if any. LSRIT4: MOVE C,(B) JUMPE C,LSRIT8 ; 0 -> nothing. CAMN C,[.BYTE 7 ? ^M ? ^J] ;crlf only -> nothing JRST LSRIT8 CAME C,[-2] CAMN C,[-4] JRST LSRIT8 AOS -1(P) ;text, won! skip return. LSRIT8: POP P,C POPJ P, ; LSRFNM searches for fullname field. LSRFNM: MOVEI B,LSR%FN PJRST LSRITM ; LSRMBX searches for NETADR field, i.e. mailbox to send to if any. LSRMBX: MOVEI B,LSR%NT PJRST LSRITM ;go find item & return.  TITLE LS2 Muncher .MLLIT==1 F=0 ;flags A=1 B=2 C=3 D=4 E=5 U1=13 ; UU UU UU UU OOOOO U2=14 ; UU UU UU UU OO OO HANDLER U3=15 ; UU UU UU UU OO OO ACCS U4=16 ; UUUUU UUUUU OOOOO P=17 ;pdl ptr DKIC==1 DKOC==2 LOC 41 JSR UUOH LOC 100 PATLEN==100 PAT: PATCH: BLOCK PATLEN PDLLEN==300 PDL: BLOCK PDLLEN POPBA1: POP P,B POPAJ1: POP P,A POPJ1: AOS (P) APOPJ: POPJ P, PPCBAJ: POP P,C POPBAJ: POP P,B POPAJ: POP P,A POPJ P, POPDC1: AOS -2(P) POPDCJ: POP P,D POPCJ: POP P,C POPJ P, PPDCBJ: POP P,D CAIA POPBJ1: AOSA -1(P) POPCBJ: POP P,C POPBJ: POP P,B POPJ P, JUNK: 0 ;for infinite-sink random writes ;uuo handler and routines USCALL==1 ;assemble special .call hackery UAREAS==1 ;and core areas .INSRT DSK:KSC;Nuuos > ;time manipulating routines .insrt dsk:ksc;lsrtn > AUTPSY: 0 .VALUE JRST .-1 MNHIDE: .CLOSE DKOC, ;comes here if dsk hung. .CLOSE DKIC, MOVEI A,60. .SLEEP A, JRST START START: MOVEI P,PDL UARINIT ARPAGS ;must initialize core areas PUSHJ P,LSRMNG ;this does it all! JSR AUTPSY .LOGOUT .BREAK 16,124000 .VALUE MPIUNM: 0 MPIFNM: 0 ARPAGS: -300,,FFPAG CONSTANTS VARIABLES SYSFPG==377 FFPAG==<.+1777>/2000 END START TITLE ENABLE INTERUPTS FOR FTPS ENTRY ENABLE NETCO__1 ;COMMAND OUTPUT CHANNEL COMMENT  ENABLES ALL INTERUPTS EXCEPT: 1.1 CHARACTER TYPED 1.4 AR OVERFLOW 1.7 SYSTEM GOING DOWN 2.4 SLOW CLOCK 2.8 PDL OVERFLOW  INTERNAL ENABLE ENABLE: MOVE 1,[JSR TSINT] MOVEM 1,42 MOVEI 1,567666 MOVEI 2,1NETCO .SETM2 1, POPJ 17, TSINT: 0 INTPC: 0 MOVEM 1,SAVE1 SKIPGE 1,TSINT JRST NETINT LOGOUT: .LOGOUT .VALUE [ASCIZ /:FTPS: INTERUPT/] INTRET: MOVE 1,SAVE1 .DISMISS INTPC NETINT: TRNN 1,1NETCO JRST LOGOUT .STATUS NETCO,1 LDB 1,[140600,,1] ;SOCKET STATE JUMPE 1,LOGOUT ;JUMPE IF HE CLOSED ME OUT JRST INTRET SAVE1: 0 END }rrD-8 rrD r5<D-8 rrpDr.pD _rD + r rD+ r+`Drr3ZDr+`~D IddvJB B%3,> ",R ,R ,R4FPa,R6F+N."P-+J`Q$A` N͗~S a0j=`/*j` " $ш6F6@ R ,k@4Ha[,k@6H `.$i-(/Q<~b+X. G  V0.60 VH OH:H/,5/6 V` :aJ~9k3JG` P2H(c~q`aH~@9p (aT n"  IG:G`H!,~ "0D 1D $"1D $!6F+ 91D 70D1Dr}qm_~ 7G1D 70D"1D! 71D &1Q QO1M IK1D& I F."P-+y $."  J҈/*r{D ~6J/* J!*6@GJ3Ȁ.$i-+ Ph/"@2Bh`= G/*  KG:G`JXxZW]~,~@." q`y`OO A F* A FȀ Q+ =`U."@ & }\W~-r +0.&Q-+-hS*|i KH:H m[3Q*|i KH:H6H +3Ȁ=d, HQ@h GQh+H&UNIXRSX-11HYDRAMULTICS \+D[J.ppC$/L.\WNM3@p,mgpN@L)SIOT#rgSPN S^\"@ GrgMTQ1xSIOarg}M$|T]wmSIOU`rg)=1T]qxrgUfSINu+SIO-mnrgrgڏTQM&SIO'x7:T]&Ooh$ YIo1C Ix+L DzbUrk T)U@R\ xP4w|4i @DffJF#NfPF=RF%D<@L?YHXL?YISٓaMpXkSA9M8enSA7_pM9SA888R@88Uxy88V1 Cj`D~@ @{s3D@SL=SU@ SO@,M`U@,Q,@,Q-@,P 0@,Q@3@,SmRjM`<RjQ}RjSM**KjEKjxMhhS 6q(UMR/P7 lVd-|d;a[Y;Y\3fd>%OX>%MHi>%M\_3uM uc,l{_C~*5Cxj-va@*5Cyj*5Czj=*5C{"jE*5D%*=1!QjC-*=1"e*=1#8*=1%u-}bP;6|D>u^cGQH@QhH]@M,q%S@,M,r'u,E)*= }la+TD rgo-u]<`|@/a`TP 1(:[lh0`3QLp] p5th5ZPT7bO29eyCeyT pfN=!M,"KG@GZPhI{qKdb@&=hhMM \O2Qu^GSS!zSM 'ACST]`IOY"D85@,KM`,>5}@,^5<,~!4=+D5SUBTTL Switch setup, to-do comments. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; ;;;;; ;;;;; "OUT" ;;;;; ;;;;; NEW OUTPUT PACKAGE INTERFACE ;;;;; ;;;;; ;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; ;;;;; ;;;;; Documentation in MC:KSC;?OUT > ;;;;; ;;;;; or [SRI-KL]OUT.DOC ;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; REQUIRES: ;;;;; .INSRT MACROS - KSC;MACROS or MACROS ;;;;; U1,U2,U3,U4 - Sequential ACs ;;;;; P - PDL AC ;;;;; AUTPSY - JSR'd to for fatal errors ;;;;; Certain items will require other defs if they are assembled. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; IFNDEF $$OUT,$$OUT==1 ; 1 = Use new OUT stuff. (else UUO's or nothing) IFNDEF $$OUUO,$$OUUO==0 ; 1 = use old output UUO's. NUUOs defaults this to 1. ; Various item class conditional switches IFNDEF $$OFLT,$$OFLT==0 ; Floating point output IFNDEF $$OBUF,$$OBUF==0 ; UC$BUF Buffered output mode (must .INSRT PAGSER) IFNDEF $$OTIM,$$OTIM==0 ; Time output items (must .INSRT TIMRTS) IFNDEF $$OHST,$$OHST==0 ; Network Host name/# (on ITS, must .INSRT NETWRK) IFNDEF $$OERR,$$OERR==0 ; OS Error string output (on ITS must def ERRCHN too) ; More conditional switches needed when not using NUUOs. IFNDEF UAREAS,UAREAS==0 ; Disable "uuo area" stuff IFNDEF ULISTS,ULISTS==0 ; Likewise "uuo lists" IFNDEF USTRGS,USTRGS==0 ; ditto "strings" stuff. ; Parameters IFNDEF $$CHMX,$$CHMX==:20 ; Max # of channels user can use. IFNDEF $$ORID,$$ORID==0 ; Interpreted mode - may never be used. IFN $$ORID,.ERR OUT Interpreted mode not fully implemented yet. IFE $$OUT\$$OUUO,.INEOF ; If don't need anything from file, stop. comment | To-do stuff: Interpreted O.-instrs vs. inline code Interpretation: compact but slower. Inline: faster, but larger. More flexible? To setup extra params like width, prec, filler: General FMT(item,x,y,z) or FLD({item,item,...},x,y,z) Can test args to see how many, then use appropriate submacro for that # of extra args (O.FM2, O.FM3, etc) Generate bracketing code like: MOVE U1,[fmtlist] JSP U4,OXFSET JSP U4,OXFDON Or could put output stuff into a CALL'd constant routine. Protocol for OC channel AC Must preserve U2 over UUO's etc if == to OC. Reshuffle 4 UUO ac's, so OC not in middle?(interfers with 2-ac stuff) STDCH macro to set OC explicitly. Should OUT save/restore? Yes - can specify alternate chan. Should STDOUT? For STDOUT(ch,arg) should preserve? force use of STDCH to explicitly set. Allow use of STDOUT, STDOBP. Extend STDOUT macro to take chan, byte addr args? Add STROUT plus ditto? Pain to save/restore (unless all use OUT call?) Screw if smashed by sub. User must know how to save/restore OC. Put STRMOVE in for string ops, allow direct access. Have error macro to replace JSR AUTPSY, so that can specify string. Something like: JRST [JSR ERRH ? . ? ASCIZ /text/] File of 2-AC instrs for CREFFin to find dependencies. See whether any dep on U1/U2. If not, make U1 the channel AC? Problem: other UUO's clobber it, so can't simply make it "default"... only within an OUT or similar. Allow user to specify string rtn for XCT-type channels? Actually should specify vector holding everything necessary such as string-mode rtn addr, unit-mode instr, overflow rtn addr, etc. Fmt params should be immediate, and allow @ or ()'ing of variable params. eg this is how to handle properly output to a BP buffer, if can do in one stroke, without overflowing. Format params: ** TYPE ** FIELD WIDTH (- left justify, + right justify) ** PRECISION - String or float String - max # chars Float - # n's spec'd by precision: Type E: [-]m.nnnnnE[-]xx Type F: [-]mmmm.nnn Type G: whichever is easiest (default) ** FILLER - specify filler to use? Blanks or 0's or nulls? | subttl .BEGIN OUT - Macro definitions .BEGIN OUT ; Start symbol block .NSTGW ; Lots of hairy defs, make sure no storage assembled. SLEV==0 ; Stack level at start of OUT macro. IFN $$OUT*<.PASS-2>,[ ; Begin moby conditional for macro defs ; Only assemble if $$OUT and pass 1. ;;; Establish stack macro DEFINE .M"STK ; To use instead of (P). (P)-OUT"SLEV!TERMIN DEFINE DEFMOC NAME,*PRE*,*POST* ; Intermediate useful macro. DEFINE NAME (CH,A=$,B=$,C=$,D=$,E=$,F=$,G=$,H=$,I=$,J=$,K=$,L=$,M=$,N=$,O=$,Q=$,R=$,S=$,T=$,U=$,V=$,W) PRE OUT"$!A OUT"$!B OUT"$!C OUT"$!D OUT"$!E OUT"$!F OUT"$!G OUT"$!H OUT"$!I OUT"$!J OUT"$!K OUT"$!L OUT"$!M OUT"$!N OUT"$!O OUT"$!Q OUT"$!R OUT"$!S OUT"$!T OUT"$!U OUT"$!V .ERR No more than 20 arguments allowed! .TAG HO POST TERMIN TERMIN DEFMOC .M"OUTCOD,| IFNB [CH]{ PUSH P,OC ? MOVEI OC,CH ? OUT"SLEV==OUT"SLEV+1 } |,|IFNB [CH]{ POP P,OC ? OUT"SLEV==OUT"SLEV-1 }| DEFMOC .M"OUTCAL,| PUSHJ P,[ IFNB [CH]{ HRLM OC,(P) ? MOVEI OC,CH } OUT"SLEV==OUT"SLEV+1 |,|IFNB [CH]{ HLRZ OC,(P) } OUT"SLEV==OUT"SLEV-1 POPJ P,]| EXPUNGE DEFMOC ;;; Establish default for simple "OUT" to use. EQUALS .M"OUT,OUTCOD ; For now, default is inline. ;EQUALS .M"OUT,OUTCAL ; Alternative would be default of CALL. ;;;----------------------------------------------------------------- ;;; Fundamental "OUT" item definitions ;;; These are critical to proper operation of the OUT macro!! DEFINE $$ ; Invoked when no arg furnished, to terminate macro. .GO HO TERMIN IFE $$ORID,{ ; Define appropriate macro for constant text output. DEFINE $ &TEXT& MOVE U3,[.LENGTH TEXT,,[ASCII TEXT]] CALL OUT"OXTC TERMIN } .ELSE { DEFINE $ &TEXT& O.+<777&<.LENGTH TEXT>,,[ASCII TEXT]> TERMIN } DEFINE $OUT ; Continuation of single OUT OUT!TERMIN ; This isn't completely thought out yet. ;;;-------------------------------------------------------- ;;; More standard OUT items ;;; Not so fundamental to macro hackery, ;;; but closely tied to package. DEFINE $CH (ARG) ; CH(chan) - Force to a new channel MOVEI OC,ARG TERMIN DEFINE $OPEN (TYP,ARG,L,BS) ; Open the channel MOVEI U1,TYP MOVEI U3,[IFSN [ARG][]{ARG} .ELSE {[0]} L+0 BS+0 ] IFSN [L!BS][] TLO U3, CALL OUT"UOPEN3 TERMIN DEFINE $PTV (ARG) ; Read channel I/O ptr CALL OUT"UPTV MOVEM U1,ARG TERMIN DEFINE $FRC ; Force out buffered stuff on channel CALL OUT"OXFRC TERMIN DEFINE $RST ; Reset channel CALL OUT"OXRST TERMIN DEFINE $CLS ; Close channel CALL OUT"OXCLS TERMIN DEFINE $PUSH ; Push channel on IO PDL CALL OUT"OXPUSH TERMIN DEFINE $POP ; Pop off PDL into channel CALL OUT"OXPOP TERMIN DEFINE $POPALL ; Pop entire PDL CALL OUT"OXPDLR TERMIN DEFINE $CALL (ARG) ; Invoke random routine. CALL ARG TERMIN ; Maybe this macro should take an initial arg saying ; how many additional instrs the field should apply to??? IFE $$ORID,[ DEFINE $FMT (A,B,C,D) %%NUM==0 OUT"$FMB(B,C,D) OUT"$!A OUT"$FME TERMIN DEFINE $FMB (WID,PREC,FILL,NUM=E,) ; Last "," needed to end default val. HRREI U1,WID IFB [PREC!FILL]{ CALL OUT"OXFST1 ? .STOP } IFB [PREC] HRLOI U3,377777 .ELSE MOV!NUM!I U3,PREC IFB [FILL]{ CALL OUT"OXFST2 ? .STOP } MOVEI U4,FILL CALL OUT"OXFST3 TERMIN DEFINE $FME CALL OUT"OXFDON TERMIN DEFINE $XCT (A) A TERMIN ] ; IFE $$ORID IFN $$ORID,[ DEFINE $FLD (A,B,C,D) ; FLD - Field definition for following instrs IFNB [A!B],{O.FLD [A ? B]} TERMIN DEFINE $XCT ?INSTR ; XCT - XCT an instruction O.XCT [INSTR] DEFINE $IF ?INSTR ; IF - Conditional O.IF [INSTR] TERMIN DEFINE $ELSE ?ARG ; ELSE - corollary of IF O.ELSE TERMIN DEFINE $END ?ARG ; END - ends a conditional O.END TERMIN ] ; end IFN $$ORID ;----------------------------------------------------------------- ; Value-printing "OUT" item routines. ; General fmt of numerical output items is ; N(,width,prec,fill) ; where N = O - Octal ; D - Decimal ; X - Hexadecimal ; F - Floating (at moment really G) ; E - Floating E fmt (at moment really G) ; G - Floating F/E fmt (whichever "best") ; See "FMT" for explanation of width,prec,fill. IRP NAM,,[O,D,X,F,E,G]RDX,,[8,10,16,F,E,G] DEFINE $!NAM (NUM,A,B,C) IFNB [A!!B!!C] OUT"$FMB(A,B,C,N) MOVE U3,NUM CALL OUT"OXN!RDX IFNB [A!!B!!C] OUT"$FME TERMIN TERMIN DEFINE $N10 (ARG) ; "N10" - Number, base 10 ; signed decimal value, MOVE U3,ARG ; with decimal point. CALL OUT"OXN10 STDOUT(".) TERMIN ; Following setup for DEFITM isn't very pretty, but is necessary ; to produce minimal macro code for each item. If only MIDAS ; had string variables!!! DEFINE DEFIT2 ITM,*INSTR*,INTNAM ; Auxiliary for DEFITM below. IFNB [INTNAM]{ DEFINE $!ITM (ARG) INSTR CALL OUT"INTNAM TERMIN .STOP } DEFINE $!ITM (ARG) INSTR CALL OUT"OX!ITM TERMIN TERMIN DEFINE DEFITM ITM,INSTR,INTNAM ; Macro for standard item definitions. IFN $$ORID,{DEFINE $!ITM (ARG) OUT"O.!ITM ARG TERMIN .STOP } ; For IFE $$ORID IFSE [INSTR][]{ DEFIT2 ITM,"MOVE U3,ARG",INTNAM .STOP } IFSE [INSTR][-]{ DEFIT2 ITM,,INTNAM .STOP } IFE &17,{ DEFIT2 ITM,"INSTR U3,ARG",INTNAM .STOP } DEFIT2 ITM,"INSTR,ARG",INTNAM TERMIN ;DEFINE $!ITM (ARG) ; for IFE $$ORID ;IFSE [INSTR][] MOVE U3,ARG ;.ELSE {IFSN [INSTR][-]{IFE &17,{INSTR U3,ARG} .ELSE {INSTR,ARG} } } ;IFNB [INTNAM] CALL OUT"INTNAM ;.ELSE CALL OUT"OX!ITM ;TERMIN DEFITM CRLF,- ; CRLF() - obvious DEFITM EOL,- ; EOL() - same as CRLF DEFITM TAB,- DEFITM TLS,,OXLS ; TLS([slp]) - Text, List String. DEFITM TA,MOVEI U1,OXAR ; TA(arpt) - Text, Area. Outputs whole area. DEFITM TS,MOVEI,OXS ; TS([,,# ? bp]) - Text, String variable. EQUALS $N9,$D EQUALS $N8,$O EQUALS $OCT,$O ; "OCT" - OCTal value of word, same as N8. EQUALS $DEC,$N10 ; "DEC" - DECimal value of word, same as N10. DEFITM NFL,,OXNFL ; NFL(aval) - floating number (G fmt) DEFITM TZ,MOVEI,OXZA ; TZ(a-asciz) - Outputs asciz string DEFITM TZ$,HRRZ,OXZA ; TZ$(a-[a-asciz]) like TZ(@A) but avoids ; further indirection (if LH non-z) DEFITM TC,,OXTC ; TC([#,,[asciz]]) Outputs ASCNT string DEFITM TPZ,,OXZ ; TPZ([bp]) - Outputs BYTEZ string DEFITM TPC,,OXPC ; TPC([#,,[bp]]) a bit of a kludge. DEFITM RH,HRRZ ; RH(aval) - Right halfword, full (6 digits) DEFITM LH,HLRZ,OXNRH ; LH(aval) - Left halfword, full. DEFITM HWD ; HWD(aval) - "LH,,RH" EQUALS $H,$HWD ; H(aval) - same as HWD DEFITM RHV,HRRZ,OXN8 ; RHV(aval) - RH as octal num, not bit pattern. DEFITM LHV,HLRZ,OXN8 ; LHV(aval) - LH as octal num, not bit pattern. DEFITM HV,,OXNHV ; HV(aval) - LHV,,RHV DEFITM RHS,HRRE,OXN8 ; RHS(aval) - RH as signed octal num DEFITM LHS,HLRE,OXN8 ; LHS(aval) - LH as signed octal num DEFITM HS,,OXNHS ; HS(aval) - LHS,,RHS DEFITM 6F ; 6F(aval) - Outputs as sixbit without trailing sp. DEFITM 6W ; 6W(aval) - Outputs all 6 sixbit chars DEFITM 6Q ; 6Q(aval) - like 6F but quotes punct. chars with ^Q ; Arpanet host output items. Requires HOSTS2 and NETWRK, unless OS%TNX. DEFITM HN ; HN(aval) - Output host # simplifying if possible DEFITM HND ; HND(aval) - like HN but decimal DEFITM HST ; HST(aval) - Output host name or #, given #. ;;; Idiosyncratic items IFE $$ORID,[ DEFINE $C (CH) ; C - character (furnish immediate value) MOVEI U1,CH STDOUT TERMIN DEFINE $S (CNT,BP) ; S - String([#],[bp]) MOVE U3,BP SKIPLE U4,CNT CALL @OUT"USCOPT(OC) TERMIN DEFINE $SL (SLP,SAR) ; String, List. SAR is optional LSE addr. MOVE U3,SLP IFB [SAR] CALL OUT"OXSL ? .STOP SKIPE U1,SAR ; Feeble robustness. CALL OUT"OXSLA TERMIN ; Define item names for various chars which would fuck up ; MIDAS macro parsing if seen in literal string. Other ; baddies are CRLF and sometimes comma or double-quote. IRP ITM,,[LABR,RABR,LBRK,RBRK,LBRC,RBRC,LPAR,RPAR]VAL,,[74,76,133,135,173,175,50,51] DEFINE $!ITM STDOUT(VAL) TERMIN TERMIN DEFINE $ERR (ARG) ; "ERR" - System error message. If arg is blank, IFB [ARG] CALL OUT"OXERRL ; use last err, otherwise arg is error code .ELSE MOVE U3,ARG ? CALL OUT"OXERR TERMIN DEFINE $TIM (TYP,ARG) IFB [ARG] CALL OUT"UTMGET ; If no arg, use current time (U2 or U3) .ELSE {MOVE IFE U2-OC,{U3,} .ELSE {U2,} ARG} IFE U2-OC,MOVEI U4,OUT"T$!TYP ? CALL OUT"OXTIME .ELSE CALL OUT"T$!TYP TERMIN ; DEFT - for matching subtype names with routines. ; Subtypes are defined in the $$OTIM section. DEFINE DEFT ITM,RTN IF2 T$!ITM==:RTN TERMIN ] ;IFE $$ORID ] ;END PASS 1 IFN $$OUT - MOBY CONDITIONAL IFN $$OUT*<.PASS-1>,[ ; Only assemble for $$OUT and pass 2 ; For anything that needs pass2 def? ] ; END PASS 2 IFN $$OUT .YSTGW ; OK to gen code now. subttl Primary routines for OUT package interpreter IFE $$ORID,[ DEFINE .M"OUTDEF NAME,ROUT ; Simply ignore if not using interpreter. TERMIN ] IFN $$ORID,[ IFNDEF OX$MAX,OX$MAX==50 OXTAB: REPEAT OX$MAX, ILUUO IF1 %%UOUT==0 ; Opcode 0 is illegal. DEFINE .M"OUTDEF NAMEX,ROUT IRPS NAME,,[NAMEX] IF1 [%%UOUT==%%UOUT+1 IFGE %%UOUT-OX$MAX, .ERR Too many OUTDEF's, must increment OX$MAX! NAME==<%%UOUT_27.> ] TMPLOC OXTAB+,ROUT TERMIN TERMIN ; OX - Main execution for interpreted OUT. ; During execution of arguments, ACs are set up as follows: ; U1 - scratch for chars ; U3 - addr of current instr ("PC") ; U4 - scratch ;.M"OX: UIOINIT ; Set up OC with channel # ; SKIPA U3,40 ; Get "PC" for item hacking OXTOPL: AOSA U3,OXPC .M"OXJSP: MOVEM U3,OXPC ; Entry pt for non-UUO version; set up "PC" SKIPGE U3,(U3) ; Get an out-instruction. RET ; No more? Done! PUSH P,[OXTOPL] ; Got one. Prepare by pushing return addr. LDB U1,[$UOPCD,,U3] ; Pluck out the opcode... CAIG U1,OU$MAX ; Make sure it's legit... PJRST @OXTAB(U1) ; Yup, go execute it! JSR AUTPSY ; Bad! (Really should find something better...) OXNEXT: AOS U3,OXPC SKIPGE U3,(U3) JRST [ SOS OXPC ? RET] OXEVAL: LDB U1,[$UOCOD,,U3] CAIG U1,OU$MAX PJRST @OXTAB(U1) JSR AUTPSY ] ;IFN $$ORID IFN $$ORID,[ ;------------------------------------------------------------------------ ; This cruft isn't finished yet. OUTDEF O.IF:,OXIF ; O.IF - Arg is instr to xct, true if skips. OXIF: PUSH P,UIFFLG ; Save state of IF flag XCT @U3 ; Execute the test... JRST OXIFF ; Failed, go handle failure case. ; IF succeeded, process until see ELSE or END. OXIF2: AOS U3,OXPC ; Bump PC, SKIPGE U3,(U3) ; and get next out-instr JRST [ SOS OXPC ? RET] ; Hit end, back up. LDB U1,[$UOCOD,,U3] ; Get opcode CAIN U1, ; ELSE? JRST OUIFF ; Yes, now flush til see END. CAIN U1, ; END? RET ; Yep, done with conditional. CALL @OXTAB(U1) ; Well, instr qualifies, so do it. JRST OXIF2 ; Failed, scan through out-instr list until reach ; ELSE. OXIFF: AOS U3,OXPC SKIPGE U3,(U3) JRST [SOS OXPC ? RET] LDB U1,U3 CAIN U1, JRST OXIF2 ; Found ELSE, start win conditional. CAIN U1, RET ; End of conditional, just return. JRST OXIFF ; Neither, continue. ] ;IFN $$ORID SUBTTL Output package channel definitions ; $UNCHS - Establish how many channels will be used, and ; set things up so that package-related channel #'s ; will have space reserved for them, altho illegal for ; "user" channels. IF1 [ %%LSV==. ? OFFSET -.+$$CHMX IFN $$OUT,[ UFLDC:: 0 ; OUT package field-output channel IFDEF USTRGS,IFE $$OUUO,IFNDEF STRC,.M"STRC:: 0 ; UUO string package chan ] .M"$UNCHS:: ; REAL maximum legal # of channels. OFFSET 0 ? LOC %%LSV ; Don't waste space EXPUNGE %%LSV ;;; UIOINIT - old output initialization. DEFINE UIOINIT IFE $$UCAL,PUSH P,UUORPC ; Get return PC on stack. LDB OC,UACFLD TERMIN ] ;IF1 SUBTTL OUT channel maintenance - basic support ;;;;;;;;;;;;; Unit Output Inline Macro for UUO Channels ;;;;;;;; ; STDOUT outputs single byte in U1 on channel in OC. ; STDOUT(arg) outputs byte "arg" on channel in OC, clobbers U1. DEFINE .M"STDOUT (A) IFSN [A][] MOVEI U1,A AOSLE @OUT"UCHCNT(OC) PUSHJ P,OUT"UCHMP XCT OUT"UCOPT(OC) TERMIN ; STDOBP - variant of STDOUT to be used when there is a BP in ; U3 that may be susceptible to "bumping". DEFINE .M"STDOBP (A) IFSN [A][] MOVEI U1,A AOSLE @OUT"UCHCNT(OC) PUSHJ P,OUT"UCHMPX XCT OUT"UCOPT(OC) TERMIN ;;;;;;;;;;;;;;;;; Tables for UUO channels ;;;;;;;;;;;;;;;;;;;; BVAR UCOPT: BLOCK $UNCHS ; XCT'd unit-mode instruction USCOPT: BLOCK $UNCHS ; Addr of string-mode routine UCHCNT: BLOCK $UNCHS ; Addr of char countdown UCNTS: BLOCK $UNCHS ; Char countdown if non-area UCHLIM: BLOCK $UNCHS ; Original count allowed UCHTYP: BLOCK $UNCHS ; ,, IFN OS%TNX,UCHJFN: BLOCK $UNCHS ; JFN for channel if any UCHSTB: BLOCK $UNCHS ; Byte ptr (UC$BPT) or ARPT (UC$UAR) IFN UAREAS,[ UBMPSP: 0 ; Holds special ptr for string output UUO's to avoid area-shift ; clobberage. ; UCHSTB, and locs immediately following up to NUSPBP, will be ; adjusted automatically to compensate for any shifts of UUO areas. NUSPBP==.-UCHSTB ] EVAR ;----------------------------------------------------------------- ; UUO Channel types. Bits start in AC field, so as not to infringe ; on indexing/indirect bits! .M"$UCUAR==<.M"UC$UAR==0> ; UAR (UUO area) chan type 0 for easy check. .M"$UCXCT==<.M"UC$XCT==1>_5 ; XCT .M"$UCBPT==<.M"UC$BPT==2>_5 ; Byte PTr .M"$UCIOT==<.M"UC$IOT==3>_5 ; .IOT/SIOT (or BOUT/SOUT) .M"$UCBUF==<.M"UC$BUF==4>_5 ; Buffered UC$IOT .M"$UCTRN==<.M"UC$TRN==5>_5 ; Translate into another chan. .M"$UCNUL==<.M"UC$NUL==6>_5 ; Null output sink .M"UC$NX==7 ; # of executable channel types. .M"$UCSAO==<.M"UC$SAO==7>_5 ; SAO - Like UAR for LSE's String-Area. .M"UC$NO==10 ; # of OPEN-able channel types. UC%FLD==<7_5>,,0 ; Mask for type number (in AC field). .M"UC%LIM==1000,,0 ; Arg flag meaning byte # limit specified. .M"UC%BSZ==2000,,0 ; Arg flag meaning bytesize specified. UC%DBF==200000 ; UCHTYP flag, means dynamic UC$BUF buffer. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; OUTOPN CH,[,,[]] ; "Opens" a UUO channel for output. Note ; is in AC field!! This allows address to be indexed etc. ;Formats: ; OUTOPN CH, ;same as type $UCIOT. ; OUTOPN CH,[$UCIOT,,0] ;uses .IOT and SIOT ; OUTOPN CH,[$UCIOT,,[JFN]] ; uses BOUT, SOUT (TNX only) ; OUTOPN CH,[$UCBPT,,[byte ptr]] ;uses idpb starting at ptr ; OUTOPN CH,[$UCXCT,,[instr]] ;XCT's the instr (arg will lie in U1) ; OUTOPN CH,[$UCUAR,,] ;uses byte ptr into specified area ; OUTOPN CH,[SETZ $UCUAR,,] ;as above, but resets area ; OUTOPN CH,[$UCTRN,,[channel #]] ;Translates into another UUO channel. ; Old style: c(E) = , ; Cvt style: U3: , E ; New style: U3: ,[ ? ... ] IFN $$OUUO,[ UUODEF OUTOPN:,UCHOPN UCHOPN: UIOINIT ; Get channel # (AC field) HRRZ U3,U40 ; Get E CAIN U3, ; In case of OUTOPN CH,0 TLOA U3,($UCIOT,,) ; provide default. HLL U3,(U3) ; Get LH stuff from c(E) LDB U1,[$ACFLD,,U3] ; Get channel type (AC field of c(E)) ] ;IFN $$OUUO ; If there is any chance that U3 will have I or X bits set at ; this point, then the following instr should be uncommented. ; In theory the $OPN macro will never use it. ;UOPEN2: HRRI U3,@U3 ; Set RH to true effective address. ; Entry point for $OPN macro invocation. ; OC - Channel # ; U1 - channel type ; U3 - ,[ ? ? ... ] UOPEN3: CAIL U1,UC$NO ; Check type JSR AUTPSY ; Unknown type! Bad argument. MOVEM U1,UCHTYP(OC) ; Store channel type, with zeroed flags. PJRST @UOPENT(U1) ; Dispatch for further processing. UOPENT: UOPNAR ; Area UOPNX ; XCT UOPNBP ; BPT UOPNIO ; IOT UOPNBF ; BUF UOPNTR ; Transl. UOPNNL ; NUL UOPNSA ; SAO IFN UC$NO-<.-UOPENT> .ERR UOPENT table loses ; Common return point for some types. ; U1 - unit-mode instr ; U4 - ,, rtn addrs for string-mode output. UOPN3: MOVEM U1,UCOPT(OC) ; Store instruction for unit-mode byte output. TLNE U3,(UC%LIM) ; Was limit explicitly specified? JRST [ HLRZM U4,USCOPT(OC) ; Yes, use limit-type string routine. MOVN U4,@1(U3) ; And get specified limit value. JRST UOPN4] HRRZM U4,USCOPT(OC) ; No, use no-limit string routine. MOVSI U4,(SETZ) ; And use max neg # for "limit". UOPN4: MOVEM U4,UCHLIM(OC) ; Set up limit. MOVEM U4,UCNTS(OC) ; and count. MOVEI U1,UCNTS(OC) ; Find addr of count MOVEM U1,UCHCNT(OC) ; and store that. RET ; UC$UAR - Channel type AREA UOPNAR: IFE UAREAS,JSR AUTPSY ; Lose if no area hackery assembled. .ELSE [ MOVEI U4,@(U3) ; Get ARPT to area UOPNA1: MOVEM U4,UCHSTB(OC) ; Store ARPT, instead of a BP HLL U4,$ARTYP(U4) ; Get type bits. TLNN U4,%ARTCH ; Area must be in char mode! JSR AUTPSY ; tsk, tsk. MOVEI U1,$ARWPT(U4) ; Get addr to write place, HRLI U1,(IDPB U1,) ; and insert instruction to XCT. MOVEM U1,UCOPT(OC) ; Store XCT for unit mode, MOVEI U1,$ARCHL(U4) MOVEM U1,UCHCNT(OC) ; and addr to find char countdown in. MOVEI U1,UOL.AR ; Get addr of string output rtn MOVEM U1,USCOPT(OC) ; and set up. CAIGE U3, ; Now, if sign bit was set in flags, CALL UXRST ; reset the area. RET ; UOL.AR - String output routine for UC$UAR type. UOL.AR: ADDM U4,@UCHCNT(OC) ; Add into count SKIPLE @UCHCNT(OC) ; Check it. PUSHJ P,UCHMPX ; If no room left, go get some. IFE OC-U2, PUSH P,U2 MOVE U2,@UCOPT(OC) ; Get BP used by the IDPB (from $ARWPT) ILDB U1,U3 IDPB U1,U2 SOJG U4,.-2 IFE OC-U2,[ EXCH U2,(P) ; Now restore BP to area's $ARWPT POP P,@UCOPT(OC) ] .ELSE MOVEM U2,@UCOPT(OC) RET ] ; IFN UAREAS ; UC$XCT - Channel type XCT UOPNX: MOVE U4,[UOL.X,,UOS.X] ; Specify string-mode rtns to use MOVE U1,@(U3) ; Get instr to XCT JRST UOPN3 ; String output, XCT UOL.X: SKIPG U1,U4 RET ADDB U1,@UCHCNT(OC) JUMPL U1,UOS.X2 CALL OVFS ; Handle overflow. UOS.X: ADDM U4,@UCHCNT(OC) UOS.X2: ILDB U1,U3 XCT UCOPT(OC) ; for now, really unit-mode. SOJG U4,.-2 RET ; UC$BPT - Channel type BPT (Byte Ptr) UOPNBP: MOVE U1,@(U3) ; Get byte ptr MOVEM U1,UCHSTB(OC) ; And use that as channel state. MOVE U1,[IDPB U1,UCHSTB] ADDI U1,(OC) ; Make IDPB point to right BP MOVE U4,[UOL.BP,,UOS.BP] ; Specify string-mode output rtns. JRST UOPN3 ; Store instruction & other stuff. ; String output, BP UOL.BP: SKIPG U1,U4 RET ADDB U1,@UCHCNT(OC) JUMPL U1,UOS.B2 CALL OVFS ; Handle overflow. UOS.BP: ADDM U4,@UCHCNT(OC) ; Inc. count UOS.B2: ILDB U1,U3 IDPB U1,UCHSTB(OC) ; BP lives there. SOJG U4,.-2 RET ; UC$IOT - Channel Type IOT ("Hard" channel) UOPNIO: IFN OS%ITS,[ MOVE U1,[.IOT U1] ; Get unit operation CAILE OC,17 ; Ch # must fit into AC field. JSR AUTPSY DPB OC,[$ACFLD,,U1] ; Store ch # into instr ] IFN OS%TNX,[ MOVE U1,@(U3) ; Get JFN for channel MOVEM U1,UCHJFN(OC) ; store MOVE U1,[CALL U.BOUT] ; Set up instr to xct ] MOVE U4,[UOL.IO,,UOS.IO] ; Specify string-mode output rtns JRST UOPN3 IFN OS%TNX,[ U.BOUT: PUSHAE P,[1,2] ; Routine called for UC$IOT byte output MOVE 1,UCHJFN(OC) MOVE 2,U1 BOUT POPAE P,[2,1] POPJ P, ] ;String output, .IOT UOL.IO: SKIPG U1,U4 RET ADDB U1,@UCHCNT(OC) JUMPL U1,UOS.I2 CALL OVFS ; Handle overflow. UOS.IO: ADDM U4,@UCHCNT(OC) ; Bump cnt. UOS.I2: IFN OS%ITS,[ SYSCAL SIOT,[OC ? U3 ? U4] ; Trivial! JSR AUTPSY ; ?!?! ] IFN OS%TNX,[ PUSHAE P,[1,2,3] MOVE 1,UCHJFN(OC) ; Set up JFN MOVE 2,U3 ; bp to string MOVN 3,U4 ; byte count SOUT POPAE P,[3,2,1] ] RET ; UC$BUF - Channel type BUF (buffered UC$IOT) ; This code assumes U3 is of form ; ,[ [arg] ? [lim] ? [bytesize]] ; is as for UC$IOT - on TNX, the JFN to use. ; is the size of bytes to use. ; Defaults to 7. ; is the buffer size, IN BYTES, to use. ; Defaults to one page. ; If negative, it is treated as an AOBJN pointer to ; the buffer; LH is # of WORDS. ; If unspecified or zero, the buffer is dynamically allocated. ; Be sure to CLS the channel, or the buffer will ; stay around forever! UOPNBF: IFE $$OBUF,JSR AUTPSY .ELSE [ MOVE U1,U3 ; Get arg ptr into better place IFN OS%TNX,[ MOVE U4,@(U1) ; Get 1st arg (JFN) MOVEM U4,UCHJFN(OC) ; Store... ] TLNN U1,(UC%BSZ) ; Was byte-size specified? JRST [ MOVEI U3,440700 ; No, default to 7-bit. Set up BP LH HRLZM U3,UCHSTB(OC) MOVEI U4,5 ; and use this many bytes/wd JRST UOPNB2] SKIPLE U4,@2(U1) ; Get byte-size... CAILE U4,36. ; Make sure it's reasonable. JSR AUTPSY MOVEI U3,440000 DPB U4,[060600,,U3] ; Insert it into S field of BP LH HRLZM U3,UCHSTB(OC) ; and store LH for later use. MOVEI U3,36. IDIV U3,@2(U1) ; Find # bytes per word MOVE U4,U3 ; Save ; Have in U4, now find buffer length. UOPNB2: TLNN U1,(UC%LIM) ; Byte limit specified? JRST UOPNBD ; Nope, use default. SKIPGE U3,@1(U1) ; If is AOBJN, it specifies # words. JRST [ HLRO U3,U3 ; Get -<# wds> MOVN U3,U3 JRST UOPNB3] ; Go set up stuff. JUMPE U3,UOPNBD ; If zero, use default of one page. PUSH P,U3 ; Save # bytes IDIVI U3,(U4) ; Find # words to use CAIE U4, ; If any remainder, ADDI U3,1 ; round up to next # of words. POP P,U4 ; Restore # bytes (want to use exact # given). JRST UOPNB4 UOPNBD: MOVEI U3,PG$SIZ UOPNB3: IMULI U4,(U3) ; Find # bytes to use in buffer. UOPNB4: MOVNM U4,UCHLIM(OC) ; Save -<# bytes> as limit. MOVNM U4,UCNTS(OC) ; and set up actual countdown. ; Now have buffer length in U3 as # words. See if must allocate. TLNE U1,(UC%LIM) ; Check again for existence. SKIPL U1,@1(U1) ; Clobber arg ptr, skip if AOBJN given. CAIA JRST UOPNB5 ; Needn't allocate! U1 RH has buf addr! IFE U2-OC,PUSH P,OC MOVEI U1,(U3) ; Ask for this many wds. IFDEF CORGET,CALL CORGET ; Get buffer space, return addr in U2 .ELSE JSR AUTPSY ? IF2 .ERR PAGSER package must be inserted for UC$BUF!! MOVEI U1,(U2) IFE U2-OC,POP P,OC ; Need hair when U2 == OC. MOVSI U4,UC%DBF ; Must set "dynamic buffer" flag IORM U4,UCHTYP(OC) ; so we remember to de-allocate later. UOPNB5: ADDI U3,(U1) ; Find last addr + 1 HRLM U1,UCHLIM(OC) ; Save start addr of buffer HRRM U1,UCHSTB(OC) ; and set up initial BP addr. HRLI U1,(U1) ADDI U1,1 ; Set up src,,src+1 for BLT zap. SETZM -1(U1) CAILE U3,(U1) ; Handle screw case of 1-wd buffer. BLT U1,-1(U3) ; Clean out the buffer. MOVEI U4,UCNTS(OC) MOVEM U4,UCHCNT(OC) ; Set addr of countdown MOVEI U4,UOL.BF ; Set string-mode rtn addr. MOVEM U4,USCOPT(OC) ; Set it. MOVEI U1,UCHSTB(OC) HRLI U1,(IDPB U1,) ; Cons up unit-mode instr MOVEM U1,UCOPT(OC) ; Set. RET ; Done... UOL.BF: SKIPG U1,U4 ; Get temp in U1 RET ; making sure something to write. ADDB U1,@UCHCNT(OC) ; Add into count JUMPGE U1,UOLBF1 ; Jump if buffer would be filled up. ILDB U1,U3 ; Nope, just copy light-heartedly. IDPB U1,UCHSTB(OC) SOJG U4,.-2 RET ; "Overflow". Note that unlike usual case, we come here even ; when count is zero, in order to optimize bulk I/O. ; The idea behind this optimization is that if buffer is ; empty and byte sizes for request/output are same, we ; can output directly and skip the copy overhead! ; This is also done if stuff is already in the buffer but ; the new stuff is large enough to force two system calls anyway. ; Only possible problem is if something depends on size of ; string output for each sys call, eg if one wants to do PMAP ; type stuff. If that ever becomes desirable, a new output type ; or flag can be created. UOLBF1: PUSH P,U3 HRRO U3,UCHLIM(OC) ; Get original limit (fill out LH) SUB U1,U4 ; Get original countdown, -<# left> CAMG U1,U3 ; Countdown increased from original? JRST UOLBF2 ; No, making huge request of virgin buffer - Optimize! MOVM U3,U3 ; Get positive buffer length SUB U3,U1 ; Add # bytes of room left in buffer CAMGE U3,U4 ; Will we need more than one sys call? JRST UOLBF4 ; No, jump to copy & output. UOLBF2: PUSH P,U1 ; Save -<# left> LDB U1,[$SFLD,,-1(P)] ; Get S field of source BP LDB U3,[$SFLD,,UCHSTB(OC)] ; Ditto for buffer BP CAIE U1,(U3) ; If same, way's clear! JRST UOLBF3 ; Nope, must convert via copy. ;;; Following code prevents the disoptimization of doing non-word-aligned ;;; SIOTs which are very slow in ITS CAIE U1,7 ; Only if byte size is 7 JRST UOLB2A PUSH P,U2 MOVN U1,(P) ; Space available in buffer IDIVI U1,5 JUMPN U2,UOLB2B ; Mustn't SIOT MOVE U1,U4 ; Amount to be output IDIVI U1,5 JUMPN U2,UOLB2B POP P,U2 ; Okay, go ahead UOLB2A: ;;; End of antidisoptimization code EXCH U4,(P) ; Save output cnt on PDL, get back -<# left> HRRO U3,UCHLIM(OC) ; Get - for quick check... MOVEM U3,UCNTS(OC) ; and reset limit in case no force-out. CAMGE U3,U4 ; Anything at all in buffer? CALL UFRCBI ; Yes, force it out using U4 for UCNTS. POPAE P,[U4,U3] ; Then restore original source BP and cnt CALRET UOS.I2 ; and go output directly via UC$IOT rtn! UOLB2B: POP P,U2 ; This could be smarter! UOLBF3: POP P,U1 ; Restore -<# left> UOLBF4: EXCH U4,(P) ; Save output cnt, get back BP MOVE U3,U4 ; Put BP in usual place JUMPGE U1,UOLBF6 ; If buffer already full, skip copy. ADDM U1,(P) ; Update saved output cnt. MOVM U4,U1 ; and get cnt of chars to copy. ILDB U1,U3 ; Twiddle IDPB U1,UCHSTB(OC) ; twaddle SOJG U4,.-2 UOLBF6: PUSH P,U3 ; Save source BP CALL UFRCBA ; Buffer always full here; output All. POP P,U3 ; Now restore source BP POP P,U4 ; and updated count JRST UOL.BF ; and start over... ; UFRCBF - Force out buffer. Clobbers U1,U3,U4. ; Alternate entry points UFRCBI - takes -<#left> countdown in U4 (Immediate) ; UFRCBA - sets -<#left> countdown to 0 (All of buffer) UFRCBA: TDZA U4,U4 UFRCBF: MOVE U4,UCNTS(OC) ; Get -<# left> UFRCBI: CAILE U4, ; Make sure something didn't trash buffer! JSR AUTPSY ; Ugh, buffer overflowed?!?! CALL UBFRST ; Reset buffer cnt/ptr, get -len in U1. SUB U4,U1 ; -<# left> - - = # to output. JUMPG U4,UOS.I2 ; Output buffer as per UC$IOT type. RET ; UBFRST - Called to reset buffer channel. ; Doesn't clobber U4, and leaves - in U1. ; UFRCBF depends on this. UBFRST: MOVE U1,UCHLIM(OC) ; Get ,,<-len> HLRZ U3,U1 HLL U3,UCHSTB(OC) ; Cons up new BP to start of buffer TLZ U3,770000 TLO U3,440000 ; Force P to 1st byte in word. MOVEM U3,UCHSTB(OC) ; and set up new ptr. TLO U1,-1 ; Make length a kosher neg. num. MOVEM U1,UCNTS(OC) ; Store to re-initialize countdown. RET ] ;IFN $$OBUF ; UC$TRN - Channel type TRANSL (translate to another UUO chan) ; Ignores any count specified. ; Main hair is setting things up so unit-mode AOS and XCT ; will work; for everything else including string-mode, the ; mapping is straightforward. UOPNTR: MOVE U4,@(U3) ; Get channel to translate to. CAIL U4,$UNCHS ; Make sure it's reasonable! JSR AUTPSY MOVE U1,[XCT UCOPT] ADDI U1,(U4) ; Do a XCT UCOPT+chan MOVEM U1,UCOPT(OC) MOVE U1,[@UCHCNT] ; Assemble an indirect into ADDI U1,(U4) ; the target channel's countdown. MOVEM U1,UCHCNT(OC) MOVE U1,UCHSTB(U4) ; Just copy UCHSTB MOVEM U1,UCHSTB(OC) MOVEM U4,UCNTS(OC) ; and hide true channel # in unused count slot. MOVEI U3,UOS.TR MOVEM U3,USCOPT(OC) RET ;String output, Translate. UOS.TR: IFN $$OUT,PUSH P,OC MOVE OC,UCNTS(OC) ; Find right channel # to use. IFN $$OUT,[ CALL @USCOPT(OC) ; and go hack. POP P,OC RET ] .ELSE PJRST @USCOPT(OC) ; UC$NUL - Null output sink UOPNNL: MOVE U4,[UOS.NL,,UOS.NL] ; Specify string-mode rtns to use MOVE U1,[NOP] ; Get instr to XCT TLZ U3,(UC%LIM) ; Ignore any specified limit. JRST UOPN3 UOS.NL: ADDM U4,@UCHCNT(OC) ; Might as well keep track of count. RET ; But that's it. ; UCHMP - called when byte count on channel runs out during unit-mode ; output; see the STDOUT macro for context. Only other place this ; routine is called is from UAR-type string output. ; OC - channel #, ; @UCHCNT(OC) contains positive # of chars "over-run". ; for output to areas, this is # of chars needed. ; UCHMPX - variant in which ; U3 contains a BP that must be preserved across area bumps. UCHMPX: IFN UAREAS,[ MOVEM U3,UBMPSP ; Save U3 in holy place, PUSHJ P,UCHMP ; so that its input ptr is bumped correctly if nec. MOVE U3,UBMPSP ; Restore from sanctuary. POPJ P, ] UCHMP: PUSHAE P,[U1,OC,U3,U4] UCHMP0: MOVE U1,UCHTYP(OC) ; Get channel type JRST @OVFTAB(U1) ; Dispatch to appropriate handler OVFTAB: OVFLAR ; UAR OVFLX ; XCT OVFLBP ; BPT OVFLIO ; IOT OVFLBF ; BUF OVFLTR ; TRAN OVFLNL ; NUL IFN .-, .ERR OVFTAB Loses ; TRAN type overflow. OVFLTR: MOVE OC,UCNTS(OC) ; Translate, get real chan # JRST UCHMP0 ; and try again. ; BUF type overflow. OVFLBF: IFE $$OBUF,JSR AUTPSY .ELSE [ SOS @UCHCNT(OC) ; Restore #-left to zero. CALL UFRCBF ; Force out buffer AOS @UCHCNT(OC) ; Allow for char wanting output JRST UCHMP9 ; And return normally. ] ; NUL, XCT, IOT, and BPT type overflow. OVFLNL: OVFLX: OVFLIO: OVFLBP: MOVE U1,UCHLIM(OC) ; Get limit for channel CAME U1,[SETZ] ; If using maximum, no limit. JRST OVFLIM ; uh-oh, actually limiting... go handle. MOVEM U1,UCNTS(OC) ; No limit, just reset count. JRST UCHMP9 ; Return and output char. ; UAR type overflow OVFLAR: IFE UAREAS,JSR AUTPSY IFN UAREAS,[ MOVE U1,UCHSTB(OC) ; Get ARPT for area SKIPG U3,$ARCHL(U1) ; and # chars needed. JSR AUTPSY ; ugh?? called when not supposed to? IFN USTRGS,[ CAIN U1,USTRAR ; Is this the string output area? PUSHJ P,USTRGC ; Ugh, yes. Go see about GC'ing. JRST OVFAR2 ; Didn't GC, proceed normally and expand SKIPL $ARCHL(U1) ; If still need room after possible GC, JRST OVFAR2 ; go expand normally. ADDB U3,$ARCHL(U1) ; GC'd! Add to cnt of chars now available JUMPL U1,UCHMP9 ; and exit if have enough now OVFAR2:] ; else drop thru to normal expansion. ADDI U3,4 IDIVI U3,5 ; Round up to # wds needed (clobbers U4) MOVEM U3,ARUNIT ; Insert # as arg to UABUMP PUSHJ P,UABUMP ; Go bumpit - adjusts $ARCHL. SKIPLE $ARCHL(U1) ; Check to be SURE. JSR AUTPSY ; Foo, didn't update or didn't get enough. JRST UCHMP9 ] ;IFN UAREAS OVFLIM: SOS @UCHCNT(OC) ; Restore original count UCHMP8: AOS -4(P) ; Abnormal return - DON'T output char!! UCHMP9: ; Normal return - output char. POPAE P,[U4,U3,OC,U1] POPJ P, ; OVFS - General-purpose overflow handler for string-mode routines. ; Only invoked for channels which are definitely being limited; ; it allows output only up to the limit specified. ; See BPT, IOT, etc. routines for context. ; This is a bit inefficient, could be improved by turning ; unit/string mode ops into NOPs. ; OC - channel # ; U1 - # chars overflowed ; U3 - source BP ; U4 - source cnt ; (P) - place to return for no-limit output ; -1(P) - place to return for no output at all. OVFS: SUB U1,U4 ; Find original count of -<# left> MOVEM U1,@UCHCNT(OC) ; Store back MOVN U4,U1 ; Smash source cnt to max allowable CAIG U4, ; If result is non-null then skip to output POP P,U1 ; Else flush 1st return, take 2nd for no output RET ; OUTPTV CH,[] For use with UUO channels. ; Returns to c(E) the cnt of chars outputted on channel since ; opened. For channels opened into an area, this is ; the # of chars between start of area and current Write BP. IFN $$OUUO,[ UUODEF OUTPTV:,UCHPTV UCHPTV: LDB OC,UACFLD ; Get channel #. CALL UPTV MOVEM U1,@U40 ; Store result UUOXRT ] ;IFN $$OUUO UPTV: MOVE U1,UCHTYP(OC) ; Get channel type. PJRST @UPTTAB(U1) UPTTAB: UPTAR ; Area UPTX ; XCT UPTBP ; BPT UPTIO ; IOT UPTBF ; BUF UPTTR ; Transl. UPTNL ; NUL IFN UC$NX-<.-UPTTAB> .ERR UPTTAB table loses UPTAR: IFE UAREAS, JSR AUTPSY .ELSE [ MOVE U4,UCHSTB(OC) ; Get ARPT MOVE U1,$ARWPT(U4) ; Get write ptr into area IFSVU2, PUSH P,U2 HRRZ U2,$ARLOC(U4) ; and "ptr" to start. CALL UPDIF7 ; Find diff between the 2 ptrs MOVE U1,U2 IFSVU2, POP P,U2 RET ] UPTIO: UPTX: UPTNL: ; These types share similar code. UPTBP: SKIPA U1,UCHLIM(OC) ; Find beginning count. UPTBF: HRRO U1,UCHLIM(OC) ; BUF type has cruft in the LH. SUB U1,@UCHCNT(OC) ; <-max> - <-max + cnt> = -cnt MOVM U1,U1 RET UPTTR: PUSH P,OC MOVE OC,UCNTS(OC) ; Get true channel # CALL UPTV POP P,OC RET ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Other maintenance routines ; OUTINI - Initialize output package. OUTINI: PUSH P,OC PUSH P,[$UNCHS] ; Keep cnt on PDL cuz ACs clobbered. OUTIN2: SOSGE OC,(P) JRST OUTIN3 CALL OXCLS ; Close channel JRST OUTIN2 OUTIN3: IFN $$OUT,[ ; Set up for field-output channel. OUTCOD(,CH(UFLDC),OPEN(UC$BPT,[440700,,UFBUF],[$LUBUF])) ] SUB P,[1,,1] POP P,OC RET OIFRC: OXFRC: IFN $$OBUF,[ HRRZ U1,UCHTYP(OC) ; Get channel type CAIN U1,UC$BUF ; If type BUF, CALRET UFRCBF ; Go force it out, ] RET ; else just return. ; Reset channel. Only meaningful for UAR and BUF. OIRST: OXRST: HRRZ U1,UCHTYP(OC) ; Get channel type IFN $$OBUF,[ CAIN U1,UC$BUF CALRET UBFRST ; Do special buffer reset if BUF. ] IFN UAREAS,[ CAIN U1,UC$UAR JRST [ MOVE U4,UCHSTB(OC) ; Get ARPT to area HLL U4,$ARTYP(U4) ; and set up type bits PJRST UXRST] ; and go reset area. ] RET OICLS: OXCLS: HRRZ U1,UCHTYP(OC) ; Get channel type IFN $$OBUF,[ CAIE U1,UC$BUF ; If not doing buffered output JRST OXCLS5 ; can skip FORCE of output. CALL UFRCBF ; Buffered, must force out vestiges. MOVE U3,UCHTYP(OC) ; Now get flags in LH HLRZ U1,UCHLIM(OC) ; and buffer addr in U1 TLNE U3,UC%DBF ; Dynamically allocated buffer? CALL CORREL ; Yup, must release it! CAIA ; Now skip down to call OCCLS and proceed. ] OXCLS5: CAIN U1,UC$IOT ; If "hard" channel type, CALL OCCLS ; must close it from OS viewpoint too. OXCLS7: MOVEI U1,UCNTS(OC) MOVEM U1,UCHCNT(OC) ; Set safe address for count (not zero!!!) MOVE U1,[CALL OBADCH] MOVEM U1,UCOPT(OC) ; Store unit-mode instruction MOVEM U1,USCOPT(OC) ; and string-mode rtn addr. SETZM UCHTYP(OC) ; Make channel type "closed" RET OBADCH: JSR AUTPSY ; Output attempted on closed channel. RET OCCLS: IFN OS%ITS,{SYSCAL CLOSE,[OC] ? JSR AUTPSY } IFN OS%TNX,{ PUSH P,1 HRRZ 1,UCHJFN(OC) CLOSF ERJMP .+1 POP P,1 } RET ; IO Channel "PDL" - PUSH, POP, POPALL IFN UAREAS,[ .SCALAR IOPDLP ; Address of ARBLK for IOPDL area. .SCALAR IOPCNT ; # of channels pushed. OXPUSH: ; Save channel vars SKIPN U4,IOPDLP ; Get address of ARBLK JRST [ UAROPN U4,[0 ? [200]] ; Must create, so make one. HRRZM U4,IOPDLP SETZM IOPCNT JRST .+1] AOS IOPCNT HRRZ U1,$ARWPT(U4) ; Get write ptr, HRRZ U3,$ARTOP(U4) ; and 1st non-ex addr, CAIL U1,-$OCFRM(U3) ; and ensure enough room. JRST [ MOVEI U4,$OCFRM UAREXP U4,@IOPDLP ; Expand the area. MOVE U4,IOPDLP ; Restore ARPT HRRZ U1,$ARWPT ; Restore write ptr. JRST .+1] ADD U1,[1,,-1] ; Avoid PDLOV interrupt overhead and get ptr. %%OCNT==. IRP LOC,,[UCOPT,USCOPT,UCHCNT,UCNTS,UCHLIM,UCHTYP,UCHSTB] PUSH U1,LOC(OC) TERMIN IFN OS%TNX,PUSH U1,UCHJFN(OC) $OCFRM==:<.-%%OCNT> ; Get # wds per frame. ADDI U1,1 HRRZM U1,$ARWPT(U4) ; Store new write ptr. HRRZ U1,UCHTYP(OC) CAIE U1,UC$IOT CAIN U1,UC$BUF CAIA CALRET OXCLS7 IFN OS%ITS,[ MOVE U1,[.IOPUSH] DPB OC,[$ACFLD,,U1] XCT U1 ] CALRET OXCLS7 ; Softwarily close channel. CALL OXPOP OXPDLR: SKIPLE IOPCNT JRST .-2 UARCLS @IOPDLP SETZM IOPDLP RET OXPOP: SOSGE IOPCNT JSR AUTPSY CALL OXCLS ; Close channel currently in slot. ; Restore channel vars. SKIPN U4,IOPDLP JSR AUTPSY ; Attempt to pop empty stack... MOVE U1,$ARWPT(U4) SUB U1,[1,,1] IFN OS%TNX,POP U1,UCHJFN(OC) IRP LOC,,[UCHSTB,UCHTYP,UCHLIM,UCNTS,UCHCNT,USCOPT,UCOPT] POP U1,LOC(OC) TERMIN ADDI U1,1 HRRZM U1,$ARWPT(U4) ; Fix up channel vars in case popped into different channel. HRRZ U3,UCHTYP(OC) JRST @.+1(U3) %%OTMP==. OXPUAR OXPXCT OXPBPT OXPIOT OXPBUF OXPTRN OXPNUL IFN <.-%%OTMP>-UC$NX, .ERR UXPOP table loses OXPBUF: OXPIOT: IFN OS%ITS,[ DPB OC,[$ACFLD,,UCOPT(OC)] ; Set up new chan for unit-mode .IOT MOVE U1,[.IOPOP] DPB OC,[$ACFLD,,U1] XCT U1 ; Pop back hardware channel. ] CAIE U3,UC$BUF JRST OXPNUL OXPBPT: MOVEI U1,UCHSTB(OC) HRRM U1,UCOPT(OC) OXPXCT: OXPNUL: MOVEI U1,UCNTS(OC) MOVEM U1,UCHCNT(OC) OXPUAR: OXPTRN: RET ] ; IFN UAREAS SUBTTL OUT - Formatting routines IFN $$OUT,[ ; FMT - Sets field width, etc for next out-instruction. OUTDEF O.FMT:,OXFMT ; FMT - arg is addr of rtn to call for setup. ; Interpreted mode isn't really figured out yet. OXFLD: JSP U4,@U3 ; Call routine JRST OXFST1 ; Return vectors according to # params. JRST OXFST2 JRST OXFST3 BVAR UFFLG: 0 ; If -1, format params in effect. UFWID: 0 ; If non-z, specifies a field width. UFPREC: 0 ; Specifies "precision" for strings & floating output UFFILL: 0 ; Specifies "fill char" or something like that. UFSCNT: 0 ; Saved channel char cnt UFSCHN: 0 ; Saved channel # EVAR OXFST1: HRLOI U3,377777 ; Specify width only. Set prec to max. OXFST2: SETZ U4, ; Specify width & prec only. Set fill char to blank. OXFST3: MOVEM U4,UFFILL ; Set fill MOVEM U3,UFPREC ; Set prec MOVEM U1,UFWID ; Set width SETOM UFFLG ; Say hacking format parameters. ; Set up channel for temporary buffer storage MOVEM OC,UFSCHN ; Save current channel, and MOVEI OC,UFLDC ; substitute "field" channel. SKIPN UCOPT(OC) ; Make sure something there... OUTCAL(,OPEN(UC$BPT,0,[$LUBUF])) ; If not, open it with limit. MOVE U1,[440700,,UFBUF] MOVEM U1,UCHSTB(OC) ; Reset write-pointer SKIPL U1,UFPREC ; Use desired limit. If negative, CAILE U1,$LUBUF ; or too large, MOVEI U1,$LUBUF ; use maximum. MOVNM U1,UCNTS(OC) ; Reset byte countdown to limit. MOVNM U1,UCHLIM(OC) ; And save limit being used. RET OUTDEF O.FDN:,OXFDON ; Interpreted mode not really figured out yet ; Finalize formatting... called when output done. OXFDON: SETZM UFFLG ; Turn off formatting. CAIE OC,UFLDC ; Make sure channel is correct one. JSR AUTPSY ; Got zapped in meantime!!?? MOVE U1,UCNTS(OC) ; Get resulting byte countdown SUB U1,UCHLIM(OC) ; <-max + cnt> - <-max> = <# chars written> MOVE OC,UFSCHN ; Now can restore previous channel. SKIPL U3,UFWID ; What sort of justification? JRST OXFRD ; Right justifying. ; Left justifying, so output buffer, then fill. ADD U3,U1 ; <# chars written> + - PUSH P,U3 ; Save -<# pads> SKIPG U4,U1 ; Set up <# chars> for output JRST OXFDL3 ; Nothing to output? MOVE U3,[440700,,UFBUF] CALL @USCOPT(OC) ; Output buffered stuff to real channel. OXFDL3: POP P,U4 ; Restore -<# pads> JUMPGE U4,[RET] ; If no fill needed, return. MOVM U4,U4 ; Get <# pads> SKIPN U1,UFFILL ; If strange fill char, CAIL U4,$LBSTR ; or filling more than is reasonable, JRST OXFDF ; jump to handle special case. MOVE U3,[440700,,UBLSTR] ; Normal case will efficiently PJRST @USCOPT(OC) ; output string of padding blanks and return. ; Finalize right-justified string... OXFRD: PUSH P,U1 ; Save <# chars written> SUB U1,U3 ; Find -<# pads to prepend> JUMPGE U1,OXFDR4 ; Jump if none; can simply output stuff. SKIPN UFFILL ; If strange fill char, CAMGE U1,[-$LBSTR] ; or too much padding, JRST OXFDR3 ; do it hard way. MOVE U3,[440700,,UFBUF] MADBP7 U3,U1 ; Adjust BP in U3 by cnt in U1 POP P,U4 SUB U4,U1 ; <# writ> - <- # pad> = total to write out PJRST @USCOPT(OC) ; Output string of blanks AND data together!! OXFDR3: MOVM U4,U1 ; Move <# pads> to right place CALL OXFDF ; Output fill chars one at a time. OXFDR4: POP P,U4 ; Restore # chars written originally MOVE U3,[440700,,UFBUF] ; Point at field buffer JUMPG U4,@USCOPT(OC) ; Output and return. RET OXFDF: SKIPN U1,UFFILL ; If fill char zero, MOVEI U1,40 ; means regular blank. OXRPTC: STDOUT ; Repeatedly output byte... SOJG U4,OXRPTC RET BVAR $LBSTR==5*30. ; # blanks in filler buffer UBLSTR: .BYTE 7 REPEAT $LBSTR,40 .BYTE ; Note buffers contiguous!! $LUBUF==$LBSTR ; # chars avail in field-adjusting buffer UFBUF: BLOCK <$LUBUF+4>/5 EVAR ] ;IFN $$OUT SUBTTL OUT - Basic output routines ; NOTE: the UUO versions of these routines are becoming obsolete. IFN $$OUUO,[ ; OUTPUT UUOS. All should avoid clobbering U4 before ; reading args, since FWRITE macro may be using it to set ; up UUO calls. Most but not all are 7-bit; OUTPC is ; completely general. UUODEF OUTI:,U7I ; Immediate - E is char UUODEF OUTZ:,U7Z ; E->ASCIZ string UUODEF OUTC:,U7C ; c(E) = <# chars>,, UUODEF OUTPZ:,U7PZ ; c(E) = BP to ASCIZ string UUODEF OUTPC:,UTPC ; c(E) = <# chars>,,[BP] IFN OS%TNX+USTRGS,UUODEF OUTS:,U7S ; c(E) = <# chars> ? UUODEF OUT6F:,U6F ; outputs c(E) as 6bit, ignores trailing blanks. EQUALS .M"OU6F,OUT6F UUODEF OUT6W:,U6W ; outputs c(E) as 6bit, all 6 chars. EQUALS .M"OU6W,OUT6W UUODEF OUT6Q:,U6Q ; outputs c(E) as 6bit, quotes punctuation chars with ^Q, drops tr blnk EQUALS .M"OU6Q,OUT6Q UUODEF OUT10.:,UN10 ; outputs c(E) as decimal value, with point. EQUALS .M"OUN10,OUT10. UUODEF OUT10:,UN9 ; like OUN10 but no decimal point. EQUALS .M"OUN9,OUT10 UUODEF OUT8:,UN8 ; outputs c(E) as octal value. EQUALS .M"OUN8,OUT8 UUODEF OUNRH:,UNRH ; outputs RH of c(E) as 6 octal digits. UUODFA CRLF:,UCRLF ; outputs CRLF, ignores E. ] ;IFN $$OUUO OUTDEF O.C:,OXCI ; C - Character U7I: UIOINIT ; Entry pt for OUTI UUO HRRZ U1,U40 IFN $$ORID,[ JRST OXC OXCI: MOVEI U1,@U3 ] ; Get argument (immediate type) OXC: STDOUT ; Direct entry pt (if needed) RET OUTDEF O.EOL:,OXEOL UCRLF: UIOINIT ; Entry pt for CRLF UUO OXCRLF: OXEOL: STDOUT(^M) STDOUT(^J) RET OXTAB: STDOUT(^I) ; For convenience. RET OUTDEF O.:,OXTXTI ; O. is used by OUT macro for short constant strings. ; Note this instr doesn't use I, X or AC because ; string is always constant, only invoked by macro. IFN $$ORID,[ OXTXTI: LDB U4,[.BP <777,,>, U3] ; Get # chars from instr itself. HRLI U3,440700 ; and turn instr into a BP to string JUMPN U4,@USCOPT(OC) ; and off to output it! RET ] OUTDEF O.ZA:,OXZAI ; O.ZA - arg is addr of ASCIZ string. U7Z: UIOINIT ; Entry pt for OUTZ UUO SKIPA U3,U40 OXZAI: MOVEI U3,@U3 ; get addr of string OXZA: HRLI U3,440700 ; form byte ptr JRST OXZ ; Jump into loop OUTDEF O.ZP:,OXZPI ; O.ZP - arg is addr of BP to BYTEZ string U7PZ: UIOINIT ; Entry pt for OUTPZ UUO SKIPA U3,@U40 OXZPI: MOVE U3,@U3 ; get byte ptr JRST OXZ OXZ1: STDOBP ; Output byte (BP in U3 in case count out) OXZ: ILDB U1,U3 ; Get input byte JUMPN U1,OXZ1 ; Loop til hit zero byte. RET OUTDEF O.PC:,OXPC ; PC - Horrible crock kept for compat. UTPC: UIOINIT ; Entry pt for OUTPC UUO SKIPA U3,@U40 ; Get ,,[bp] OXPCI: MOVE U3,@U3 OXPC: HLRZ U4,U3 ; Direct entry - get cnt MOVE U3,(U3) ; Get the bp JUMPN U4,@USCOPT(OC) ; Dispatch RET OUTDEF O.TC:,OXTCI ; O.TC [<# chs>,,[ASCII]] U7C: UIOINIT ; Entry pt for OUTC UUO SKIPA U3,@U40 OXTCI: MOVE U3,@U3 ; Get cnt,,stringloc OXTC: HLRZ U4,U3 ; Get cnt HRLI U3,440700 ; Form BP in U3 JUMPG U4,@USCOPT(OC) ; Dispatch RET OUTDEF O.SA:,OXSAI ; O.SI - E->[[# bytes] ? [BP]] OXSAI: MOVEI U3,@U3 ; Get E OXSA: MOVE U1,(U3) ; Get addr of byte cnt MOVE U3,1(U3) ; Get addr of BP MOVE U3,@U3 ; Get BP MOVE U4,@U1 ; Get byte cnt JUMPN U4,@USCOPT(OC) ; Vector to right routine RET OUTDEF O.S:,OXSI ; O.S [,,<# bytes> ? ] U7S: UIOINIT ; Entry pt for OUTS UUO SKIPA U3,U40 OXSI: MOVEI U3,@U3 ; Get addr to string descriptor OXS: HRRZ U4,(U3) ; Get byte cnt MOVE U3,1(U3) ; Get byte ptr JUMPG U4,@USCOPT(OC) ; Jump into output rtn RET ; Return if null string. SUBTTL OUT - Sixbit output OUTDEF O.6W:,OX6WI ; O.6W - outputs arg as 6bit, all 6 chars U6W: UIOINIT SKIPA U3,@U40 ; Entry pt for OUT6W UUO OX6WI: MOVE U3,@U3 ; Get 6bit wd OX6W: MOVE U4,[440600,,U3] OX6W1: ILDB U1,U4 ; Get 6bit char ADDI U1,40 ; Convert to ASCII STDOUT ; Output TLNE U4,770000 ; BP counted out yet? JRST OX6W1 RET OUTDEF O.6F:,OX6FI ; O.6F - outputs arg as 6bit, no trailing spaces. U6F: UIOINIT SKIPN U3,@U40 RET JRST OX6F OX6FI: SKIPN U3,@U3 ; Get 6bit wd RET ; Return if nothing (no trailing blanks) OX6F: SETZ U4, ; Direct calling sequence SKIPE U3,ARG ? CALL OX6F ROTC U3,6 STDOUT(40(U4)) JUMPN U3,OX6F RET OUTDEF O.6Q:,OX6QI ; O.6Q - outputs arg as 6bit, quotes punct, no tr. sp. U6Q: UIOINIT SKIPA U3,@U40 OX6QI: MOVE U3,@U3 ; Get 6bit wd OX6Q: SETZ U4, ROTC U3,6 ; Get next character in 6bit CAIN U4,'- ; If other than letter, number, or hyphen JRST OX6Q3 ; will need a ^Q to quote it. CAIL U4,'0 CAILE U4,'Z JRST OX6Q2 CAILE U4,'9 CAIL U4,'A JRST OX6Q3 OX6Q2: STDOUT(^Q) OX6Q3: STDOUT(40(U4)) JUMPN U3,OX6Q RET SUBTTL OUT - Numerical output OUTDEF O.O:,OXN8I ; O - Octal OUTDEF O.D:,OXN10I ; D - Decimal OUTDEF O.X:,OXN16I ; X - Hexadecimal UN10: UIOINIT ; Entry pt for OUT10. UUO MOVE U3,@U40 OXN10.: MOVEI U1,10. CALL UNTYP STDOUT(".) RET UN8: SKIPA U1,[8.] ; Entry pt for OUT8 UUO UN9: MOVEI U1,10. ; Entry pt for OUT10 UUO UIOINIT MOVE U3,@U40 JRST UNTYP OXN16I: MOVEI U1,16. ? JRST UNTYPI OXN8I: SKIPA U1,[8.] OXN10I: MOVEI U1,10. UNTYPI: SKIPL U3,@U3 ; Get argument value JRST UNTYP1 UNTYP5: MOVM U3,U3 ; Negative, print minus sign. MOVE U4,U1 ; Save radix STDOUT("-) MOVE U1,U4 ; Restore radix JRST UNTYP1 ; Direct call entry points to numerical typeout rtn. OXN16: MOVEI U1,16. ? JRST UNTYP OXN8: SKIPA U1,[8.] OXN10: MOVEI U1,10. UNTYP: JUMPL U3,UNTYP5 ; Go print minus sign. UNTYP1: IDIVI U3,(U1) JUMPE U3,UNTYP2 HRLM U4,(P) ; save digit on stack. PUSHJ P,UNTYP1 HLRZ U4,(P) UNTYP2: CAILE U4,9. SKIPA U1,-10.(U4)+["A ? "B ? "C ? "D ? "E ? "F] ; For hex output MOVEI U1,"0(U4) ;put char in u1 STDOUT POPJ P, SUBTTL Halfword output OUTDEF O.RH:,OXRHI ; O.RH - prints RH of arg as 6 octal digits OUTDEF O.LH:,OXLHI ; O.LH - ditto for LH OUTDEF O.HWD:OXHWDI ; O.HWD - LH,,RH OXHWDI: MOVE U3,@U3 OXHWD: PUSH P,U3 CALL OXLH POP P,U3 STDOUT(54) ; Comma STDOUT(54) CALRET OXRH OUTDEF O.HV:,OXHVI OUTDEF O.HS:,OXHSI OXHVI: MOVE U3,@U3 OXHV: PUSH P,U3 HLRZ U3,U3 CALL OXN8 POP P,U3 STDOUT(54) STDOUT(54) HRRZ U3,U3 CALRET OXN8 OXHSI: MOVE U3,@U3 OXHS: PUSH P,U3 HLRE U3,U3 CALL OXN8 POP P,U3 STDOUT(54) STDOUT(54) HRRE U3,U3 CALRET OXN8 OXLHI: HLRZ U3,@U3 CALRET OXRH OXLH: HLRZ U3,U3 ; Somewhat useless since can just setup arg to CALRET OXRH ; call OXRH directly, but for completeness... UNRH: UIOINIT ; Entry pt for OUNRH UUO SKIPA U3,@U40 OXRHI: MOVE U3,@U3 ; Get word OXRH: MOVE U4,[220300,,U3] ; Set up BP, 6 bytes of 3 bits. OXRH1: ILDB U1,U4 STDOUT("0(U1)) ; Convert & output TLNE U4,770000 ; BP counted out yet? JRST OXRH1 RET SUBTTL OUT - Floating-point output IFN $$OFLT,[ IFN $$OUUO,[ UUODEF OUNFLT:,UNFL10 ; Outputs c(E) as floating decimal EQUALS .M"OUNFL,OUNFLT ] ;IFN $$OUUO IFNDEF E,E=:D+1 IFGE E-U1, .ERR ACs will lose for floating output! UNFL10: UIOINIT SKIPA U3,@U40 OXNFLI: MOVE U3,@U3 OXNF: ; F format, mmm.nn OXNE: ; E format, m.nnnnnE+ee OXNG: ; G format; F if within range, else E. Maximum prec. OXNFL: PUSHAE P,[A,B,C,D,E,OFLTFS] SETZM OFLTFS PUSHJ P,UNFO POPAE P,[OFLTFS,E,D,C,B,A] RET .SCALAR OFLTFS ; Holds various flags. Sign bit = E fmt. ; This routine adapted from that in MACLISP. UNFO: SKIPL A,U3 JRST UFP1 STDOUT("-) MOVN A,U3 UFP1: SETZB B,D ; For E-fmt, B holds add'l signif bin digits CAMGE A,[.01] ; and D is exponent sign indicator JRST UFP4 ; D=0 => negative exponent [x < 1.0e-2] CAML A,[1.0^8] AOJA D,UFP4F ; D=1 => positive exponent [x > 1.0e+8 - 1] ; "F" format, for 1.0e-2 <= x < 1.0e8 CAMGE A,[1.0] ; First find -<# digits to right of point.> JRST [ MOVNI E,10. CAML A,[.1] ; .1 <= x < 1.0 JRST UFP3 SOJA E,UFP3] ; .01 <= x < .1 PUSHJ P,UFPL10 ; <# digits to left of .>+1 will now be in E SUBI E,9. ; Get -<# digits to right.> UFP3: SETZB B,C ASHC A,-27. ; Split exponent part off ASHC B,-243(A) ; Split number into integral and fract part MOVE U3,B ; Output integer part PUSHJ P,OXN10 STDOUT(".) MOVE B,C ; Move fract part MOVM D,E ; D now holds # digits to print to right of . MOVSI E,200000 ; Compute position of last significant bits ASH E,-243+1+<43-27.>(A) IFN $$OUT,[ SKIPE U4,UFFLG ; Format params in effect? MOVN U4,UFPREC ; Yes, get precision (# columns to right of .) ] .ELSE SETZ U4, UFP3A: MOVE A,B MULI A,10. IMULI E,10. CAMGE B,E JRST UFPX0 MOVN C,E TLZ C,400000 CAMLE B,C AOJA A,UFPX0 ; Last sig digit, but round upwards IFN $$OUT,[ ; Note only truncate when U4 was positive to start with. SOJE U4,[TLNE B,200000 ; If forcing last digit, round upwards. CAIL A,9. ; Round. This is a KLUDGE check since JRST UFPX0 ; can't carry the roundup further (digits AOJA A,UFPX0] ; already output). Oh well. ] STDOUT("0(A)) CAIN D,2 ; On ninth output digit, use only half a digit ASH E,-1 ; for end-of-precision test SOJG D,UFP3A IFN $$OUT,JUMPG U4,UFPX1 POPJ P, ; Last significant digit, so stop UFPX0: STDOUT("0(A)) IFE $$OUT, RET .ELSE [ SOJG U4,UFPX1 ; Skip if precision not done yet. RET UFPX1: MOVEI U1,40 ; Need to pad out. Default filler is space, SKIPE OFLTFS ; but if doing E fmt, MOVEI U1,"0 ; then pad with zeros instead. CALRET OXRPTC ; Go pad out. ] ; ----------- Here for "E" format ------------------- UFP4: JUMPN A,UFP4F ; Floating point "E" format STDOUT("0) STDOUT(".) STDOUT("0) IFN $$OUT,[ SKIPE U4,UFFLG MOVN U4,UFPREC ; If formating, get precision. SOJG U4,UFPX1 ; If must space out, do so. ] POPJ P, UFP4F: MOVEI E,1 JUMPE D,UFP4E ; Jump out if negative exponent. UFP4E0: FDVL A,UFP10.0 ; Double-prec div by 10.0 until FDVRI A+1,(10.0) ; quotient is < 10.0 FADL A,A+1 CAML A,UFP10.0 AOJA E,UFP4E0 JRST UFP4B UFP4E: FMPRI A+1,(10.0) MOVEM A+1,A+2 ; Double-precision mul by 10.0 until FMPL A,UFP10.0 ; product is >= 1.0 UFA A+1,A+2 ; Keeping count in E FADL A,A+2 CAMGE A,UFP1.0 AOJA E,UFP4E UFP4B: PUSH P,E ; Save exponent PUSH P,(D)["- ? "+] ; Save sign of exponent SETZ B, MOVNI E,8. IFN $$OUT,[ MOVSI U4,(SETZ) ; Indicate hacking E format. IORM U4,OFLTFS ] PUSHJ P,UFP3 ; Num has been normalized for 1.0 <= x < 10.0 STDOUT("E) POP P,U1 ; Restore sign char STDOUT ; Output it. POP P,U3 ; Restore exponent value CAIL U3,100. ; Shouldn't be possible to exceed, but... PJRST OXN10 ; hack more than 2 digits in exponent. IDIVI U3,10. STDOUT("0(U3)) ; Always use 2 digits in output. STDOUT("0(U4)) POPJ P, UFPL10: MOVEI E,8 CAMGE A,UFP1.0-1(E) SOJG E,.-1 POPJ P, UFP1.0: REPEAT 8,1.0^.RPCNT UFP10.0=UFP1.0+1 ] ;end IFN $$OFLT SUBTTL Various special item output IFN UAREAS,[ ; OUTAR CH, Outputs char-mode area on CH. IFN $$OUUO,{UUODEF OUTAR:,U7XA EQUALS .M"OUTA,OUTAR } OUTDEF O.AR:,OIAR U7XA: UIOINIT ; Entry pt for OUTAR UUO SKIPA U1,U40 ; Get ARPT to area. OIAR: MOVEI U1,@U3 ; Note arg in "non-standard" U1. OXAR: SKIPN $AROPN(U1) ; Make sure it's open. RET ; Just return if it isn't. MOVE U3,$ARWPT(U1) ; Get write pointer (end of used area) SUB U3,$ARLOC(U1) ; Make relative to beg MULI U3,5 ; do bp hack ADD U4,UADBP7(U3) ; Get # chars. MOVE U3,$ARLOC(U1) ; Now cons up a BP to start. HRLI U3,440700 JUMPN U4,@OUT"USCOPT(OC) ; Finally dispatch to string output, RET ; unless nothing to output. ] ;IFN UAREAS IFN ULISTS,[ ; OUTLS CH,[slp] Outputs string that SLP points to, on channel CH. UUODEF OUTLS:,U7LS OUTDEF O.LS:,OILS U7LS: UIOINIT SKIPA U3,@U40 ; Get SLP. OILS: MOVE U3,(U3) OXLS: OXSL: ; Preferred label. IF1 IFNDEF LISTAR, NOP ; 1st pass may not have macro def'd yet. .ELSE MOVE U3,LISTAR(U3)+1 ; Get its SPT. HLRZ U4,U3 ; Get count. ADD U3,$LSLOC(L) ; Make address absolute HRLI U3,440700 ; and turn into a BP. JUMPG U4,@USCOPT(OC) ; Jump into output loop if anything there. RET ; Else no-op. ; List-String relative to specific LSE. ; U1 - addr of LSE ; U3 - SLP to SLN within that LSE. OXSLA: EXCH L,U1 ; For addressing purposes... IF1 IFNDEF LISTAR, NOP ; 1st pass may not have macro def'd yet. .ELSE MOVE U3,LISTAR(U3)+1 ; Get the SPT. ADD U3,$LSLOC(L) ; Make address absolute. MOVE L,U1 ; Restore original L. HLRZ U4,U3 ; Get count, HRLI U3,440700 ; make BP, JUMPG U4,@USCOPT(OC) ; and off to output it. RET ] ;IFN ULISTS ; UC$SAO output type - replaces old SAOBEG UUO. ; Initializes for standard UUO output into SA area; argument is ; a LSE pointer, e.g. OPEN(UC$SAO,$ARLOC+MSGAR) or OUTOPN CH,[$UCSAO,,L]. ; The %LTSAO type bit in MAKELN will form a string LN of accumulated ; output. UOPNSA: IFE ULISTS, JSR AUTPSY .ELSE [ SKIPN U4,@(U3) ; Get pointer to LSE MOVE U4,L ; If none specified, use current LSE. MOVE U1,$LSFRE(U4) ADD U1,$LSLOC(U4) ; Get abs start addr HRLI U1,440700 ; Form BP MOVEM U1,$LSWPT(U4) ; and set up new write ptr for area. MOVEI U1,(U1) SUB U1,$LSTOP(U4) ; Get -<# wds left> IMULI U1,5 MOVEM U1,$LSCHL(U4) ; Store as $ARCHL for SA. MOVEI U4,$LSAR(U4) ; Finally get pointer to string-area ARPT. MOVEI U1,UC$UAR ; Replace channel type with normal area. MOVEM U1,UCHTYP(OC) PJRST UOPNA1 ; Dispatch to complete normal area-open. ] ;IFN ULISTS SUBTTL ERR item output IFN $$OERR,[ ; Code for ERR output type. ; Arg is error #. ; If arg -1, use "last error". ; Include crocks for compatibility with old kludge. ERRMOA: SKIPA U3,A ERRMO: SETO U3, PUSH P,OC MOVEI OC,(B) CALL OXERR POP P,OC RET OUTDEF O.ERR:,OXERRI OXERRL: SKIPA U3,[-1] ; Entry pt to use last error OXERRI: MOVE U3,@U3 ; Get error # OXERR: IFN OS%ITS,[ MOVEI U4,4 ; Assume # specified, CAIGE U3, ; But if want "last error", MOVEI U4,1 ; ask system for that. IFNDEF ERRCHN,.ERR ERRCHN must be defined for $$OERR to work. SYSCAL OPEN,[CIMM ERRCHN [SIXBIT/ERR/] ? U4 ? U3 ] JRST [ MOVEI U3,[ASCIZ "?? Can't get error msg from ERR device ??"] PJRST OXZA] OXERR2: .IOT ERRCHN,U1 CAIGE U1,40 JRST [ .CLOSE ERRCHN, RET ] STDOUT JRST OXERR2 ] ;END IFN ITS IFN OS%TNX,[ PUSHAE P,[1,2,3] MOVEI 2,(U3) HRLI 2,.FHSLF ; 2 = ,, MOVSI 3,-UERBFL ; 3 = -<# chs>,, HRROI 1,UERBUF ; 1 = -1,, ERSTR ; Get error string ERJMP [MOVEI U3,[ASCIZ //] JRST OXERR5] JRST [ MOVEI U3,[ASCIZ //] JRST OXERR5] SETZ 3, IDPB 3,1 MOVEI U3,UERBUF OXERR5: POPAE P,[3,2,1] PJRST OXZA UERBFL==140. ; Max # chars in err msg .VECTOR UERBUF(/5) ] ;END IFN TNX ];end IFN $$OERR IFE $$OUT,.END ? .INEOF ; Efficiency hack -- all features from here on ; depend on $$OUT being set! SUBTTL Host name/number output IFN $$OHST,[ OUTDEF O.HN:,OXHNI ; Output host num in octal OUTDEF O.HND:,OXHNDI ; Output host num in decimal OXHNI: MOVE U3,@U3 JRST OXHN OXHNDI: MOVE U3,@U3 OXHND: PUSH P,[OXN10] CAIA OXHN: PUSH P,[OXN8] IFN OS%TNX, RET IFN OS%ITS,[ IFN <.PASS&1>+,[ LDB U4,[NETWRK"NW$BYT,,U3] ; If no string exists, check number. CAIN U4,NETWRK"NW%ARP ; Not Arpanet? ] .ELSE JSR AUTPSY ? 0 TDNE U3,[777,,77700774] ; Or any extended bits set? RET ; If so, just print num (hack slash fmt later) ; Can print in old-style format... DPB U3,[170200,,U3] ; Move host # ahead of imp # LSH U3,-9. ANDI U3,377 RET ; finally output old-form number ] OUTDEF O.HST:,OXHSTI OXHSTI: MOVE U3,@U3 OXHST: IFN OS%ITS,[ PUSHAE P,[A,B,D] ;clobbered by HSTSRC routine SKIPN B,U3 IFN <.PASS&1>+,[ MOVE B,OWNHST CALL NETWRK"HSTSRC ; make A point to asciz name ] .ELSE JSR AUTPSY ? JSR AUTPSY JRST [ CALL OXHN JRST OXHST1] MOVEI U3,(A) CALL OXZA OXHST1: POPAE P,[D,B,A] RET ] ;IFN ITS IFN OS%TNX,[ PUSHAE P,[1,2] HRROI 1,UHSTBF MOVE 2,U3 CVHST ERJMP [CALL OXN8 ? JRST OXHST2] NOP SETZ U1, IDPB U1,1 MOVEI U3,UHSTBF CALL OXZA OXHST2: POPAE P,[2,1] RET .SCALAR UHSTBF(50./5) ; Allow hostname up to 49. chars long. ] ;IFN TNX ] ;IFN $$OHST SUBTTL OUT - Miscellaneous routines ;------------------------------------------------------- OUTDEF O.CH:,OXCHI ; CH - Channel specification OXCHI: MOVEI OC,@U3 ; Get argument (IMMEDIATE type) CAIGE OC,$UNCHS ; Compare with # of channels allowed RET ; Is okay, just return. JSR AUTPSY ; Yuck!!! Channel # too big. OUTDEF O.XCT:,OXXCTI ; XCT - Execute instruction OXXCTI: XCT @U3 ; Do it. RET ; Just in case, RET ; allow for skips. ;-------------------------------------------------------- SUBTTL Time Output IFN $$OTIM,[ ; Requires that TIMRTS be .INSRT'd someplace. ; Sub-types for "TIM" output item. YOU try to think of ; better names for F1, F2, etc!! DEFT HMS,OXTMTS ; HMS - Time as "hh:mm:ss". (old WC) DEFT MDY,OXTMD ; MDY - Date as "mm/dd/yy" DEFT MDYT,OXTMDT ; MDYT - Datime as "mm/dd/yy hh:mm:ss" (old WA) DEFT MONTH,OXTLMN ; MONTH - Month as "Month" DEFT MON,OXTMN ; MON - Month as "MON" DEFT DOW,OXTLDW ; DOW - Day of week as "Fooday" DEFT DOW3,OXTDW ; DOW3 - Day of week as "Foo" DEFT F1,OXTME ; F1 - Datime as "dd MON yy hhmm-ZON" (old WB) DEFT F2,OXTMX ; F2 - Datime as "dd Month yyyy hh:mm-ZON" (old WD) ; All of these routines assume that the time-word value resides in UTMV, ; which is defined as either U2 or a variable location, depending on ; whether U2 == OC. ; In the latter case, the TIM item macro dispatches to an interface which ; saves/restores UTMV; this preserves re-entrant qualities and allows for ; nice compact compatible code which in either case is much better than ; previous TIMRTS. ; Dispatcher when U2 == OC. ; Time word in U3, actual routine desired in U4. IFN U2-OC, UTMV==:U2 .ELSE [ .SCALAR UTMV OXTIME: PUSH P,UTMV MOVEM U3,UTMV CALL (U4) POP P,UTMV RET ] ; Date as MM/DD/YY OXTMD: LDB U3,[TM$MON,,UTMV] CALL OXTD2 STDOUT("/) LDB U3,[TM$DAY,,UTMV] CALL OXTD2 STDOUT("/) OXTYR2: LDB U3,[TM$YR,,UTMV] ; Year as 2-digit number. CALRET OXTD2 ; Date/time as MM/DD/YY HH:MM:SS OXTMDT: CALL OXTMD ; Date STDOUT(40) ; Fall through for time ; Time as HH:MM:SS OXTMTS: HRRZ U3,UTMV LSH U3,-1 IDIVI U3,60. ; Get secs PUSH P,U4 ; Save IDIVI U3,60. ; Get hr and mins PUSH P,U4 ; Save mins too. CALL OXTD2 ; Output hours STDOUT(":) POP P,U3 CALL OXTD2 ; Output minutes STDOUT(":) POP P,U3 CALRET OXTD2 ; Output secs and done. ; Date/time as " 7 AUG 1976 0831-EDT" (constant length) OXTMEC: CALL UTMGET ; Entry pt for current time OXTME: CALL OXTDAY ; Output day, 2 columns STDOUT(40) CALL OXTMN ; Output 3-letter month STDOUT(40) ; Space out CALL OXTYR ; Output 4-digit year STDOUT(40) HRRZ U3,UTMV ; Get half-sec since midnight IDIVI U3,60.*2 ; Get mins IDIVI U3,60. ; Get hrs in U3, mins in U4 (flush secs) PUSH P,U4 CALL OXTD2 ; Output hrs POP P,U3 CALL OXTD2 ; Output mins CALRET OXTMZD ; Print time-zone & return ; Date/time as "7 August 1976 08:31-EDT" OXTMXC: CALL UTMGET ; Entry pt for current time OXTMX: CALL OXTDAV ; Output day, one or two columns STDOUT(40) CALL OXTLMN ; Output "long" month name STDOUT(40) CALL OXTYR ; Output 4-digit year STDOUT(40) HRRZ U3,UTMV ; Get half-sec since midnight IDIVI U3,60.*2 ; Get mins IDIVI U3,60. ; Get hrs in U3, mins in U4 (flush secs) PUSH P,U4 CALL OXTD2 ; Output hrs STDOUT(":) POP P,U3 CALL OXTD2 ; Output mins ; Fall through to output timezone & return. ; Output local timezone (time-word val indicates whether DST) OXTMZD: STDOUT("-) ; Entry pt for prefix dash OXTMZ: SKIPN U3,TLZONP ; Get pointer to local timezone JRST [ CALL TMZONG ; Not there yet? Set it up. MOVE U3,TLZONP JRST .+1] IFE U2-OC,MOVE U4,UTMV ? TRNE U4,TM%DST ; Daylight savings on? .ELSE TRNE U2,TM%DST MOVE U3,TLZONQ ; Use that version instead. CALRET OXZA ; Output ASCIZ. ; Day of the month in two columns. OXTDAY: LDB U3,[TM$DAY,,UTMV] ; Get day IDIVI U3,10. CAIN U3, SKIPA U1,[40] MOVEI U1,"0(U3) STDOUT STDOUT("0(U4)) RET ; Day of the month in one or two columns (Variable format). OXTDAV: LDB U3,[TM$DAY,,UTMV] ; Get day IDIVI U3,10. CAIN U3, JRST OXTDV1 STDOUT("0(U3)) OXTDV1: STDOUT("0(U4)) RET ; For both versions of month output, use ASCIZ ; rather than ASCNT since former guarantees U2 ; will be preserved. OXTLMN: LDB U3,[TM$MON,,UTMV] ; Get month MOVE U3,LMNTAB(U3) ; Get ascnt ptr to string for it CALRET OXZA ; Output ASCIZ string OXTMN: LDB U3,[TM$MON,,UTMV] ; Get month MOVE U3,MONTAB(U3) ; Get ascnt ptr to string for it CALRET OXZA ; Output asciz (only 3 chars) OXTDW: SKIPA U1,[DOWTB+1(U4)] ; Use short-form table. OXTLDW: MOVE U1,[LDOWTB+1(U4)] ; Use long-form table. PUSH P,A MOVE A,UTMV CALL TIMADY ; Get absolute # days in A MOVE U3,A POP P,A IDIVI U3,7 ; Get modulus MOVE U3,@U1 ; Get appropriate string, table idx'd by U4. CALRET OXZA ; Output as asciz to avoid U2 clobberage. OXTYR: LDB U3,[TM$YR,,UTMV] ; Get year ADDI U3,1900. ; Get real year ; Fall through to output 4 digits. ; Internal routines to output 4 or 2 digits of num in U3. OXTD4: IDIVI U3,100. ; Output 4 digits PUSH P,U4 CALL OXTD2 POP P,U3 OXTD2: IDIVI U3,10. ; Output 2 digits STDOUT("0(U3)) STDOUT("0(U4)) RET DEFINE UTMAC IFE U2-OC,{U3}.ELSE {U2}!TERMIN UTMGET: PUSH P,A CALL TIMGET MOVEM A,UTMV POP P,A RET IFN OS%TNX,[ ; Need routines to ; (1) get TNX current time, ; (2) convert TNX to std format, ; (3) convert std format to TNX? UTMXGT: SETO UTMAC, UTMXCV: PUSHAE P,[1,2,3,4] MOVE 2,UTMAC SETZ 4, ODCNV ; Break down time into variousness ERJMP [SETZB 2,3 SETZ 4, JRST .+1] LSH 4,1 TLNE 4,(IC%ADS_1) ; Depends on fact that IC%ADS not sign bit. TRO 4,TM%DST ; Set DST bit. MOVEI UTMAC,(4) ; Set # seconds in time word HLRZ 4,3 ; Get day number (0 based) ADDI 4,1 ; Make 1 based. DPB 4,[TM$DAY,,UTMAC] ; Set in time word. ADDI 2,1 ; Make month # 1-based. DPB 2,[TM$MON,,UTMAC] HLRZ 2,2 ; Get year # SUBI 2,1900. ; Make relative to 1900 DPB 2,[TM$YR,,UTMAC] ; Set year POPAE P,[4,3,2,1] RET ] ;IFN TNX ] ;IFN $$OTIM .END ; End the OUT symbols block. :=SUBTTL Switch setup, to-do comments. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; ;;;;; ;;;;; "OUT" ;;;;; ;;;;; NEW OUTPUT PACKAGE INTERFACE ;;;;; ;;;;; ;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; ;;;;; ;;;;; Documentation in MC:KSC;?OUT > ;;;;; ;;;;; or [SRI-KL]OUT.DOC ;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; REQUIRES: ;;;;; .INSRT MACROS - KSC;MACROS or MACROS ;;;;; U1,U2,U3,U4 - Sequential ACs ;;;;; P - PDL AC ;;;;; AUTPSY - JSR'd to for fatal errors ;;;;; Certain items will require other defs if they are assembled. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; IFNDEF $$OUT,$$OUT==1 ; 1 = Use new OUT stuff. (else UUO's or nothing) IFNDEF $$OUUO,$$OUUO==0 ; 1 = use old output UUO's. NUUOs defaults this to 1. ; Various item class conditional switches IFNDEF $$OFLT,$$OFLT==0 ; Floating point output IFNDEF $$OBUF,$$OBUF==0 ; UC$BUF Buffered output mode (must .INSRT PAGSER) IFNDEF $$OTIM,$$OTIM==0 ; Time output items (must .INSRT TIMRTS) IFNDEF $$OHST,$$OHST==0 ; Network Host name/# (on ITS, must .INSRT NETWRK) IFNDEF $$OERR,$$OERR==0 ; OS Error string output (on ITS must def ERRCHN too) ; More conditional switches needed when not using NUUOs. IFNDEF UAREAS,UAREAS==0 ; Disable "uuo area" stuff IFNDEF ULISTS,ULISTS==0 ; Likewise "uuo lists" IFNDEF USTRGS,USTRGS==0 ; ditto "strings" stuff. ; Parameters IFNDEF $$CHMX,$$CHMX==:20 ; Max # of channels user can use. IFNDEF $$ORID,$$ORID==0 ; Interpreted mode - may never be used. IFN $$ORID,.ERR OUT Interpreted mode not fully implemented yet. IFE $$OUT\$$OUUO,.INEOF ; If don't need anything from file, stop. comment | To-do stuff: Interpreted O.-instrs vs. inline code Interpretation: compact but slower. Inline: faster, but larger. More flexible? To setup extra params like width, prec, filler: General FMT(item,x,y,z) or FLD({item,item,...},x,y,z) Can test args to see how many, then use appropriate submacro for that # of extra args (O.FM2, O.FM3, etc) Generate bracketing code like: MOVE U1,[fmtlist] JSP U4,OXFSET JSP U4,OXFDON Or could put output stuff into a CALL'd constant routine. Protocol for OC channel AC Must preserve U2 over UUO's etc if == to OC. Reshuffle 4 UUO ac's, so OC not in middle?(interfers with 2-ac stuff) STDCH macro to set OC explicitly. Should OUT save/restore? Yes - can specify alternate chan. Should STDOUT? For STDOUT(ch,arg) should preserve? force use of STDCH to explicitly set. Allow use of STDOUT, STDOBP. Extend STDOUT macro to take chan, byte addr args? Add STROUT plus ditto? Pain to save/restore (unless all use OUT call?) Screw if smashed by sub. User must know how to save/restore OC. Put STRMOVE in for string ops, allow direct access. Have error macro to replace JSR AUTPSY, so that can specify string. Something like: JRST [JSR ERRH ? . ? ASCIZ /text/] File of 2-AC instrs for CREFFin to find dependencies. See whether any dep on U1/U2. If not, make U1 the channel AC? Problem: other UUO's clobber it, so can't simply make it "default"... only within an OUT or similar. Allow user to specify string rtn for XCT-type channels? Actually should specify vector holding everything necessary such as string-mode rtn addr, unit-mode instr, overflow rtn addr, etc. Fmt params should be immediate, and allow @ or ()'ing of variable params. eg this is how to handle properly output to a BP buffer, if can do in one stroke, without overflowing. Format params: ** TYPE ** FIELD WIDTH (- left justify, + right justify) ** PRECISION - String or float String - max # chars Float - # n's spec'd by precision: Type E: [-]m.nnnnnE[-]xx Type F: [-]mmmm.nnn Type G: whichever is easiest (default) ** FILLER - specify filler to use? Blanks or 0's or nulls? | subttl .BEGIN OUT - Macro definitions .BEGIN OUT ; Start symbol block .NSTGW ; Lots of hairy defs, make sure no storage assembled. SLEV==0 ; Stack level at start of OUT macro. IFN $$OUT*<.PASS-2>,[ ; Begin moby conditional for macro defs ; Only assemble if $$OUT and pass 1. ;;; Establish stack macro DEFINE .M"STK ; To use instead of (P). (P)-OUT"SLEV!TERMIN DEFINE DEFMOC NAME,*PRE*,*POST* ; Intermediate useful macro. DEFINE NAME (CH,A=$,B=$,C=$,D=$,E=$,F=$,G=$,H=$,I=$,J=$,K=$,L=$,M=$,N=$,O=$,Q=$,R=$,S=$,T=$,U=$,V=$,W) PRE OUT"$!A OUT"$!B OUT"$!C OUT"$!D OUT"$!E OUT"$!F OUT"$!G OUT"$!H OUT"$!I OUT"$!J OUT"$!K OUT"$!L OUT"$!M OUT"$!N OUT"$!O OUT"$!Q OUT"$!R OUT"$!S OUT"$!T OUT"$!U OUT"$!V .ERR No more than 20 arguments allowed! .TAG HO POST TERMIN TERMIN DEFMOC .M"OUTCOD,| IFNB [CH]{ PUSH P,OC ? MOVEI OC,CH ? OUT"SLEV==OUT"SLEV+1 } |,|IFNB [CH]{ POP P,OC ? OUT"SLEV==OUT"SLEV-1 }| DEFMOC .M"OUTCAL,| PUSHJ P,[ IFNB [CH]{ HRLM OC,(P) ? MOVEI OC,CH } OUT"SLEV==OUT"SLEV+1 |,|IFNB [CH]{ HLRZ OC,(P) } OUT"SLEV==OUT"SLEV-1 POPJ P,]| EXPUNGE DEFMOC ;;; Establish default for simple "OUT" to use. EQUALS .M"OUT,OUTCOD ; For now, default is inline. ;EQUALS .M"OUT,OUTCAL ; Alternative would be default of CALL. ;;;----------------------------------------------------------------- ;;; Fundamental "OUT" item definitions ;;; These are critical to proper operation of the OUT macro!! DEFINE $$ ; Invoked when no arg furnished, to terminate macro. .GO HO TERMIN ; Define appropriate macro for constant text output. ; Optimizes 1-char case. DEFINE $ &TEXT& IFN <.LENGTH TEXT>-1,{ MOVE U3,[.LENGTH TEXT,,[ASCII TEXT]] CALL OUT"OXTC } .ELSE { MOVEI U1,_-29. STDOUT } TERMIN ; For $$ORID ;DEFINE $ &TEXT& ;O.+<777&<.LENGTH TEXT>,,[ASCII TEXT]> ;TERMIN ; Continuation of single OUT ; This isn't completely thought out yet. DEFINE $OUT (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V) OUTCOD(,A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T,U,V) TERMIN ;;;-------------------------------------------------------- ;;; More standard OUT items ;;; Not so fundamental to macro hackery, ;;; but closely tied to package. DEFINE $CH (ARG) ; CH(chan) - Force to a new channel MOVEI OC,ARG TERMIN DEFINE $OPEN (TYP,ARG,L,BS) ; Open the channel MOVEI U1,TYP MOVEI U3,[IFSN [ARG][]{ARG} .ELSE {[0]} L+0 BS+0 ] IFSN [L!BS][] TLO U3, CALL OUT"UOPEN3 TERMIN DEFINE $PTV (ARG) ; Read channel I/O ptr CALL OUT"UPTV MOVEM U1,ARG TERMIN DEFINE $FRC ; Force out buffered stuff on channel CALL OUT"OXFRC TERMIN DEFINE $RST ; Reset channel CALL OUT"OXRST TERMIN DEFINE $CLS ; Close channel CALL OUT"OXCLS TERMIN DEFINE $PUSH ; Push channel on IO PDL CALL OUT"OXPUSH TERMIN DEFINE $POP ; Pop off PDL into channel CALL OUT"OXPOP TERMIN DEFINE $POPALL ; Pop entire PDL CALL OUT"OXPDLR TERMIN DEFINE $CALL (ARG) ; Invoke random routine. CALL ARG TERMIN ; Maybe this macro should take an initial arg saying ; how many additional instrs the field should apply to??? IFE $$ORID,[ DEFINE $FMT (A,B,C,D) %%NUM==0 OUT"$FMB(B,C,D) OUT"$!A OUT"$FME TERMIN DEFINE $FMB (WID,PREC,FILL,NUM=E,) ; Last "," needed to end default val. HRREI U1,WID IFB [PREC!FILL]{ CALL OUT"OXFST1 ? .STOP } IFB [PREC] HRLOI U3,377777 .ELSE MOV!NUM!I U3,PREC IFB [FILL]{ CALL OUT"OXFST2 ? .STOP } MOVEI U4,FILL CALL OUT"OXFST3 TERMIN DEFINE $FME CALL OUT"OXFDON TERMIN DEFINE $XCT (A) A TERMIN ] ; IFE $$ORID IFN $$ORID,[ DEFINE $FLD (A,B,C,D) ; FLD - Field definition for following instrs IFNB [A!B],{O.FLD [A ? B]} TERMIN DEFINE $XCT ?INSTR ; XCT - XCT an instruction O.XCT [INSTR] DEFINE $IF ?INSTR ; IF - Conditional O.IF [INSTR] TERMIN DEFINE $ELSE ?ARG ; ELSE - corollary of IF O.ELSE TERMIN DEFINE $END ?ARG ; END - ends a conditional O.END TERMIN ] ; end IFN $$ORID ;----------------------------------------------------------------- ; Value-printing "OUT" item routines. ; General fmt of numerical output items is ; N(,width,prec,fill) ; where N = O - Octal ; D - Decimal ; X - Hexadecimal ; F - Floating (at moment really G) ; E - Floating E fmt (at moment really G) ; G - Floating F/E fmt (whichever "best") ; See "FMT" for explanation of width,prec,fill. IRP NAM,,[O,D,X,F,E,G]RDX,,[8,10,16,F,E,G] DEFINE $!NAM (NUM,A,B,C) IFNB [A!!B!!C] OUT"$FMB(A,B,C,N) MOVE U3,NUM CALL OUT"OXN!RDX IFNB [A!!B!!C] OUT"$FME TERMIN TERMIN DEFINE $N10 (ARG) ; "N10" - Number, base 10 ; signed decimal value, MOVE U3,ARG ; with decimal point. CALL OUT"OXN10 STDOUT(".) TERMIN ; Following setup for DEFITM isn't very pretty, but is necessary ; to produce minimal macro code for each item. If only MIDAS ; had string variables!!! DEFINE DEFIT2 ITM,*INSTR*,INTNAM ; Auxiliary for DEFITM below. IFNB [INTNAM]{ DEFINE $!ITM (ARG) INSTR CALL OUT"INTNAM TERMIN .STOP } DEFINE $!ITM (ARG) INSTR CALL OUT"OX!ITM TERMIN TERMIN DEFINE DEFITM ITM,INSTR,INTNAM ; Macro for standard item definitions. IFN $$ORID,{DEFINE $!ITM (ARG) OUT"O.!ITM ARG TERMIN .STOP } ; For IFE $$ORID IFSE [INSTR][]{ DEFIT2 ITM,"MOVE U3,ARG",INTNAM .STOP } IFSE [INSTR][-]{ DEFIT2 ITM,,INTNAM .STOP } IFE &17,{ DEFIT2 ITM,"INSTR U3,ARG",INTNAM .STOP } DEFIT2 ITM,"INSTR,ARG",INTNAM TERMIN ;DEFINE $!ITM (ARG) ; for IFE $$ORID ;IFSE [INSTR][] MOVE U3,ARG ;.ELSE {IFSN [INSTR][-]{IFE &17,{INSTR U3,ARG} .ELSE {INSTR,ARG} } } ;IFNB [INTNAM] CALL OUT"INTNAM ;.ELSE CALL OUT"OX!ITM ;TERMIN DEFITM CRLF,- ; CRLF() - obvious DEFITM EOL,- ; EOL() - same as CRLF DEFITM TAB,- ; TAB() - output a tab DEFITM SP,- ; SP() - output a space DEFITM TLS,,OXLS ; TLS([slp]) - Text, List String. DEFITM TA,MOVEI U1,OXAR ; TA(arpt) - Text, Area. Outputs whole area. DEFITM TS,MOVEI,OXS ; TS([,,# ? bp]) - Text, String variable. EQUALS $N9,$D EQUALS $N8,$O EQUALS $OCT,$O ; "OCT" - OCTal value of word, same as N8. EQUALS $DEC,$N10 ; "DEC" - DECimal value of word, same as N10. DEFITM NFL,,OXNFL ; NFL(aval) - floating number (G fmt) DEFITM TZ,MOVEI,OXZA ; TZ(a-asciz) - Outputs asciz string DEFITM TZ$,HRRZ,OXZA ; TZ$(a-[a-asciz]) like TZ(@A) but avoids ; further indirection (if LH non-z) DEFITM TC,,OXTC ; TC([#,,[asciz]]) Outputs ASCNT string DEFITM TPZ,,OXZ ; TPZ([bp]) - Outputs BYTEZ string DEFITM TPC,,OXPC ; TPC([#,,[bp]]) a bit of a kludge. DEFITM RH,HRRZ ; RH(aval) - Right halfword, full (6 digits) DEFITM LH,HLRZ,OXRH ; LH(aval) - Left halfword, full. DEFITM HWD ; HWD(aval) - "LH,,RH" EQUALS $H,$HWD ; H(aval) - same as HWD DEFITM RHV,HRRZ,OXN8 ; RHV(aval) - RH as octal num, not bit pattern. DEFITM LHV,HLRZ,OXN8 ; LHV(aval) - LH as octal num, not bit pattern. DEFITM HV ; HV(aval) - LHV,,RHV DEFITM RHS,HRRE,OXN8 ; RHS(aval) - RH as signed octal num DEFITM LHS,HLRE,OXN8 ; LHS(aval) - LH as signed octal num DEFITM HS,,OXNHS ; HS(aval) - LHS,,RHS DEFITM 6F ; 6F(aval) - Outputs as sixbit without trailing sp. DEFITM 6W ; 6W(aval) - Outputs all 6 sixbit chars DEFITM 6Q ; 6Q(aval) - like 6F but quotes punct. chars with ^Q ; Arpanet host output items. Requires HOSTS2 and NETWRK, unless OS%TNX. DEFITM HN ; HN(aval) - Output host # simplifying if possible DEFITM HND ; HND(aval) - like HN but decimal DEFITM HST ; HST(aval) - Output host name or #, given #. ;;; Idiosyncratic items IFE $$ORID,[ DEFINE $C (CH) ; C - character (furnish immediate value) MOVEI U1,CH STDOUT TERMIN DEFINE $S (CNT,BP) ; S - String([#],[bp]) MOVE U3,BP SKIPLE U4,CNT CALL @OUT"USCOPT(OC) TERMIN DEFINE $SL (SLP,SAR) ; String, List. SAR is optional LSE addr. MOVE U3,SLP IFB [SAR] CALL OUT"OXSL ? .STOP SKIPE U1,SAR ; Feeble robustness. CALL OUT"OXSLA TERMIN ; Define item names for various chars which would fuck up ; MIDAS macro parsing if seen in literal string. Other ; baddies are CRLF and sometimes comma or double-quote. IRP ITM,,[LABR,RABR,LBRK,RBRK,LBRC,RBRC,LPAR,RPAR]VAL,,[74,76,133,135,173,175,50,51] DEFINE $!ITM STDOUT(VAL) TERMIN TERMIN DEFINE $ERR (ARG) ; "ERR" - System error message. If arg is blank, IFB [ARG] CALL OUT"OXERRL ; use last err, otherwise arg is error code .ELSE MOVE U3,ARG ? CALL OUT"OXERR TERMIN DEFINE $TIM (TYP,ARG) IFB [ARG]{ ; If no arg, use current time. IFN OS%ITS, CALL OUT"UTMGTS IFN OS%TNX, SETO U3, } .ELSE MOVE U3,ARG MOVEI U1,OUT"T$!TYP CALL OUT"OXTXS TERMIN ; DEFT - for matching subtype names with routines. ; Subtypes are defined in the $$OTIM section. DEFINE DEFT ITM,RTN IF2 T$!ITM==:RTN TERMIN ] ;IFE $$ORID ] ;END PASS 1 IFN $$OUT - MOBY CONDITIONAL IFN $$OUT*<.PASS-1>,[ ; Only assemble for $$OUT and pass 2 ; For anything that needs pass2 def? ] ; END PASS 2 IFN $$OUT .YSTGW ; OK to gen code now. ;;; Resolve a few awkward defs that are shared with other files ;;; which may or may not be inserted (specifically NUUOS) IF1 $$O%BP==0 IF1 IFNDEF MADBP7,$$O%BP==1 IFN $$O%BP,[ ; Needs 7-bit ADJBP macro and tables DEFINE MADBP7 BP,CNT MULI BP,5 ADD BP+1,UADBP7(BP) ADD BP+1,CNT MOVE BP,BP+1 IDIVI BP,5 SUB BP,UHADB7(BP+1) TERMIN ; Subtracted from 0,,addr to give appropriate BP pointing at ; indexed char (ILDB to get it). UHADB7: -010700,,1 -350700,,0 -260700,,0 -170700,,0 -100700,,0 -010700,,0 ; 5th char, may want to index table by UHADB7+1(A) ; so as to get pointer for LDB, not ILDB. 133500,,0 ; to handle -5 produced by 440700 repeat 4,0 UADBP7: -54300,,5 -104300,,4 -134300,,3 -164300,,2 -214300,,1 ] ; IFN $$O%BP subttl Primary routines for OUT package interpreter IFE $$ORID,[ DEFINE .M"OUTDEF NAME,ROUT ; Simply ignore if not using interpreter. TERMIN ] IFN $$ORID,[ IFNDEF OX$MAX,OX$MAX==50 OXTAB: REPEAT OX$MAX, ILUUO IF1 %%UOUT==0 ; Opcode 0 is illegal. DEFINE .M"OUTDEF NAMEX,ROUT IRPS NAME,,[NAMEX] IF1 [%%UOUT==%%UOUT+1 IFGE %%UOUT-OX$MAX, .ERR Too many OUTDEF's, must increment OX$MAX! NAME==<%%UOUT_27.> ] TMPLOC OXTAB+,ROUT TERMIN TERMIN ; OX - Main execution for interpreted OUT. ; During execution of arguments, ACs are set up as follows: ; U1 - scratch for chars ; U3 - addr of current instr ("PC") ; U4 - scratch ;.M"OX: UIOINIT ; Set up OC with channel # ; SKIPA U3,40 ; Get "PC" for item hacking OXTOPL: AOSA U3,OXPC .M"OXJSP: MOVEM U3,OXPC ; Entry pt for non-UUO version; set up "PC" SKIPGE U3,(U3) ; Get an out-instruction. RET ; No more? Done! PUSH P,[OXTOPL] ; Got one. Prepare by pushing return addr. LDB U1,[$UOPCD,,U3] ; Pluck out the opcode... CAIG U1,OU$MAX ; Make sure it's legit... PJRST @OXTAB(U1) ; Yup, go execute it! JSR AUTPSY ; Bad! (Really should find something better...) OXNEXT: AOS U3,OXPC SKIPGE U3,(U3) JRST [ SOS OXPC ? RET] OXEVAL: LDB U1,[$UOCOD,,U3] CAIG U1,OU$MAX PJRST @OXTAB(U1) JSR AUTPSY ] ;IFN $$ORID IFN $$ORID,[ ;------------------------------------------------------------------------ ; This cruft isn't finished yet. OUTDEF O.IF:,OXIF ; O.IF - Arg is instr to xct, true if skips. OXIF: PUSH P,UIFFLG ; Save state of IF flag XCT @U3 ; Execute the test... JRST OXIFF ; Failed, go handle failure case. ; IF succeeded, process until see ELSE or END. OXIF2: AOS U3,OXPC ; Bump PC, SKIPGE U3,(U3) ; and get next out-instr JRST [ SOS OXPC ? RET] ; Hit end, back up. LDB U1,[$UOCOD,,U3] ; Get opcode CAIN U1, ; ELSE? JRST OUIFF ; Yes, now flush til see END. CAIN U1, ; END? RET ; Yep, done with conditional. CALL @OXTAB(U1) ; Well, instr qualifies, so do it. JRST OXIF2 ; Failed, scan through out-instr list until reach ; ELSE. OXIFF: AOS U3,OXPC SKIPGE U3,(U3) JRST [SOS OXPC ? RET] LDB U1,U3 CAIN U1, JRST OXIF2 ; Found ELSE, start win conditional. CAIN U1, RET ; End of conditional, just return. JRST OXIFF ; Neither, continue. ] ;IFN $$ORID SUBTTL Output package channel definitions ; $UNCHS - Establish how many channels will be used, and ; set things up so that package-related channel #'s ; will have space reserved for them, altho illegal for ; "user" channels. IF1 [ %%LSV==. ? OFFSET -.+$$CHMX IFN $$OUT,[ UFLDC:: 0 ; OUT package field-output channel IFDEF USTRGS,IFE $$OUUO,IFNDEF STRC,.M"STRC:: 0 ; UUO string package chan ] .M"$UNCHS:: ; REAL maximum legal # of channels. OFFSET 0 ? LOC %%LSV ; Don't waste space EXPUNGE %%LSV ;;; UIOINIT - old output initialization. IFE $$OUUO,[ ; If not using output UUOs, DEFINE UIOINIT ; make sure attempts fail. JSR AUTPSY TERMIN U40==:40 ; Satisfy refs to this also. ] .ELSE [ ; Else using old output UUO's, DEFINE UIOINIT ; so make them work. IFE $$UCAL,PUSH P,UUORPC ; Get return PC on stack. LDB OC,UACFLD TERMIN ] ;IFN $OUUO ] ;IF1 SUBTTL OUT channel maintenance - basic support ;;;;;;;;;;;;; Unit Output Inline Macro for UUO Channels ;;;;;;;; ; STDOUT outputs single byte in U1 on channel in OC. ; STDOUT(arg) outputs byte "arg" on channel in OC, clobbers U1. DEFINE .M"STDOUT (A) IFSN [A][] MOVEI U1,A AOSLE @OUT"UCHCNT(OC) PUSHJ P,OUT"UCHMP XCT OUT"UCOPT(OC) TERMIN ; STDOBP - variant of STDOUT to be used when there is a BP in ; U3 that may be susceptible to "bumping". DEFINE .M"STDOBP (A) IFSN [A][] MOVEI U1,A AOSLE @OUT"UCHCNT(OC) PUSHJ P,OUT"UCHMPX XCT OUT"UCOPT(OC) TERMIN ;;;;;;;;;;;;;;;;; Tables for UUO channels ;;;;;;;;;;;;;;;;;;;; BVAR UCOPT: BLOCK $UNCHS ; XCT'd unit-mode instruction USCOPT: BLOCK $UNCHS ; Addr of string-mode routine UCHCNT: BLOCK $UNCHS ; Addr of char countdown UCNTS: BLOCK $UNCHS ; Char countdown if non-area UCHLIM: BLOCK $UNCHS ; Original count allowed UCHTYP: BLOCK $UNCHS ; ,, IFN OS%TNX,UCHJFN: BLOCK $UNCHS ; JFN for channel if any UCHSTB: BLOCK $UNCHS ; Byte ptr (UC$BPT) or ARPT (UC$UAR) IFN UAREAS,[ UBMPSP: 0 ; Holds special ptr for string output UUO's to avoid area-shift ; clobberage. ; UCHSTB, and locs immediately following up to NUSPBP, will be ; adjusted automatically to compensate for any shifts of UUO areas. NUSPBP==.-UCHSTB ] EVAR ;----------------------------------------------------------------- ; UUO Channel types. Bits start in AC field, so as not to infringe ; on indexing/indirect bits! .M"$UCUAR==<.M"UC$UAR==0> ; UAR (UUO area) chan type 0 for easy check. .M"$UCXCT==<.M"UC$XCT==1>_5 ; XCT .M"$UCBPT==<.M"UC$BPT==2>_5 ; Byte PTr .M"$UCIOT==<.M"UC$IOT==3>_5 ; .IOT/SIOT (or BOUT/SOUT) .M"$UCBUF==<.M"UC$BUF==4>_5 ; Buffered UC$IOT .M"$UCTRN==<.M"UC$TRN==5>_5 ; Translate into another chan. .M"$UCNUL==<.M"UC$NUL==6>_5 ; Null output sink .M"UC$NX==7 ; # of executable channel types. .M"$UCSAO==<.M"UC$SAO==7>_5 ; SAO - Like UAR for LSE's String-Area. .M"UC$NO==10 ; # of OPEN-able channel types. UC%FLD==<7_5>,,0 ; Mask for type number (in AC field). .M"UC%LIM==1000,,0 ; Arg flag meaning byte # limit specified. .M"UC%BSZ==2000,,0 ; Arg flag meaning bytesize specified. UC%DBF==200000 ; UCHTYP flag, means dynamic UC$BUF buffer. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; OUTOPN CH,[,,[]] ; "Opens" a UUO channel for output. Note ; is in AC field!! This allows address to be indexed etc. ;Formats: ; OUTOPN CH, ;same as type $UCIOT. ; OUTOPN CH,[$UCIOT,,0] ;uses .IOT and SIOT ; OUTOPN CH,[$UCIOT,,[JFN]] ; uses BOUT, SOUT (TNX only) ; OUTOPN CH,[$UCBPT,,[byte ptr]] ;uses idpb starting at ptr ; OUTOPN CH,[$UCXCT,,[instr]] ;XCT's the instr (arg will lie in U1) ; OUTOPN CH,[$UCUAR,,] ;uses byte ptr into specified area ; OUTOPN CH,[SETZ $UCUAR,,] ;as above, but resets area ; OUTOPN CH,[$UCTRN,,[channel #]] ;Translates into another UUO channel. ; Old style: c(E) = , ; Cvt style: U3: , E ; New style: U3: ,[ ? ... ] IFN $$OUUO,[ UUODEF OUTOPN:,UCHOPN UCHOPN: UIOINIT ; Get channel # (AC field) HRRZ U3,U40 ; Get E CAIN U3, ; In case of OUTOPN CH,0 TLOA U3,($UCIOT,,) ; provide default. HLL U3,(U3) ; Get LH stuff from c(E) LDB U1,[$ACFLD,,U3] ; Get channel type (AC field of c(E)) ] ;IFN $$OUUO ; If there is any chance that U3 will have I or X bits set at ; this point, then the following instr should be uncommented. ; In theory the $OPN macro will never use it. ;UOPEN2: HRRI U3,@U3 ; Set RH to true effective address. ; Entry point for $OPN macro invocation. ; OC - Channel # ; U1 - channel type ; U3 - ,[ ? ? ... ] UOPEN3: CAIL U1,UC$NO ; Check type JSR AUTPSY ; Unknown type! Bad argument. ;; Should the following code be implemented?? Would it break ;; any programs, or be grossly inefficient, or what? --KLH 11/11/82 ;; SKIPN UCHTYP(OC) ; Check existing channel type ;; JRST [ PUSHAE P,[U1,U3] ; Ugh, it's still open! ;; CALL OXCLS ; Close up the channel! ;; POPAE P,[U3,U1] ;; JRST .+1] MOVEM U1,UCHTYP(OC) ; Store channel type, with zeroed flags. PJRST @UOPENT(U1) ; Dispatch for further processing. UOPENT: UOPNAR ; Area UOPNX ; XCT UOPNBP ; BPT UOPNIO ; IOT UOPNBF ; BUF UOPNTR ; Transl. UOPNNL ; NUL UOPNSA ; SAO IFN UC$NO-<.-UOPENT> .ERR UOPENT table loses ; Common return point for some types. ; U1 - unit-mode instr ; U4 - ,, rtn addrs for string-mode output. UOPN3: MOVEM U1,UCOPT(OC) ; Store instruction for unit-mode byte output. TLNE U3,(UC%LIM) ; Was limit explicitly specified? JRST [ HLRZM U4,USCOPT(OC) ; Yes, use limit-type string routine. MOVN U4,@1(U3) ; And get specified limit value. JRST UOPN4] HRRZM U4,USCOPT(OC) ; No, use no-limit string routine. MOVSI U4,(SETZ) ; And use max neg # for "limit". UOPN4: MOVEM U4,UCHLIM(OC) ; Set up limit. MOVEM U4,UCNTS(OC) ; and count. MOVEI U1,UCNTS(OC) ; Find addr of count MOVEM U1,UCHCNT(OC) ; and store that. RET ; UC$UAR - Channel type AREA UOPNAR: IFE UAREAS,JSR AUTPSY ; Lose if no area hackery assembled. .ELSE [ MOVEI U4,@(U3) ; Get ARPT to area UOPNA1: MOVEM U4,UCHSTB(OC) ; Store ARPT, instead of a BP HLL U4,$ARTYP(U4) ; Get type bits. TLNN U4,%ARTCH ; Area must be in char mode! JSR AUTPSY ; tsk, tsk. MOVEI U1,$ARWPT(U4) ; Get addr to write place, HRLI U1,(IDPB U1,) ; and insert instruction to XCT. MOVEM U1,UCOPT(OC) ; Store XCT for unit mode, MOVEI U1,$ARCHL(U4) MOVEM U1,UCHCNT(OC) ; and addr to find char countdown in. MOVEI U1,UOL.AR ; Get addr of string output rtn MOVEM U1,USCOPT(OC) ; and set up. CAIGE U3, ; Now, if sign bit was set in flags, CALL UXRST ; reset the area. RET ; UOL.AR - String output routine for UC$UAR type. UOL.AR: ADDM U4,@UCHCNT(OC) ; Add into count SKIPLE @UCHCNT(OC) ; Check it. PUSHJ P,UCHMPX ; If no room left, go get some. IFE OC-U2, PUSH P,U2 MOVE U2,@UCOPT(OC) ; Get BP used by the IDPB (from $ARWPT) ILDB U1,U3 IDPB U1,U2 SOJG U4,.-2 IFE OC-U2,[ EXCH U2,(P) ; Now restore BP to area's $ARWPT POP P,@UCOPT(OC) ] .ELSE MOVEM U2,@UCOPT(OC) RET ] ; IFN UAREAS ; UC$XCT - Channel type XCT UOPNX: MOVE U4,[UOL.X,,UOS.X] ; Specify string-mode rtns to use MOVE U1,@(U3) ; Get instr to XCT JRST UOPN3 ; String output, XCT UOL.X: SKIPG U1,U4 RET ADDB U1,@UCHCNT(OC) JUMPL U1,UOS.X2 CALL OVFS ; Handle overflow. UOS.X: ADDM U4,@UCHCNT(OC) UOS.X2: ILDB U1,U3 XCT UCOPT(OC) ; for now, really unit-mode. SOJG U4,.-2 RET ; UC$BPT - Channel type BPT (Byte Ptr) UOPNBP: MOVE U1,@(U3) ; Get byte ptr MOVEM U1,UCHSTB(OC) ; And use that as channel state. MOVE U1,[IDPB U1,UCHSTB] ADDI U1,(OC) ; Make IDPB point to right BP MOVE U4,[UOL.BP,,UOS.BP] ; Specify string-mode output rtns. JRST UOPN3 ; Store instruction & other stuff. ; String output, BP UOL.BP: SKIPG U1,U4 RET ADDB U1,@UCHCNT(OC) JUMPL U1,UOS.B2 CALL OVFS ; Handle overflow. UOS.BP: ADDM U4,@UCHCNT(OC) ; Inc. count UOS.B2: ILDB U1,U3 IDPB U1,UCHSTB(OC) ; BP lives there. SOJG U4,.-2 RET ; UC$IOT - Channel Type IOT ("Hard" channel) UOPNIO: IFN OS%ITS,[ MOVE U1,[.IOT U1] ; Get unit operation CAILE OC,17 ; Ch # must fit into AC field. JSR AUTPSY DPB OC,[$ACFLD,,U1] ; Store ch # into instr ] IFN OS%TNX,[ MOVE U1,@(U3) ; Get JFN for channel MOVEM U1,UCHJFN(OC) ; store MOVE U1,[CALL U.BOUT] ; Set up instr to xct ] MOVE U4,[UOL.IO,,UOS.IO] ; Specify string-mode output rtns JRST UOPN3 IFN OS%TNX,[ U.BOUT: PUSHAE P,[1,2] ; Routine called for UC$IOT byte output MOVE 1,UCHJFN(OC) MOVE 2,U1 BOUT POPAE P,[2,1] POPJ P, ] ;String output, .IOT UOL.IO: SKIPG U1,U4 RET ADDB U1,@UCHCNT(OC) JUMPL U1,UOS.I2 CALL OVFS ; Handle overflow. UOS.IO: ADDM U4,@UCHCNT(OC) ; Bump cnt. UOS.I2: IFN OS%ITS,[ SYSCAL SIOT,[OC ? U3 ? U4] ; Trivial! JSR AUTPSY ; ?!?! ] IFN OS%TNX,[ PUSHAE P,[1,2,3] MOVE 1,UCHJFN(OC) ; Set up JFN MOVE 2,U3 ; bp to string MOVN 3,U4 ; byte count SOUT POPAE P,[3,2,1] ] RET ; UC$BUF - Channel type BUF (buffered UC$IOT) ; This code assumes U3 is of form ; ,[ [arg] ? [lim] ? [bytesize]] ; is as for UC$IOT - on TNX, the JFN to use. ; is the size of bytes to use. ; Defaults to 7. ; is the buffer size, IN BYTES, to use. ; Defaults to one page. ; If negative, it is treated as an AOBJN pointer to ; the buffer; LH is # of WORDS. ; If unspecified or zero, the buffer is dynamically allocated. ; Be sure to CLS the channel, or the buffer will ; stay around forever! UOPNBF: IFE $$OBUF,JSR AUTPSY .ELSE [ MOVE U1,U3 ; Get arg ptr into better place IFN OS%TNX,[ MOVE U4,@(U1) ; Get 1st arg (JFN) MOVEM U4,UCHJFN(OC) ; Store... ] TLNN U1,(UC%BSZ) ; Was byte-size specified? JRST [ MOVEI U3,440700 ; No, default to 7-bit. Set up BP LH HRLZM U3,UCHSTB(OC) MOVEI U4,5 ; and use this many bytes/wd JRST UOPNB2] SKIPLE U4,@2(U1) ; Get byte-size... CAILE U4,36. ; Make sure it's reasonable. JSR AUTPSY MOVEI U3,440000 DPB U4,[060600,,U3] ; Insert it into S field of BP LH HRLZM U3,UCHSTB(OC) ; and store LH for later use. MOVEI U3,36. IDIV U3,@2(U1) ; Find # bytes per word MOVE U4,U3 ; Save ; Have in U4, now find buffer length. UOPNB2: TLNN U1,(UC%LIM) ; Byte limit specified? JRST UOPNBD ; Nope, use default. SKIPGE U3,@1(U1) ; If is AOBJN, it specifies # words. JRST [ HLRO U3,U3 ; Get -<# wds> MOVN U3,U3 JRST UOPNB3] ; Go set up stuff. JUMPE U3,UOPNBD ; If zero, use default of one page. PUSH P,U3 ; Save # bytes IDIVI U3,(U4) ; Find # words to use CAIE U4, ; If any remainder, ADDI U3,1 ; round up to next # of words. POP P,U4 ; Restore # bytes (want to use exact # given). JRST UOPNB4 UOPNBD: MOVEI U3,PG$SIZ UOPNB3: IMULI U4,(U3) ; Find # bytes to use in buffer. UOPNB4: MOVNM U4,UCHLIM(OC) ; Save -<# bytes> as limit. MOVNM U4,UCNTS(OC) ; and set up actual countdown. ; Now have buffer length in U3 as # words. See if must allocate. TLNE U1,(UC%LIM) ; Check again for existence. SKIPL U1,@1(U1) ; Clobber arg ptr, skip if AOBJN given. CAIA JRST UOPNB5 ; Needn't allocate! U1 RH has buf addr! IFE U2-OC,PUSH P,OC MOVEI U1,(U3) ; Ask for this many wds. IFDEF CORGET,CALL CORGET ; Get buffer space, return addr in U2 .ELSE JSR AUTPSY ? IF2 .ERR PAGSER package must be inserted for UC$BUF!! MOVEI U1,(U2) IFE U2-OC,POP P,OC ; Need hair when U2 == OC. MOVSI U4,UC%DBF ; Must set "dynamic buffer" flag IORM U4,UCHTYP(OC) ; so we remember to de-allocate later. UOPNB5: ADDI U3,(U1) ; Find last addr + 1 HRLM U1,UCHLIM(OC) ; Save start addr of buffer HRRM U1,UCHSTB(OC) ; and set up initial BP addr. HRLI U1,(U1) ADDI U1,1 ; Set up src,,src+1 for BLT zap. SETZM -1(U1) CAILE U3,(U1) ; Handle screw case of 1-wd buffer. BLT U1,-1(U3) ; Clean out the buffer. MOVEI U4,UCNTS(OC) MOVEM U4,UCHCNT(OC) ; Set addr of countdown MOVEI U4,UOL.BF ; Set string-mode rtn addr. MOVEM U4,USCOPT(OC) ; Set it. MOVEI U1,UCHSTB(OC) HRLI U1,(IDPB U1,) ; Cons up unit-mode instr MOVEM U1,UCOPT(OC) ; Set. RET ; Done... UOL.BF: SKIPG U1,U4 ; Get temp in U1 RET ; making sure something to write. ADDB U1,@UCHCNT(OC) ; Add into count JUMPGE U1,UOLBF1 ; Jump if buffer would be filled up. ILDB U1,U3 ; Nope, just copy light-heartedly. IDPB U1,UCHSTB(OC) SOJG U4,.-2 RET ; "Overflow". Note that unlike usual case, we come here even ; when count is zero, in order to optimize bulk I/O. ; The idea behind this optimization is that if buffer is ; empty and byte sizes for request/output are same, we ; can output directly and skip the copy overhead! ; This is also done if stuff is already in the buffer but ; the new stuff is large enough to force two system calls anyway. ; Only possible problem is if something depends on size of ; string output for each sys call, eg if one wants to do PMAP ; type stuff. If that ever becomes desirable, a new output type ; or flag can be created. UOLBF1: PUSH P,U3 HRRO U3,UCHLIM(OC) ; Get original limit (fill out LH) SUB U1,U4 ; Get original countdown, -<# left> CAMG U1,U3 ; Countdown increased from original? JRST UOLBF2 ; No, making huge request of virgin buffer - Optimize! MOVM U3,U3 ; Get positive buffer length SUB U3,U1 ; Add # bytes of room left in buffer CAMGE U3,U4 ; Will we need more than one sys call? JRST UOLBF4 ; No, jump to copy & output. UOLBF2: PUSH P,U1 ; Save -<# left> LDB U1,[$SFLD,,-1(P)] ; Get S field of source BP LDB U3,[$SFLD,,UCHSTB(OC)] ; Ditto for buffer BP CAIE U1,(U3) ; If same, way's clear! JRST UOLBF3 ; Nope, must convert via copy. IFN OS%ITS,[ ;;; Following code prevents the disoptimization of doing non-word-aligned ;;; SIOTs which are very slow in ITS CAIE U1,7 ; Only if byte size is 7 JRST UOLB2A PUSH P,U2 MOVN U1,(P) ; Space available in buffer IDIVI U1,5 JUMPN U2,UOLB2B ; Mustn't SIOT MOVE U1,U4 ; Amount to be output IDIVI U1,5 JUMPN U2,UOLB2B POP P,U2 ; Okay, go ahead UOLB2A: ;;; End of antidisoptimization code ] ;IFN OS%ITS EXCH U4,(P) ; Save output cnt on PDL, get back -<# left> HRRO U3,UCHLIM(OC) ; Get - for quick check... MOVEM U3,UCNTS(OC) ; and reset limit in case no force-out. CAMGE U3,U4 ; Anything at all in buffer? CALL UFRCBI ; Yes, force it out using U4 for UCNTS. POPAE P,[U4,U3] ; Then restore original source BP and cnt CALRET UOS.I2 ; and go output directly via UC$IOT rtn! IFN OS%ITS,[ UOLB2B: POP P,U2 ; This could be smarter! ] UOLBF3: POP P,U1 ; Restore -<# left> UOLBF4: EXCH U4,(P) ; Save output cnt, get back BP MOVE U3,U4 ; Put BP in usual place JUMPGE U1,UOLBF6 ; If buffer already full, skip copy. ADDM U1,(P) ; Update saved output cnt. MOVM U4,U1 ; and get cnt of chars to copy. ILDB U1,U3 ; Twiddle IDPB U1,UCHSTB(OC) ; twaddle SOJG U4,.-2 UOLBF6: PUSH P,U3 ; Save source BP CALL UFRCBA ; Buffer always full here; output All. POP P,U3 ; Now restore source BP POP P,U4 ; and updated count JRST UOL.BF ; and start over... ; UFRCBF - Force out buffer. Clobbers U1,U3,U4. ; Alternate entry points UFRCBI - takes -<#left> countdown in U4 (Immediate) ; UFRCBA - sets -<#left> countdown to 0 (All of buffer) UFRCBA: TDZA U4,U4 UFRCBF: MOVE U4,UCNTS(OC) ; Get -<# left> UFRCBI: CAILE U4, ; Make sure something didn't trash buffer! JSR AUTPSY ; Ugh, buffer overflowed?!?! CALL UBFRST ; Reset buffer cnt/ptr, get -len in U1. SUB U4,U1 ; -<# left> - - = # to output. JUMPG U4,UOS.I2 ; Output buffer as per UC$IOT type. RET ; UBFRST - Called to reset buffer channel. ; Doesn't clobber U4, and leaves - in U1. ; UFRCBF depends on this. UBFRST: MOVE U1,UCHLIM(OC) ; Get ,,<-len> HLRZ U3,U1 HLL U3,UCHSTB(OC) ; Cons up new BP to start of buffer TLZ U3,770000 TLO U3,440000 ; Force P to 1st byte in word. MOVEM U3,UCHSTB(OC) ; and set up new ptr. TLO U1,-1 ; Make length a kosher neg. num. MOVEM U1,UCNTS(OC) ; Store to re-initialize countdown. RET ] ;IFN $$OBUF ; UC$TRN - Channel type TRANSL (translate to another UUO chan) ; Ignores any count specified. ; Main hair is setting things up so unit-mode AOS and XCT ; will work; for everything else including string-mode, the ; mapping is straightforward. UOPNTR: MOVE U4,@(U3) ; Get channel to translate to. CAIL U4,$UNCHS ; Make sure it's reasonable! JSR AUTPSY MOVE U1,[XCT UCOPT] ADDI U1,(U4) ; Do a XCT UCOPT+chan MOVEM U1,UCOPT(OC) MOVE U1,[@UCHCNT] ; Assemble an indirect into ADDI U1,(U4) ; the target channel's countdown. MOVEM U1,UCHCNT(OC) MOVE U1,UCHSTB(U4) ; Just copy UCHSTB MOVEM U1,UCHSTB(OC) MOVEM U4,UCNTS(OC) ; and hide true channel # in unused count slot. MOVEI U3,UOS.TR MOVEM U3,USCOPT(OC) RET ;String output, Translate. UOS.TR: IFN $$OUT,PUSH P,OC MOVE OC,UCNTS(OC) ; Find right channel # to use. IFN $$OUT,[ CALL @USCOPT(OC) ; and go hack. POP P,OC RET ] .ELSE PJRST @USCOPT(OC) ; UC$NUL - Null output sink UOPNNL: MOVE U4,[UOS.NL,,UOS.NL] ; Specify string-mode rtns to use MOVE U1,[NOP] ; Get instr to XCT TLZ U3,(UC%LIM) ; Ignore any specified limit. JRST UOPN3 UOS.NL: ADDM U4,@UCHCNT(OC) ; Might as well keep track of count. RET ; But that's it. ; UCHMP - called when byte count on channel runs out during unit-mode ; output; see the STDOUT macro for context. Only other place this ; routine is called is from UAR-type string output. ; OC - channel #, ; @UCHCNT(OC) contains positive # of chars "over-run". ; for output to areas, this is # of chars needed. ; UCHMPX - variant in which ; U3 contains a BP that must be preserved across area bumps. UCHMPX: IFN UAREAS,[ MOVEM U3,UBMPSP ; Save U3 in holy place, PUSHJ P,UCHMP ; so that its input ptr is bumped correctly if nec. MOVE U3,UBMPSP ; Restore from sanctuary. POPJ P, ] UCHMP: PUSHAE P,[U1,OC,U3,U4] UCHMP0: MOVE U1,UCHTYP(OC) ; Get channel type JRST @OVFTAB(U1) ; Dispatch to appropriate handler OVFTAB: OVFLAR ; UAR OVFLX ; XCT OVFLBP ; BPT OVFLIO ; IOT OVFLBF ; BUF OVFLTR ; TRAN OVFLNL ; NUL IFN .-, .ERR OVFTAB Loses ; TRAN type overflow. OVFLTR: MOVE OC,UCNTS(OC) ; Translate, get real chan # JRST UCHMP0 ; and try again. ; BUF type overflow. OVFLBF: IFE $$OBUF,JSR AUTPSY .ELSE [ SOS @UCHCNT(OC) ; Restore #-left to zero. CALL UFRCBF ; Force out buffer AOS @UCHCNT(OC) ; Allow for char wanting output JRST UCHMP9 ; And return normally. ] ; NUL, XCT, IOT, and BPT type overflow. OVFLNL: OVFLX: OVFLIO: OVFLBP: MOVE U1,UCHLIM(OC) ; Get limit for channel CAME U1,[SETZ] ; If using maximum, no limit. JRST OVFLIM ; uh-oh, actually limiting... go handle. MOVEM U1,UCNTS(OC) ; No limit, just reset count. JRST UCHMP9 ; Return and output char. ; UAR type overflow OVFLAR: IFE UAREAS,JSR AUTPSY IFN UAREAS,[ MOVE U1,UCHSTB(OC) ; Get ARPT for area SKIPG U3,$ARCHL(U1) ; and # chars needed. JSR AUTPSY ; ugh?? called when not supposed to? IFN USTRGS,[ CAIN U1,USTRAR ; Is this the string output area? PUSHJ P,USTRGC ; Ugh, yes. Go see about GC'ing. JRST OVFAR2 ; Didn't GC, proceed normally and expand SKIPL $ARCHL(U1) ; If still need room after possible GC, JRST OVFAR2 ; go expand normally. ADDB U3,$ARCHL(U1) ; GC'd! Add to cnt of chars now available JUMPL U1,UCHMP9 ; and exit if have enough now OVFAR2:] ; else drop thru to normal expansion. ADDI U3,4 IDIVI U3,5 ; Round up to # wds needed (clobbers U4) MOVEM U3,ARUNIT ; Insert # as arg to UABUMP PUSHJ P,UABUMP ; Go bumpit - adjusts $ARCHL. SKIPLE $ARCHL(U1) ; Check to be SURE. JSR AUTPSY ; Foo, didn't update or didn't get enough. JRST UCHMP9 ] ;IFN UAREAS OVFLIM: SOS @UCHCNT(OC) ; Restore original count UCHMP8: AOS -4(P) ; Abnormal return - DON'T output char!! UCHMP9: ; Normal return - output char. POPAE P,[U4,U3,OC,U1] POPJ P, ; OVFS - General-purpose overflow handler for string-mode routines. ; Only invoked for channels which are definitely being limited; ; it allows output only up to the limit specified. ; See BPT, IOT, etc. routines for context. ; This is a bit inefficient, could be improved by turning ; unit/string mode ops into NOPs. ; OC - channel # ; U1 - # chars overflowed ; U3 - source BP ; U4 - source cnt ; (P) - place to return for no-limit output ; -1(P) - place to return for no output at all. OVFS: SUB U1,U4 ; Find original count of -<# left> MOVEM U1,@UCHCNT(OC) ; Store back MOVN U4,U1 ; Smash source cnt to max allowable CAIG U4, ; If result is non-null then skip to output POP P,U1 ; Else flush 1st return, take 2nd for no output RET ; OUTPTV CH,[] For use with UUO channels. ; Returns to c(E) the cnt of chars outputted on channel since ; opened. For channels opened into an area, this is ; the # of chars between start of area and current Write BP. IFN $$OUUO,[ UUODEF OUTPTV:,UCHPTV UCHPTV: LDB OC,UACFLD ; Get channel #. CALL UPTV MOVEM U1,@U40 ; Store result UUOXRT ] ;IFN $$OUUO UPTV: MOVE U1,UCHTYP(OC) ; Get channel type. PJRST @UPTTAB(U1) UPTTAB: UPTAR ; Area UPTX ; XCT UPTBP ; BPT UPTIO ; IOT UPTBF ; BUF UPTTR ; Transl. UPTNL ; NUL IFN UC$NX-<.-UPTTAB> .ERR UPTTAB table loses UPTAR: IFE UAREAS, JSR AUTPSY .ELSE [ MOVE U4,UCHSTB(OC) ; Get ARPT MOVE U1,$ARWPT(U4) ; Get write ptr into area IFSVU2, PUSH P,U2 HRRZ U2,$ARLOC(U4) ; and "ptr" to start. CALL UPDIF7 ; Find diff between the 2 ptrs MOVE U1,U2 IFSVU2, POP P,U2 RET ] UPTIO: UPTX: UPTNL: ; These types share similar code. UPTBP: SKIPA U1,UCHLIM(OC) ; Find beginning count. UPTBF: HRRO U1,UCHLIM(OC) ; BUF type has cruft in the LH. SUB U1,@UCHCNT(OC) ; <-max> - <-max + cnt> = -cnt MOVM U1,U1 RET UPTTR: PUSH P,OC MOVE OC,UCNTS(OC) ; Get true channel # CALL UPTV POP P,OC RET ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Other maintenance routines ; OUTINI - Initialize output package. OUTINI: PUSH P,OC PUSH P,[$UNCHS] ; Keep cnt on PDL cuz ACs clobbered. OUTIN2: SOSGE OC,(P) JRST OUTIN3 CALL OXCLS ; Close channel JRST OUTIN2 OUTIN3: IFN $$OUT,[ ; Set up for field-output channel. OUTCOD(,CH(UFLDC),OPEN(UC$BPT,[440700,,UFBUF],[$LUBUF])) ] SUB P,[1,,1] POP P,OC RET OIFRC: OXFRC: IFN $$OBUF,[ HRRZ U1,UCHTYP(OC) ; Get channel type CAIN U1,UC$BUF ; If type BUF, CALRET UFRCBF ; Go force it out, ] RET ; else just return. ; Reset channel. Only meaningful for UAR and BUF. OIRST: OXRST: HRRZ U1,UCHTYP(OC) ; Get channel type IFN $$OBUF,[ CAIN U1,UC$BUF CALRET UBFRST ; Do special buffer reset if BUF. ] IFN UAREAS,[ CAIN U1,UC$UAR JRST [ MOVE U4,UCHSTB(OC) ; Get ARPT to area HLL U4,$ARTYP(U4) ; and set up type bits PJRST UXRST] ; and go reset area. ] RET OICLS: OXCLS: HRRZ U1,UCHTYP(OC) ; Get channel type CALL @OXCLST(U1) ; Do whatever needed for specific type OXCLS7: MOVEI U1,UCNTS(OC) MOVEM U1,UCHCNT(OC) ; Set safe address for count (not zero!!!) MOVE U1,[CALL OBADCH] MOVEM U1,UCOPT(OC) ; Store unit-mode instruction MOVEM U1,USCOPT(OC) ; and string-mode rtn addr. SETZM UCHTYP(OC) ; Make channel type "closed" (actually UAR, IF2 IFNDEF APOPJ,APOPJ: RET ; but what to do? Set -1?) OXCLST: APOPJ ; Area APOPJ ; XCT APOPJ ; BPT OCCLS ; IOT OXCLS3 ; BUF APOPJ ; Transl. APOPJ ; NUL APOPJ ; SAO IFN UC$NO-<.-OXCLST> .ERR OXCLST table loses OXCLS3: IFE $$OBUF, JSR AUTPSY IFN $$OBUF,[ ; BUffered output close. CALL UFRCBF ; Buffered, must force out vestiges. MOVE U3,UCHTYP(OC) ; Now get flags in LH HLRZ U1,UCHLIM(OC) ; and buffer addr in U1 TLNE U3,UC%DBF ; Dynamically allocated buffer? CALL CORREL ; Yup, must release it! ; Now drop thru to call OCCLS and proceed. ] OCCLS: IFN OS%ITS,{SYSCAL CLOSE,[OC] ? JSR AUTPSY } IFN OS%TNX,{ PUSH P,1 HRRZ 1,UCHJFN(OC) CLOSF ERJMP .+1 POP P,1 } RET OBADCH: JSR AUTPSY ; Output attempted on closed channel. RET ; IO Channel "PDL" - PUSH, POP, POPALL IFN UAREAS,[ .SCALAR IOPDLP ; Address of ARBLK for IOPDL area. .SCALAR IOPCNT ; # of channels pushed. OXPUSH: ; Save channel vars SKIPN U4,IOPDLP ; Get address of ARBLK JRST [ UAROPN U4,[0 ? [200]] ; Must create, so make one. HRRZM U4,IOPDLP SETZM IOPCNT JRST .+1] AOS IOPCNT HRRZ U1,$ARWPT(U4) ; Get write ptr, HRRZ U3,$ARTOP(U4) ; and 1st non-ex addr, CAIL U1,-$OCFRM(U3) ; and ensure enough room. JRST [ MOVEI U4,$OCFRM UAREXP U4,@IOPDLP ; Expand the area. MOVE U4,IOPDLP ; Restore ARPT HRRZ U1,$ARWPT ; Restore write ptr. JRST .+1] ADD U1,[1,,-1] ; Avoid PDLOV interrupt overhead and get ptr. %%OCNT==. IRP LOC,,[UCOPT,USCOPT,UCHCNT,UCNTS,UCHLIM,UCHTYP,UCHSTB] PUSH U1,LOC(OC) TERMIN IFN OS%TNX,PUSH U1,UCHJFN(OC) $OCFRM==:<.-%%OCNT> ; Get # wds per frame. ADDI U1,1 HRRZM U1,$ARWPT(U4) ; Store new write ptr. HRRZ U1,UCHTYP(OC) CAIE U1,UC$IOT CAIN U1,UC$BUF CAIA CALRET OXCLS7 IFN OS%ITS,[ MOVE U1,[.IOPUSH] DPB OC,[$ACFLD,,U1] XCT U1 ] CALRET OXCLS7 ; Softwarily close channel. CALL OXPOP OXPDLR: SKIPLE IOPCNT JRST .-2 UARCLS @IOPDLP SETZM IOPDLP RET OXPOP: SOSGE IOPCNT JSR AUTPSY CALL OXCLS ; Close channel currently in slot. ; Restore channel vars. SKIPN U4,IOPDLP JSR AUTPSY ; Attempt to pop empty stack... MOVE U1,$ARWPT(U4) SUB U1,[1,,1] IFN OS%TNX,POP U1,UCHJFN(OC) IRP LOC,,[UCHSTB,UCHTYP,UCHLIM,UCNTS,UCHCNT,USCOPT,UCOPT] POP U1,LOC(OC) TERMIN ADDI U1,1 HRRZM U1,$ARWPT(U4) ; Fix up channel vars in case popped into different channel. HRRZ U3,UCHTYP(OC) JRST @.+1(U3) %%OTMP==. OXPUAR OXPXCT OXPBPT OXPIOT OXPBUF OXPTRN OXPNUL IFN <.-%%OTMP>-UC$NX, .ERR UXPOP table loses OXPBUF: OXPIOT: IFN OS%ITS,[ DPB OC,[$ACFLD,,UCOPT(OC)] ; Set up new chan for unit-mode .IOT MOVE U1,[.IOPOP] DPB OC,[$ACFLD,,U1] XCT U1 ; Pop back hardware channel. ] CAIE U3,UC$BUF JRST OXPNUL OXPBPT: MOVEI U1,UCHSTB(OC) HRRM U1,UCOPT(OC) OXPXCT: OXPNUL: MOVEI U1,UCNTS(OC) MOVEM U1,UCHCNT(OC) OXPUAR: OXPTRN: RET ] ; IFN UAREAS SUBTTL OUT - Formatting routines IFN $$OUT,[ ; FMT - Sets field width, etc for next out-instruction. OUTDEF O.FMT:,OXFMT ; FMT - arg is addr of rtn to call for setup. ; Interpreted mode isn't really figured out yet. OXFLD: JSP U4,@U3 ; Call routine JRST OXFST1 ; Return vectors according to # params. JRST OXFST2 JRST OXFST3 BVAR UFFLG: 0 ; If -1, format params in effect. UFWID: 0 ; If non-z, specifies a field width. UFPREC: 0 ; Specifies "precision" for strings & floating output UFFILL: -1 ; Fill char, defaults to neg (meaning blank). UFSCNT: 0 ; Saved channel char cnt UFSCHN: 0 ; Saved channel # EVAR OXFST1: HRLOI U3,377777 ; Specify width only. Set prec to max. OXFST2: SETO U4, ; Specify width & prec only. Set fill char to blank. OXFST3: MOVEM U4,UFFILL ; Set fill MOVEM U3,UFPREC ; Set prec MOVEM U1,UFWID ; Set width SETOM UFFLG ; Say hacking format parameters. ; Set up channel for temporary buffer storage MOVEM OC,UFSCHN ; Save current channel, and MOVEI OC,UFLDC ; substitute "field" channel. SKIPN UCOPT(OC) ; Make sure something there... OUTCAL(,OPEN(UC$BPT,0,[$LUBUF])) ; If not, open it with limit. MOVE U1,[440700,,UFBUF] MOVEM U1,UCHSTB(OC) ; Reset write-pointer SKIPL U1,UFPREC ; Use desired limit. If negative, CAILE U1,$LUBUF ; or too large, MOVEI U1,$LUBUF ; use maximum. MOVNM U1,UCNTS(OC) ; Reset byte countdown to limit. MOVNM U1,UCHLIM(OC) ; And save limit being used. RET OUTDEF O.FDN:,OXFDON ; Interpreted mode not really figured out yet ; Finalize formatting... called when output done. OXFDON: SETZM UFFLG ; Turn off formatting. CAIE OC,UFLDC ; Make sure channel is correct one. JSR AUTPSY ; Got zapped in meantime!!?? MOVE U1,UCNTS(OC) ; Get resulting byte countdown SUB U1,UCHLIM(OC) ; <-max + cnt> - <-max> = <# chars written> MOVE OC,UFSCHN ; Now can restore previous channel. SKIPL U3,UFWID ; What sort of justification? JRST OXFRD ; Right justifying. ; Left justifying, so output buffer, then fill. ADD U3,U1 ; <# chars written> + - PUSH P,U3 ; Save -<# pads> SKIPG U4,U1 ; Set up <# chars> for output JRST OXFDL3 ; Nothing to output? MOVE U3,[440700,,UFBUF] CALL @USCOPT(OC) ; Output buffered stuff to real channel. OXFDL3: POP P,U4 ; Restore -<# pads> JUMPGE U4,[RET] ; If no fill needed, return. MOVM U4,U4 ; Get <# pads> SKIPGE U1,UFFILL ; If strange fill char, CAIL U4,$LBSTR ; or filling more than is reasonable, JRST OXFDF ; jump to handle special case. MOVE U3,[440700,,UBLSTR] ; Normal case will efficiently PJRST @USCOPT(OC) ; output string of padding blanks and return. ; Finalize right-justified string... OXFRD: PUSH P,U1 ; Save <# chars written> SUB U1,U3 ; Find -<# pads to prepend> JUMPGE U1,OXFDR4 ; Jump if none; can simply output stuff. SKIPGE UFFILL ; If strange fill char, CAMGE U1,[-$LBSTR] ; or too much padding, JRST OXFDR3 ; do it hard way. MOVE U3,[440700,,UFBUF] MADBP7 U3,U1 ; Adjust BP in U3 by cnt in U1 POP P,U4 SUB U4,U1 ; <# writ> - <- # pad> = total to write out PJRST @USCOPT(OC) ; Output string of blanks AND data together!! OXFDR3: MOVM U4,U1 ; Move <# pads> to right place CALL OXFDF ; Output fill chars one at a time. OXFDR4: POP P,U4 ; Restore # chars written originally MOVE U3,[440700,,UFBUF] ; Point at field buffer JUMPG U4,@USCOPT(OC) ; Output and return. RET OXFDF: SKIPGE U1,UFFILL ; If fill char negative, MOVEI U1,40 ; means regular blank. OXRPTC: STDOUT ; Repeatedly output byte... SOJG U4,OXRPTC RET BVAR $LBSTR==5*30. ; # blanks in filler buffer UBLSTR: .BYTE 7 REPEAT $LBSTR,40 .BYTE ; Note buffers contiguous!! $LUBUF==$LBSTR ; # chars avail in field-adjusting buffer UFBUF: BLOCK <$LUBUF+4>/5 EVAR ] ;IFN $$OUT SUBTTL OUT - Basic output routines ; NOTE: the UUO versions of these routines are becoming obsolete. IFN $$OUUO,[ ; OUTPUT UUOS. All should avoid clobbering U4 before ; reading args, since FWRITE macro may be using it to set ; up UUO calls. Most but not all are 7-bit; OUTPC is ; completely general. UUODEF OUTI:,U7I ; Immediate - E is char UUODEF OUTZ:,U7Z ; E->ASCIZ string UUODEF OUTC:,U7C ; c(E) = <# chars>,, UUODEF OUTPZ:,U7PZ ; c(E) = BP to ASCIZ string UUODEF OUTPC:,UTPC ; c(E) = <# chars>,,[BP] IFN OS%TNX+USTRGS,UUODEF OUTS:,U7S ; c(E) = <# chars> ? UUODEF OUT6F:,U6F ; outputs c(E) as 6bit, ignores trailing blanks. EQUALS .M"OU6F,OUT6F UUODEF OUT6W:,U6W ; outputs c(E) as 6bit, all 6 chars. EQUALS .M"OU6W,OUT6W UUODEF OUT6Q:,U6Q ; outputs c(E) as 6bit, quotes punctuation chars with ^Q, drops tr blnk EQUALS .M"OU6Q,OUT6Q UUODEF OUT10.:,UN10 ; outputs c(E) as decimal value, with point. EQUALS .M"OUN10,OUT10. UUODEF OUT10:,UN9 ; like OUN10 but no decimal point. EQUALS .M"OUN9,OUT10 UUODEF OUT8:,UN8 ; outputs c(E) as octal value. EQUALS .M"OUN8,OUT8 UUODEF OUNRH:,UNRH ; outputs RH of c(E) as 6 octal digits. UUODFA CRLF:,UCRLF ; outputs CRLF, ignores E. ] ;IFN $$OUUO OUTDEF O.C:,OXCI ; C - Character U7I: UIOINIT ; Entry pt for OUTI UUO HRRZ U1,U40 IFN $$ORID,[ JRST OXC OXCI: MOVEI U1,@U3 ] ; Get argument (immediate type) OXC: STDOUT ; Direct entry pt (if needed) RET OUTDEF O.EOL:,OXEOL UCRLF: UIOINIT ; Entry pt for CRLF UUO OXCRLF: OXEOL: STDOUT(^M) STDOUT(^J) RET OXTAB: SKIPA U1,[^I] ; For convenience. OXSP: MOVEI U1,40 ; Ditto STDOUT RET OUTDEF O.:,OXTXTI ; O. is used by OUT macro for short constant strings. ; Note this instr doesn't use I, X or AC because ; string is always constant, only invoked by macro. IFN $$ORID,[ OXTXTI: LDB U4,[.BP <777,,>, U3] ; Get # chars from instr itself. HRLI U3,440700 ; and turn instr into a BP to string JUMPN U4,@USCOPT(OC) ; and off to output it! RET ] OUTDEF O.ZA:,OXZAI ; O.ZA - arg is addr of ASCIZ string. U7Z: UIOINIT ; Entry pt for OUTZ UUO SKIPA U3,U40 OXZAI: MOVEI U3,@U3 ; get addr of string OXZA: HRLI U3,440700 ; form byte ptr JRST OXZ ; Jump into loop OUTDEF O.ZP:,OXZPI ; O.ZP - arg is addr of BP to BYTEZ string U7PZ: UIOINIT ; Entry pt for OUTPZ UUO SKIPA U3,@U40 OXZPI: MOVE U3,@U3 ; get byte ptr JRST OXZ OXZ1: STDOBP ; Output byte (BP in U3 in case count out) OXZ: ILDB U1,U3 ; Get input byte JUMPN U1,OXZ1 ; Loop til hit zero byte. RET OUTDEF O.PC:,OXPC ; PC - Horrible crock kept for compat. UTPC: UIOINIT ; Entry pt for OUTPC UUO SKIPA U3,@U40 ; Get ,,[bp] OXPCI: MOVE U3,@U3 OXPC: HLRZ U4,U3 ; Direct entry - get cnt MOVE U3,(U3) ; Get the bp JUMPN U4,@USCOPT(OC) ; Dispatch RET OUTDEF O.TC:,OXTCI ; O.TC [<# chs>,,[ASCII]] U7C: UIOINIT ; Entry pt for OUTC UUO SKIPA U3,@U40 OXTCI: MOVE U3,@U3 ; Get cnt,,stringloc OXTC: HLRZ U4,U3 ; Get cnt HRLI U3,440700 ; Form BP in U3 JUMPG U4,@USCOPT(OC) ; Dispatch RET OUTDEF O.SA:,OXSAI ; O.SI - E->[[# bytes] ? [BP]] OXSAI: MOVEI U3,@U3 ; Get E OXSA: MOVE U1,(U3) ; Get addr of byte cnt MOVE U3,1(U3) ; Get addr of BP MOVE U3,@U3 ; Get BP MOVE U4,@U1 ; Get byte cnt JUMPN U4,@USCOPT(OC) ; Vector to right routine RET OUTDEF O.S:,OXSI ; O.S [,,<# bytes> ? ] U7S: UIOINIT ; Entry pt for OUTS UUO SKIPA U3,U40 OXSI: MOVEI U3,@U3 ; Get addr to string descriptor OXS: HRRZ U4,(U3) ; Get byte cnt MOVE U3,1(U3) ; Get byte ptr JUMPG U4,@USCOPT(OC) ; Jump into output rtn RET ; Return if null string. SUBTTL OUT - Sixbit output OUTDEF O.6W:,OX6WI ; O.6W - outputs arg as 6bit, all 6 chars U6W: UIOINIT SKIPA U3,@U40 ; Entry pt for OUT6W UUO OX6WI: MOVE U3,@U3 ; Get 6bit wd OX6W: MOVE U4,[440600,,U3] OX6W1: ILDB U1,U4 ; Get 6bit char ADDI U1,40 ; Convert to ASCII STDOUT ; Output TLNE U4,770000 ; BP counted out yet? JRST OX6W1 RET OUTDEF O.6F:,OX6FI ; O.6F - outputs arg as 6bit, no trailing spaces. U6F: UIOINIT SKIPN U3,@U40 RET JRST OX6F OX6FI: SKIPN U3,@U3 ; Get 6bit wd RET ; Return if nothing (no trailing blanks) OX6F: SETZ U4, ; Direct calling sequence SKIPE U3,ARG ? CALL OX6F ROTC U3,6 STDOUT(40(U4)) JUMPN U3,OX6F RET OUTDEF O.6Q:,OX6QI ; O.6Q - outputs arg as 6bit, quotes punct, no tr. sp. U6Q: UIOINIT SKIPA U3,@U40 OX6QI: MOVE U3,@U3 ; Get 6bit wd OX6Q: SETZ U4, ROTC U3,6 ; Get next character in 6bit CAIN U4,'- ; If other than letter, number, or hyphen JRST OX6Q3 ; will need a ^Q to quote it. CAIL U4,'0 CAILE U4,'Z JRST OX6Q2 CAILE U4,'9 CAIL U4,'A JRST OX6Q3 OX6Q2: STDOUT(^Q) OX6Q3: STDOUT(40(U4)) JUMPN U3,OX6Q RET SUBTTL OUT - Numerical output OUTDEF O.O:,OXN8I ; O - Octal OUTDEF O.D:,OXN10I ; D - Decimal OUTDEF O.X:,OXN16I ; X - Hexadecimal UN10: UIOINIT ; Entry pt for OUT10. UUO MOVE U3,@U40 OXN10.: MOVEI U1,10. CALL UNTYP STDOUT(".) RET UN8: SKIPA U1,[8.] ; Entry pt for OUT8 UUO UN9: MOVEI U1,10. ; Entry pt for OUT10 UUO UIOINIT MOVE U3,@U40 JRST UNTYP OXN16I: MOVEI U1,16. ? JRST UNTYPI OXN8I: SKIPA U1,[8.] OXN10I: MOVEI U1,10. UNTYPI: SKIPL U3,@U3 ; Get argument value JRST UNTYP1 UNTYP5: MOVM U3,U3 ; Negative, print minus sign. MOVE U4,U1 ; Save radix STDOUT("-) MOVE U1,U4 ; Restore radix JRST UNTYP1 ; Direct call entry points to numerical typeout rtn. OXN16: MOVEI U1,16. ? JRST UNTYP OXN8: SKIPA U1,[8.] OXN10: MOVEI U1,10. UNTYP: JUMPL U3,UNTYP5 ; Go print minus sign. UNTYP1: IDIVI U3,(U1) JUMPE U3,UNTYP2 HRLM U4,(P) ; save digit on stack. PUSHJ P,UNTYP1 HLRZ U4,(P) UNTYP2: CAILE U4,9. SKIPA U1,-10.(U4)+["A ? "B ? "C ? "D ? "E ? "F] ; For hex output MOVEI U1,"0(U4) ;put char in u1 STDOUT POPJ P, SUBTTL Halfword output OUTDEF O.RH:,OXRHI ; O.RH - prints RH of arg as 6 octal digits OUTDEF O.LH:,OXLHI ; O.LH - ditto for LH OUTDEF O.HWD:OXHWDI ; O.HWD - LH,,RH OXHWDI: MOVE U3,@U3 OXHWD: PUSH P,U3 CALL OXLH POP P,U3 STDOUT(54) ; Comma STDOUT(54) CALRET OXRH OUTDEF O.HV:,OXHVI OUTDEF O.HS:,OXHSI OXHVI: MOVE U3,@U3 OXHV: PUSH P,U3 HLRZ U3,U3 CALL OXN8 POP P,U3 STDOUT(54) STDOUT(54) HRRZ U3,U3 CALRET OXN8 OXHSI: MOVE U3,@U3 OXHS: PUSH P,U3 HLRE U3,U3 CALL OXN8 POP P,U3 STDOUT(54) STDOUT(54) HRRE U3,U3 CALRET OXN8 OXLHI: HLRZ U3,@U3 CALRET OXRH OXLH: HLRZ U3,U3 ; Somewhat useless since can just setup arg to CALRET OXRH ; call OXRH directly, but for completeness... UNRH: UIOINIT ; Entry pt for OUNRH UUO SKIPA U3,@U40 OXRHI: MOVE U3,@U3 ; Get word OXRH: MOVE U4,[220300,,U3] ; Set up BP, 6 bytes of 3 bits. OXRH1: ILDB U1,U4 STDOUT("0(U1)) ; Convert & output TLNE U4,770000 ; BP counted out yet? JRST OXRH1 RET SUBTTL OUT - Floating-point output IFN $$OFLT,[ .SCALAR OFLTFS ; Indicates type of output. - E, + F, 0 G. FLT%FE==400000,,0 FLT%FF==200000,,0 IFN $$OUUO,[ UUODEF OUNFLT:,UNFL10 ; Outputs c(E) as floating decimal EQUALS .M"OUNFL,OUNFLT ] ;IFN $$OUUO IFNDEF E,E=:D+1 IFGE E-U1, .ERR ACs will lose for floating output! OXNE: SKIPA U1,[OUT"FLT%FE] ; E format, m.nnnnnE+ee OXNF: MOVEI U1,OUT"FLT%FF ; F format, mmm.nn PJRST OXNFL UNFL10: UIOINIT SKIPA U3,@U40 OXNFLI: MOVE U3,@U3 OXNG: SETZ U1, ; G format; F if within range, else E. Maximum prec. OXNFL: PUSHAE P,[A,B,C,D,E,OFLTFS] MOVEM U1,OFLTFS ; Set flags to use PUSHJ P,UNFO POPAE P,[OFLTFS,E,D,C,B,A] RET ; This routine adapted from that in MACLISP. UNFO: SKIPL A,U3 JRST UFP1 STDOUT("-) MOVN A,U3 UFP1: SKIPLE OFLTFS ; If want F-format, JRST UFP1F ; Go straight to it. SETZB B,D ; For E-fmt, B holds add'l signif bin digits CAMGE A,[.01] ; and D is exponent sign indicator JRST UFP4 ; D=0 => negative exponent [x < 1.0e-2] CAML A,[1.0^8] AOJA D,UFP4F ; D=1 => positive exponent [x > 1.0e+8 - 1] SKIPGE OFLTFS ; Made it, can use F fmt, but is E required? JRST [ CAMGE A,[1.0] ; Yes, test to get exponent sign. JRST UFP4 ; Neg exp AOJA D,UFP4F] ; Pos exp ; "F" format. "G" comes here for 1.0e-2 <= x < 1.0e8 UFP1F: CAMGE A,[1.0] ; First find -<# digits to right of point.> JRST [ MOVNI E,10. CAML A,[.1] ; .1 <= x < 1.0 JRST UFP3 SOJA E,UFP3] ; .01 <= x < .1 PUSHJ P,UFPL10 ; <# digits to left of .>+1 will now be in E SUBI E,9. ; Get -<# digits to right.> UFP3: SETZB B,C ASHC A,-27. ; Split exponent part off ASHC B,-243(A) ; Split number into integral and fract part MOVE U3,B ; Output integer part PUSHJ P,OXN10 STDOUT(".) MOVE B,C ; Move fract part MOVM D,E ; D now holds # digits to print to right of . MOVSI E,200000 ; Compute position of last significant bits ASH E,-243+1+<43-27.>(A) IFN $$OUT,[ SKIPE U4,UFFLG ; Format params in effect? MOVN U4,UFPREC ; Yes, get precision (# columns to right of .) ] .ELSE SETZ U4, UFP3A: MOVE A,B MULI A,10. IMULI E,10. CAMGE B,E JRST UFPX0 MOVN C,E TLZ C,400000 CAMLE B,C AOJA A,UFPX0 ; Last sig digit, but round upwards IFN $$OUT,[ ; Note only truncate when U4 was positive to start with. SOJE U4,[TLNE B,200000 ; If forcing last digit, round upwards. CAIL A,9. ; Round. This is a KLUDGE check since JRST UFPX0 ; can't carry the roundup further (digits AOJA A,UFPX0] ; already output). Oh well. ] STDOUT("0(A)) CAIN D,2 ; On ninth output digit, use only half a digit ASH E,-1 ; for end-of-precision test SOJG D,UFP3A IFN $$OUT,JUMPG U4,UFPX1 POPJ P, ; Last significant digit, so stop UFPX0: STDOUT("0(A)) IFE $$OUT, RET .ELSE [ SOJG U4,UFPX1 ; Skip if precision not done yet. RET UFPX1: MOVEI U1,40 ; Need to pad out. Default filler is space, SKIPGE OFLTFS ; but if doing E fmt, MOVEI U1,"0 ; then pad with zeros instead. CALRET OXRPTC ; Go pad out. ] ; ----------- Here for "E" format ------------------- UFP4: JUMPN A,UFP4F ; Floating point "E" format STDOUT("0) STDOUT(".) STDOUT("0) IFN $$OUT,[ SKIPE U4,UFFLG MOVN U4,UFPREC ; If formating, get precision. SOJG U4,UFPX1 ; If must space out, do so. ] POPJ P, UFP4F: MOVEI E,1 JUMPE D,UFP4E ; Jump out if negative exponent. UFP4E0: FDVL A,UFP10.0 ; Double-prec div by 10.0 until FDVRI A+1,(10.0) ; quotient is < 10.0 FADL A,A+1 CAML A,UFP10.0 AOJA E,UFP4E0 JRST UFP4B UFP4E: FMPRI A+1,(10.0) MOVEM A+1,A+2 ; Double-precision mul by 10.0 until FMPL A,UFP10.0 ; product is >= 1.0 UFA A+1,A+2 ; Keeping count in E FADL A,A+2 CAMGE A,UFP1.0 AOJA E,UFP4E UFP4B: PUSH P,E ; Save exponent PUSH P,(D)["- ? "+] ; Save sign of exponent SETZ B, MOVNI E,8. IFN $$OUT,[ MOVSI U4,(FLT%FE) ; Indicate hacking E format. IORM U4,OFLTFS ] PUSHJ P,UFP3 ; Num has been normalized for 1.0 <= x < 10.0 STDOUT("E) POP P,U1 ; Restore sign char STDOUT ; Output it. POP P,U3 ; Restore exponent value CAIL U3,100. ; Shouldn't be possible to exceed, but... PJRST OXN10 ; hack more than 2 digits in exponent. IDIVI U3,10. STDOUT("0(U3)) ; Always use 2 digits in output. STDOUT("0(U4)) POPJ P, UFPL10: MOVEI E,8 CAMGE A,UFP1.0-1(E) SOJG E,.-1 POPJ P, UFP1.0: REPEAT 8,1.0^.RPCNT UFP10.0=UFP1.0+1 ] ;end IFN $$OFLT SUBTTL Various special item output IFN UAREAS,[ ; OUTAR CH, Outputs char-mode area on CH. IFN $$OUUO,{UUODEF OUTAR:,U7XA EQUALS .M"OUTA,OUTAR } OUTDEF O.AR:,OIAR U7XA: UIOINIT ; Entry pt for OUTAR UUO SKIPA U1,U40 ; Get ARPT to area. OIAR: MOVEI U1,@U3 ; Note arg in "non-standard" U1. OXAR: SKIPN $AROPN(U1) ; Make sure it's open. RET ; Just return if it isn't. MOVE U3,$ARWPT(U1) ; Get write pointer (end of used area) SUB U3,$ARLOC(U1) ; Make relative to beg MULI U3,5 ; do bp hack ADD U4,UADBP7(U3) ; Get # chars. MOVE U3,$ARLOC(U1) ; Now cons up a BP to start. HRLI U3,440700 JUMPN U4,@OUT"USCOPT(OC) ; Finally dispatch to string output, RET ; unless nothing to output. ] ;IFN UAREAS IFN ULISTS,[ ; OUTLS CH,[slp] Outputs string that SLP points to, on channel CH. UUODEF OUTLS:,U7LS OUTDEF O.LS:,OILS U7LS: UIOINIT SKIPA U3,@U40 ; Get SLP. OILS: MOVE U3,(U3) OXLS: OXSL: ; Preferred label. IF1 IFNDEF LISTAR, NOP ; 1st pass may not have macro def'd yet. .ELSE MOVE U3,LISTAR(U3)+1 ; Get its SPT. HLRZ U4,U3 ; Get count. ADD U3,$LSLOC(L) ; Make address absolute HRLI U3,440700 ; and turn into a BP. JUMPG U4,@USCOPT(OC) ; Jump into output loop if anything there. RET ; Else no-op. ; List-String relative to specific LSE. ; U1 - addr of LSE ; U3 - SLP to SLN within that LSE. OXSLA: EXCH L,U1 ; For addressing purposes... IF1 IFNDEF LISTAR, NOP ; 1st pass may not have macro def'd yet. .ELSE MOVE U3,LISTAR(U3)+1 ; Get the SPT. ADD U3,$LSLOC(L) ; Make address absolute. MOVE L,U1 ; Restore original L. HLRZ U4,U3 ; Get count, HRLI U3,440700 ; make BP, JUMPG U4,@USCOPT(OC) ; and off to output it. RET ] ;IFN ULISTS ; UC$SAO output type - replaces old SAOBEG UUO. ; Initializes for standard UUO output into SA area; argument is ; a LSE pointer, e.g. OPEN(UC$SAO,$ARLOC+MSGAR) or OUTOPN CH,[$UCSAO,,L]. ; The %LTSAO type bit in MAKELN will form a string LN of accumulated ; output. UOPNSA: IFE ULISTS, JSR AUTPSY .ELSE [ SKIPN U4,@(U3) ; Get pointer to LSE MOVE U4,L ; If none specified, use current LSE. MOVE U1,$LSFRE(U4) ADD U1,$LSLOC(U4) ; Get abs start addr HRLI U1,440700 ; Form BP MOVEM U1,$LSWPT(U4) ; and set up new write ptr for area. MOVEI U1,(U1) SUB U1,$LSTOP(U4) ; Get -<# wds left> IMULI U1,5 MOVEM U1,$LSCHL(U4) ; Store as $ARCHL for SA. MOVEI U4,$LSAR(U4) ; Finally get pointer to string-area ARPT. MOVEI U1,UC$UAR ; Replace channel type with normal area. MOVEM U1,UCHTYP(OC) PJRST UOPNA1 ; Dispatch to complete normal area-open. ] ;IFN ULISTS SUBTTL ERR item output IFN $$OERR,[ ; Code for ERR output type. ; Arg is error #. ; If arg -1, use "last error". ; Include crocks for compatibility with old kludge. ERRMOA: SKIPA U3,A ERRMO: SETO U3, PUSH P,OC MOVEI OC,(B) CALL OXERR POP P,OC RET OUTDEF O.ERR:,OXERRI OXERRL: SKIPA U3,[-1] ; Entry pt to use last error OXERRI: MOVE U3,@U3 ; Get error # OXERR: IFN OS%ITS,[ MOVEI U4,4 ; Assume # specified, CAIGE U3, ; But if want "last error", MOVEI U4,1 ; ask system for that. IFNDEF ERRCHN,.ERR ERRCHN must be defined for $$OERR to work. SYSCAL OPEN,[CIMM ERRCHN [SIXBIT/ERR/] ? U4 ? U3 ] JRST [ MOVEI U3,[ASCIZ "?? Can't get error msg from ERR device ??"] PJRST OXZA] OXERR2: .IOT ERRCHN,U1 CAIGE U1,40 JRST [ .CLOSE ERRCHN, RET ] STDOUT JRST OXERR2 ] ;END IFN ITS IFN OS%TNX,[ PUSHAE P,[1,2,3] MOVEI 2,(U3) HRLI 2,.FHSLF ; 2 = ,, MOVSI 3,-UERBFL ; 3 = -<# chs>,, HRROI 1,UERBUF ; 1 = -1,, ERSTR ; Get error string ERJMP [MOVEI U3,[ASCIZ //] JRST OXERR5] JRST [ MOVEI U3,[ASCIZ //] JRST OXERR5] SETZ 3, IDPB 3,1 MOVEI U3,UERBUF OXERR5: POPAE P,[3,2,1] PJRST OXZA UERBFL==140. ; Max # chars in err msg .VECTOR UERBUF(/5) ] ;END IFN TNX ];end IFN $$OERR IFE $$OUT,.END ? .INEOF ; Efficiency hack -- all features from here on ; depend on $$OUT being set! SUBTTL Host name/number output IFN $$OHST,[ ; NOTE: this code now assumes addresses are in HOSTS3 format! OUTDEF O.HN:,OXHNI ; Output host num in octal (single #) OUTDEF O.HND:,OXHNDI ; Output host num in decimal (IN fmt) OXHNI: MOVE U3,@U3 OXHN: CALRET OXN8 ; Simply output in octal OXHNDI: MOVE U3,@U3 OXHND: PUSH P,U3 IF1, BLOCK 3 IF2 [ IFDEF NETWRK"CVH3NA, EXCH A,(P) ? CALL NETWRK"CVH3NA ? EXCH A,(P) .ELSE JRST .+2 ? JRST 4,. ? JRST 4,. ] TLNE U3,(17_32.) ; Internet address? JRST [ LDB U3,[.BP <17_32.>, (P)] ; No, so exhibit high 4 bits. CALL OXN8 ; Note octal! STDOUT(":) JRST .+1] REPEAT 4,[ IFN .RPCNT, STDOUT(".) LDB U3,[.BP <377_<8.*<3-.RPCNT>>>, (P)] CALL OXN10 ] POP P,U3 RET OUTDEF O.HST:,OXHSTI OXHSTI: MOVE U3,@U3 OXHST: IFN OS%ITS,[ PUSHAE P,[A,B,D] ;clobbered by HSTSRC routine SKIPN B,U3 IFN <.PASS&1>+,[ MOVE B,OWNHST CALL NETWRK"HSTSRC ; make A point to asciz name ] .ELSE JSR AUTPSY ? JSR AUTPSY JRST [ CALL OXHND JRST OXHST1] MOVEI U3,(A) CALL OXZA OXHST1: POPAE P,[D,B,A] RET ] ;IFN ITS IFN OS%TNX,[ PUSHAE P,[1,2] HRROI 1,UHSTBF MOVE 2,U3 CVHST ERJMP [CALL OXHND ? JRST OXHST2] NOP SETZ U1, IDPB U1,1 MOVEI U3,UHSTBF CALL OXZA OXHST2: POPAE P,[2,1] RET .SCALAR UHSTBF(50./5) ; Allow hostname up to 49. chars long. ] ;IFN TNX ] ;IFN $$OHST SUBTTL OUT - Miscellaneous routines ;------------------------------------------------------- OUTDEF O.CH:,OXCHI ; CH - Channel specification OXCHI: MOVEI OC,@U3 ; Get argument (IMMEDIATE type) CAIGE OC,$UNCHS ; Compare with # of channels allowed RET ; Is okay, just return. JSR AUTPSY ; Yuck!!! Channel # too big. OUTDEF O.XCT:,OXXCTI ; XCT - Execute instruction OXXCTI: XCT @U3 ; Do it. RET ; Just in case, RET ; allow for skips. ;-------------------------------------------------------- SUBTTL Time Output IFN $$OTIM,[ ; Requires that TIMRTS be .INSRT'd someplace; the external defs ; needed from it are listed: ; (ITS) TIMADY - rtn to cvt sys-int timeword to abs (used for finding DOW) ; (ITS) TIMGET - rtn to get current sys-int time, with DST bit set. ; Sub-types for "TIM" output item. YOU try to think of ; better names for F1, F2, etc!! DEFT HMS,OXTMTS ; HMS - Time as "hh:mm:ss". (old WC) DEFT MDY,OXTMD ; MDY - Date as "mm/dd/yy" DEFT MDYT,OXTMDT ; MDYT - Datime as "mm/dd/yy hh:mm:ss" (old WA) DEFT MONTH,OXTLMN ; MONTH - Month as "Month" DEFT MON,OXTMN ; MON - Month as "MON" DEFT DOW,OXTLDW ; DOW - Day of week as "Fooday" DEFT DOW3,OXTDW ; DOW3 - Day of week as "Foo" DEFT F1,OXTME ; F1 - Datime as "dd MON yy hhmm-ZON" (old WB) DEFT F2,OXTMX ; F2 - Datime as "dd Month yyyy hh:mm-ZON" (old WD) ; OUT invocations ; with TIM() use the sequence ; (arg in U3) ; MOVEI U1,OXTnam ; CALL OXTXS ; with TIMA() use sequence like TIM() but CALL OXTXA. ; with TIMB() use the sequence ; (arg in UTMAC) ; CALL OXTnam IFNDEF $LTIMB,[ ; Define time-block here if not already def'd elsewhere TM.YR==:0 TM.MON==:1 TM.DAY==:2 TM.HR==:3 TM.MIN==:4 TM.SEC==:5 TM.ZON==:6 ; ,, TM.DOW==:7 ; 0 = Monday, 6 = Sunday $LTIMB==:10 ] IFN U2-OC, UTMAC==:U2 ; Normal case .ELSE UTMAC==:U4 ; Screw case ; OXTXS - Execute time-routine using System-internal time. ; OC/ ; U1/ ; U3/ OXTXS: IFE U2-OC, PUSH P,OC MOVEI U2,1(P) ; Get pointer to timeblock ADD P,[$LTIMB,,$LTIMB] ; Make room for timeblock CALL OXTCSB ; Insert values in timeblock IFE U2-OC, MOVEI U4,(U2) ? MOVE OC,-$LTIMB(P) CALL (U1) ; Process stuff IFN U2-OC, SUB P,[$LTIMB,,$LTIMB] .ELSE SUB P,[$LTIMB+1,,$LTIMB+1] RET ; OXTCSB - Convert System-internal timeword to timeblock. ; U2/ ; U3/ ; Smashes U3, U4 only OXTCSB: IFN OS%ITS,[ LDB U4,[TM$YR,,U3] ADDI U4,1900. MOVEM U4,TM.YR(U2) LDB U4,[TM$MON,,U3] MOVEM U4,TM.MON(U2) LDB U4,[TM$DAY,,U3] MOVEM U4,TM.DAY(U2) SKIPN U4,UTZLV ; Get local timezone JRST [ CALL UTZGET ; Get if not initialized JRST .-1] ; Repeat after init. TRNE U3,1 ; DST bit set? TLOA U4,-1 ; Yes, set LH to -1 TLZ U4,-1 ; No, ensure LH clear MOVEM U4,TM.ZON(U2) MOVEI U3,(U3) LSH U3,-1 IDIVI U3,60.*60. MOVEM U3,TM.HR(U2) MOVEI U3,(U4) IDIVI U3,60. MOVEM U3,TM.MIN(U2) MOVEM U4,TM.SEC(U2) SETOM TM.DOW(U2) ; Punt DOW value for now, rarely use it. RET ] IFN OS%TNX,[ PUSHAE P,[1,2,3,4] MOVE 2,U3 SETZ 4, ODCNV ERJMP [SETZB 2,3 ; 20X only (10X generates .ICILI) SETZ 4, JRST .+1] HLRZM 2,TM.YR(U2) ; Store year # ADDI 2,1 HRRZM 2,TM.MON(U2) ; Store month # (1 based) HLRZM 3,TM.DAY(U2) AOS TM.DAY(U2) ; Day # (1 based) HRRZM 3,TM.DOW(U2) ; Store day-of-week (0=Monday) MOVEI 1,(4) IDIVI 1,60.*60. IDIVI 2,60. MOVEM 1,TM.HR(U2) MOVEM 2,TM.MIN(U2) MOVEM 3,TM.SEC(U2) LDB 1,[.BP ,4] ; Get timezone TLNE 4,(IC%ADS) ; If DST was applied TLO 1,-1 ; then put -1 in LH MOVEM 1,TM.ZON(U2) POPAE P,[4,3,2,1] RET ] ; All of the following output routines assume that UTMAC points ; to a timeblock structure. ; Date as MM/DD/YY OXTMD: MOVE U3,TM.MON(UTMAC) CALL OXTD2 STDOUT("/) MOVE U3,TM.DAY(UTMAC) CALL OXTD2 STDOUT("/) OXTYR2: MOVE U3,TM.YR(UTMAC) ; Year as 2-digit number. SUBI U3,1900. CALRET OXTD2 ; Date/time as MM/DD/YY HH:MM:SS OXTMDT: CALL OXTMD ; Date STDOUT(40) ; Fall through for time ; Time as HH:MM:SS OXTMTS: MOVE U3,TM.HR(UTMAC) CALL OXTD2 ; Output hours STDOUT(":) MOVE U3,TM.MIN(UTMAC) CALL OXTD2 ; Output minutes STDOUT(":) MOVE U3,TM.SEC(UTMAC) CALRET OXTD2 ; Output secs and done. ; Date/time as " 7 AUG 1976 0831 EDT" (constant length) OXTME: CALL OXTDAY ; Output day, 2 columns STDOUT(40) CALL OXTMN ; Output 3-letter month STDOUT(40) ; Space out CALL OXTYR ; Output 4-digit year STDOUT(40) MOVE U3,TM.HR(UTMAC) CALL OXTD2 ; Output hrs MOVE U3,TM.MIN(UTMAC) CALL OXTD2 ; Output mins CALRET OXTMZD ; Print time-zone & return ; Date/time as "7 August 1976 08:31 EDT" OXTMX: CALL OXTDAV ; Output day, one or two columns STDOUT(40) CALL OXTLMN ; Output "long" month name STDOUT(40) CALL OXTYR ; Output 4-digit year STDOUT(40) MOVE U3,TM.HR(UTMAC) CALL OXTD2 ; Output hrs STDOUT(":) MOVE U3,TM.MIN(UTMAC) CALL OXTD2 ; Output mins ; Fall through to output timezone & return. ; Output local timezone (time-word val indicates whether DST) OXTMZD: STDOUT(" ) ; Entry pt for prefix dash OXTMZ: SKIPN U3,UTZLSS ; Get pointer to local timezone JRST [ CALL UTZGET ; Not there yet? Set it up. JRST .-1] SKIPGE TM.ZON(UTMAC) ; Daylight savings on? MOVE U3,UTZLDS ; Yes, use DST version instead. CALRET OXZA ; Output ASCIZ. ; Day of the month in two columns. OXTDAY: MOVE U3,TM.DAY(UTMAC) ; Get day CAIL U3,10. ; If number will have two digits, CALRET OXTD2 ; dispatch to routine for that. STDOUT(40) ; Else output a space STDOUT("0(U3)) ; and the digit. RET ; Day of the month in one or two columns (Variable format). OXTDAV: MOVE U3,TM.DAY(UTMAC) ; Get day CAIL U3,10. ; If two digits, CALRET OXTD2 ; dispatch to better routine. STDOUT("0(U3)) RET ; For both versions of month output, use ASCIZ ; rather than ASCNT since former guarantees U2 ; will be preserved. OXTLMN: MOVE U3,TM.MON(UTMAC) ; Get month MOVE U3,UTBMON(U3) ; Get ascnt ptr to string for it CALRET OXZA ; Output ASCIZ string OXTMN: MOVE U3,TM.MON(UTMAC) ; Get month MOVE U3,UTBMO3(U3) ; Get ascnt ptr to string for it CALRET OXZA ; Output asciz (only 3 chars) ; Day-Of-Week output OXTDW: SKIPA U1,[UTBDO3(U3)] ; Use short-form table. OXTLDW: MOVE U1,[UTBDOW(U3)] ; Use long-form table. SKIPGE U3,TM.DOW(UTMAC) ; All's well if have valid DOW value CALL UTMGDW ; Sigh, must get it (into U3) MOVE U3,@U1 ; Get appropriate string, table idx'd by U3 CALRET OXZA ; Output as asciz to avoid U4 clobberage. OXTYR: MOVE U3,TM.YR(UTMAC) ; Get year ; Fall through to output 4 digits. ; Internal routines to output 4 or 2 digits of num in U3. OXTD4: IFE UTMAC-U4, PUSH P,U4 IDIVI U3,100. ; Output 4 digits PUSH P,U4 CALL OXTD2 POP P,U3 ; Fall thru to OXTD2 again IFE UTMAC-U4, CAIA OXTD2: IFE UTMAC-U4, PUSH P,U4 IDIVI U3,10. ; Output 2 digits STDOUT("0(U3)) STDOUT("0(U4)) IFE UTMAC-U4, POP P,U4 RET ; Get system internal time in U3 UTMGTS: IFN OS%ITS,[ PUSH P,A CALL TIMGET MOVE U3,A POP P,A ] IFN OS%TNX,[ PUSH P,1 GTAD MOVE U3,1 POP P,1 ] RET ; UTMGDW - Given ptr to time-block in UTMAC, return ; DOW value in U3 (0=Monday). Clobbers U4 (unless == UTMAC) UTMGDW: IFN OS%TNX, MOVEI U3,7 ; TNX shouldn't ever have to ask IFN OS%ITS,[ CALL UTCBDA ; Get absolute # days IFE UTMAC-U4,PUSH P,U4 IDIVI U3,7 MOVEI U3,(U4) IFE UTMAC-U4,POP P,U4 ] ;OS%ITS RET ; UTCBDA - Time Convert, Block to Day Absolute ; UTMAC/ ptr to time-block ; Returns ; U3/ absolute # days since Jan 1, 1900 ; Clobbers U4 (unless == UTMAC) IFN OS%ITS,[ UTCBDA: IFN UTMAC-U2,PUSH P,U2 ? MOVE U2,UTMAC ; Ensure ptr in U2 PUSH P,U1 MOVE U3,TM.DAY(U2) ; Get day # MOVE U1,TM.MON(U2) ; Get month # ADD U3,TMONTB(U1) ; Add days thus far in year MOVE U4,TM.YR(U2) ; Get year SUBI U4,1900. ; Make simplifying assumption TRNE U4,3 ; Specified year a leap year? JRST .+3 ; No, can skip month check CAIL U1,3 ; Leap year -- is it after Feb? ADDI U3,1 ; Yes, add extra day MOVEI U1,-1(U4) ; Adjust, and LSH U1,-2 ; Get # of leapyears since 1900, excl this yr IMULI U4,365. ; # years times 365 ADDI U4,(U1) ; plus # prior leapyears (extra days) ADDI U3,-1(U4) ; plus days so far this yr (-1 because day # POP P,U1 ; was 1-based) IFE UTMAC-U4, MOVE UTMAC,U2 ? POP P,U2 RET ] ;IFN OS%ITS ; Time-zone hacks ; For all three params below, LH=-1 when set (thus 0 val means ; var isn't initialized). Actual var is in RH. .SCALAR UTZLV ; Local timezone value .SCALAR UTZLSS ; Local STD timezone string (addr of ASCIZ) .SCALAR UTZLDS ; Local DST timezone string (addr of ASCIZ) ; UTZGET - Set up the above three parameters. UTZGET: PUSH P,U1 IFN OS%ITS,MOVEI U1,5 ; All ITS systems are in EST IFN OS%TNX,[ PUSHAE P,[2,3,4] SETO 2, SETZ 4, ODCNV LDB U1,[.BP IC%TMZ, 4] POPAE P,[4,3,2] ] HRROM U1,UTZLV ; Store local time-zone value MOVE U1,UTBZON(U1) ; Get ASCIZ strings for zone HLROM U1,UTZLSS ; Store STD string HRROM U1,UTZLDS ; Store DST string POP P,U1 RET DEFINE TZONE STD,DST [ASCIZ /STD/],,[ASCIZ /DST/] TERMIN UTBZON: TZONE GMT,GMT ; 0 How to ask for British Summer Time?? TZONE ; 1 TZONE ; 2 TZONE ; 3 (NST = Newfoundland is -0330) TZONE AST,ADT ; 4 Atlantic TZONE EST,EDT ; 5 Eastern TZONE CST,CDT ; 6 Central TZONE MST,MDT ; 7 Mountain TZONE PST,PDT ; 8 Pacific TZONE YST,YDT ; 9 Yukon TZONE HST,HDT ; 10 Alaska-Hawaii TZONE BST,BDT ; 11 Bering REPEAT 24.-11.,TZONE ; 12-24 unspecified ; Various tables ; Table for printing month, indexed by 1-12. UTBMON: 0 IRP M,,[January,February,March,April,May,June,July,August,September,October,November,December] .LENGTH "M",,[ASCIZ "M"] TERMIN ; Table for printing month, indexed by 1-12. UTBMO3: 0 IRP M,,[JAN,FEB,MAR,APR,MAY,JUN,JUL,AUG,SEP,OCT,NOV,DEC] 3,,[ASCIZ /M/] ; All strings length 3. TERMIN ; Tables for printing day-of-week, indexed by 0-6. ; Note TNX internal convention has 0 = Monday. ; Note also that Jan 1, 1900 (abs day 0) = Monday. ; Fooday included so masking low 3 bits of DOW value will always win. UTBDOW: IRP D,,[Monday,Tuesday,Wednesday,Thursday,Friday,Saturday,Sunday,Fooday] .LENGTH /D/,,[ASCIZ /D/] TERMIN UTBDO3: IRP D,,[MON,TUE,WED,THU,FRI,SAT,SUN,FOO] 3,,[ASCIZ /D/] ; All strings of length 3. TERMIN ] ;IFN $$OTIM .END ; End the OUT symbols block.