;;;-*-MIDAS-*- SUBTTL HAIRY LIST HANDLING UUO'S - description IFN 0,[ New List-area storage format: One list entity, or LSE, requires 3 separate UUO areas, termed the HDR, LA, and SA, for storage respectively of Header information, List structures, and Strings. The SA is simply an amorphous buffer for string storage, and the HDR contains various addressing and management information. (See "Contents of HDR".) List structures are composed of linked List Nodes, or LN's. $LNSIZ is an assembly parameter defining the # words per LN, currently 2; this is constant for ALL LN's, which can be of 3 types: value, list, and string. _______________________________________________ |Res |Data|Res | Attrib | | |srvd|type|srvd| type | CDR ---------|------> next LN (cdr=0 if last) | 0 | 7 | 0 | 777 | 777777 | |_____________________________________________| | | | Data Word | |_____________________________________________| The "Data type" field indicates which of these 3 types the LN is, and affects only the interpretation of the LN's data word. It can be considered syntactic information about the structure of the data, as opposed to the Attrib-type field which is a "name" for it and is purely semantic. The 3 types are defined below, one to a flag bit: ] ; LN type flags & field definitions %LTVAL==10000 ; data is a Value %LTLST==20000 ; data is a List-Pointer %LTSTR==40000 ; data is a String-Pointer %LTMSK==70000 ; mask for Data-type field. %LAMSK==777 ; mask for Attrib-type field. ; BP LH for Attribute field. $LAFLD==(.BP <%LAMSK,,0>,) $LTFLD==(.BP <%LTMSK,,0>,) $LNSIZ==2 ; LN's are 2 words. IFN 0,[ A "Value" type LN (VLN) simply treats the data word as 36 bits of data. For a List-Pointer LN (LLN), the data word is a List Pointer or LP which points to another list of LN's. For a String-Pointer LN (SLN), the data word is an string pointer (SPT) in ASCNT format, relative to the SA. That is, the LH contains a char count, and the RH is the relative address of the string in the SA area. This has the restriction that such strings must begin on a word boundary. LP's are, of course, relative to the beginning of the LA; this allows fast shifting and loading, at some expense in addressing time. The first LN in the LA (i.e. at LP address 0) is always zeroed, to prevent LP's of 0 from doing anything. Initialized and deleted LN's are kept on a Freelist, which will link all unused LN's as long as no trees are accidentally left dangling. ] ;PRINT VERSION NUMBER .TYO6 .IFNM1 .TYO 40 .TYO6 .IFNM2 PRINTX/ included in this assembly. / ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;;; ;;;;;;;; CONTENTS OF HDR: ;;;;;;;;; ;;;;;;;; HDR Area Definitions and initial Address-table ;;;;;;;;; UHDRDF: OFFSET -. ; So symbolic addresses are defined relative to beginning ; of HDR, starting at 0. $LHBEG::REPEAT 20,[%%IDX==.RPCNT REPEAT $LNSIZ, (%%IDX)+.RPCNT ] ; First of all comes addressing table for LA access. ; (See explanation, "LA Addressing") $LHLTB==.-$LHBEG ; This is resultant length of above table. $LHARP:: 0 ; Stores addr of ARBLK (ie ARPT) for this (HDR) area. $LLFRE:: 0 ; $LLLST:: 0 ; Main List pointer. $LLFRL:: 0 ; Freelist pointer. $LLFRC:: 0 ; Freelist count. <# free LN's> $LSFRE:: 0 ; = <# words used> $LSGC:: 0 ; <# of wds SA uses which are garbage> 0 ? 0 ? 0 ? 0 ? 0 ; Spare words for easier expansion. $LLAR:: BLOCK $ARSIZ ; LA ARBLK, with various auxiliary defs $LLLOC==$LLAR+$ARLOC ; abs location of LA $LLWPT==$LLAR+$ARWPT ; abs write ptr $LLRPT==$LLAR+$ARRPT ; abs read ptr $LLLEN==$LLAR+$ARLEN ; area length $LLCHL==$LLAR+$ARCHL ; # chs left to write in (if type %ARTCH) $LLTOP==$LLAR+$ARTOP ; area lastaddr+1 (loc+len) $LSAR:: BLOCK $ARSIZ ; SA ARBLK, exactly as for LA. $LSLOC==$LSAR+$ARLOC ; abs location of SA $LSWPT==$LSAR+$ARWPT ; etc. $LSRPT==$LSAR+$ARRPT $LSLEN==$LSAR+$ARLEN $LSCHL==$LSAR+$ARCHL $LSTOP==$LSAR+$ARTOP 0 ? 0 ? 0 ? 0 ; More spare words. ; Any other assembled HDR defs must come before $LHEND! $LHEND:: ; Highest used. Can expand HDR area dynamically above this. $LHSIZ:: ; Minimum size required for HDR area. OFFSET 0 ;Back to normal LOC IFN 0,[ LA Addressing: The REPEAT's at $LHBEG represent an addressing table for use with the LISTAR macro. To "directly" address a location in the LA, AC L must be loaded with the address of the HDR, i.e. the $ARLOC entry for that area. One can then reference anything in the HDR with constructs like ADD A,$LSLOC(L). However, to address a list structure, one must have the LP in a register (say C) and use MOVE A,LISTAR(C). The idea is to treat LISTAR as equivalent to the absolute address of the LA. What it actually expands to is @(L)+<$LNSIZ*C>. Thus, it indirectly addresses location $LNSIZ*C of the table, which contains (C)LADDR. The use of $LNSIZ*20 entries allows references such as LISTAR(C)+1, etc. to win, as long as the additional increment is less than $LNSIZ. (unfortunately due to macro difficulties one can't say the more usual LISTAR+1(C). ) ] ; Special macro to simulate start addr of current LA. ;note that one must say LISTAR(X)+1 instead of LISTAR+1(X), ;and an index reg must always be present! Better than ;nothing though. DEFINE LISTAR ?IDX @$LNSIZ*IDX(L)TERMIN IFN 0,[ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;; ;;;;;;;; ;;;;;;;; Disk Storage of LSE's ;;;;;;;; A list entity is stored on disk in a "List Block" of the following format. Any number of such List Blocks can be kept in a single file, since all information is relative to the LB or its internal HDR, LA, etc blocks. Since disk storage implies that formats must be adhered to in order to read previously written data, a version numbering scheme is included so that new versions can be introduced without destroying the ability to read data written in old formats. The point at which conversion takes place is in LSEIN, where the disk data is actually read; user routines should never have to know what the version number actually is. --------------------------------- 0: <# words in total blk> 1: 2: ,, 3: 4: <# wds in HDR blck> 5: <# wds in LA block> 6: <# wds in SA block> rel loc of HDR block: ; Immediately follows HDR ; " " LA -------------------------------- The contents of the HDR, LA, and SA blocks are exactly as they exist in core, and they can be written out directly. However, on readin some HDR-block parameters are of necessity reinitialized, such as the LA addressing table and the ARBLKs for the LA and SA. Those which are invariant and meaningful are: $LLFRE - rel addr of first free LA word $LSFRE - rel addr of first free SA word $LLFRL - Freelist pointer $LLFRC - Freelist count $LLLST - Main list pointer $LSGC - # of garbage words in SA The can be anything which belongs in the block somehow, and is meant to allow for easy addition of new features, but it must all fit within the block bounds as specified by word 0. ] ;end of IFN 0 SUBTTL LNCOPY - LN Copier. ; LNCOPY AC,[[addr of LSE] ? SETZ [lp]] ; General-purpose LN copier. The given LSE address (HDR loc) ; specifies the "X-LSE" which the LP points into, and the list ; pointed to is completely (CDR and all) copied into the L-LSE, with ; pointer left in AC. (Note: If the specified LSE's are in fact one ; and the same, "pure" strings are used for fast copying.) ; ; LNCOPY AC,[[addr of LSE] ? [lp]] ; Without the SETZ, acts just like above, but copies only the ; single LN pointed to, ignoring its CDR. UUODEF LNCOPY:,ULCOPY ULCOPY: MOVE U3,U40 ;get addr of 2-wd block SKIPE U4,(U3) ;get addr to LSE-address SKIPN U4,@U4 ;if addr and LSE-address both non-zero, get it. MOVE U4,L ;else use L. EXCH U4,L ; Reference X-LSE HRRZ U1,@1(U3) ; to get LP. CAML U1,$LLLEN(L) ; Check range JSR AUTPSY JUMPE U1,ULCOP1 ; Empty list IFSVU2, PUSH P,U2 MOVE U2,LISTAR(U1) ; And get first wd of LN. SKIPL 1(U3) ; Now if sign bit (SETZ) was set, that's it. HLLZS U2 ; else must flush CDR, for single-LN copy. MOVE U3,LISTAR(U1)+1 ; 2nd wd of LN. EXCH U4,L ; restore LSE pointers PUSHJ P,LNPOP ; Get a free LN to copy into. PUSH P,U1 ; and save LP, because ULCPY doesn't! PUSHJ P,ULCPY2 ; copy it. Special entry needed to allow single-LN hack. LDB U2,UACFLD POP P,(U2) ; restore LP to list directly into result AC. IFSVU2, POP P,U2 UUOXRT ULCOP1: LDB U1,UACFLD SETZM (U1) UUOXRT ; ULCPY - List Copier. Given LP in U1, copies and leaves new LP in U1. Thinks it is ; supposed to copy from X-LSE to L-LSE, specified by U4 and L ; respectively. If c(L) = c(U4) then string LN's are copied directly ; with no re-writing of the string. Clobbers everything but U4. ULCPY: MOVE U2,U1 PUSHJ P,LNPOP ; U1 = new LP, U2 = source X-LP PUSH P,U1 PUSHJ P,ULCPY1 POP P,U1 ; restore LP to new list. POPJ P, ; Workhorse for ULCPY. This routine takes LP in U1 to destination ; LN, LP in U2 to source LN for copying. Is able to iterate on ; CDR to copy list because it need not worry about saving U1, which ; is up to the caller! ULCPY1: PUSH P,U1 MOVE U1,U2 ; get X-LP out of U2. EXCH U4,L ;To read from X-LSE, put right thing in L. MOVE U2,LISTAR(U1) ;Get first wd of LN in X-LSE MOVE U3,LISTAR(U1)+1 ;and second. EXCH U4,L ;now restore LSE pointers. POP P,U1 ; restore new LP. ULCPY2: TLNE U2,%LTLST ;list? (note - entry pt for LNCOPY UUO.) JRST [ PUSHAE P,[U1,U2] HRRZ U1,U3 TRNE U1,-1 ; Skip if LP = 0 PUSHJ P,ULCPY ;recurse, copy list. MOVE U3,U1 ;get returned LP POPAE P,[U2,U1] JRST ULCPY6] ;and go store it as value. TLNE U2,%LTSTR JRST ULCPY8 ;if string, go to special rtn. ;consider it a value. ULCPY6: MOVEM U3,LISTAR(U1)+1 ;store value HLLZM U2,LISTAR(U1) ;store LH only (don't have CDR yet) TRNN U2,-1 ; If CDR non-existent, POPJ P, ; then all done! ; Iterate on CDR. MOVE U3,U1 ; Save new-LP temporarily PUSHJ P,LNPOP ; get LP to be its CDR HRRM U1,LISTAR(U3) ; and store CDR in the LN! JRST ULCPY1 ; U1 = new LP, U2 = source LP, go copy. ;copy string. auxiliary part of ULCPY. U2 and U3 have wds 1 & 2 ;of LN to be copied. U1 has LP to free LN to copy into. Copies ;string only if LSE's different, and puts new SPT in U3 as value. ;Mustn't clobber U1, U2, or U4! ULCPY8: CAMN L,U4 JRST ULCPY6 ;if LSE's same, just use same SPT. PUSHAE P,[U2] ;else must actually re-write string... ugh. MOVE U2,U3 ;get original SPT in better place HLRZ U3,U2 ;get char count. ADDI U3,4 PUSH P,U4 IDIVI U3,5 ;find # words necessary for string. POP P,U4 ADD U3,$LSFRE(L) ;get what will be new $LSFRE ptr. CAML U3,$LSLEN(L) ;compare new count with length of area, and JRST [ PUSHAE P,[U1,U3] SUB U3,$LSLEN(L) ;gobble more room if need be. Find how much MOVEM U3,ARUNIT ;and set up MOVEI U1,$LSAR(L) ; GIVE IT THE ARPT PUSHJ P,UABUMP ;and get the room. POPAE P,[U3,U1] JRST .+1] ADD U3,$LSLOC(L) ;get absolute end+1 for BLT. ADD U2,$LSLOC(U4) ;get abs source address for original SPT. PUSH P,U4 HRRZ U4,$LSFRE(L) ADD U4,$LSLOC(L) ;get abs destination address in RH. HRL U4,U2 ;and stuff abs source addr in LH. BLT U4,-1(U3) ;xfer the words! POP P,U4 SUB U3,$LSLOC(L) ;make end relative again EXCH U3,$LSFRE(L) ;and store as new first-free ptr (swap with old) HLL U3,U2 ;stuff char count in to form new SPT. POPAE P,[U2] JRST ULCPY6 ;done with string copy! SUBTTL List String Comparision UUO's - SLNE, SLNEA, USLNE, USLNEA ; SLNE AC,[slp] AC must also hold a SLP (LP to a string LN). ; 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 LN is not string type. ; USLNE AC,[slp] same, but forces both to upper case during compare. ; SLNEA AC,[ASCNT [string]] ; USLNEA AC,[ASCNT [string]] See below. UUODEF SLNE:,UQSTRE UUODEF USLNE:,UQUSTR LVAR UQSTRF: 0 ; Flag set when comparing with uppercase force. LVAR UQSTRC: 0 ; cnt to loop on 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 IFSVU2, PUSH P,U2 MOVE U2,@U40 ;get addr = ptr MOVE U3,LISTAR(U1) MOVE U4,LISTAR(U2) TLNN U3,%LTSTR ;be sure type is string JRST UQSTR9 ;lose TLNN U4,%LTSTR JRST UQSTR9 ;ditto MOVE U3,LISTAR(U1)+1 ;get string vals (# cnt,,addr) MOVE U4,LISTAR(U2)+1 ADD U3,$LSLOC(L) ;make abs. ADD U4,$LSLOC(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 XORI U1,(U2) ; Get XOR of the chars... CAIE U1,40 ; Same char but different case? JRST UQSTR9 ; Definitely not same char. CAIL U2,"A ; Aha, win if one char is A-Z or a-z. CAILE U2,"z ; First test for A-z. JRST UQSTR9 ; Outside range, so no case folding. CAIG U2,"Z ; Within A-z, is it inside A-Z? JRST UQSTR5 ; Yes, win! CAIL U2,"a ; Hmm, within a-z? JRST UQSTR5 ; Yes, win! ; Bah, between Z-a! Fall thru to fail. UQSTR9: IFSVU2, POP P,U2 UUOXRT ;return w/o skipping UQSTR7: IFSVU2, POP P,U2 AOS UUORPC UUOXRT ; won, skip ; SLNEA AC,[ASCNT [string]] AC must contain a SLP, as for (U)SLNE; ; however, comparision is done with the specified string. The advantage ; is that a template string need not be stored in a list-area. ; USLNEA AC,[ASCNT [string]] Same, but uppercase compare. UUODEF SLNEA:,ULSTR UUODEF USLNEA:,ULUSTR ULSTR: SETZM UQSTRF CAIA ULUSTR: SETOM UQSTRF ;uppercase compare LDB U1,UACFLD MOVE U1,(U1) ;get ptr IFSVU2, PUSH P,U2 MOVE U2,LISTAR(U1) TLNN U2,%LTSTR ; String type? JRST UQSTR9 ; No, fail. MOVE U3,LISTAR(U1)+1 ;get stringval ADD U3,$LSLOC(L) ;make abs MOVE U4,@U40 ;get literal stringval(already abs) JRST UQSTR4 ;jump into normal routine. SUBTTL Wonderful Super LN-Creation UUO - MAKELN !! ; MAKELN AC,[ ,,[[list-ptr]] Make a LN according to args, ; ,,[[LN-value]]] and leave LP 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. ; - an arbitrary value to be put into the ATTRIB field of the LN. ; list-ptr - will be inserted in RH of the LN, i.e. what list-ptr points to ; becomes the CDR of that LN. ; - tells the routine what type of LN it is (value, list, string) and ; how to gobble the given LN-value. The defined types are: ; %LTVAL - type VAL, stores LN-val as the value of LN (2nd word). ; %LTLST - type LIST, stores LN-val as a ptr to a list. ; %LTSTR - type STRING, takes LN-val as being ASCNT /string/ and stores. ; %LTBPT - type STRING, takes LN-val as <# chars>,,[b.p. to string] ; %LTSAR - type STRING, takes LN-val as an ARPT and forms a LN string ; value from the text in that area. ; %LTSAO - type STRING, makes string of everything accumulated on ; regular output UUO's since a SAOBEG. If a ; non-zero value is furnished, it is interpreted ; as an instruction to XCT, and the resulting ; output is used for the string; no SAOBEG is needed. ; Output must be on the "standard output"; the OUT ; package must be used. %LTBPT==1 ; This flag is for MAKELN only. (see above) %LTSAR==2 ; Ditto. %LTSAO==4 ; Ditto. ; The right thing is done when various fields are left zero, e.g. saying ; MAKELN A,[A$RHST,,0 is legal and produces a VAL-type LN with attribute of ; %LTVAL,,0] A$RHST. Its CDR is 0 and its value is 0, because ; neither arg is accessible. UUODEF MAKELN,UMAKEL UMAKEL: MOVE U4,U40 IFSVU2, PUSH P,U2 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,%LTSTR+%LTBPT+%LTSAR+%LTSAO ;skip if type is string JRST USTOQ7 ;isn't string. store value/list TLZ U3,%LTMSK ;clear all type bits TLO U3,%LTSTR ;force type to string EXCH U3,U4 ;save 1st wd in u4 TLNE U3,%LTSAO ;type store accumulated SA output? JRST USTOQ3 TLNE U3,%LTBPT ;is type=byte ptr to string? JRST [ MOVE U3,(U2) JRST USTOQ5] ;yes, get the byte ptr TLNE U3,%LTSAR ;type = string area? JRST [ MOVE U3,$ARLOC(U2) ;U2 has ARPT. Get abs location of area HRLI U3,440700 PUSH P,U1 MOVE U1,$ARWPT(U2) ; Get write ptr, SUBI U1,(U3) ; Make it relative to beg, MULI U1,5 ; and do bp hack ADD U2,UADBP7(U1) ; to get char count in U2. POP P,U1 JRST USTOQ6] HRRZ U3,U2 ;no, just form a 440700,,addr HRLI U3,440700 USTOQ5: HLRZ U2,U2 ;count in rh USTOQ6: MOVEM U3,OUT"UBMPSP ;kludgery necessary to ensure ptr correct PUSHJ P,LNPOP ;even if LNPOP bumps areas. get ptr in U1 to free LN. HRLZ U3,U2 ;form SPT beforehand... get count HRR U3,$LSFRE(L) ;and rel addr. PUSH P,U3 ;and save SPT. MOVE U3,OUT"UBMPSP ;restore source BP. PUSHJ P,USSTRG ;do it POP P,LISTAR(U1)+1 ;Done, now store SPT computed previously, MOVEM U4,LISTAR(U1) ;and finally 1st wd of LN. JRST USTOQ9 ;last thing to do: return LP in AC. USTOQ7: HLLZ U4,U4 ;get type,,0 IOR U3,U4 ;put type flag into 1st LN lh PUSHJ P,LNPOP ;if not, get one. MOVEM U3,LISTAR(U1) ;store 1st LN wd MOVEM U2,LISTAR(U1)+1 ;store 2nd USTOQ9: LDB U2,UACFLD ;get # acc (again) MOVEM U1,(U2) ;return ptr in it. IFSVU2, POP P,U2 UUOXRT ; Make SLN of stuff between $LSFRE addr and $LSWPT write pointer. ; (i.e. it's already been output there) ; U4 contains word to store in 1st wd of LN, otherwise everything ; clobberable. USTOQ3: IFN $$OUT,[ JUMPE U2,USTOQ4 ; If no value given, assume closing-up. ; Special hack! Value given for %LTSAO is instruction to XCT. ; It should output on the standard output channel... ; Could reference SAOCH if necessary, but should be avoided. IFE $$UCAL,PUSH P,UUORPC PUSHAE P,[U40,OC,U4,U2] ; Note U2 last!! Don't need U1,U3. OUT(,CH(SAOCH),OPEN(UC$SAO)) ; Open SAOCH, make std output. XCT (P) ; Execute the frob! Might be UUO. POPAE P,[U2,U4,OC,U40] IFE $$UCAL,POP P,UUORPC ; Then drop through to finalize! USTOQ4: ] MOVE U1,$LSWPT(L) ; Get write ptr SUB U1,$LSLOC(L) ; Make rel to start of SA MOVE U3,$LSFRE(L) ; Get rel addr of start of free stuff, SUBI U1,(U3) ; and BP rel to this. MULI U1,5 ; Now do BP hack ADD U2,UADBP7(U1) ; to get # chars used. HRL U2,U3 ; Now use it to make reversed SPT PUSHJ P,LNPOP ; Get a free LN, MOVEM U4,LISTAR(U1) ; and store 1st and MOVSM U2,LISTAR(U1)+1 ; 2nd words in it. (Note halves swapped!) MOVEI U2,4(U2) ; Now get # chars + 4 IDIVI U2,5 ; Find # wds used, ADDB U2,$LSFRE(L) ; and bump addr of first free loc. SUB U2,$LSLEN(L) ; Make sure we didn't overrun anything - CAILE U2,0 ; (note this gives neg of # wds free) JSR AUTPSY ; First free greater than length means illegal loc writ! IMULI U2,5 MOVEM U2,$LSCHL(L) ;store new -cnt of chars left. JRST USTOQ9 ;done ; USSTRG - auxiliary rtn for MAKELN. given ;LN ptr in U1, chr cnt in U2, byte ptr in U3, does the actual ;write of string into SA. Clobbers U2, U3. USSTRG: JUMPE U2,APOPJ PUSHAE P,[U1,U4] MOVEM U3,OUT"UBMPSP ;store BP in convenient place for auto-adjust. MOVE U4,U2 ;and store cnt in AC out of way. ADDI U2,4 IDIVI U2,5 ;find # words string will need. PUSH P,U2 ;save ADD U2,$LSFRE(L) ;add current relative write addr. SUB U2,$LSLEN(L) ;check bounds by subtracting area length. JUMPGE U2,[MOVEM U2,ARUNIT ;oops! need more core! Indicate this much. MOVEI U1,$LSAR(L) ;and give ARPT to string area. PUSHJ P,UABUMP ;get um. JRST .+1] MOVE U3,OUT"UBMPSP ;restore (possibly bumped) BP. MOVE U2,$LSFRE(L) ADD U2,$LSLOC(L) ;get abs ptr to start. HRLI U2,440700 ;make BP. ILDB U1,U3 ;get char IDPB U1,U2 ;dep. SOJG U4,.-2 ;fast. POP P,U2 ;get back # wds newly occupied. ADDM U2,$LSFRE(L) ;and cnt of wds used. POPAE P,[U4,U1] ;return POPJ P, ; SAOBEG CH, - Initializes for standard UUO output into SA area, ; given channel # output will occur on. The %LTSAO type ; bit in MAKELN will form a string LN of accumulated output. ; Sets OC to CH as current channel. UUODFA SAOBEG,USABG USABG: MOVE U1,$LSFRE(L) ADD U1,$LSLOC(L) ;get abs start addr HRLI U1,440700 ;form BP MOVEM U1,$LSWPT(L) ;and set up new write ptr for area. HRRZS U1 SUB U1,$LSTOP(L) ;get -<# wds left> IMULI U1,5 MOVEM U1,$LSCHL(L) ;store as $ARCHL for SA. ;; LDB U2,UACFLD ;now ready to open indicated channel. Get it. ;; MOVE U1,[OUTOPN [$UCUAR,,$LSAR(L)]] ;get instr with right args. ;; DPB U2,[$ACFLD,,U1] ;;IFE $$UCAL,PUSH P,UUORPC ; Save return addr, since using UUO within UUO! ;; XCT U1 ; Do the OUTOPN! ;;IFE $$UCAL,POP P,UUORPC LDB U1,UACFLD ; Get channel # OUT(,CH((U1)),OPEN(UC$UAR,$LSAR(L))) ; Open channel into area UUOXRT ; Return SUBTTL List Searching UUO's - FINDA and FINDAL ; FINDA AC,[,,[[list-ptr]]] ; Searches list pointed to by list-ptr for a LN containing the ; given attribute type, and if one is found immediately skips with ptr ; to it in AC. Else doesn't skip and AC is meaningless. ; FINDA AC,[%HSIGN ,,[[list-ptr]] ; []] ; As a special case, this form will search for the attribute type ; which has a string-value matching (exactly) the given string. LN's ; which have the right attrib type but wrong data type (non-string) ; will obviously not match. UUODEF FINDA:,UFINDA UFINDA: SKIPGE U3,@U40 ; Get c(e)= $attr,,[loc] JRST UFNDA3 ; If sign bit set, hack special string-search. HRRZ U1,@(U3) ; Get c(loc)=ptr to first node CAML U1,$LLLEN(L) ; Check validity JSR AUTPSY HLRZ U3,U3 ; Put attrib in rh JUMPE U1,UUORTL ; Now enter loop, unless first pointer zero! IFSVU2, PUSH P,U2 UFNDA0: LDB U2,[$LAFLD,,LISTAR(U1)] ; Get attrib of LN pointed to CAIN U2,(U3) ; Equal to one we want? JRST UFNDA9 ; Yes, jump out. UFNDA1: HRRZ U1,LISTAR(U1) ; No, get CDR and continue, JUMPN U1,UFNDA0 ; as long as list still exists. IFSVU2, POP P,U2 UUOXRT ; Sigh, never found. ; Sign bit is set, search for attrib with matching string. UFNDA3: HRRZ U1,@(U3) ; Get c(Loc) = LP to first node JUMPE U1,UUORTL ; Stop right here if first pointer zero... HLRZS U3 ; Get attrib type into RH TRZ U3,%HSIGN ; Ensuring that the sign bit is cleared! MOVE U4,U40 IFSVU2, PUSH P,U2 PUSH P,@1(U4) ; Get ASCNT ptr to string, onto stack. UFNDA4: LDB U2,[$LAFLD,,LISTAR(U1)] ;get attrib of LN pointed to CAIN U2,(U3) ; equal to one we want? JRST UFNDA6 ; Yes, jump out. UFNDA5: HRRZ U1,LISTAR(U1) ; No, get CDR and continue, JUMPN U1,UFNDA4 ; as long as list still exists. SUB P,[1,,1] IFSVU2, POP P,U2 UUOXRT ; Sigh, never found. ; Found right attrib, now see if string matches... UFNDA6: MOVE U2,LISTAR(U1) ; Get word for testing... TLNN U2,%LTSTR ; Skip if string, JRST UFNDA5 ; else obviously not a match. HLRZ U2,LISTAR(U1)+1 ; Get cnt of SPT for attrib name. HLRZ U4,(P) ; and cnt for string being sought. CAME U2,U4 ; String lengths equal? JRST UFNDA5 ; Nope, keep looking. MOVE U2,LISTAR(U1)+1 ; Aha, counts equal, test contents. Get whole SPT ADD U2,$LSLOC(L) ; Make absolute MOVE U4,(P) ; Get whole ascnt ptr for test string. PUSH P,U3 UFNDA7: JUMPL U4,UFNDA8 ; See if any left to test. TLNN U4,-1 ; Check both neg. and 0 JRST UFNDA8 ; and jump if all done... MOVE U3,(U2) ; get a word to test CAME U3,(U4) ; Match against template string. JRST [ POP P,U3 ; No match. JRST UFNDA5] ADD U4,[-5,,1] ; Else bump down char cnt and increment index. AOJA U2,UFNDA7 ; and get another word. ; Aha, found right attrib with matching string! UFNDA8: SUB P,[2,,2] ; Flush both saved U3 and ASCNT template. ; Found attrib. UFNDA9: LDB U2,UACFLD ; Get result acc MOVEM U1,(U2) ; Store ptr. IFSVU2, POP P,U2 AOS UUORPC ; Skip on return UUOXRT DEFINE FNDSTR AC,PTRLOC,ATTRIB,STRING FINDA AC,[%HSIGN+ATTRIB,,[PTRLOC] LITSTR [STRING]] TERMIN IFN 0,[ ; FINDAL AC,[,,[[list-ptr]]] ; Like FINDA above, but searches through the entire tree pointed to. UUODEF FINDAL,UFNDAL UFNDAL: MOVE U4,@U40 ;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 UFNRT' ;clear loc where result stored PUSHJ P,UFND ;get um recursively. SKIPG U1,UFNRT ;get result into u1 if found UUOXRT ;no. blah. LDB U2,UACFLD ;aha! must store MOVEM U1,(U2) ;in uuo acc AOS UUORPC ;and skip UUOXRT UFND: TRNN U1,-1 ;skip unless rh=0 POPJ P, MOVE U3,LISTAR(U1) LDB U2,[$LAFLD,,U3] ;get attrib of LN pointed to CAIN U2,(U4) ;equal to one we want? JRST [ HRRZM U1,UFNRT POPJ P,] ;if so, store tr and return TLNN U3,%LTLST ;still hope if list JRST [ HRRZ U1,U3 JRST UFND] ;nope PUSH P,U3 HRRZ U1,LISTAR(U1)+1 ;get ptr to list PUSHJ P,UFND POP P,U3 SKIPLE UFNRT ;skip unless found something POPJ P, ;if found, return HRRZ U1,U3 ;nope, try cdr. JRST UFND ] SUBTTL Randomness - LNAPP, OUTLS, NREVERSE ; LNAPP [[list-lp A] ? [list-lp-B]] ; Appends the list B points to onto the end of the list A points to. ; Simply stuffs list-lp-B in as the CDR of the last item in list A. UUODFE LNAPP:,UAPND UAPND: MOVE U4,U40 ; Get addr of 2-wd arg block HRRZ U3,@(U4) ; Get LP to base list (appended to) HRRZ U1,@1(U4) ; Get LP to list being appended. CAMGE U1,$LLLEN(L) ; Check both CAML U3,$LLLEN(L) JSR AUTPSY JUMPE U3,[HRRM U1,@(U4) ; If nil base list, store LP B in place UUOXRT] ; LP A would occupy. UAPND1: MOVEI U4,(U3) ; Loop to find end of list A. HRRZ U3,LISTAR(U4) JUMPN U3,UAPND1 HRRM U1,LISTAR(U4) ; Found end, smash CDR to point at list B. UUOXRT ; NREVERSE LP, Reverses the LNs in the list by bashing the CDR ; pointers, and returns the LP to the thus reversed ; list in AC. Analogous to the LISP function, of course. UUODFA NREVERSE:,UNREV UNREV: IFSVU2, LDB U1,UACFLD ? SKIPN U1,(U1) ; Get our argument, an LP. .ELSE LDB U2,UACFLD ? SKIPN U1,(U2) UUOXRT ; If nothing there, just ignore. HRRZ U3,LISTAR(U1) ; Initialize the loop HLLZS LISTAR(U1) ; Special case: zero out this CDR. UNREV1: HRRZ U4,LISTAR(U3) ; Loop, in which U1 is an LP to a HRRM U1,LISTAR(U3) ; LN in the list, and U3 an LP MOVE U1,U3 ; to the immediately next node. SKIPE U3,U4 ; If that was zero, all done. JRST UNREV1 IFSVU2, LDB U3,UACFLD ? MOVEM U1,(U3) .ELSE MOVEM U1,(U2) ; Store back result in the AC. UUOXRT SUBTTL Free-list Manipulation Primitives - LNPOP and friends. ; LNPOP - called when want a free LN from list area. ;Returns ptr in U1 to a free LN. LNPOP: SKIPG U1,$LLFRL(L) ; Get LP to a free LN. JRST LNPOP2 ; none there? Must get new freelist. SOSGE $LLFRC(L) ; Got one, bump count down... JSR AUTPSY ; and fulfill its sole purpose in life. MOVE U1,LISTAR(U1) ; Won. Get CDR to next free LN EXCH U1,$LLFRL(L) ; and make it new freelist ptr. RET ; Return previous ptr to free LN. ; Freelist ptr is nil, must create more free LN's. LNPOP2: SKIPE $LLFRC(L) ; Consistency check... JSR AUTPSY ; count should have zeroed out!! MOVE U1,$LLFRE(L) ; Get # wds actually used in LA area. SUB U1,$LLLEN(L) ; Subtract total length, to get -# wds avail. ADDI U1,100*$LNSIZ ; Gobble at least 100 new ones at a time. CAIG U1,0 ; If need to get more core, skip. JRST LNPOP3 ; Else needn't expand, just use extra room. MOVEM U1,ARUNIT MOVEI U1,$LLAR(L) ; Set up ARPT for UABUMP. PUSHJ P,UABUMP ; Expand LA. LNPOP3: SETZM $LLFRL(L) ; Make SURE current freelist is nil. PUSHJ P,LNINIT ; Now munch extra core onto freelist! SKIPN $LLFRL(L) ; Make sure something now on freelist. JSR AUTPSY ; Ugh?? CALRET LNPOP ; Now go back and get a LN. ; LNINIT - looks at "extra" core between $LLFRE and actual end of LA area, ; and makes freelist LN's out of it. Updates $LLFRE, $LLFRL, and $LLFRC. LNINIT: PUSHAE P,[U1,U2,U3] MOVE U1,$LLLEN(L) ; Get total # wds in area, MOVE U3,$LLFRE(L) ; and rel addr of 1st free wd in area. SUB U1,U3 ; Find # wds extra by subtracting # used. IDIVI U1,$LNSIZ ; Get # LN's possible within this space. JUMPE U1,LNINI9 ; If can't snarf any, quit immediately. ADDM U1,$LLFRC(L) ; Can make some! Update count now. MOVNS U1 HRLZS U1 ; Make AOBJN of HRRI U1,(U3) ; -<# LN's to make>,, LNINI1: MOVEI U2,$LNSIZ(U1) ; Get ptr to next LN MOVEM U2,LISTAR(U1) ; Insert ptr in current LN ADDI U1,$LNSIZ-1 ; Bump ptr AOBJN U1,LNINI1 HRRZM U1,$LLFRE(L) ; First unused LP => first unused addr. SUBI U1,$LNSIZ ; Point to last LN MOVE U2,$LLFRL(L) ; Get current freelist ptr HRRZM U2,LISTAR(U1) ; Store its ptr in last LN of new list. MOVEM U3,$LLFRL(L) ; And set freelist ptr to 1st new LN. LNINI9: POPAE P,[U3,U2,U1] POPJ P, SUBTTL More Freelist manipulators - LNDEL UUO, LNFREE ; LNDEL AC,[] ; There are 3 cases depending on presence or absence of AC and E. ; When either is present, their contents must be LP's; the general ; semantics are that AC indicates a single LN for the flushing ; operation, whereas c(E) indicates a list. ; ; (0) LNDEL - Error. ; (1) LNDEL AC, - The indicated LN only is flushed (not its CDR). ; (2) LNDEL [] - As above, but CDR is flushed also, hence ; this is "list-flush". ; (3) LNDEL AC,[] - Only LN indicated by AC is flushed from list ; indicated by c(E). It is a fatal error if ; the LN is not in fact found on the list! ; ; Whenever E is specified, the LP to resulting list is stored back in ; c(E). Since for case 3 the LP pointing to deleted LN is changed to ; point to the next LN, c(E) will be modified if c(E)=c(AC). ; Case 2 will clear c(E). UUODEF LNDEL:,ULNDEL ULNDEL: MOVE U3,U40 ; Get instruction IFSVU2, PUSH P,U2 LDB U2,[$ACFLD,,U3] ; Get AC # JUMPE U2,[TRNN U3,-1 ; If no AC, make sure E exists. JSR AUTPSY ; It doesn't?? HRRZ U1,(U3) ; It does, get LP to start of list, HLLZS (U3) ; zap RH of c(E) before actually flushing, and PUSHJ P,LNFREE ; Flush it, IFSVU2, POP P,U2 UUOXRT] ; and return. HRRZ U1,(U2) ; Get c(AC) TRNN U3,-1 ; Is E = 0? JRST ULNDL8 ; If so, go flush only this LN. MOVE U2,(U3) ; No, get c(E) = LP to first node of list LN is on. CAIN U1,(U2) ; Special first test... LPs same? JRST [ MOVE U2,LISTAR(U2) ; Yes! replace c(E) by CDR of doomed LN. HRRM U2,(U3) ; Like so. JRST ULNDL8] ; And go flush doomed LN. ULNDL4: MOVE U3,U2 ; Search list. Save LP to previous LN. MOVE U2,LISTAR(U3) ; Get LP to next LN. TRNN U2,-1 ; If it's 0, JSR AUTPSY ; then the LN wasn't on the list!! Lose. CAIE U1,(U2) ; This it? JRST ULNDL4 ; No, continue search. MOVE U2,LISTAR(U2) ; Aha, found it! Get CDR of doomed LN, HRRM U2,LISTAR(U3) ; and put it in previous LN. ULNDL8: HLLZS LISTAR(U1) ; Now kill LN's CDR to isolate it. PUSHJ P,LNFREE ; And delete it. IFSVU2, POP P,U2 UUOXRT ; LNFREE - hairy routine to track down everything pointed to by ; a LN and flush it into freelist. ; Takes ptr in U1 to first node; LH must be zero! ; Clobbers U1, U2, U3. LNFREE: JUMPE U1,[POPJ P,] ; Do nothing if LP = 0. LNFRE1: CAML U1,$LLLEN(L) ; Safety check to make sure LP within bounds. JSR AUTPSY MOVE U2,LISTAR(U1) ; Get 1st wd of LN (CDR in RH) TLNN U2,%LTLST ; Is data a list? JRST LNFRE5 ; No, continue ; Flush list PUSH P,U1 HRRZ U1,LISTAR(U1)+1 ; Put list ptr in as arg PUSHJ P,LNFREE ; to a recursion! POP P,U1 JRST LNFRE8 ; Now go flush node like a value. LNFRE5: TLNN U2,%LTSTR ; Data a string? JRST LNFRE8 ; No, must be Value. ; String...bleah HLRZ U2,LISTAR(U1)+1 ; Get char cnt ADDI U2,4 IDIVI U2,5 ; Get # wds being flushed. ADDM U2,$LSGC(L) ; Add to # wds garbage in string area. ; Value. flush current LN and go after its CDR LNFRE8: MOVE U2,$LLFRL(L) ; Get freelist ptr EXCH U2,LISTAR(U1) ; Cons LN on freelist by making CDR = old list HRRZM U1,$LLFRL(L) ; and pointing freelist at freed LN. AOS $LLFRC(L) ; Increment cnt of # free for checking. SETZM LISTAR(U1)+1 ; Zap data wd just for neatness. TRNN U2,-1 ; Now see if anything in old CDR... POPJ P, ; Nope, can return! MOVEI U1,(U2) ; Else must put into U1 JRST LNFRE1 ; and go flush it. SUBTTL LSEGC - LSE garbage collection (compactor) ; There are several possible screws one can hit while trying to ; GC a LSE. At the moment, this code assumes that there is ; only one well-ordered list in the LSE, which $LLLST points to, ; and that there are no "pure strings". ; "Well-ordered" means no circular lists and only one pointer ; to any single LN. ; One feature is that the entire HDR is copied except for those ; parameters which are address dependent. This preserves any ; idiosyncratic HDR info. ; L - Specifies LSE to compact. ; On return, L will address new LSE. The ARBLK which LSE is based in ; will likewise be updated. LSGEC: PUSHAE P,[A,B,C] SKIPE C,$LHARP(L) ; Get ARPT pointing at this LSE. SKIPN $AROPN(C) ; Who knows? Just in case. JSR AUTPSY MOVEI A,LGCAR CALL LSEOPN ; Create a minimal LSE. ; Now copy extra HDR words over... MOVE B,$ARLEN(C) ; Find length of source HDR SUBI B,$LHSIZ ; Find how many extra wds CAIGE B, JSR AUTPSY ; Must not be less! JUMPG B,[UAREXP B,LGCAR ; Expand by additional # of wds. HRLZ A,$ARLOC(C) HRR A,$ARLOC+LGCAR ; Get ,, ADD A,[$LHSIZ,,$LHSIZ] ADDI B,(A) ; Get last addr+1 BLT A,-1(B) ; Move the extra stuff. JRST .+1] ; Now simply copy the whole thing... MOVE B,L ; Save LSE pointer MOVE L,$ARLOC+LGCAR ; and make new LSE current. LNCOPY B,[B ? SETZ $LLLST(L)] ; Copy whole list! MOVEM B,$LLLST(L) ; Store LP as pointer to whole list in new LSE. ; Now move new LSE HDR ARBLK stuff into old ARBLK. UARPUSH LGCAR ; Push LSE on stack UARPOP (C) ; Pop back to final location, closing old LSE! POPAE P,[C,B,A] RET LVAR LGCAR: BLOCK $ARSIZ SUBTTL LSEOPN, LSEIN, LSEOUT - Initialization and I/O rtns for LSE's. ; LSEOPX - Create a fresh LSE ; A - ARPT to use for HDR area. MOVE L,$ARLOC(A) will make LSE current. ; B - address of a 3-wd block, specifying initial sizes for LSE. ; B -> [size for HDR] ? [size for LA] ? [size for SA] ; Addrs can be any ACs except A or B. ; LSEOPN - As above, but B is defaulted to minimums. .SCALAR LSESZS(3) ; Temps for area sizes LSESZD: $LHSIZ ? 100 ? 100 ; Default sizes. LSEOPN: PUSH P,B SETZ B, CALL LSEOPX PJRST POPBJ LSEOPX: PUSHAE P,[L,A] ; ARPT is (P) CAIN B, MOVEI B,[0 ? 0 ? 0] ; Use defaults. PUSH P,B MOVSI A,-3 LSEOP3: SKIPE B,(B) ; Get addr of HDR size MOVE B,@B ; Get size for HDR CAMGE B,LSESZD(A) MOVE B,LSESZD(A) ; Force above minimal value. MOVEM B,LSESZS(A) AOS B,(P) AOBJN A,LSEOP3 POP P,B MOVE A,(P) UAROPN [%ARTLH,,(A) ; Open HDR area, using ARPT in A. LSESZS+0] ; Flag indicates HDR. MOVE L,$ARLOC(A) ; Set up address. HRRZM A,$LHARP(L) ; Now store HDR's ARPT in HDR itself! MOVE A,L HRLI A,UHDRDF ; Set up BLT ptr from initial HDR block BLT A,(L)$LHEND-1 ; to created one, and zap things up! ; Initialize LA. UAROPN [%ARTLA,,$LLAR(L) ; ARPT is in HDR... flag says LA-type, LSESZS+1] ; causing initialization of LA address table. ; OK, can now access LA! MOVSI A,-$LNSIZ SETZM LISTAR(A) ; Set first LN to 0. AOBJN A,.-1 MOVEI A,$LNSIZ MOVEM A,$LLFRE(L) ; Indicate first LN is "used". PUSHJ P,LNINIT ; Init freelist starting right after zero'd LN. ; Now initialize SA. UAROPN [%ARTZM+%ARTCH,,$LSAR(L) ; Open SA, ARBLK is in HDR too. LSESZS+2] POPAE P,[A,L] POPJ P, ; All done! ; Disk-Block (DB) index definitions BVAR ULSDBH: OFFSET -. ; Buffer for reading in disk-block header. DB$LEN::0 ; DB length DB$ID:: 0 ; DB identifier (SIXBIT) DB$VER::0 ; DB flags,,version DB$HLC::0 ; Loc of HDR relative to start of DB (DB$LEN) DB$HDR::0 ; # wds in HDR block DB$LA:: 0 ; # wds in LA block DB$SA:: 0 ; # wds in SA block DB$SIZ:: ; Size of a disk-block header. OFFSET 0 EVAR ULSEID: SIXBIT /LSEID0/ ; LSE ID word contents. DB$V1==:1 ; Version 1 symbol. ; LSEIN - Routine taking ARPT in A, .ACCESS pointer in B on opened ; DKIC channel. Reads in a LSE from specified point in ; file, using given ARBLK for the HDR area. If B negative, ; reads from current point on DKIC. ; Skips unless IOC error or bad format. LSEIN: PUSHAE P,[A,B,C,D,L] JUMPL B,[SYSCAL RFPNTR,[CIMM DKIC ? CRET B] ; if B neg, find current ptr. JSR AUTPSY JRST LSEIN0] .ACCESS DKIC,B ; If B specified, set ACCESS ptr to it. LSEIN0: MOVEM B,ULSIPT ; Save initial .ACCESS ptr. MOVE C,[-DB$SIZ,,ULSDBH] XCTIOC [.IOT DKIC,C] ; Get disk header of DB into ULSDBH. JRST LSEIN9 ; Jump if lost MOVE D,ULSEID CAMN D,ULSDBH+DB$ID ; Does DB have right identifier? JRST LSEI20 ; Yes, go handle normal case. JRST LSEIN9 ; No ID word, must be garbaged IFN 0,[ ; No ID word. For now, assume old-style format. MOVE D,ULSDBH+1 ; Get <# wds in HDR>,, PUSH P,ULSDBH+2 ; Get <# wds in LA> PUSH P,ULSDBH+3 ; Get <# wds in SA> HRRZM D,ULSDBH+DB$HLC ; Store stuff in right places. HLRZM D,ULSDBH+DB$HDR POP P,ULSDBH+DB$SA POP P,ULSDBH+DB$LA SETZM ULSDBH+DB$VER ; Zero out version # and flags. JRST LSEI22 ; Skip over version # check. ]; end IFN 0 ; Do normal-style new format readin. LSEI20: HRRZ D,ULSDBH+DB$VER ; Get version # CAIE D,DB$V1 ; V1 is only thing we hack now. JRST LSEIN9 ; Lost badly. LSEI22: ADD B,ULSDBH+DB$HLC ; Find absolute disk addr of HDR block. .ACCESS DKIC,B ; Point there. MOVE C,ULSDBH+DB$HDR ; Get size of HDR block. UAROPN [%ARTLH,,(A) ? C] ; Open HDR area with that size. IMUL C,[-1,,0] ; Now set up block mode pointer... HRR C,$ARLOC(A) ; Addr to snarf into. XCTIOC [.IOT DKIC,C] ; Get HDR JRST LSEIN9 ; Jump if lost. MOVE L,$ARLOC(A) ; Get beg addr again, to set up L index SKIPE ULSDBH+DB$VER ; Hacking old-format? JRST LSEI30 ; No, can continue normally. ; Must convert old-fmt HDR to new. Just push everything that ; needs preserving, and pop back to right places. Note that ; push/pop lists are reversed relative to each other. HLRZ C,53(L) ; Get cnt from old $LLFRL = <#>,, HRRZ D,53(L) ; Get LP PUSHAE P,[C,D,52(L),54(L),66(L),67(L)] ; Save old stuffs. MOVEI D,$LHEND-70 ; Find # wds must expand by. UAREXP D,(A) ; Expand the HDR area; may bump. MOVE L,$ARLOC(A) ; Make sure L points to right place. MOVE D,$ARTOP(A) ; Find addr of last wd + 1 HRROI C,-<1+$LHEND-70>(D) ; Set up a "PDL ptr" to last data wd. SUBI D,$LHEND(L) ; Get # wds to move. POP C,<$LHEND-70>(C) ; Move to end of HDR area, SOJG D,.-1 ; until all non-assembled stuff gone. POPAE P,[$LSGC(L),$LSFRE(L),$LLLST(L),$LLFRE(L),$LLFRL(L),$LLFRC(L)] LSEI30: MOVEM A,$LHARP(L) ; and store ARPT within HDR. SETZM $LLAR(L)+$AROPN ; Clear "OPEN" flags for LA and SA ARBLKs, SETZM $LSAR(L)+$AROPN ; to avoid attempt by UAROPN to "close" them! UAROPN [%ARTLA,,$LLAR(L) ; Open LA area (Note size). ULSDBH+DB$LA] ; This inits all LA addressing info too. MOVN C,ULSDBH+DB$LA HRLZS C HRR C,$LLLOC(L) ; Set up block mode ptr -,, XCTIOC [.IOT DKIC,C] ; (LA immediately follows HDR) JRST LSEIN9 ; Jump if lost. UAROPN [%ARTZM+%ARTCH,,$LSAR(L) ; Open SA area, as for LA. ULSDBH+DB$SA] MOVN C,ULSDBH+DB$SA HRLZS C HRR C,$LSLOC(L) ; And read in as for LA. XCTIOC [.IOT DKIC,C] ; (SA immediately follows LA) JRST LSEIN9 ; Jump if lost. ; Readin all done. Point .ACCESS ptr to immediately after DB. LSEI85: MOVE B,ULSIPT ; Get back original dsk addr ADD B,ULSDBH ; Add in tot # wds in block. .ACCESS DKIC,B ; Set to right after it. AOS -5(P) ; Won, skip return. LSEIN9: POPAE P,[L,D,C,B,A] POPJ P, LVAR ULSIPT: 0 ; Initial .ACCESS ptr for LSEIN LVAR ULSOPT: 0 ; Initial .ACCESS ptr for LSEOUT ; LSEOUT - Routine similar to LSEIN, A has ARPT to a LSE HDR, ; B has either an .ACCESS pointer or -1, meaning use current. ; Writes out LSE block on DKOC channel. ; Returns in A the original .ACCESS pntr, in B # words written. LSEOUT: PUSHAE P,[C,L] MOVE L,$ARLOC(A) ; Set up L JUMPL B,[SYSCAL RFPNTR,[CIMM DKOC ? CRET B] JSR AUTPSY JRST .+2] .ACCESS DKOC,B MOVEM B,ULSOPT ; Save .ACCESS ptr MOVEI C,DB$SIZ MOVEM C,ULSDBH+DB$LEN ; Initialize cumulative total of # wds in blk. MOVE C,$ARLEN(A) ; Find length of HDR area MOVEM C,ULSDBH+DB$HDR ; Store, and ADDM C,ULSDBH+DB$LEN ; add to cumulative sum. MOVE C,$LLLEN(L) ; Find length of LA area MOVEM C,ULSDBH+DB$LA ; ditto ditto ADDM C,ULSDBH+DB$LEN MOVE C,$LSLEN(L) ; Find length of SA MOVEM C,ULSDBH+DB$SA ADDM C,ULSDBH+DB$LEN ; Now finish cumulative total of # wds in blk! MOVEI C,DB$SIZ ; Start HDR immediately after the DB header. MOVEM C,ULSDBH+DB$HLC MOVE C,ULSEID ; Set up ID word MOVEM C,ULSDBH+DB$ID MOVEI C,DB$V1 ; and version # MOVEM C,ULSDBH+DB$VER MOVE C,[-DB$SIZ,,ULSDBH] .IOT DKOC,C ; Out goes the header! ; Now output HDR, LA, SA areas. IRP LENX,,[DB$HDR,DB$LA,DB$SA]LOC,,[L,$LLLOC(L),$LSLOC(L)] MOVN C,ULSDBH+LENX ; Get -length of area HRLZS C ; Put in LH for ptr HRR C,LOC ; Point to start of area .IOT DKOC,C ; Out it goes! TERMIN MOVE A,ULSOPT ; Return original .ACCESS ptr MOVE B,ULSDBH+DB$LEN ; And # wds written out. POPAE P,[L,C] POPJ P, subttl LSE debugging aids ; Debugging aids for list stuff... DEBEG: JSR DEBSAV .VALUE [ASCIZ /: Ready /] DEBEND: JSR DEBRST .VALUE [ASCIZ /: Reset /] LVAR DEBSAV: 0 ? JRST DEBSV0 ; jump to pure LVAR DEBCHP: 0 ;-1 if channel already opened by user. DEBSV0: PUSHAE P,[U40] IFE $$UCAL,PUSH P,UUORPC MOVEM 17,DEBACS+17 MOVEI 17,DEBACS BLT 17,DEBACS+16 ; Save ACs MOVE 17,DEBACS+17 SKIPN DEBCHP JRST [ .OPEN DBC,[.UAO,,'TTY] .VALUE OUT(DBC,OPEN(UC$IOT)) JRST .+1 ] JRST @DEBSAV LVAR DEBRST: 0 ? JRST DEBRS0 ; jump to pure DEBRS0: SKIPN DEBCHP .CLOSE DBC, MOVSI 17,DEBACS BLT 17,17 IFE $$UCAL,POP P,UUORPC POPAE P,[U40] JRST @DEBRST BVAR DEBACS: BLOCK 20 DEBAR: BLOCK $ARSIZ ; Area block, in case debug rtns want to use an area. EVAR ; DEBPRF - Print out a file (LSE-block). ; Argument, in DEBFIL, is the address of file block LVAR DEBFIL: 0 ; Must have addr of FN1/FN2 DEBPRF: JSR DEBSAV SKIPN A,DEBFIL JRST DEBPLX ; If nothing, simply return. .IOPUSH DKIC, SYSCAL OPEN,[[.BII,,DKIC] ? (A) ? 1(A) ? 2(A) ? 3(A)] JRST [ OUT(DBC,("Couldn't open "),6F((A)),SP,6F(1(A))) JRST DEBPFX] MOVEI A,DEBAR SETZ B, PUSHJ P,LSEIN ; Read in. .VALUE MOVE L,$ARLOC+DEBAR MOVE A,$LLLST(L) PUSHJ P,DEBPL ; Print out main list. UARCLS DEBAR DEBPFX: .IOPOP DKIC, JSR DEBRST POPJ P, ; DEBLSE - Print out a LSE. Uses current LSE as indicated by L. ; Outputs on DBC. DEBPRL same, but uses LP in DEBLP instead ; of $LLLST(L). DEBLSE: SETOM DEBLP DEBPRL: JSR DEBSAV SETZM DEBLEV SKIPGE A,DEBLP MOVE A,$LLLST(L) PUSHJ P,DEBPL DEBPLX: JSR DEBRST ; $G here if DEBPRL loses during printout. POPJ P, LVAR DEBLP: 0 ; LP to list to print. If negative, uses $LLLST(L). LVAR DEBLEV: 0 ; Level of recursion (indent) DEBPL: OUT(,CH(DBC),O(A),TAB) MOVE B,DEBLEV SOJGE B,[OUT(,(" ")) JRST .] MOVE C,LISTAR(A) ; Get 1st wd OUT(,HV(C),SP) TLNE C,%LTLST OUTCAL(,("List ")) TLNE C,%LTVAL OUTCAL(,("Val ")) TLNE C,%LTSTR OUTCAL(,("Str ")) LDB B,[$LAFLD,,LISTAR(A)] ; Get attrib # OUT(,O(B),SP,TC(ATTRTB(B)),EOL,TAB) MOVE B,DEBLEV SOJGE B,[OUT(,(" ")) JRST .] TLNE C,%LTSTR JRST [ OUT(,HV(LISTAR(A)+1),(| "|),TLS(A),C("")) JRST DEBPL5] TLNE C,%LTVAL JRST [ OUT(,O(LISTAR(A)+1)) JRST DEBPL5] OUT(,HV(LISTAR(A)+1)) DEBPL5: OUT(,EOL) TLNN C,%LTLST JRST DEBPL6 ;not a list... PUSH P,A AOS DEBLEV HRRZ A,LISTAR(A)+1 PUSHJ P,DEBPL ; Print out its list. SOS DEBLEV POP P,A DEBPL6: MOVE C,LISTAR(A) TRNN C,-1 POPJ P, OUT(,EOL) ; Do the CDR HRRZ A,C JRST DEBPL