Trailing-Edge
-
PDP-10 Archives
-
-
There are no other files named in the archive.
COMMENT VALID 00065 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002
C00007 00003 VALID 00054 PAGES VERSION 17-1(27)
C00011 00004 HISTORY
C00020 00005 Leaping runtime routines. Sept. 1972.
C00028 00006 DSCR FOREACH INTERPRETATION EXAMPLE
C00030 00007 VARIOUS DEFINITIONS OF BITS IN THE CONTROL WORD:
C00032 00008 DSCR USEFUL MACROS
C00035 00009 DSCR INTERLOCKS FOR LEAP GLOBAL MODEL
C00041 00010 DSCR LEAP ALLOCATION -- START OF PROGRAM.
C00045 00011 INTERNAL LPINI
C00052 00012
C00057 00013 NOLOCL:
C00061 00014 ALLOCATE INITIAL ITEM TYPES AND PNAMES
C00062 00015 DSCR MAIN DISPATCHER FOR LEAP
C00065 00016 DISPATCH TABLE FOR THE LEAP INTERPRETER.
C00071 00017 DSCR ASSOCIATIVE SEARCH ROUTINES
C00073 00018 THE SEARCH ROUTINES.....
C00076 00019 A XOR O EQV X
C00081 00020 A XOR X EQV V
C00085 00021 X XOR O EQV V
C00089 00022 X XOR Y EQV V
C00093 00023 A XOR X EQV Y
C00099 00024 URHASH <
C00106 00025
C00112 00026 X IN S
C00114 00027 DSCR FORSET AND NOFOR -- MAKE A SEARCH CONTROL BLOCK
C00121 00028 DSCR FOREACH STATEMENT INTERPRETER
C00128 00029 JRST TO DOAG, FRFAL
C00137 00030 DSCR FRPOP, CORPOP
C00139 00031 DSCR ? LOCAL STACK ROUTINES,STK4LC,STK4VL
C00142 00032 DSCR BNDTRP- BINDING FORM OF BOOLEAN A XOR O EQV V
C00146 00033 DSCR ISIT,BRITM
C00148 00034 DSCR DERIVED SETS -- NOT IN FOREACH SPECIFICATIONS.
C00150 00035 DSCR MAKE AND ERASE
C00161 00036 URLEAP <
C00166 00037 URLEAP <
C00172 00038 NOURLEAP <
C00175 00039 SKIPA
C00178 00040 LEAP BREAKPOINTS EXIST.
C00182 00041 DSCR ISTRIPLE, SELECTOR
C00184 00042 JRST ERR1 NO, ERROR
C00185 00043 DSCR DELETE
C00196 00044 DSCR ARRRCL RECLAIM ARRAY OF SETS,LISTS
C00198 00045 DSCR NEW (VARIOUS KINDS), AND ARRAY ITEM CODE.
C00203 00046 NEWART: PUSHJ HERE FOR NEW WITH ARITHMETIC TYPE
C00207 00047 NEWARY: JRST HERE
C00214 00048 DSCR SET AND ITEM STORING OPERATIONS.
C00221 00049 DSCR PUTIN REMOV
C00227 00050 DSCR SIP ,LSTMAK
C00231 00051 DSCR STIN, LSTIN
C00234 00052 DSCR COUNT,UNIT,STLOP
C00236 00053 DSCR SETEST
C00239 00054 DSCR UNION, INTERSECTION, SUBTRACTION
C00246 00055 DSCR PUTAFTER,PUTBEFORE
C00252 00056 DSCR SET RECLAMATION ROUTINES.
C00254 00057 TRANSFER FUNCTION SET_ LIST
C00257 00058 DSCR RPLAC
C00259 00059 DSCR TYPEX-to determine the type of an item
C00262 00060 DSCR TYPEIT -same as TYPEX except does not return datum address in left
C00266 00061 DSCR PUTXA,PUTXB
C00268 00062 DSCR INTNAM,CVSI,CVIS,DEL.PNAME,NEW.PNAME
C00275 00063
C00281 00064 DSCR MATCHING PROCEDURE ROUTINES, CALMP,RESMP,SUCFA1
C00286 00065 NOGLOB <
C00287 ENDMK
C;
COMMENT VALID 00054 PAGES VERSION 17-1(27)
RECORD PAGE DESCRIPTION
00001 00001
00011 00002 HISTORY
00020 00003 Leaping runtime routines. Sept. 1972.
00027 00004 DSCR FOREACH INTERPRETATION EXAMPLE
00029 00005 VARIOUS DEFINITIONS OF BITS IN THE CONTROL WORD:
00031 00006 DSCR USEFUL MACROS
00033 00007 DSCR INTERLOCKS FOR LEAP GLOBAL MODEL
00039 00008 DSCR LEAP ALLOCATION -- START OF PROGRAM.
00043 00009 INTERNAL LPINI
00048 00010
00052 00011 NOLOCL:
00056 00012 ALLOCATE INITIAL ITEM TYPES AND PNAMES
00057 00013 DSCR MAIN DISPATCHER FOR LEAP
00060 00014 DISPATCH TABLE FOR THE LEAP INTERPRETER.
00066 00015 DSCR ASSOCIATIVE SEARCH ROUTINES
00068 00016 THE SEARCH ROUTINES.....
00073 00017 X XOR O EQV V
00081 00018 X IN S
00083 00019 DSCR FORSET AND NOFOR -- MAKE A SEARCH CONTROL BLOCK
00089 00020 DSCR FOREACH STATEMENT INTERPRETER
00103 00021 DSCR FRPOP, CORPOP
00105 00022 DSCR ? LOCAL STACK ROUTINES,STK4LC,STK4VL
00107 00023 DSCR BNDTRP- BINDING FORM OF BOOLEAN A XOR O EQV V
00111 00024 DSCR ISIT,BRITM
00113 00025 DSCR DERIVED SETS -- NOT IN FOREACH SPECIFICATIONS.
00115 00026 DSCR MAKE AND ERASE
00122 00027 JRST TO BMAKE
00124 00028 PUSHJ, TO ERASE
00126 00029 SKIPA
00129 00030 LEAP BREAKPOINTS EXIST.
00132 00031 DSCR ISTRIPLE, SELECTOR
00134 00032 DSCR DELETE
00144 00033 DSCR ARRRCL RECLAIM ARRAY OF SETS,LISTS
00146 00034 DSCR NEW (VARIOUS KINDS), AND ARRAY ITEM CODE.
00150 00035 NEWART: PUSHJ HERE FOR NEW WITH ARITHMETIC TYPE
00155 00036 NEWARY: JRST HERE
00163 00037 DSCR SET AND ITEM STORING OPERATIONS.
00170 00038 DSCR PUTIN REMOV
00176 00039 DSCR SIP ,LSTMAK
00180 00040 DSCR STIN, LSTIN
00183 00041 DSCR COUNT,UNIT,STLOP
00185 00042 DSCR SETEST
00188 00043 DSCR UNION, INTERSECTION, SUBTRACTION
00195 00044 DSCR PUTAFTER,PUTBEFORE
00201 00045 DSCR SET RECLAMATION ROUTINES.
00203 00046 TRANSFER FUNCTION SET_ LIST
00206 00047 DSCR RPLAC
00208 00048 DSCR TYPEX-to determine the type of an item
00211 00049 DSCR TYPEIT -same as TYPEX except does not return datum address in left
00215 00050 DSCR PUTXA,PUTXB
00217 00051 DSCR INTNAM,CVSI,CVIS,DEL.PNAME,NEW.PNAME
00224 00052
00230 00053 DSCR MATCHING PROCEDURE ROUTINES, CALMP,RESMP,SUCFA1
00235 00054 NOGLOB <
00236 ENDMK
;
COMMENT HISTORY
AUTHOR,REASON
021 102100000033 ;
COMMENT
VERSION 17-1(28) 24-AUG-76 BY JES (@UOR) 18-BIT ITEM SPACE (URLEAP)
VERSION 17-1(27) 2-26-75 BY RHT BUG #UC# ERRORS IN REFITEM DELETION
VERSION 17-1(26) 9-22-74 BY rht BUG #TK# TYPO IN STK4LC
VERSION 17-1(25) 5-20-74 BY RHT BUG #SB# REFITM STACKS VALUE STRINGS NOW
VERSION 17-1(24) 4-17-74
VERSION 17-1(23) 4-14-74 BY RHT BUG #RU# USER MAY NEED SETTING UP AT RECQQ
VERSION 17-1(22) 3-6-74 BY JRL BUG #RM# (CMU =B3=) FIX BY LDE FP1 LIST GLUBBED UP
VERSION 17-1(21) 3-6-74
VERSION 17-1(20) 2-14-74 BY RHT BUG #RF# LSTMAK WAS MAKING BAGS INSTEAD
VERSION 17-1(19) 1-11-74 BY RHT MODIFY WAY GBRK IS DEFINED
VERSION 17-1(18) 1-11-74
VERSION 17-1(17) 1-11-74
VERSION 17-1(16) 12-9-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(15) 12-9-73 BY JRL REMOVE SPECIAL STANFORD CHARACTERS(WHERE POSSIBLE)
VERSION 17-1(14) 11-18-73 BY JRL CHANGE PDLOF UUO CALLS TO JSP USER,$PDLOV
VERSION 17-1(13) 11-4-73 BY JRL BUG #OW# STATIC LINK IS ONLY IN RIGHT HALF OF STACK ENTRY
VERSION 17-1(12) 10-29-73 BY JRL MORE GRACEFUL EXIT WHEN SAME PNAME USED TWICE
VERSION 17-1(11) 10-24-73 BY JRL MUNGE THE LPINI LEAP INITIALIZER
VERSION 17-1(10) 10-23-73 BY JRL FEATURE %AG% ITEM OVERLAP STUFF
VERSION 17-1(9) 10-23-73 BY JRL FEATURE %AF% DIFFERENT BOOLEANS FOR SET LIST MEMBERSHIP
VERSION 17-1(8) 9-15-73 BY JRL BUG #OE# AVOID DRYROT WHEN DELETING DECLARED STRING ARRAY ITEM
VERSION 17-1(7) 9-4-73 BY JRL BUG #OA# REMOVE ALL DESTROYED FREE-STORAGE LIST
VERSION 17-1(6) 8-30-73 BY RHT BUG #NZ# TRAP DELETION OF RESERVED ITEM
VERSION 17-1(5) 8-30-73
VERSION 17-1(4) 8-27-73 BY JRL BUG #NW# DRYROT WHEN DELETING STRING ARRAY ITEM
VERSION 17-1(3) 8-27-73
VERSION 17-1(2) 8-16-73 BY JRL BUG #NS# SHOULD PICK UP NUMBER OF BUCKETS WITH HLRE NOT HLRZ
VERSION 17-1(1) 8-4-73 BY JRL BUG #NL# A XOR ANY EQV ANY BOOLEAN ALWAYS FAILED
VERSION 17-1(0) 7-26-73 BY RHT **** VERSION 17 ****
VERSION 16-2(59) 7-22-73 BY JRL BUG #ND# DELETING LIST ARRAY ITEMS
VERSION 16-2(58) 5-6-73
VERSION 16-2(57) 5-6-73 BY JRL ADD REFITM
VERSION 16-2(56) 5-6-73
VERSION 16-2(55) 5-6-73
VERSION 16-2(54) 5-6-73
VERSION 16-2(53) 4-5-73 BY JRL BUG #LY# GLOBAL PROPS BEING DESTROYED
VERSION 16-2(52) 4-5-73
VERSION 16-2(51) 4-2-73 BY JRL DON'T ALLOW PNAMES FOR ANY
VERSION 16-2(50) 3-20-73
VERSION 16-2(49) 3-20-73
VERSION 16-2(48) 3-20-73 BY JRL DON'T ERASE ASSOCIATIONS WHEN DELETE BTRIP
VERSION 16-2(47) 2-27-73 BY JRL FIX BYTE POINTERS FOR PROPS
VERSION 16-2(46) 2-19-73 BY JRL FLUSH POPTOP (NOW COMPILED INLINE)
VERSION 16-2(45) 2-13-73
VERSION 16-2(44) 1-28-73 BY JRL HAVE DELETE TO A FORGET ALL TO CONTEXT ITEMS
VERSION 16-2(43) 1-25-73 BY JRL ADD ? TYPE ASSOCIATIVE BOOLEANS
VERSION 16-2(42) 1-23-73 BY JRL MAKE ANY AND UNBOUND DISTINCT,DETECT ANY EVERYWHERE
VERSION 16-2(41) 1-23-73 BY JRL MAKE PROPS FIELD 12 BITS WIDE
VERSION 16-2(40) 1-22-73 BY JRL BRITM RETURNS NIC(IF FAIL) HANDLE(X XOR X EQV FOO)
VERSION 16-2(39) 1-22-73
VERSION 16-2(38) 1-5-73 BY JRL DCS ALLOW UNBOUND IN SETS,LIST
VERSION 16-2(37) 1-5-73
VERSION 16-2(36) 1-5-73
VERSION 16-2(35) 1-5-73
VERSION 16-2(34) 12-8-72 BY JRL ADD O EQV V DERIVED SET
VERSION 16-2(33) 12-4-72 BY DCS FIX F1 SEARCH BUG
VERSION 16-2(32) 12-1-72 BY JRL BUG #KP# FDONS DESTROYED AC A
VERSION 16-2(31) 11-26-72 BY JRL ADD POTENTIAL ANY XOR ANY EQV ANY SEARCH
VERSION 16-2(30) 11-18-72 BY JRL CHANGE HASH TABLE TO ONE WORD POINTERS TO CONFLICT LISTS
VERSION 16-2(29) 11-10-72 BY JRL ADD PROPS TO LEAP INIT
VERSION 16-2(28) 11-9-72 BY JRL ADD BNDTRP ROUTINE (BINDING ASSOC BOOL)
VERSION 16-2(27) 11-8-72 BY JRL MAKE INFTB INTO BYTE POINTER
VERSION 16-2(26) 10-16-72 BY jrl update item codes to include contexts
VERSION 16-2(25) 10-9-72 BY JRL GIVE MAINPI ETC TYPES, DON'T ALLOW UNBOUND IN MAKES,SETS,LIST
VERSION 16-2(24) 10-4-72 BY JRL BUG #JL# BNDFOR TURNED OFF FOR SETS
VERSION 16-2(23) 10-2-72 BY JRL BUG #JJ# MULTPLE PROCESS STUFF WAS DESTROYING FP2 LIST
VERSION 16-2(22) 10-2-72 BY JRL BUG #JI# FIX IFGLOBAL
VERSION 16-2(21) 9-17-72
VERSION 16-2(20) 9-17-72
VERSION 16-2(19) 9-17-72
VERSION 16-2(18) 9-11-72 BY JRL TURN OFF BNDFOR BIT WHEN FETCHING ? LOCALS
VERSION 16-2(17) 9-7-72 BY JRL ADD ROUTINES TO STACK ?LOCALS
VERSION 16-2(16) 8-25-72 BY JRL CHANGE CALL TO DELETE FROM MPFAIL
VERSION 16-2(15) 8-25-72 BY JRL MAINTAIN FRLOC AS CURSCB FOR PROCESSES
VERSION 16-2(14) 8-24-72 BY JRL ADD MATCHING PROCEDURE ROUTINES
VERSION 16-2(13) 8-23-72 BY JRL CHANGE FORGO TO HANDLE DISPLAY ITEMVARS
VERSION 16-2(12) 8-22-72 BY RHT BE SURE THAT LEAP IS INITED WHEN NEED
VERSION 16-2(11) 8-10-72 BY DCS MAKE LINK GO IN RIGHT SEG
VERSION 16-2(10) 8-7-72 BY RHT CHANGE LPINI LINKAGE
VERSION 16-2(9) 7-24-72 BY JRL ADD GLOBAL-LOCAL CHECKING MAKES,ERASES,DELETES
VERSION 16-2(8) 7-2-72 BY JRL LPINI CALLED FROM ALLOC IN GOGOL
VERSION 16-2(7) 6-8-72 BY DCS BUG #HP# RETURN NULL STR FROM CVIS IF NO PNAME
VERSION 15-6(6) 2-22-72
VERSION 15-6(5) 2-20-72
VERSION 15-2(4) 2-6-72 BY DCS BUG #GC# CONSISTENCY ABOUT FIRST ACTUAL ITEM #
VERSION 15-2(3) 2-1-72 BY DCS USE SYMBOLIC (HEAD-DEFINED) INDICES IN SPACE TABLE
VERSION 15-2(2) 12-22-71 BY DCS REMOVE SAILRUN
VERSION 15-2(1) 12-2-71 BY DCS INSTALL VERSION NUMBER
;
SUBTTL Leaping runtime routines. Sept. 1972.
LSTON (LEPRUN)
IFNDEF UPPER,<?UPPER__0>
IFNDEF LOWER,<?LOWER__0>
IFNDEF ALWAYS,<?ALWAYS__0>
IFNDEF SEGS,<?SEGS__0>
IFNDEF GLOBSW,<?GLOBSW__0>
IFNDEF RENSW,<?RENSW__0>
BEGIN LEAP
INTERNAL LEAP,CVIS,CVSI,NEW.PNAME,DEL.PNAME,TYPEX,TYPEIT,LISTX
;;#US% ! JFR 8-12-75 add TYPEIT
IFE ALWAYS,<ENTRY LEAP,CVIS,CVSI,TYPEIT
TITLE LEAP
EXTERNAL GOGTAB,ARCOP,CORGET,CORREL,ARMAK,ARYEL,TERMIN,RESUME
EXTERNAL SPRPDA,RUNNER,DADDY,CURSCB,SPROUT,$PDLOV
EXTERNAL .SKIP.,DATM,LKSTAT,INFTB,X11,X22,X33,SAVE,RESTR,EQU
EXTERNAL PROPS,STACSV,STACRS
URLEAP<
;; \UR#7\ SUPPRESS OVERLAP MESSAGE IF USER SO DESIRES.
EXTERNAL $$LNOWARN
;; \UR#7\
>;URLEAP
URLEAP <
;; && JES (@UOR) NEW LEAP HASH AND ITEM ALLOCATION
EXTERNAL TPALLC,ITMBOT
>;URLEAP
URSTAT <
;; %% JES LOCATIONS USED FOR COUNTING THE NUMBER OF TIMES INNER
; LOOPS OF LEAP SEARCHES ARE EXECUTED
EXTERNAL RCNT1,RCNT2,RCNT3,RCNT4,RCNT5,RCNT6,RCNT7
EXTERNAL RSUC1,RSUC2,RSUC3,RSUC4,RSUC5,RSUC6,RSUC7
>;URSTAT
EXTERNAL FP1DON,FP2DON,SDESCR,CORGZR,FPEES,ALLFOR,FSAV,FREST
INTERNAL COPARR,ARRRCL,RECQQ,CATLST,LPINI
>
REN <
TWOSEG 400000
RELOC 400000
USE HIGHS
USE
RELOC
USE HIGHS
>;REN
COMMENT
These are the leap runtime routines. If you can believe it,there
is only one entry, LEAP. On entry FLAG contains a
control word. The right half specifies
a routine name (see table of routines). The left half has
various bits -- such as:
BOUND
BINDING **during foreach lists only.
SETT **these bits are present for all (3) arguments.
SETT is passed in but never used since without set arguments
to MAKE,ERASE etc, it is superfluous
FOREA -- says that this call is inside a foreach list.
This is never used, it is not clear it is even passed in.
SETOP -- this is a set or list type thing (e.g. x IN S)
BRACKET -- this is a bracketed search.
GLOB <
GLBSRC -- this is a global model operation
>;GLOB
Since there is no elegant way of drawing spaghetti with characters,
I will refrain from describing here the mess that these
routines build and destroy (at random).
;ac definitions.
IFNDEF A,<
A__1
B__2
C__3
D__4
>
?FLAG __5
FP_6
FRTAB_TAC1
FPD_10
PNT_11
GLOB <
TABL__7
>;GLOB
NOGLOB <
TABL __ USER ;MAKE IT THE SAME AS USER.
>;NOGLOB
NOURLEAP <
ITLEN_=12 ;ITEM NUMBERS ARE 12 BITS LONG
>;NOURLEAP
;LENGTHS OF VARIOUS THINGS.....
PHASLN __ =128 ;LENGTH OF PNAME HASH TABLE
HASLEN__777 ;MUST BE OF THIS FORM.
;I.E. 2^N-1 .(THIS IS LENGTH OF HASH TABLE)
URLEAP <
TOPITM__777777 ;MAXIMUM NUMBER OF ITEMS
>;URLEAP
NOURLEAP <
TOPITM__7777
INFOLEN__7777
>;NOURLEAP
GLOB <
IFNDEF GBRK,<
;DO IT THIS WAY SINCE GOGOL ALSO SETS THIS
;VALUE (ON PAGE WITH STSW)
URLEAP <
GBRK __ 600000 ;LOCAL - GLOBAL ITEM NUMBER BREAK
;MAXIMUM GLOBAL ITEM # IS 777776
>;URLEAP
NOURLEAP <
GBRK __ 6000 ;LOCAL - GLOBAL ITEM NUMBER BREAK
;MAXIMUM GLOBAL ITEM # IS 7776
>;NOURLEAP
>; OF THE IFNDEF
>;GLOB
;FOREACH BLOCK TEMPLATE.
;THIS IS THE "SEARCH CONTROL BLOCK" -- ONE IS MADE FOR EACH KIND
;OF ASSOCIATIVE SEARCHING ROUTINE CALLED. THE FPD STACK HAS GOOD
;MASKS, TEMPORARY POINTERS, AND A-O-V INFORMATION IN IT.
SATNO__MAXLOC ;MAX NO. OF SATISFIERS.(foreach locals)
;CURRENTLY =10
;** FOLLOWING ARE INDICES INTO SEARCH CONTROL BLOCK (USUALLY "FRTAB")
FPDP__0 ;FOREACH PUSHDOWN POINTER.
MOVEA__1 ;INSTRUCTION TO EXECUTE TO LOAD AC "A"
;WITH THE CURRENT SATISFIER FOR THE LOCAL NUMBER
;IN "A"
MOVEB__2 ;SAME FOR AC "B"
MC__3 ;BYTE POINTER FOR DEPOSITING SATISFIERS.
INDEX4__4 ;INCREMENT TO SEARCH ROUTINE FOR ? LOCALS
SCNT__5 ;NUMBER OF CORE SATISFIERS FOR THIS SEARCH.
SATIS__6-1 ;START OF SATISFIERS.
;EACH CELL HAS :
; RH PNTS TO USER CORE ADDRESS OF VARB.
; LH CURRENT SATISFIER ITEM NUMBER.
; (PUT THERE WITH "MC", RETRIEVED
; WITH "MOVEA" OR "MOVEB"
;Note that SCNT is used for depositing satisfiers
;to ANY and thus when count really wanted should
;loaded with HRRE
OLDSAT __ SATIS+1+SATNO ;BLOCK OF OLD VALUES OF FOREACH LOCALS
FPDL__OLDSAT+SATNO ;PUSH DOWN AREA.
;DISPLACEMENTS IN FPD STACK FOR VARIOUS THINGS.
; USED BY THE SEARCH ROUTINES TO FIND ARGUMENTS LEFT BY
; THE FOREACH SEARCH CALLER.
T2__2
TT1__3
MASK__4
ATTP__5
ITMP__5
OBJP__6
SETP__6
VALP__7
LENFPD__10 ;LENGTH OF AN FPD STACK ENTRY
FPDLEN__=10*LENFPD ;FOREACH PUSHDOWN LIST LENGTH
;ALLOW 10 SEARCHES
FRCHLEN__FPDL+FPDLEN+2 ;TOTAL LENGTH.
SCBLNK__FRCHLEN-1 ;FRCHLEN-1 OFFSET OF SCBLINK
;BITS IN LEFT HALF OF LOCAL ITEMVARS
CDISP __ 100000 ;A DISPLAY MUST BE CALCULATED
MPPAR __ 200000 ;THIS IS A ? ITEMVAR PARAMETER
POTUNB __ 400000 ;THIS LOCAL IS ONLY POTENTIALLY UNBOUND
;IF POTUNB THEN SATISFIER CAN CONTAIN FOLLOWING
NOURLEAP <
BNDFOR __ 400000 ;THIS LOCAL WAS BOUND ON ENTRY
>;NOURLEAP
URLEAP <
;LOCAL WAS BOUND ON ENTRY IS NOW INDICATED BY -1 IN L.H. OF THE
;CORRESPONDING ENTRY IN OLDSAT
>;URLEAP
DSCR FOREACH INTERPRETATION EXAMPLE
;
COMMENT @
THE THREE FOLLOWING DEFINITIONS PERTAIN TO THE (SAY) THREE ARGUMENTS
IN A FOREACH SEARCH SPECIFICATION: IF I SAID:
FOREACH X | A XOR X EQV B AND X IN FOOSET DO...
THE CODE WOULD BE:
MOVEI TAC1,.+4 ;ADDRESS SATIS INFO BLOCK
MOVEI FLAG,11 ;ROUTINE NO. 11, START A FOREACH
PUSHJ P,LEAP
JRST .+4 ;JUMP AROUND SATIS INFO BLOCK
JRST 2232323 ;WHERE TO GO WHEN FOREACH ALL DONE.
1 ;NUMBER OF FREE LOCALS
X ;ADDRESS OF THE ITEMVAR X.
PUSH P,[A] ;ITEM A
PUSH P,[1] ;FIRST SATISFIER
PUSH P,B ;ITEMVAR B.
MOVE FLAG,[XWD 20,2] ;SPECIFIES THAT OBJECT IS BEING BOUND
;IN THIS OPERATION ("BINDING"), AND
;TO USE SEARCH 2 (OBJECT UNBOUND).
PUSHJ P,LEAP
PUSH P,[1] ;FIRST SATISFIER
PUSH P,FOOSET ;SET
MOVE [XWD 20410,7] ;SET SEARCH. SPECIFIES THAT THIS IS
;A SET OPERATION ("SETOP") AND THAT
;THE FIRST ARG. IS A BOUND SATISFIER.
PUSHJ P,LEAP
MOVEI FLAG,12 ;PUT SATISFIERS DOWN IN CORE....
PUSHJ P,LEAP
@
;VARIOUS DEFINITIONS OF BITS IN THE CONTROL WORD:
; THIS IS THE CONTROL WORD LOADED INTO FLAG BEFORE THE PUSHJ P,LEAP.
; THESE BITS ARE IN THE LEFT HALF, AND SPECIFY MODIFICATIONS
; ON THE ROUTINE NUMBER MENTIONED IN THE RIGHT HALF.
BOUND__4 ;THESE NEXT 3 REPEATED FOR A,O AND V.
BINDING__2
SETT__1
FOREA__40000 ;A FOREACH SEARCH (NOT USED)
SETOP__20000 ;A SET SEARCH IN A FOREACH.
GLOB <
GLBSRC__200000 ;GLOBAL SEARCH SPECIFIED.
>;GLOB
BRACKET__400000 ;MUST BE SIGN BIT.
;MEANS A BRACKETED TRIPLE SEARCH IN
;FOREACH CONTEXT.
ATTPOS__6 ;POSITION IN THE WORD.....
OBJPOS__3
VALPOS__0
;BITS IN THE DATA STRUCTURES OF LEAP.
BRABIT__400000 ;MUST BE SIGN BIT.
NOURLEAP <
;ON IF NEXT GUY IN THE VALUE LIST IS A
;BRACKETED TRIPLE
>;NOURLEAP
;THIS BIT IS USED BOTH IN THE FOREACH SPEC.
;FOR THE SEARCH, AND IN THE LEAP LIST
;STRUCTURES CREATED.
COMMENT THERE IS A TBITS TABLE CALLED TBTBL IN EVAL -- IN FILE IOSER
DSCR USEFUL MACROS
;
;THE MAGIC MACRO TO HASH
URHASH <
DEFINE HASH (X,Y,Z) <
IFDIF <X><Y>,<MOVE X,Y>
LSH X,@RMASK3(TABL) ;SHIFT X OVER
;; \UR#21 - JRL late 1977 following instruction used to store in
;; a local variable (which was write protected in shared
;; systems). Instead we now use the stack.
MOVEM C,1(P) ;SAVE C SO AS NOT TO CLOBBER IT
MOVE C,Z ;PUT Z (OBJECT) IN C
AND C,RMASK4(TABL) ;MASK OUT ALL BUT LAST FEW BITS
XOR X,C ;XOR X (ATT) AND Z (OBJECT)
MOVE C,1(p) ;RESTORE C (I'M BEING VERY CAUTIOUS)
AND X,HASMSK(TABL) ;MASK OUT HIGH ORDER BITS
ADD X,HASTAB(TABL) ;ADD TO BASE PTR
>
>;URHASH
NOURHASH <
DEFINE HASH (X,Y,Z) <
IFDIF <X><Y>,<MOVE X,Y>
LSH X,1
XOR X,Z
AND X,HASMSK(TABL)
ADD X,HASTAB(TABL)
>
>;NOURHASH
;MAGIC MACRO TO TEST FOR BRACKETED TRIPLE.
NOGLOB <
DEFINE BRACKP (X) <TRZE X,BRABIT> ;SKIPS IF NO BRACK. TRIPLE.
DEFINE BRACKN (X) <TRZN X,BRABIT> ;SKIPS IF BRACKETED TRIPLE.
>;NOGLOB
GLOB <
DEFINE BRACKP (X) <
CAIN TABL,GLUSER
JRST [JUMPE X,.+ 3
TRON X,BRABIT
JRST .+2
JRST .+3]
TRZE X,BRABIT
>
DEFINE BRACKN (X) <
CAIN TABL,GLUSER
JRST [JUMPE X, .+2
TRON X,BRABIT
JRST .+3
JRST .+2]
TRZN X,BRABIT
>
>;GLOB
NOEXPO <
NOGLOB <
INTERNAL .MES1,.MES2
.MES1:.MES2: POP P,(P)
POPJ P,
>;NOGLOB
INTERNAL DATERR
DATERR: ERR <INCORRECT ITEM # FOR GLOBAL DATUM>,1
POPJ P,
>;NOEXPO
INTERNAL $$DERR
;; \UR#6\ ERROR MESSAGE FOR VERIFY!DATUMS
HEREFK($$DERR,$$DER.)
MOVE USER,GOGTAB
POP P,UUO1(USER) ; FOR ERROR MESSAGE
ERR <INCORRECT ITEM DATA TYPE FOR DATUM>,1
JRST @UUO1(USER)
;; \UR#6\
DSCR INTERLOCKS FOR LEAP GLOBAL MODEL
PMUTX,VMUTX,PNOENT,VNOEN,RDSEC,WRITSEC,NOSEC
GLOB <
COMMENT THE BASIC STRATEGY IS TO CONSIDER LEAP ACTIONS AS DIVIDED
INTO TWO CLASSES. THOSE WHICH READ ONLY, AND THOSE WHICH BOTH READ
AND WRITE. ANY NUMBER OF JOBS MAY BE ALLOWED TO ENTER LEAP IF
ALL THEY WANT TO DO IS READ AND THERE IS NO JOB CURRENTLY IN LEAP
WHICH WILL WRITE. THE SOLUTION TO THE CRITICAL SECTION PROBLEM
IS TAKEN FROM THE COURTOIS, ET AL ARTICLE IN CACM, OCT. 1971
;MACROS TO AID US
DEFINE PMUTX <
PUSHJ P,PMUTXR
>; PREFORMS P OPERATION ON SEMAPHORE MUTEX
DEFINE VMUTX <
SOS MUTEX
>; PREFORMS V OPERATION ON SEMAPHORE MUTEX
DEFINE PNOENT <
PUSHJ P,PNOENR
>; PREFORMS P OPERATION ON SEMAPHORE NOENTER
DEFINE VNOENT <
SOS NOENTER
>; PERFORMS V OPERATION ON SEMAPHORE NOENTER
DEFINE WRITSEC <
PUSHJ P,ENTWRT
>; MAKE SURE INSIDE OF WRITING SECTION
DEFINE RDSEC <
PUSHJ P,ENTRD
>; MAKE SURE INSIDE OF READING SECTION
DEFINE NOSEC <
PUSHJ P,NOSECR
>; EXIT WHATEVER KIND OF SECTION WE'RE IN IF ANY
;ROUTINE THAT DO THE WORK FOR MACROS
^AOSENT: ;TO START READING SECTION
TLNN FLAG,GLBSRC ;GLOBAL OPERATION
POPJ P, ;NO.
PMUTX ;MANIPULATING READCOUNT CRITICAL
AOSN ENTERED ;INC COUNT, FIRST JOB IN?
PNOENT ;YES, LOCK OUT WRITING JOBS
VMUTX ;EXIT THIS CRIT. SECTION
POPJ P, ;RETURN
^SOSENT: ;TO EXIT READING SECTION
TLNN FLAG,GLBSRC ;GLOBAL OPERATION
POPJ P, ;NO.
PMUTX ;MANIPULATING READCOUNT CRITICAL
SOSGE ENTERED ;DEC COUNT,OTHERS READERS AROUND?
VNOENT ;NO. FREE CRIT. SECT.
SETZM LKSTAT ;NOT IN ANY TYPE OF SECTION
VMUTX ;EXIT THIS CRIT. SECT.
POPJ P, ;RETURN
^PMUTXR: ;P(MUTEX)
AOSE MUTEX ;IF NOW=ZERO WE'RE O.K.
JRST [SOS MUTEX ;TOO BAD WE HAVE TO WAIT
PUSHJ P,WAIT1 ;SLEEP AWHILE
JRST .-1 ;TRY AGAIN
]
POPJ P, ;WE'RE IN CRIT. SECTION MUTEX
^PNOENR: ;P(NOENTER)
AOSE NOENTER ;ZERO, WE'RE ALLOWED IN
JRST [SOS NOENTER ;WE HAVE TO WAIT
PUSHJ P,WAIT10 ;SLEEP SOUNDLY
JRST .-1]
POPJ P, ;WE'RE INSIDE.
ENTCHK: ;TO ENTER WRITING SECTION
PNOENT ;WAIT UNTIL WE CAN ENTER
PUSH P,A ;FREE AN AC
CALLI A,30 ;GET JOB NO.
MOVEM A,LKJBNO ;SAVE IN CASE ANYONE WANTS TO KNOW
POP P,A ;RESTORE A
POPJ P, ;RETURN
EXCHK: ;TO EXIT FROM WRITING SECTION
VNOENT ;EXIT WRITING, ALLOW READERS BACK IN
SETZM LKSTAT ;NOT IN ANY SECTION
SETZM LKJBNO ;CLEAR JOB NUMBER
POPJ P, ;RETURN
^^WAITQQ:
WAIT1: PUSH P,A ;SAVE AC
MOVEI A,1 ;ONE SECOND SLEEP
JRST WAIT10+2
WAIT10: PUSH P,A ;SAVE AN AC
MOVEI A,10 ;10 SEC. WAIT
CALLI A,31 ;BEDDY-BYE
POP P,A ;RESTORE A
POPJ P, ;RETURN
ENTWRT: ;FORCE INTO WRITING SECTION
TLNN FLAG,GLBSRC ;IF NOT GLOBAL FORGET IT.
POPJ P,
SKIPGE LKSTAT ;ALREADY IN WRITING SECTION?
POPJ P, ;IF SO, RETURN
SKIPE LKSTAT ;IN READING SECTION?
PUSHJ P,SOSENT ;YES, EXIT FIRST
PUSHJ P,ENTCHK ;ENTER WRITING SECTION
SETOM LKSTAT ;MARK AS INSIDE WRITING SECTION
POPJ P,
ENTRD: ;FORCE INTO READING SECTION
TLNN FLAG,GLBSRC ;GLOBAL OPERATION?
POPJ P, ;NO FORGET IT.
SKIPLE LKSTAT ;ALREADY IN READING SECTION?
POPJ P, ;YES.
SKIPE LKSTAT ;IN WRITING SECTION?
PUSHJ P,EXCHK ;YES EXIT IT.
AOS LKSTAT ;MARK AS INSIDE READING SECTION
PUSHJ P,AOSENT ;ENTER SECTION
POPJ P,
NOSECR: ;EXIT ANY SECTION
SKIPN LKSTAT ;IN A SECTION?
POPJ P, ;NO, RETURN
SKIPG LKSTAT ;WRITING
PUSHJ P,EXCHK ;YES
SKIPE LKSTAT ;READING
PUSHJ P,SOSENT ;YES
POPJ P,
>;GLOB
DSCR LEAP ALLOCATION -- START OF PROGRAM.
Allocation (initially).
The initialization proceeds in several phases:
1. zero all the set variables.
2. accumulate counts of declared items and NEW estimates.
3. allocate hash table, datum table, info table, and frees.
4. initialize random other things (datum, foreach tables)
5. initialize printnames, item types for declared items
;MACRO TO GET LEAP CORE.
DEFINE LPCOR (SIZE,PLACE) <
IFDIF <SIZE><>,<MOVEI C,SIZE>
PUSHJ P,CORGZR
IFDIF <PLACE><>,<MOVEM B,PLACE(TABL)>
>
DSCR INITIT - INITIALIZE ITEM TYPE FOR DECLARED ITEMS
COMMENT AC A is assumed to contain address of type info block
from SPLNK. Type info block contains word containing N
the number of declared items followed by N words containing
item # ,, type index.
this routine destroys contents ac A.
INITIT: ;CALLED BY PUSHJ FROM LPINI
PUSH P,B ;GET SOME AC'S TO PLAY WITH
PUSH P,C
GLOB <
MOVEI TABL,GLUSER ;POINT TO GLOBAL STUFF
PUSH P,[HRRM B,(C)] ;USED TO INSERT INTO GLOBAL INFOTAB
HRRZ B,INFOTAB(TABL) ;ADDRESS INFOTAB
ADDM B,(P)
>;GLOB
PUSH P,[HRRM B,(C)]
HRRZ B,INFOTAB(USER) ;
ADDM B,(P)
MOVN B,(A) ;NEG. COUNT OF DECLARED ITEMS
JUMPE B,ITRETRN ;NO DECLARED ITEMS?
ADDI A,1 ;POINT TO FIRST "DATA" WORD
HRL A,B ;MAKE AOBJN POINTER
LPINIT: HRRZ B,(A) ;GET TYPE CODE
HLRZ C,(A) ;GET ITEM NUMBER
GLOB <
CAIL C,GBRK
;; #LY# GLOBAL ITEM TYPES SHOULD ONLY BE INITIALIZED ONCE.
JRST [SKIPN LEPINI ;IF GLOBAL ALREADY INITIALIZED DON'T DESTROY PROPS
XCT -1(P) ;PUT IN GLOBAL INFOTAB
JRST .+1]
;; #
>;GLOB
SKIPL UUO1(USER) ;IF NO LOCAL MODEL DON'T
XCT (P) ;PUT IN LOCAL INFOTAB
CAIE B,STTYPE ;STRING ITEM?
JRST ADDONE ;NO.
PUSHJ P,SDESCR ;GET A STRING DESCRIPTOR
POP P,@DATM ;SAVE AS DATUM
ADDONE: AOBJN A,LPINIT ;THROUGH?
ITRETRN:
NOGLOB <
SUB P,X11 ;REMOVE HRRM
>;NOGLOB
GLOB <
MOVEI TABL,(USER) ;REFER TO LOCAL MODEL AGAIN
SUB P,X22 ;REMOVE BOTH HRRM'S
>;GLOB
SKIPGE UUO1(USER) ;IF NO LOCAL MODEL
JRST ITRET2 ;JUST RETURN
MOVEI C,EVTYPI ;EVENT TYPE ITEM
MOVEI B,1 ;CODE FOR NO DATUM
MOVEM B,@INFTB ;STORE CODE
MOVEI C,NIC ;NIC ITEM
MOVEM B,@INFTB ;ALSO UNTYPED ITEM
ITRET2:
POP P,C
POP P,B
POPJ P,
INTERNAL LPINI
NOLOW <
NOUP <
REN <
USE
>;REN
LPLNK: 0
LPINI
0
LINK %INLNK,LPLNK
REN <
USE HIGHS
>;REN
>;NOUP
>;NOLOW
^LPINI2: ERR <LEAP SHOULD HAVE BEEN INITIALIZED>,1,LIN.1
HERE(LPINI)
SKIPN HASMSK(USER) ;LEAP INITIALIZATION ROUTINE.
POPJ P, ;DONT NEED IT
LIN.1: PUSH P,TAC1 ;NOT SAVED IN CORGET AND FRIENDS.
GLOB <
WRITSEC ;INSIDE WRITING SECTION
MOVEI TABL,(USER) ;START OFF AS LOCAL MODEL
>;GLOB
; FIRST CLEAR OUT ALL SETS AND LISTS LINKED BY COMPILER
MOVE B,SETLNK(USER) ;CLEAR OUT ALL SETS LINKED BY COMPILER
JUMPE B,LPALLO ;NO SETS!!!!
GOSET: MOVE C,-1(B)
SETZM (C) ;ZERO THE SET.
AOBJN C,.-1
HRRZ B,(B)
JUMPN B,GOSET ;CDR OF LIST.
;
LPALLO: ;SEARCH SPACE ALLOCATION INFORMATION.
; C WILL CONTAIN THE MAXIMUM DECLARED ITEM,
; D WILL CONTAIN THE TOTAL OF REQUIRED NEW ITEMS
; LH OF UUO1(USER) IS FLAG, -1 IF NO LOCAL MODEL, 0 IF LOCAL MODEL
; HASMSK(USER) WILL CONTAIN MAXIMUM BUCKETS REQUIRED
; A PTS TO SPACE ALLOCATION BLOCK FOR CURRENT RELFILE
; B SAVES STACK PTR AS WE WILL BE SAVING THE ITEM RANGES (LOWEST,HIGHEST) ON
; THE P-STACK
GLOB <
; LPSA CONTAINS "MINIMUM" DECLARED GLOBAL ITEM
>;GLOB
SETZB C,D ;ACCUMULATE MAXIMUM ITEM COUNT.
SETZM HASMSK(USER) ;WILL COLLECT MAX BUCKETS REQUIRED
GLOB <
URLEAP <
MOVEI LPSA,777777
>;URLEAP
NOURLEAP <
MOVEI LPSA,7777
>;NOURLEAP
>;GLOB
HRROS UUO1(USER) ;ASSUME NO LEAP LOCAL MODEL.
MOVE B,P
MOVE A,SPLNK(USER) ;ALLOCATION LINK POINTER
ITMWQ:
HRRE TEMP,$ITNO(A) ;TOP ITEM NUMBER USED.
CAILE TEMP,10 ;THERE ARE 7 DUMMIES.
; THIS WAS A CAILE -- I THINK IT'S BETTER THIS WAY -- DCS 10-6-71
; THIS IS A CAILE AGAIN -- OTHERWISE THE HAND/EYE SYSTEM GETS THE ERROR MESSAGE
; EVERY TIME - KKP 10-25-71
JRST [CAILE TEMP,(C) ;NEW HIGHEST ITEM NUMBER?
MOVEI C,(TEMP) ;YES
HLL TEMP,$ITNO(A) ;GET BACK LOWEST ITEM NUMBER
TLNN TEMP,-1 ;IF NONE WILL DEFAULT TO 11
HRLZI TEMP,11
PUSH P,TEMP ;SAVE LOWEST,HIGHEST PAIRS ON P-STACK
HRRZS UUO1(USER) ;SAY LOCAL LEAP MODEL
JRST .+1]
URLEAP<
;; \UR#7\ SUPPRESS WARNING IF USER SAID OVERLAP!OK
HLRE TEMP,$TINIT(A) ; SUPPRESS OVERLAP MSG FLAG
ORM TEMP,$$LNOWARN
;; \UR#7\
>;URLEAP
HRRE TEMP,$NWITM(A);IF ITEMS REALLY REQUESTED,
JUMPLE TEMP,.+2
HRRZS UUO1(USER) ;SAY LOCAL LEAP MODEL
ADD D,TEMP ;ESTIMATE OF NEW ITEMS REQUIRED.
GLOB <
HRRZ TEMP,$GITNO(A) ;LH OF GITNO CONTAINS "LEAPIS" FLAG
JUMPE TEMP,.+3
CAIL LPSA,(TEMP) ;JUST SO K PINGLE NEED NOT COMPILE WITH GLOB MODEL.
MOVEI LPSA,(TEMP) ;GLOBAL ITEMS ALLOCATED.
;CANNOT EXCEED 7776...
>;GLOB
;;#NS# ! USED TO BE HLRZ WE SHOULD ALLOW NEGATIVES
HLRE TEMP,$NWITM(A) ;NUMBER OF BUCKETS REQUIRED
CAMLE TEMP,HASMSK(USER) ;MORE THAN BEFORE?
MOVEM TEMP,HASMSK(USER) ;YES.
HRRZ A,(A) ;GO DOWN LINK.
JUMPN A,ITMWQ ;0 WHEN DONE.
ITMDON: ;FINISHED WITH SPACES.
CAIGE C,10 ;MAKE SURE ITEMS 10 AND BELOW NOT ALLOCATED
;;#GC# DCS 2-6-72 (1-1) BE CONSISTENT
MOVEI C,10 ;NEXT NEW WILL YIELD 11
;;#GC# (1-1) FIRST DECLARED WAS 11 -- NOW IF NONE DECLARED, FIRST IS 11
URLEAP < ;; %% JES(@UOR) FOR DESCENDING ITEM ALLOCATION
MOVEM C,TPALLC ;TOP ITEM ALLOCATED.
>;URLEAP
NOURLEAP <
MOVEM C,MAXITM(USER) ;TOP ITEM ALLOCATED
>;NOURLEAP
SOSGE FP,HASMSK(USER)
MOVEI FP,HASLEN&777777;FOR THE HASH TABLE MASK.
MOVEM FP,HASMSK(USER) ;AND SAVE
URHASH <
;THE FOLLOWING REPRESENTS THE CODE WHICH WILL STUFF THE RMASKS WITH
;APPROPRIATE INFORMATION BASED ON THIS INVOCATION OF LEAP
;(RICK RASHID 3/15/76)
;THE FOLLOWING NEW (JES 30-JUL-76) VERSION OF THIS LEAVES THE RMASKS AS
;FOLLOWS, ASSUMING THE REQUESTED HASH TABLE SIZE IS 2^N:
; RMASK1(USER) = 2 ^ (N DIV 2) - 1 (USUALLY 17)
; RMASK2(USER) = 2 ^ (N DIV 2) (USUALLY 20)
; RMASK3(USER) = N DIV 2 (USUALLY 4)
; RMASK4(USER) = 2 ^ ((N + 1) DIV 2) - 1 (USUALLY 37)
PUSH P,A ;SAVE A FOR SAFETY SAKE
PUSH P,B
PUSH P,C ;AND C, I'M GOING TO USE IT TOO
MOVE A,HASMSK(USER) ;PICK UP 2 ^ N - 1 (USUALLY 777)
JFFO A,.+1 ;LEAVE COUNT OF LEADING ZEROS IN B
MOVEI A,=36
SUB A,B ;LEAVE N IN A
IDIVI A,2 ;LEAVE REMAINDER IN B
MOVEM A,RMASK3(USER)
MOVEI C,1
ASH C,@A
MOVEM C,RMASK2(USER)
SUBI C,1
MOVEM C,RMASK1(USER)
JUMPE B,.+3 ;IF N WAS ODD THEN RMASK4 NEEDS ANOTHER 1-BIT
LSH C,1
ADDI C,1
MOVEM C,RMASK4(USER)
POP P,C
POP P,B
POP P,A
>;URHASH
SKIPGE UUO1(USER) ;A LOCAL LEAP MODEL?
JRST NOLOCL ;NO
PUSHJ P,FPEES ;GET AN INITIAL ONE-TWO WORD FREES
;FIRST TIME ONLY GET 1 TWO-WORD FREE
;AND 10 1-WORD FREES
ADDI C,50(D) ;MAX EXPECTED OVER "DECLARED"
NOGLOB <
CAILE C,TOPITM
MOVEI C,TOPITM
>;NOGLOB
GLOB <
CAILE C,GBRK-1
MOVEI C,GBRK-1
>;GLOB
MOVEM C,ITMTOP(USER) ;SAVE THE MAXIMUM ITEM NUMBER
URLEAP <
;ITEMS WILL BE ALLOCATED IN DESCENDING ORDER, STARTING
; WITH -1(C)
MOVEM C,MAXITM(USER) ;STORE IT HERE TOO (THIS IS A KLUDGE
;DESCENDING FROM THE OLD ITEM ALLOCATION)
MOVEM C,ITMBOT ;LOAD A DOWN-COUNTER WITH ONE ...
;... MORE THAN MAXIMUM ITEM NUMBER
MOVEI TEMP,(C) ;NO KLUDGES HERE
SUB TEMP,TPALLC ;SUBTRACT THE NUMBER ALREADY USED
>;URLEAP
NOURLEAP <
MOVEI TEMP,-3(C) ;BUILD THE NUMBER OF FREE ITEMS (- FUDGE)
SUB TEMP,MAXITM(USER)
>;NOURLEAP
MOVEM TEMP,FREITM(USER)
; AT THIS POINT ON THE P-STACK FROM LOCATIONS 1(B) TO (P) ARE PAIRS
; LOWEST,,HIGHEST CORRESPONDING TO THE DECLARED ITEMS USED BY A PROGRAM
; WE WILL NOW SORT THESE IN DESCENDING ORDER
SRTINT:
MOVEI A,(B) ;BUBBLE SORT
OTRSRT:
ADDI A,1
CAIL A,(P) ;THROUGH?
JRST SRTED ;YES
MOVEI C,(A) ;PREPARE FOR INNER LOOP
INRSRT:
MOVE TEMP,(C) ;
CAML TEMP,1(C)
JRST ADDIC ;NO SWAP
EXCH TEMP,1(C)
MOVEM TEMP,(C)
ADDIC:
ADDI C,1
CAIE C,(P) ;DONE INNER LOOP?
JRST INRSRT ;NO.
JRST OTRSRT ;YES, CONTINUE OUTER LOOP
SRTED:
; CHECK TO MAKE SURE NO OVERLAP
MOVEI A,-1(P) ;
CHKOVR:
CAIG A,(B)
JRST OVRCHKD ;THROUGH
HLRZ TEMP,(A) ;START OF NEXT
MOVE C,1(A) ;END OF THIS
CAILE TEMP,(C) ;EVERYTHING FINE?
SOJA A,CHKOVR ;YES
URLEAP<
;; \UR#7\ CHECK IF USER SAID TO SUPPRESS WARNING
SKIPN $$LNOWARN ; USER DOESN'T WANT WARNINGS
;;\UR#7\
>;URLEAP
TERPRI <WARNING: TWO PROGRAMS WITH ITEM OVERLAP>
SETZM 1(A)
HLLM TEMP,(A) ;MERGE TWO OVERLAPS
CAIN TEMP,11 ;INITIAL OVERLAP?
SOJA A,CHKOVR
MOVEI TEMP,(TEMP) ;FOR ERR UUO BELOW
ERR < LEAP OVERLAP: FIRST CONFLICT ITEM NUMBER >,7
SOJA A,CHKOVR
OVRCHKD:
MOVE FP,FP1(USER) ;WE WILL LINK UP
HRRZM FP,OLDITM(USER) ;LINKED LIST OF AVAILABLE ITEMS
SKIPN (P)
JRST [SUB P,X11 ;LOOP UNTIL FIND NON-EMPTY STACK ELEMENT
JRST .-1]
MOVEI C,0 ;FLAG TO DETERMINE IF WE LINKED ANY AT ALL
HLRZ TEMP,(P) ;LOWEST DECLARED ITEM NUMBER
MOVEI A,10 ;
PUSHJ P,LNKITM
CAMN P,B
JRST LNKOVR
LPLNKM:
HRRZ A,(P)
LPLNK2:
SUB P,X11
CAMN P,B ;THROUGH?
JRST LNKOVR ;YES
SKIPN (P)
JRST LPLNK2
HLRZ TEMP,(P)
PUSHJ P,LNKITM
JRST LPLNKM
LNKITM: ;PUSHJ'D TO
ADDI A,1 ;LINK IN ITEMS FROM (A)+1 TO (TEMP)-1
CAIG TEMP,(A) ;DONE?
POPJ P, ;YES
MOVEI C,(FP)
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON
HRLM A,(C) ;ITEM FOR FREE LIST
AOS FREITM(USER)
JRST LNKITM
LNKOVR:
JUMPE C,[SETZM OLDITM(USER) ;THERE WEREN'T ANY
JRST NOLOCL]
HRRM FP,FP1(USER)
HLLZS (C)
NOLOCL:
GLOB <
;GLOBAL MODEL INITIALIZATION.
AOSE LEPINI ;INITED ALREADY?
JRST LNONIT ;YES
MOVEI FP,HASLEN&777777
MOVEM FP,HASMSK+GLUSER;IN TWO PLACES.
MOVEI TABL,GLUSER ;
URHASH <
;MORE CODE FOR STUFFING RMASKS (3/15/76)
PUSH P,A ;JUST TO BE ON SAFE SIDE
MOVEI A,17
MOVEM A,RMASK1(TABL)
MOVEI A,20
MOVEM A,RMASK2(TABL)
MOVEI A,4
MOVEM A,RMASK3(TABL)
MOVEI A,37
MOVEM A,RMASK4(TABL)
POP P,A
>;URHASH
MOVEM LPSA,MAXITM(TABL);AS WE ACCUMULATED IT.
MOVEI D,GBRK ;ADJUST FOR LOCAL -GLOBAL DIFFERENCE.
MOVEI C,TOPITM-GBRK+1 ;NUMBER OF GLOBAL ITEMS TO ALLOC.
PUSHJ P,SPALLO ;AND ALLOCATE
MOVEM A,GINFTB ;GLOBAL TYPE-CHECKING
HRLI A,(<POINT 12,(3),29>) ;FOR PROPS FIELD
MOVEM A,GPROPS
MOVEM B,GDATM ;GLOBAL DATUM REFERENCES.
PUSHJ P,FPEES ;FREES.
LNONIT:
MOVEI TABL,(USER) ;REFER TO LOW CORE AGAIN
>;GLOB
SKIPGE UUO1(USER) ;DOES USER REALLY WANT LOCAL MOD?
JRST INDONE ;THIS IS TO AVOID HAVING SOME
;POOR LOSER WHO ONLY WANTS GLOBAL
;ARRAYS GETTING 15 K CORE FOR LEAP!
NOGLOB <
MOVE C,ITMTOP(USER) ;HOW MANY LOCAL ITEMS WE'RE GOING TO HAVE
>;NOGLOB
GLOB <
URLEAP <
;SINCE THE TOP GLOBAL ITEM IS 777777 (HALFWORD -1), WE WILL ALLOCATE
; THE DATUM TABLE AND THE INFOTAB IN THE FOLLOWING WAY:
;
; MAXIMUM LOCAL ITEM
; .
; . (LOCAL ITEMS)
; .
; TABLE POINTER: ITEM 0 (I.E. ANY)
; ITEM 777777 (I.E. TOPITM)
; .
; . (GLOBAL ITEMS)
; .
; ITEM GBRK (600000 FOR NOW)
;
MOVE C,ITMTOP(USER) ;HOW MANY LOCAL ITEMS WE'RE GOING TO HAVE
MOVEI C,-GBRK(C) ;ADD THE NUMBER OF GLOBAL ITEMS
MOVEI D,GBRK ;OFFSET FROM BOTTOM OF TABLES TO ITEM 0
PUSH P,[SPDON] ;DUMMY RETURN ADDRESS
>;URLEAP
NOURLEAP <
MOVEI C,TOPITM
MOVEI D,0
PUSH P,[SPDON] ;DUMMY RETURN ADDRESS.
>;NOURLEAP
>;GLOB
SPALLO:
URLEAP <
MOVEI C,1(C) ;INCREMENT C SO THE TABLES WILL BE BIG ENOUGH
>;URLEAP
PUSH P,C
LPCOR (,) ;GET CORE FOR VALUE LINKS, ETC.
GLOB <
SUBI B,(D) ;SUBTRACT OFF LOWER BOUND.
>;GLOB
HRLI B,(<POINT 6,(C),35>);MAKE INTO BYTE POINTER
MOVEM B,INFOTAB(TABL) ;RECORD IT.
MOVE C,HASMSK(TABL)
ADDI C,1 ; NUMBER OF BUCKETS
LPCOR (,HASTAB);HASH TABLE SPACE.
POP P,C ;RESTORE SIZE
LPCOR (,) ;AND FOR DATUMS.
GLOB <
SUBI B,(D) ;ADJUST IF NECESSARY
>;GLOB
HRLI B,3 ;ACCUMULATOR NUMBER FOR DATUM.
MOVEM B,DATAB(TABL) ;RECORD IT.
MOVE A,INFOTAB(TABL) ;FOR DYNAMIC TYPE-CHECKING
GLOB <
MOVEI TABL,(USER) ;WE'RE BACK TO LOWER SEGMENT STUFF
POPJ P,
SPDON: ;USUALLY POPJ ABOVE CONTINUES HERE
;GET ONE AND TWO WORD FREES
>;GLOB
MOVEM A,INFTB ;FOR TYPE CHECKING
HRLI A,(<POINT 12,(3),29>) ;BYTE POINTER FOR PROPS FIELD
MOVEM A,PROPS
MOVEM B,DATM ;THIS IS FOR REFERENCING DATUMS.
GLOB <
PUSHJ P,GFREES ;WILL TRY TO USE HOLES IN INFOTAB,DATAB FOR ALLOC.
>;GLOB
; **** COMMENT HERE ON BUFACS PROBLEM *****
INDONE: LPCOR (FRCHLEN,LEABOT) ;GET CORE FOR "ERASE" SCB
SETZM SCBLNK(B) ;NOT CONSIDERED NESTED FOREACH
SETZM SCBCHN(USER) ;NO FREE SCB'S
MOVEI TAC1,(USER) ;SO FRGO WON'T CAUSE ILL MEM REF.
JSP FP,FRGO ;INITIALIZE "ERASE" SCB
;ALLOCATE INITIAL ITEM TYPES AND PNAMES
MOVE B,SPLNK(USER) ;SPACE ALLOCATION LIST
PNMTYPLP:
PUSH P,B ;SAVE THROUGH CALLS
;; SKIPE A,$TINIT(B) ;ITEM TYPE INITIALIZATION
;; \UR#7\ LH OF $TINIT NOW OVERLAP OK FLAG
HRRZ A,$TINIT(B) ;HERE LH($TINIT) USED FOR
;LEAP WARNING SUPPRESSION
JUMPE A,.+2
PUSHJ P,INITIT
SKIPE A,$PINIT(B) ;PRINTNAME INITIALIZATION
PUSHJ P,INTNAM
POP P,B
HRRZ B,(B) ;CDR SPACE ALLOCATION LIST
JUMPN B,PNMTYPLP
INITDN:
GLOB <
NOSEC
>;GLOB
POP P,TAC1 ;RESTORE AC.
POPJ P, ;GO AWAY...
DSCR MAIN DISPATCHER FOR LEAP
THIS IS THE MAIN ENTRY OF THIS CODE (I.E. "LEAP").
THE APPROPRIATE INTERPRETER ROUTINE IS CALLED.
****** AC'S SET UP FOR ALL INTERPRETER ROUTINES ******
USER SET UP TO GOGTAB.
UUO1(USER) CONTAINS THE USER'S RETURN ADDRESS.
FLAG CONTAINS CONTROL WORD.. UNTOUCHED
P PUSH-DOWN STACK HAS RETURN ADDRESS WORD POPPED OFF.
;
HERE (LEAP) ;THIS HERE IS LEAP.
MOVE USER,GOGTAB
GLOB <
MOVEI TABL,(USER) ;AND FOR LOCAL TABLES.
>;GLOB
SKIPN HASMSK(USER) ;TEST TO SEE IF INITIALIZED ALREADY.
PUSHJ P,LPINI2 ;NO -- GO DO IT.
POP P,UUO1(USER) ;RETURN ADDRESS
GLOB <
TLNE FLAG,GLBSRC
MOVEI TABL,GLUSER ;REFER TO UPPER SEG.
RDSEC ;ENTER READING SECTION
>;GLOB
XCT ROUTABLE(FLAG) ;CALL THE ROUTINE.
?LEAV: ;UNIFORM EXIT LOCATION.
GLOB <
PUSH SP,P ;UNCLEAN HACK.
MOVE P,SP ;USE STRING STACK TEMPORARILY.
NOSEC ;EXIT ANY SECTION
POP SP,P ;USE OLD STACK AGAIN
>;GLOB
JRST @UUO1(USER)
GLOB < ;MISCELLANEOUS....
INTERNAL GINFTB,GDATM,NOENTER,ENTERED,LKJBNO,MUTEX,GPROPS
MUTEX: -1 ;FOR CRITICAL SECTION CHANGING ENTERED
LKJBNO: 0
NOENTER: -1 ;GTR EQ 0 IF WRITING LOCKED OUT
GINFTB: 0 ;INDIRECT WORD FOR REFERING TO INFOTAB
GDATM: 0
GPROPS: 0 ;HOLDS BYTE POINTER FOR ACCESSING PROPS FIELD
LEPINI: -1
ENTERED: -1
;HERE IS A RESET ROUTINE.
INTERNAL RE.MOD
RE.MOD: SETOM NOENTER
SETOM ENTERED
SETOM QUETCH
SETZM MESQ
SETZM JOBCNT ;THIS REALLY RESETS THE WORLD.
SETZM LKJBNO
POPJ P,
>;GLOB
;DISPATCH TABLE FOR THE LEAP INTERPRETER.
;WHEN COMPILER OF (FEB 19) IN USE WILL HAVE TO CHANGE ROUTABLE
;TO REFLECT NEW NO-OPS
ROUTABLE:
REPEAT 12,<JRST FOREC> ;0-11 -- FOREACH SEARCHES.
JRST FORGO ;12 -- START OF FOREACH STAT.
PUSHJ P, FRPOP ;13 -- POP FOREACH SATISFIERS INTO CORE.
JRST DOAG ;14 -- LOOP AT END OF FOREACH STAT.
JRST FRFAL ;15 -- IF A FOREACH BOOLEAN IF FALSE.
PUSHJ P, MAKE ;16 -- MAKE AN ASSOCIATION.
JRST BMAKE ;17 -- MAKE A BRACKETED TRIPLE.
ESTART:
REPEAT 10,<PUSHJ P, ERASE> ;20-27 -- ERASES
PUSHJ P, ISTRIPLE;30 -- ISTRIPLE (FOO)
SELET1:
REPEAT 3,<PUSHJ P, SELECTOR>;31-33 FIRST,SECOND AND THIRD.
PUSHJ P, CORPOP ;34 -- CORE INTO SATISFIERS(INVERSE OF 12)
LD0: JRST LD1 ;35 -- DERIVED SETS -- INSIDE FOREACH.
JRST LD2 ;36
JRST LD3 ;37
DSTART: JRST D1 ;40 -- DERIVED SETS -- NORMAL.
JRST D2 ;41
JRST D3 ;42
JRST DELETE ;43 -- DELETE. -- NOTE: INDEX USED BY APPLY, TOO
PUSHJ P, NEW ;44 -- REGULAR NEW.
PUSHJ P, NEWART ;45 -- NEW (ARITHMETIC VALUE)
JRST NEWARY ;46 -- NEW (ARRAY)
PUSHJ P, FDONS ;47 -- RELEASE THIS FOREACH STATEMENT.
PUSHJ P, PUTIN ;50 -- PUT X IN SET.
PUSHJ P, REMOV ;51 -- REMOVE X FROM SET.
PUSHJ P, SIP ;52 -- <A,B,C,D>
;; %AF% ! (1 OF 3) DIFFERENT BOOLEANS FOR LIST AND SET MEMBERSHIP
PUSHJ P, LSTIN ;53 -- BOOLEAN X IN LIST?
PUSHJ P, COUNT ;54 -- LENGTH OF SET.
PUSHJ P, UNIT ;55 -- COP OF SET.
PUSHJ P, UNION ;56 -- SET UNION
PUSHJ P, INTER ;57 -- SET INTERSECTION.
PUSHJ P, SUBTRA ;60 -- SET SUBTRACTION.
JRST STORITM ;61 -- STORE A SET OR ITEM FROM STACK.
JRST STORBUTDONTREMOVE ;62 -- SAME AS 61, BUT LEAVE ON STACK.
;; %AF% ! (2 OF 3) DIFFERENT BOOLEANS FOR LIST AND SET MEMBERSHIP
PUSHJ P, STIN ;63 -- BOOLEAN X IN SET?
JRST POPSET ;64 -- (NO LONGER IN COMPILED CODE)
;POP PERM SET INTO AC1
RELSTART:
REPEAT 6,<PUSHJ P, SETEST> ;65-72 -- SET RELATIONALS.
ISBEG:
REPEAT 10,< JRST ISIT > ;73-102 -- ANSWER TO A XOR B EQV C ?
BSTART:
REPEAT 10,<JRST BRITM> ;103-112 -- FIND ITEM FOR [A XOR B EQV C]
JRST ITMRY ;113 -- FOR INITIALIZING ARRAY ITEMS.
JRST ITMYR ;114 -- FOR INITIALIZING ARRAY ITEMS.
JRST STLOP ;115 -- LOP OF SET.
JRST BNDTRP ;116 -- BINDING FORM OF ASSOCIATIVE BOOLEAN
JRST SETCOP ;117 -- COPY A FORMAL SET.
JRST SETRCL ;120 -- RECLAIM A FORMAL SET.
PUSHJ P, CATLST ;121 -- CONCATENATE TWO LISTS
PUSHJ P, PUTAFTER ;122 -- INSERT IN LIST
PUSHJ P, PUTBEFOR ;123 -- INSERT IN LIST
JRST SELFETCH ;124 -- SELECT ITEM FROM LIST
PUSHJ P, TSBLST;125 -- LIST[EXPR TO EXPR]
PUSHJ P, FSBLST ;126 -- LIST[EXPR FOR EXPR]
JRST SETLXT ;127 -- TRANSFORM LIST TO SET
PUSHJ P, RPLAC ; 130 -- REPLACE ELEMENT OF LIST
PUSHJ P, REMX ;131 -- REMOVE ELEMENT FROM LIST
PUSHJ P, REMALL ;132 -- REMOVE ALL INSTANCES OF AN ITEM
PUSHJ P, PUTXA ;133 -- PUT AFTER INDEXED
PUSHJ P, PUTXB ;134 -- PUT BEFORE INDEXED
PUSHJ P, LSTMAK ;135 -- FOR MAKING UP LISTS
JRST CALMP ;136 -- SPROUT MATCHING PROCEDURE
JRST STK4VL ;137 -- STACK ? LOCAL AS VAL PARM
JRST STK4LC ;140 -- STACK ? LOCAL AS MP PARM
DSCR DISPATCH TABLE FOR THE FOREACH SEARCHES
INDEXED BY THE FLAG CONTROL WORD NUMBER -- RESULT
IS ROUTINE NUMBER TO EXECUTE. IF THE INDEX IS -1,
"FDONE" IS CALLED, WHICH AUTOMATICALLY FLUSHES THE
CURRENT FOREACH STATEMENT GROUP OF SEARCHES (I.E.
THE OUTERMOST SEARCH FAILED, AND IT IS TIME TO GO AWAY).
;
FDONE
ETAB:
SEROUT: F1
F4
F3
F5
F2
F7
F6
F8
S2
S1
CALINDX:RESMP
DSCR ASSOCIATIVE SEARCH ROUTINES
;
comment @
These are the 9 kinds of associative searches:
f1 A XOR O EQV v
f2 A XOR O EQV X
f3 A XOR X EQV V
f4 X XOR O EQV V
f5 X XOR Y EQV V
f6 A XOR X EQV Y
f7 X XOR O EQV Y
s1 x IN S
s2 A IN S
These all use a "search control block" to describe the details
of the search. Any bound items have values in the FPD stack,
at -ATTP(FPD),-OBJP(FPD), and -VALP(FPD) depending whether
they are attribute, object or value. If these items are unbound,
then the stack entries contain the satisfier number (and hence
a description of a place where to put the result we find in the
search).
-TT1(FPD) and -T2(FPD) are used as temporaries by each routine --
they are used to store pointers into the data structure, and
to remember whether the search has been initialized once.
The initial values of these entries are -1 and 0 respectively.
Each search routine skips if it succeeds in finding an association
of the correct variety. In this case, register A points to the
2 word cell which stores that association. ERASE code counts
on this pointer, as do some other people (?).
If the search fails, or is exhausted, the normal (non-skipping)
return is taken.
@
;THE SEARCH ROUTINES.....
; A XOR O EQV V
F1: AOSE -TT1(FPD) ;THIS SEARCH CAN ONLY SUCCEED ONCE
POPJ P, ;SO FAIL RETURN IF WE'VE BEEN HERE BEFORE
HASH (A,<-ATTP(FPD)>,<-OBJP(FPD)>)
URLEAP <
MOVE B,-MASK(FPD) ;GET DESIRED A-O FROM SCB
COMP: HRRZ A,(A) ;GET ADDR OF NEXT M.H. BLOCK
URSTAT <
AOS RCNT1 ;COUNT A PROBE
>;URSTAT
JUMPE A,CPOPJ ;IF NO MORE M.H. BLOCKS IN THE CONFLICT LIST,
;GO FAIL-RETURN
CAME B,1(A) ;DO WE HAVE AN A-O MATCH HERE?
JRST COMP ;GO DOWN CONFLICT LIST IF NOT
;A-O MATCH - NOW LOOK IN M.H. LIST FOR MATCHING VALUE
HRRZ B,-VALP(FPD) ;GET DESIRED VALUE
F11: HLRZ A,(A) ;GET ADDRESS OF NEXT VALUE BLOCK
URSTAT <
AOS RCNT1
>;URSTAT
JUMPE A,CPOPJ ;IF NO MORE VALUE BLOCKS, GO FAIL-RETURN
HRRZ C,1(A) ;GET THIS VALUE
CAIE C,(B) ;HAVE WE A MATCH?
JRST F11 ;GO TRY AGAIN IF NOT
URSTAT <
AOS RSUC1 ;COUNT A SUCCESS
>;URSTAT
AOS (P) ;SO RETURN WILL SKIP
POPJ P, ;SUCCESS RETURN
>;URLEAP
NOURLEAP <
SKIPN A,(A) ;SEE IF A-O-V IS THERE AT ALL
URSTAT <
JRST [AOS RCNT1 ;COUNT A PROBE
POPJ P, ] ;FAIL - NOTHING FOR THIS HASH VALUE
>;URSTAT
NOURSTAT<
POPJ P, ;FAIL - NOTHING AT ALL FOR THIS HASH VALUE
>;NOURSTAT
COMP: MOVE B,1(A) ;PICK UP A-O-V
XOR B,-MASK(FPD) ;HAVE WE GOT IT?
JUMPN B,NO
YES: AOS (P)
URSTAT <
AOS RCNT1
AOS RSUC1
>;URSTAT
POPJ P, ;SUCCESSFUL RETURN
NO: TDNE B,[ 777777770000];DO A-O AT LEAST MATCH?
JRST [HRRZ A,(A) ;CONFLICT POINTER
JUMPN A,COMP ;AND LOOK IF NONZERO
POPJ P,] ;FAIL OTHERWISE
MOVE B,1(A)
TRNE B,7777 ;IS VALUE ZERO?
POPJ P, ;NO -- HENCE CANNOT SUCCEED.
HLRZ A,(A) ;VALUE LINK POINTS TO MULTIPLE HITS.
VALE: MOVE B,1(A) ;THIS IS IT.
CAMN B,-MASK(FPD) ;COMPARE
JRST YES
URSTAT <
AOS RCNT1
>;URSTAT
HRRZ A,(A) ;MULTIPLE HITS LIST
JUMPN A,VALE
POPJ P, ;FAILED.
>;NOURLEAP
; A XOR O EQV X
F2: AOSE -TT1(FPD) ;BEEN HERE BEFORE?
JRST NEXT ;YESSIR
URLEAP <
HRRZ B,-MASK(FPD) ;PICK UP OBJECT ...
HLRZ A,-MASK(FPD) ;... AND ATTRIBUTE
HASH (A,A,B)
URSTAT <
AOS RCNT2
>;URSTAT
SKIPN A,(A) ;SEE IF THERE'S A M.H. HEADER FOR THIS HASH
POPJ P, ;NOTHING'S THERE, SO FAIL
MOVE B,-MASK(FPD) ;PICK UP DESIRED A-O WORD
COMP2: CAMN B,1(A) ;DOES THIS M.H. HEADER BLOCK MATCH?
JRST YES2 ;GO WORRY ABOUT VALUE BLOCKS IF IT DOES
URSTAT <
;------------------------LEAP STATISTICS INSTRUCTION------------
AOS RCNT2 ;INCREMENT LEAP STATISTIC
;--------------------------------------------------------------
>;URSTAT
HRRZ A,(A) ;GO DOWN CONFLICT LIST TO NEXT M.H. HEADER
JUMPN A,COMP2 ;GO BACK & TRY AGAIN IF THERE IS ONE
POPJ P, ;OTHERWISE FAILURE EXIT
YES2: HLRZ A,(A) ;GET FIRST VALUE BLOCK
YS21: HLRZ C,(A) ;GET POINTER TO NEXT ONE
MOVEM C,-T2(FPD) ;SAVE IT FOR NEXT TIME
HRRZ B,1(A) ;PICK UP VALUE FROM VALUE BLOCK
HRRZ C,-VALP(FPD) ;LOCAL # FOR VALUE
HRLM B,@MC(FRTAB) ;STORE IT IN SATISFIER TABLE
AOS (P) ;SIMULATE A SKIP ON RETURN
URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
AOS RCNT2 ;INCREMENT LEAP STATISTIC
AOS RSUC2 ;INCREMENT SUCCESS COUNT
;---------------------------------------------------------------
>;URSTAT
POPJ P, ;SUCCESSFUL RETURN
NEXT: SKIPE -VALP(FPD) ;ANY ?
SKIPN A,-T2(FPD) ;GET NEXT ONE
POPJ P, ;NONE.
JRST YS21 ;BACK WE GO...
>;URLEAP
NOURLEAP<
LDB B,[POINT ITLEN,-MASK(FPD),23] ;PICK UP OBJECT
LDB A,[POINT ITLEN,-MASK(FPD),ITLEN-1] ;PICK UP ATTRIBUTE
HASH (A,A,B)
SKIPN A,(A) ;CHECK TO SEE IF A-O-V IS THERE AT ALL
JRST [URSTAT <
AOS RCNT2 ;STATISTIC INCREMENT
>; URSTAT
POPJ P, ;FAIL
]
COMP2: MOVE B,1(A)
TRZ B,7777 ;MASK OUT VALUE.
CAMN B,-MASK(FPD) ;SEE IF IT MATCHES...
JRST YES2
URSTAT <
;------------------------LEAP STATISTICS INSTRUCTION------------
AOS RCNT2 ;INCREMENT LEAP STATISTIC
;--------------------------------------------------------------
>;URSTAT
HRRZ A,(A) ;CONFLICT.
JUMPN A,COMP2 ;LOOP
POPJ P, ;FAILURE
YES2: MOVE B,1(A) ;PICK IT UP AGAIN.
TRNE B,7777 ;COULD STILL BE A MULTIPLE HIT.
JRST PUT ;NOPE
HLRZ A,(A) ;POINTER TO MULTIPLE HITS.
HRRZ C,(A) ;POINTER TO NEXT ONE.
MOVEM C,-T2(FPD) ;SAVE FOR NEXT TIME.
PUTA: MOVE B,1(A) ;PICK UP A-O-V
PUT: MOVE C,-VALP(FPD) ;LOCAL NUMBER FOR VALUE
DPB B,MC(FRTAB) ;PUT IN SATISFIER TABLE.
AOS (P)
URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
AOS RCNT2 ;INCREMENT LEAP STATISTIC
AOS RSUC2 ;INCREMENT SUCCESS COUNT
;---------------------------------------------------------------
>;URSTAT
POPJ P, ;SUCCESSFUL RETURN
NEXT: SKIPE -VALP(FPD) ;ANY ?
SKIPN A,-T2(FPD) ;GET NEXT ONE
POPJ P, ;NONE.
HRRZ C,(A) ;POINTER TO NEXT.
MOVEM C,-T2(FPD) ;SAVE IT.
JRST PUTA ;GO GET THE VALUE.
>;NOURLEAP
; A XOR X EQV V
F3: AOSE -TT1(FPD) ;FIRST TIME
JRST NEXT3 ;NO
MOVE A,-VALP(FPD) ;VALUE
ADD A,INFOTAB(TABL) ;PREPARE TO GET VALUE LINK
HLRZ A,(A) ;VALUE LINK!
URLEAP <
NN: JUMPE A,CPOPJ ;IF ZERO, THERE IS NONE.
HLRZ B,1(A) ;GET BACK POINTER TO M.H. HEADER FOR THIS ASSOC
HLRZ C,1(B) ;GET ATTRIBUTE FROM M.H. HEADER
URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
AOS RCNT3 ;INCREMENT STATISTIC
;---------------------------------------------------------------
>;URSTAT
CAME C,-ATTP(FPD) ;IS IT THE DESIRED ONE?
JRST [HRRZ A,(A) ;GET POINTER TO NEXT VALUE BLOCK ON VALUE LIST
JRST NN] ;GO SEE IF IT WILL DO
HRRZ C,(A) ;GET POINTER TO NEXT VALUE BLOCK
MOVEM C,-T2(FPD) ;STASH IT AWAY FOR NEXT TIME
HRRZ B,1(B) ;GET OBJECT FROM M.H. HEADER
MOVE C,-OBJP(FPD) ;LOCAL # FOR OBJECT
HRLM B,@MC(FRTAB) ;STORE OBJECT IN SATISFIER TABLE
AOS (P) ;SIMULATE SKIP FOR SUCCESS-RETURN
URSTAT<
;-----------------LEAP STATISTICS--------------------------
AOS RSUC3 ;INCREMENT SUCCESS COUNT
;----------------------------------------------------------
>;URSTAT
POPJ P, ;GOODBYE
>;URLEAP
NOURLEAP<
JUMPE A,CPOPJ ;IF ZERO, THERE IS NONE.
NN: MOVE B,1(A) ;PICK UP A-O-V
AND B,[BYTE (ITLEN) 7777,0,7777]
URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
AOS RCNT3 ;INCREMENT STATISTIC
;---------------------------------------------------------------
>;URSTAT
CAME B,-MASK(FPD) ;IS THIS THE ONE?
JRST NO3
HLRZ C,(A) ;VALUE LINK
BRACKP C ;IF BRACKETED TRIPLE THEN
HLRZ C,(C) ;PASS UP BRACKET NUMBER
MOVEM C,-T2(FPD)
MOVE C,-OBJP(FPD) ;OBJECT NUMBER
LDB B,[POINT ITLEN,1(A),23]
DPB B,MC(FRTAB) ;STORE IN SATISFIER TABLE.
AOS (P)
URSTAT<
;-----------------LEAP STATISTICS--------------------------
AOS RSUC3 ;INCREMENT SUCCESS COUNT
;----------------------------------------------------------
>;URSTAT
POPJ P,
NO3: HLRZ A,(A) ;VALUE LINK
BRACKP A
HLRZ A,(A) ;PAST BRACKETED ITEM NUMBER.
JUMPN A,NN ;LOOP UNTIL EXHAUSTED
POPJ P, ;EXHAUSTED.
>;NOURLEAP
NEXT3: MOVE A,-T2(FPD) ;GET THE LAST POINTER
SKIPE -OBJP(FPD) ;OBJECT = ANY?
JUMPN A,NN ; -- WANT TO DO SEARCH AGAIN.
POPJ P,
; X XOR O EQV V
F4: AOSE -TT1(FPD) ;FIRST TIME
JRST NEXT4 ;NO
MOVE A,-VALP(FPD) ;VALUE
ADD A,INFOTAB(TABL) ;PREPARE TO GET VALUE LINK
HLRZ A,(A) ;VALUE LINK!
URLEAP <
NN4: JUMPE A,CPOPJ ;IF ZERO, THERE IS NONE.
HLRZ B,1(A) ;GET BACK POINTER TO M.H. HEADER FOR THIS ASSOC
HRRZ C,1(B) ;GET OBJECT FROM M.H. HEADER
URSTAT <
;---------------------LEAP STATISTICS INSTRUCTION---------------
AOS RCNT4 ;INCREMENT STATISTIC
;---------------------------------------------------------------
>;URSTAT
CAME C,-OBJP(FPD) ;IS IT THE DESIRED ONE?
JRST [HRRZ A,(A) ;GET POINTER TO NEXT VALUE BLOCK ON VALUE LIST
JRST NN4] ;GO SEE IF IT WILL DO
HRRZ C,(A) ;GET POINTER TO NEXT VALUE BLOCK
MOVEM C,-T2(FPD) ;STASH IT AWAY FOR NEXT TIME
HLRZ B,1(B) ;GET ATTRIBUTE FROM M.H. HEADER
MOVE C,-ATTP(FPD) ;LOCAL # FOR ATTRIBUTE
HRLM B,@MC(FRTAB) ;STORE ATTRIBUTE IN SATISFIER TABLE
AOS (P) ;SIMULATE SKIP FOR SUCCESS-RETURN
URSTAT<
;-----------------LEAP STATISTICS--------------------------
AOS RSUC4 ;INCREMENT SUCCESS COUNT
;----------------------------------------------------------
>;URSTAT
POPJ P, ;GOODBYE
NEXT4: MOVE A,-T2(FPD) ;GET THE LAST POINTER
SKIPE -ATTP(FPD) ;ATTRIBUTE = ANY?
JUMPN A,NN4 ; -- WANT TO DO SEARCH AGAIN.
POPJ P,
>;URLEAP
NOURLEAP<
JUMPE A,CPOPJ ;FAIL
NN4: MOVE B,1(A) ;A-O-V WORD
URSTAT <
;----------------------LEAP STATISTIC INSTRUCTION---------------
AOS RCNT4 ;INCREMENT STATISTIC
;---------------------------------------------------------------
>;URSTAT
TLZ B,777700 ;MASK OFF ATTRIBUTE
CAME B,-MASK(FPD) ;IS THIS THE ONE?
JRST NO4
HLRZ C,(A) ;VALUE LINK
BRACKP C ;TEST FOR BRACKETED TRIPLE.
HLRZ C,(C) ;PASS UP BRACKET ID NUMBER
MOVEM C,-T2(FPD) ;SAVE FOR NEXT TIME.
MOVE C,-ATTP(FPD) ;ATTRIBUTE ID NUMBER
LDB B,[POINT ITLEN,1(A),ITLEN-1];ATTRIBUTE NUMBER
DPB B,MC(FRTAB) ;STORE IN SATISFIER TABLE.
AOS (P)
URSTAT <
;----------------LEAP STATISTICS----------------------------
AOS RSUC4 ;INCREMENT SUCCESS COUNT
;-----------------------------------------------------------
>;URSTAT
POPJ P, ;RETURN....
NO4: HLRZ A,(A) ;VALUE LINK
BRACKP A ;TEST FOR BRACKETED TRIPLE.
HLRZ A,(A) ;PAST BRACKETED ITEM NUMBER.
JUMPN A,NN4
POPJ P, ;FAILED.
NEXT4: MOVE A,-T2(FPD) ;POINTER
SKIPE -ATTP(FPD) ; IS THE ATTRIBUTE "ANY" ?
JUMPN A,NN4 ; NO -- TRY TO CONTINUE SEARCH
POPJ P,
>;NOURLEAP
; X XOR Y EQV V
F5: MOVE A,-T2(FPD) ;FOR NEXT......
AOSE -TT1(FPD) ;BEEN HERE BEFORE?
JRST NEXT5 ;YUP
MOVE A,-VALP(FPD) ;VALUENUMBER
ADD A,INFOTAB(TABL) ;GET READY TO GET
HLRZ A,(A) ;VALUE LINK
JRST NEXT6 ;DO NOT CHECK FOR "ANY" FIRST TIME - KKP
NEXT5: SKIPN -ATTP(FPD) ;IF BOTH ARGS ARE "ANY", THEN
SKIPE -OBJP(FPD) ;RETURN IMMEDIATELY.
NEXT6: SKIPN A ;NOT THERE.
POPJ P,
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-----------
AOS RCNT5 ;INCREMENT STATISTIC
;-----------------------------------------------------------
>;URSTAT
URLEAP <
HRRZ B,(A) ;NEXT VALUE POINTER
MOVEM B,-T2(FPD) ;SAVE IT FOR NEXT TIME
HLRZ D,1(A) ;GET BACK POINTER TO M.H. HEADER
MOVE D,1(D) ;PICK UP ATTR-OBJ WORD
MOVE C,-ATTP(FPD) ;LOCAL # FOR ATTRIBUTE
HLLM D,@MC(FRTAB) ;STORE ATTRIBUTE IN SATISFIER TABLE
;; #NL# A XOR ANY EQV ANY , BOTH ANY'S DON'T HAVE TO MATCH;
SKIPE C,-OBJP(FPD) ;OBJECT ID NUMBER, IF ANY DON' WORRY
CAME C,-ATTP(FPD) ;ATTRIB AND OBJECT TO BE BOUND THE SAME?
JRST .+2
;; #NL#
JRST [HLRZ C,D ;ATTRIBUTE FROM A-O WORD
HRRZ D,D ;CLEAR L.H. D LEAVING OBJECT ONLY
CAIN C,(D) ;THE SAME?
JRST ROSP5 ;SINCE OBJECT IS ATTRIBUTE, IT'S ALREADY
;STORED, SO JUST SUCCEED-RETURN
MOVE A,B ;TRY AGAIN
JRST NEXT6]
HRLM D,@MC(FRTAB) ;STORE OBJECT IN SATISFIER TABLE
ROSP5:
URSTAT <
AOS RSUC5
>;URSTAT
>;URLEAP
NOURLEAP <
HLRZ C,(A) ;NEXT VALUE POINTER
BRACKP C ;TEST FOR BRACKETED TRIPLE.
HLRZ C,(C) ;PASS UP BRACKET ID NUMBER
MOVEM C,-T2(FPD)
MOVE B,1(A) ;A-O-V WORD.
ROT B,ITLEN ;ATTRIBUTE IS NOW LOW.
MOVE C,-ATTP(FPD) ;ATTRIBUTE NUMBER
DPB B,MC(FRTAB) ;STORE IN SATISFIER TABLE.
ROT B,ITLEN ;OJECT IS NOW LOW
;; #NL# A XOR ANY EQV ANY , BOTH ANY'S DON'T HAVE TO MATCH;
SKIPE C,-OBJP(FPD) ;OBJECT ID NUMBER, IF ANY DON' WORRY
CAME C,-ATTP(FPD) ;ATTRIB AND OBJECT TO BE BOUND THE SAME?
JRST .+2
;; #NL#
JRST [LDB D,MC(FRTAB) ;BINDING FOR ATTRIB.
ANDI B,7777 ;JUST THE OBJECT
CAIN D,(B) ;THE SAME?
JRST [
URSTAT < AOS RSUC5 >;URSTAT
JRST AOSP
]
MOVE A,-T2(FPD) ;TRY AGAIN
JRST NEXT6]
DPB B,MC(FRTAB)
>;NOURLEAP
AOSP: AOS (P)
POPJ P,
; A XOR X EQV Y
NOURHASH <
F6: AOSE -TT1(FPD)
JRST [SKIPE -VALP(FPD);IS VALUE "ANY" ?
JRST GRT6 ;NO -- CONTINUE SEARCH.
SKIPE -OBJP(FPD);IS OBJECT "ANY"
JRST UPDAT ;NO -- GO TO NEXT OBJECT.
POPJ P, ;YES-- IT WAS ANY AND ANY
]
GLOB <
TLNE FLAG,GLBSRC ;IF GLOBAL SEARCH,THEN
JRST [MOVE A,MAXITM+GLUSER ;START THE COUNT AT LOWEST GL. ITEM-KKP
DPB A,[POINT ITLEN,-MASK(FPD),2*ITLEN-1] ;
MOVEI B,(A) ;SO WE DON'T HAVE TO DO LDB - KKP
JRST UPDAT+3]; AND JUMP AROUND IT - KKP
>;GLOB
UPDAT: MOVEI A,1ITLEN ; 10000
ADDB A,-MASK(FPD) ; GO UP ONE ITEM NUMBER OBJ. POSITION
LDB B,[POINT ITLEN,A,2*ITLEN-1];OBJECT
GLOB <
CAIL B,TOPITM ;HAVE WE GONE OFF COMPLETELY??
POPJ P,
CAMGE B,MAXITM+GLUSER ; THIS MEANS ITEM IN GLOBAL AREA.
CAMG B,MAXITM(USER) ;THIS TESTS FOR ITEM IN LOCAL AREA.
JRST OKIT1 ;FINE...
MOVE B,MAXITM+GLUSER
DPB B,[POINT ITLEN,-MASK(FPD),2*ITLEN-1] ;PUT IT DOWN.
OKIT1:
>;GLOB
NOGLOB <
CAMLE B,MAXITM(USER) ;GONE FAR ENOUGH?
POPJ P, ;YES
>;NOGLOB
MOVE C,-OBJP(FPD) ;OBJECT ID NUMBER.
DPB B,MC(FRTAB) ;FILL SATISFIER
SETZM -T2(FPD) ;RESTART SEARCH
SETOM -TT1(FPD) ;RESTART SEARCH
GRT6:
URSTAT <
PUSH P,RCNT2
PUSH P,RSUC2
SETZM RCNT2
>;URSTAT
PUSHJ P,F2 ; A XOR O EQV X
JRST [ URSTAT <
MOVE B,RCNT2
ADDM B,RCNT6
POP P,RSUC2
POP P,RCNT2
>;URSTAT
JRST UPDAT]
URSTAT <MOVE B,RCNT2
ADDM B,RCNT6
POP P,RSUC2
POP P,RCNT2
>;URSTAT
SKIPE C,-VALP(FPD) ;ANY
CAME C,-OBJP(FPD) ;SAME OBJ,VAL ITEMVAR?
JRST ROSP6 ;NORMAL
LDB D,[POINT ITLEN,1(A),35] ;THE VALUE
LDB C,[POINT ITLEN,1(A),2*ITLEN-1];THE OBJECT
CAIE D,(C) ;THE SAME?
JRST GRT6 ;NO,TRY AGAIN.
ROSP6:
;-----------------LEAP STATISTICS------------------------
URSTAT< AOS RSUC6 >;URSTAT
;--------------------------------------------------------
JRST AOSP
; X XOR O EQV Y
F7: AOSE -TT1(FPD)
JRST [SKIPE -VALP(FPD);IS VALUE "ANY"
JRST GRT7 ;NO -- GO AHEAD
SKIPE -ATTP(FPD);IS ATTRIBUTE "ANY" ?
JRST UPDAT7 ;NO -- GET ANOTHER ATTRIBUTE
POPJ P,] ;NO -- GO AHEAD
GLOB <
TLNE FLAG,GLBSRC ;IF GLOBAL SEARCH.
JRST [MOVE A,MAXITM+GLUSER; SEE COMMENT ON LAST SEARCH - KKP
DPB A,[POINT ITLEN,-MASK(FPD),ITLEN-1]; START COUNT
MOVEI B,(A)
JRST UPDAT7+3] ;AT RIGHT PLACE.
>;GLOB
UPDAT7: MOVSI A,(1(2*ITLEN)) ; 1000
ADDB A,-MASK(FPD) ;UPDATE MASK ATTRIBUTE NUMBER
LDB B,[POINT ITLEN,A,ITLEN-1];ATTRIBUTENUMBER
GLOB <
CAIL B,TOPITM
POPJ P, ;GONE TOO FAR.
CAMGE B,MAXITM+GLUSER
CAMG B,MAXITM(USER) ;IN ALLOWED RANGE??
JRST OKIT2 ;YES
MOVE B,MAXITM+GLUSER ;NO -- BUMP IT UP.
DPB B,[POINT ITLEN,-MASK(FPD),ITLEN-1];PUT IT AWAY.
OKIT2:
>;GLOB
NOGLOB <
CAMLE B,MAXITM(USER) ;GONE FAR ENOUGH?
POPJ P,
>;NOGLOB
MOVE C,-ATTP(FPD) ;ATTRIBUTE ID NUMBER
DPB B,MC(FRTAB) ;FILL SATISFIER
SETZM -T2(FPD) ;RESTART SEARCH
SETOM -TT1(FPD) ;RESTART SEARCH
GRT7:
URSTAT <
PUSH P,RCNT2
PUSH P,RSUC2
SETZM RCNT2
>;URSTAT
PUSHJ P,F2 ; A XOR O EQV X
JRST [ URSTAT <
MOVE B,RCNT2
ADDM B,RCNT7
POP P,RSUC2
POP P,RCNT2
>;URSTAT
JRST UPDAT7]
URSTAT <MOVE B,RCNT2
ADDM B,RCNT7
POP P,RSUC2
POP P,RCNT2
>;URSTAT
SKIPE C,-VALP(FPD) ;THE VALUE SAT NO.
CAME C,-ATTP(FPD) ;THE ATTIB SAT NO.
JRST ROSP7 ;NOT SAME OR VAL ANY
LDB D,[POINT ITLEN,1(A),35]; THE VALUE
LDB C,[POINT ITLEN,1(A),ITLEN-1]; THE ATTRIB
CAIE D,(C) ;THE SAME?
JRST GRT7 ;NO, TRY AGAIN
ROSP7:
;--------------LEAP STATISTICS------------------------------
URSTAT< AOS RSUC7 >;URSTAT
;-----------------------------------------------------------
JRST AOSP
>;NOURHASH
URHASH <
; A XOR X EQV Y
F6: AOSE -TT1(FPD) ;HAVE WE BEEN HERE BEFORE?
JRST [SOS -TT1(FPD) ;UNDO DAMAGE FROM ABOVE
SKIPE -VALP(FPD) ;IS VALUE ANY?
JRST CONT6 ;IF NOT GET NEXT ONE
SKIPE -OBJP(FPD) ;IS OBJECT ANY?
JRST NXT6 ;GET NEXT OBJECT
POPJ P, ] ;JUST FAIL RETURN IF BOTH ANY
URLEAP <
HLRZ A,-MASK(FPD) ;PICK UP DESIRED ATTRIBUTE
>;URLEAP
NOURLEAP <
LDB A,[POINT ITLEN, -MASK(FPD), ITLEN-1]
>;NOURLEAP
LSH A,@RMASK3(TABL) ;BUILD RESULT OF HASHING WITH ZERO
TRZ A,@RMASK4(TABL)
AND A,HASMSK(TABL)
MOVEM A,-TT1(FPD) ;SAVE HASH OFFSET
JRST UPDT6
UPDAT6: AOS A,-TT1(FPD) ;INCREMENT HASH OFFSET
AND A,RMASK4(TABL) ;HAVE WE TRIED ALL POSSIBILITIES?
JUMPE A,CPOPJ ;IF SO, FAIL-RETURN
MOVE A,-TT1(FPD) ;PICK UP HASH OFFSET AGAIN
UPDT6: ADD A,HASTAB(TABL) ;MAKE HASH POINTER
SKIPN A,(A) ;IS ANYTHING THERE?
URSTAT <
JRST [AOS RCNT6
JRST UPDAT6]
>;URSTAT
NOURSTAT<
JRST UPDAT6 ;TRY THE NEXT HASH POSITION
>;NOURSTAT
URLEAP <
COMP6: HLLZ B,1(A) ;GET ATTRIBUTE FROM THIS M.H. BLOCK
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-------------
AOS RCNT6
;---------------------------------------------------------------
>;URSTAT
CAMN B,-MASK(FPD) ;IS IT THE ONE WE'RE LOOKING FOR?
JRST YES6 ;GOOD-OH
HRRZ A,(A) ;GO DOWN CONFLICT LIST TO NEXT M.H.
JUMPN A,COMP6 ;SEE IF ITS ATTRIBUTE IS O.K.
JRST UPDAT6 ;OTHERWISE TRY A NEW HASH POSITION
YES6: HRRZ B,(A) ;GET POINTER TO NEXT M.H. HEADER
HRRZM B,-T2(FPD) ;SAVE IT FOR NEXT TIME
HRRZ B,1(A) ;PICK UP OBJECT FOR THESE ASSOCIATIONS
MOVE C,-OBJP(FPD) ;LOCAL # FOR OBJECT
HRLM B,@MC(FRTAB) ;SAVE IT IN SATISFIER BLOCK
HLRZ A,(A) ;GET ADDR OF FIRST VALUE BLOCK
YES6A: HLRZ D,(A) ;ADDR OF NEXT VALUE BLOCK
URSTAT <
AOS RCNT6
>;URSTAT
HRLM D,-T2(FPD) ;SAVE IT FOR NEXT TIME
HRRZ D,1(A) ;GET VALUE ITEM FROM THIS VALUE BLOCK
SKIPN C,-VALP(FPD) ;PICK UP LOCAL # FOR VALUE
URSTAT <
JRST [ROSP6: AOS RSUC6
JRST AOSP
]
>;URSTAT
NOURSTAT<
JRST AOSP ;SUCCEED-RETURN IF IT'S ANY
>;NOURSTAT
HRLM D,@MC(FRTAB) ;STORE VALUE IN SATISFIER TABLE
CAIE B,(D) ;IF VALUE & OBJECT ITEMS ARE THE SAME ...
CAME C,-OBJP(FPD) ;... OR THE LOCALS ARE DIFFERENT ...
URSTAT <
JRST ROSP6
>;URSTAT
NOURSTAT<
JRST AOSP ;... THEN EVERYTHING'S COOL
>;NOURSTAT
;IF WE FALL THROUGH HERE, WE WERE LOOKING FOR AN ASSOCIATION WITH IDENTICAL
;OBJECT AND VALUE, WE DIDN'T FIND IT, AND WE HAVE TO KEEP LOOKING.
CONT6: HLRZ A,-T2(FPD) ;NEXT VALUE BLOCK ON M.H. LIST
JUMPN A,YES6A
NXT6: HRRZ A,-T2(FPD) ;NEXT M.H. BLOCK ON CONFLICT LIST
JUMPN A,COMP6
JRST UPDAT6 ;IF ALL ELSE FAILS, TRY HASH
>;URLEAP
NOURLEAP <
COMP6: MOVE B,1(A)
AND B,[777700000000]
CAMN B,-MASK(FPD)
JRST YES6
HRRZ A,(A)
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-------------
AOS RCNT6
;---------------------------------------------------------------
>;URSTAT
JUMPN A,COMP6
JRST UPDAT6
YES6: HRRZ C,(A)
MOVEM C,-T2(FPD)
MOVE B,1(A)
TRNE B,1ITLEN-1
JRST PUT6
HLRZ A,(A)
NEXTH6: HRL C,(A)
HRR C,-T2(FPD)
MOVEM C,-T2(FPD)
PUT6: MOVE B,1(A)
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION------------
AOS RCNT6
;--------------------------------------------------------------
>;URSTAT
MOVE C,-VALP(FPD)
DPB B,MC(FRTAB)
LSH B,-14
MOVE C,-OBJP(FPD)
DPB B,MC(FRTAB)
SKIPE C,-VALP(FPD)
CAME C,-OBJP(FPD)
JRST ROSP6
MOVE B,1(A)
LDB C,[POINT ITLEN,B,35]
LDB D,[POINT ITLEN,B,2*ITLEN-1]
CAIN D,(C)
JRST ROSP6
CONT6: HLRZ A,-T2(FPD)
JUMPN A,NEXTH6
NXT6: HRRZ A,-T2(FPD)
JUMPN A,COMP6
JRST UPDAT6
ROSP6:
;-----------LEAP STATISTICS-------------------------------
URSTAT< AOS RSUC6 >;URSTAT
;---------------------------------------------------------
JRST AOSP
>;NOURLEAP
; X XOR O EQV Y
F7: AOSE -TT1(FPD)
JRST [SOS -TT1(FPD)
SKIPE -VALP(FPD)
JRST CONT7
SKIPE -ATTP(FPD)
JRST NEXT7
POPJ P, ]
URLEAP <
HRRZ A,-MASK(FPD) ;PICK UP DESIRED OBJECT
>;URLEAP
NOURLEAP <
LDB A,[POINT ITLEN, -MASK(FPD), 2*ITLEN-1]
>;NOURLEAP
AND A,RMASK1(TABL)
MOVEM A,-TT1(FPD)
JRST UPDT7
UPDAT7: MOVE A,RMASK2(TABL)
ADDB A,-TT1(FPD)
TRZ A,@RMASK1(TABL)
AND A,HASMSK(TABL)
JUMPE A,CPOPJ ;FAIL-RETURN IF WE'VE TRIED EVERYTHING
MOVE A,-TT1(FPD)
UPDT7: ADD A,HASTAB(TABL)
SKIPN A,(A)
URSTAT <
JRST [AOS RCNT7
JRST UPDAT7]
>;URSTAT
NOURSTAT<
JRST UPDAT7 ;TRY AGAIN IF NOBODY'S HOME
>;NOURSTAT
;INCREMENT LEAP STATISTIC (SEE ABOVE)
URLEAP <
COMP7: HRRZ B,1(A) ;PICK UP OBJECT FOR THESE ASSOCIATIONS
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-------------
AOS RCNT7
;---------------------------------------------------------------
>;URSTAT
CAMN B,-MASK(FPD)
JRST YES7
HRRZ A,(A)
JUMPN A,COMP7
JRST UPDAT7
YES7: HRRZ B,(A) ;GET POINTER TO NEXT M.H. HEADER
HRRZM B,-T2(FPD) ;SAVE IT FOR NEXT TIME
HLRZ B,1(A) ;PICK UP ATTRIBUTE FOR THESE ASSOCIATIONS
MOVE C,-ATTP(FPD) ;LOCAL # FOR ATTRIBUTE
HRLM B,@MC(FRTAB) ;SAVE IT IN SATISFIER BLOCK
HLRZ A,(A) ;GET ADDR OF FIRST VALUE BLOCK
YES7A: HLRZ D,(A) ;ADDR OF NEXT VALUE BLOCK
URSTAT <
AOS RCNT7
>;URSTAT
HRLM D,-T2(FPD) ;SAVE IT FOR NEXT TIME
HRRZ D,1(A) ;GET VALUE ITEM FROM THIS VALUE BLOCK
SKIPN C,-VALP(FPD) ;PICK UP LOCAL # FOR VALUE
URSTAT <
JRST [
ROSP7: AOS RSUC7
JRST AOSP
]
>;URSTAT
NOURSTAT<
JRST AOSP ;SUCCEED-RETURN IF IT'S ANY
>;NOURSTAT
HRLM D,@MC(FRTAB) ;STORE VALUE IN SATISFIER TABLE
CAIE B,(D) ;IF VALUE & ATTRIBUTE ITEMS ARE THE SAME ...
CAME C,-ATTP(FPD) ;... OR THE LOCALS ARE DIFFERENT ...
URSTAT <
JRST ROSP7
>;URSTAT
NOURSTAT<
JRST AOSP ;... THEN EVERYTHING'S COOL
>;NOURSTAT
;IF WE FALL THROUGH HERE, WE WERE LOOKING FOR AN ASSOCIATION WITH IDENTICAL
;ATTRIBUTE AND VALUE, WE DIDN'T FIND IT, AND WE HAVE TO KEEP LOOKING.
CONT7: HLRZ A,-T2(FPD) ;NEXT VALUE BLOCK ON M.H. LIST
JUMPN A,YES7A
NEXT7: HRRZ A,-T2(FPD) ;NEXT M.H. BLOCK ON CONFLICT LIST
JUMPN A,COMP7
JRST UPDAT7 ;IF ALL ELSE FAILS, TRY HASH
>;URLEAP
NOURLEAP <
COMP7: MOVE B,1(A)
AND B,[000077770000]
CAMN B,-MASK(FPD)
JRST YES7
HRRZ A,(A)
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION-------------
AOS RCNT7
;---------------------------------------------------------------
>;URSTAT
JUMPN A,COMP7
JRST UPDAT7
YES7: HRRZ C,(A)
MOVEM C,-T2(FPD)
MOVE B,1(A)
TRNE B,1ITLEN-1
JRST PUT7
HLRZ A,(A)
NEXTH7: HRL C,(A)
HRR C,-T2(FPD)
MOVEM C,-T2(FPD)
PUT7: MOVE B,1(A)
URSTAT <
;-----------------------LEAP STATISTICS INSTRUCTION---------
AOS RCNT7
;---------------------------------------------------------------
>;URSTAT
MOVE C,-VALP(FPD)
DPB B,MC(FRTAB)
LSH B,-30
MOVE C,-ATTP(FPD)
DPB B,MC(FRTAB)
SKIPE C,-VALP(FPD)
CAME C,-ATTP(FPD)
JRST ROSP7
MOVE B,1(A)
LDB C,[POINT ITLEN,B,35]
LDB D,[POINT ITLEN,B,ITLEN-1]
CAIN D,(C)
JRST ROSP7
CONT7: HLRZ A,-T2(FPD)
JUMPN A,NEXTH7
NEXT7: HRRZ A,-T2(FPD)
JUMPN A,COMP7
JRST UPDAT7
ROSP7:
;-----------LEAP STATISTICS------------------------------
URSTAT< AOS RSUC7 >;URSTAT
;--------------------------------------------------------
JRST AOSP
>;NOURLEAP
>;URHASH
F8: ERR <ASSOCIATIVE SEARCH WITH NOTHING BOUND>,1
POPJ P, ;ALWAYS FAIL
; X IN S
S1: MOVE A,-T2(FPD) ;IN CASE OF NEXT
AOSE -TT1(FPD)
JRST NEXS1 ;BEEN HERE BEFORE
SKIPN A,-SETP(FPD)
POPJ P, ;NULL SET
HRRZ A,(A) ;GET PAST SET HEADER
NEXS1: JUMPE A,CPOPJ ;DONE
HLRZ B,(A) ;ITEM NUMBER
MOVE C,-ITMP(FPD) ;DESTINATION TEMP
URLEAP <
HRLM B,@MC(FRTAB)
>;URLEAP
NOURLEAP <
DPB B,MC(FRTAB)
>;NOURLEAP
HRRZ B,(A) ;NEXT POINTER.
MOVEM B,-T2(FPD) ;FOR NEXT TIME.
AOS (P)
POPJ P, ;SUCCESS.
; A IN S
S2: AOSE -TT1(FPD) ;SO THAT YOU DON'T
POPJ P, ;GO THROUGH TWICE
SKIPN A,-SETP(FPD) ;PICK UP SET POINTER
POPJ P, ;NULL SET
HRRZ A,(A) ;PASS UP HEADER
NXT: JUMPE A,CPOPJ ;GONE TO END AND NOT FOUND.
HLRZ B,(A)
CAMN B,-ITMP(FPD) ;RIGHT ONE?
JRST YESS1
HRRZ A,(A)
JRST NXT
YESS1: AOS (P)
CPOPJ: POPJ P,
DSCR FORSET AND NOFOR -- MAKE A SEARCH CONTROL BLOCK
THESE ROUTINES TAKE ENTRIES OFF THE STACK (P) AND
MAKE UP SEARCH CONTROL BLOCKS BASED ON THESE ENTRIES AND
THE CONTENTS OF THE FLAG WORD. THESE ROUTINES ARE
CALLED BY THE FOREACH INTERPRETER, THE ERASE CODE,
AND SOME OF THE "IS THIS ASSOCIATION IN THE STORE"
ROUTINES.
THE DIFFERENCE BETWEEN THE ROUTINES IS THIS:
NOFOR HANDLES "ANY" CONSTRUCTS DIFFERENTLY. THE SEARCH ROUTINES
ARE CAPABLE OF CUTTING SHORT THEIR SEARCHES, BASED ON THE
EXISTENCE OF AN "ANY". THIS IS A FINE IDEA FOR THE
FOREACH STATEMENT, SINCE THE USER IS NOT INTERESTED
IN THE ACTUAL ITEMS WHICH WILL MATCH THE "ANY".
HOWEVER, THE ERASE CODE IS VITALLY INTERESTED, SINCE
IT MUST ERASE ALL OF THEM. SO:
NOFOR -- CALL IF YOU WANT SEARCH CONTROL BLOCK WHICH WILL
RETURN ON ALL SUCCESSFUL MATCHES TO "ANY"
FORSET -- CALL IF YOU WANT THE ABBREVIATED SEARCHES.
CALLS: BOTH WITH JSP LPSA,xxxx
;
NOFOR: ;ONLY CALLED BY ERASE
MOVE FRTAB,LEABOT(USER) ;ALWAYS AVAILABLE BLOCK
SKIPE -2(P) ;ANY?
JRST NOFOR1 ;NO.
TLO FLAG,BINDINGATTPOS
MOVEI A,1 ;THIS WILL BE THE SATISFIER NO.
MOVEM A,-2(P) ;THEN FIX.
NOFOR1: SKIPE -1(P)
JRST NOFOR2
TLO FLAG,BINDINGOBJPOS
MOVEI A,2 ;MAKE THEM ALL DIFFERENT
MOVEM A,-1(P)
NOFOR2: SKIPE (P)
JRST FORSET
TLO FLAG,BINDINGVALPOS
MOVEI A,3
MOVEM A,(P) ;THE COMPILER CAN'T REALLY DO THIS.
;SINCE ANY CAN NOW BE STORED IN ITEMVARS
FORSET: MOVE FPD,FPDP(FRTAB) ;PICK UP THE LEAP PUSH-DOWN POINTER.
TLNE FLAG,SETOP
AOBJN FPD,P2 ;NO ENTRY IF A SET.
TLNE FLAG,BRACKET ;IF BRACKETED TRIPLE SEARCH.
POP P,D ;THE BRACKETED ITEM NUMBER
P3: POP P,B ;THE VALUE
TLNE FLAG,BOUNDVALPOS ;IF VALUE IS A BOUND ITEMVAR, THEN
XCT MOVEB(FRTAB) ;GET THE SATISFIER FROM THE TABLE.
NOURLEAP <
TRZ B,BNDFOR ;TURN OFF "BOUND"BIT
>;NOURLEAP
JUMPN B,.+2
TLO FLAG,BINDINGVALPOS ;VALUE IS "ANY"
PUSH FPD,B
URLEAP <
GLOB <
TLNE FLAG,BINDINGVALPOS ;IS ENTRY UNBOUND?
JRST P2 ;NOT BOUND
TLNE FLAG,GLBSRC ;GLOBAL SEARCH?
CAIGE B,GBRK ;WITH LOCAL ITEM?
;ABOVE SKIP GOES TO P2
ERR <GLOBAL SEARCH WITH LOCAL ITEM>,1
>;GLOB
;VALUE DOESN'T GO INTO MASK IN URLEAP
>;URLEAP
NOURLEAP <
TLNE FLAG,BINDINGVALPOS ;IS ENTRY UNBOUND?
GLOB <
JRST P3A ;NOT BOUND
TLNE FLAG,GLBSRC ;GLOBAL SEARCH?
CAIL B,GBRK ;WITH LOCAL ITEM?
JRST P3OK
ERR <GLOBAL SEARCH WITH LOCAL ITEM>,1
SKIPA
P3A:
>;GLOB
SETZM B ;ZERO UNBOUND ENTRY
P3OK:
LSHC B,-ITLEN ;MAKE UP MASK IN C.
>;NOURLEAP
P2: POP P,B
TLNE FLAG,BOUNDOBJPOS
XCT MOVEB(FRTAB)
NOURLEAP <
;;#JL# BY JRL 10-4-72 SETS NOT POT(ENTIALLY) BOUND
TLNN FLAG,SETOP ;BNDFOR ONLY FOR ITEMS
TRZ B,BNDFOR
>;NOURLEAP
JUMPN B,.+2
TLO FLAG,BINDINGOBJPOS ;OBJECT IS ANY.
PUSH FPD,B
TLNE FLAG,BINDINGOBJPOS
GLOB <
JRST P2A ;UNBOUND ENTRY
TLNE FLAG,SETOP ;A SET OPERATION?
JRST P2OK ;YES.
TLNE FLAG,GLBSRC ;GLOBAL SEARCH?
CAIL B,GBRK ;GLOBAL ITEM?
JRST P2OK ;ALL OK.
ERR <GLOBAL SEARCH WITH LOCAL ITEM>,1
SKIPA
P2A:
>;GLOB
SETZM B
P2OK:
URLEAP <
MOVE C,B ;SAVE OBJECT IN C FOR MASK
>;URLEAP
NOURLEAP <
LSHC B,-ITLEN
>;NOURLEAP
P1: POP P,B ;ATTRIBUTE
TLNE FLAG,BOUNDATTPOS
XCT MOVEB(FRTAB)
NOURLEAP <
TRZ B,BNDFOR
>;NOURLEAP
JUMPN B,.+2
TLO FLAG,BINDINGATTPOS ;ATTRIB IS ANY
PUSH FPD,B
TLNE FLAG,BINDINGATTPOS
GLOB <
JRST P1A
TLNE FLAG,GLBSRC
CAIL B,GBRK
JRST P1OK
ERR <GLOBAL SEARCH WITH LOCAL ITEM>,1
SKIPA
P1A:
>;GLOB
SETZM B
P1OK:
URLEAP <
HRL C,B ;MASK IS ATTRIBUTE,,OBJECT
>;URLEAP
NOURLEAP <
LSHC B,-ITLEN
>;NOURLEAP
SETZM INDEX4(FRTAB)
PUSH FPD,C ;THE MASK OF A-O ( -V IF NOURLEAP )
;UNBOUND PORTIONS OF THE MASK ARE 0
PUSH FPD,[-1] ;INITIAL -TT1(FPD)
PUSH FPD,[0] ;INITIAL -T2(FPD)
TLNE FLAG,SETOP ;DON'T COMPUTE ROUTINE NAME FOR SET SEARCH
JRST STSRCH
HRRI FLAG,0
TLNE FLAG,BINDINGATTPOS
TRO FLAG,1
TLNE FLAG,BINDINGOBJPOS
TRO FLAG,2
TLNE FLAG,BINDINGVALPOS
TRO FLAG,4
STSRCH:
PUSH FPD,FLAG ;SAVE THE ROUTINE NAME.
PUSH FPD,UUO1(USER) ;SAVE RETURN ADDRESS.(on success)
HRLM D,(FPD) ;SAVE BRACKETED ITEM # IN LH.
JRST (LPSA) ;ALL DONE.
DSCR FOREACH STATEMENT INTERPRETER
THERE ARE SEVERAL ROUTINES IN THIS SECTION:
FORGO -- CALLED TO INITIALIZE A FOREACH STATEMENT.
RECORDS FAILURE ADDRESS.
RECORDS COUNT AND ADDRESSES OF FREE ITEMVARS.
FRGO -- TO INITIALIZE A PART OF LEAP CORE (JUST LIKE THE
LEABOT(USER) AREA) TO USE AS A SEARCH CONTROL
BLOCK.
FDONE -- WHEN THE OUTERMOST SEARCH IN THE FOREACH STAT.
FAILS, THIS IS CALLED. IT MERELY TAKES THE
FAILURE EXIT FROM THE FOREACH STATEMENT.
FDONS -- USED BY THE "DONE" CONSTRUCT (OR BY A "GO TO")
WHEN EXITING FROM INSIDE A FOREACH STATEMENT -- THE
IDEA IS TO BACK UP THE NESTING OF FOREACH SEARCHES BY
ONE, AND DO SOME BOOKEEPING.
FRPOP -- CALLED AT END OF SEARCH SPECIFICATIONS IN FOREACH
OR WHEN PREPARING FOR A BOOLEAN EXPRESSION INSIDE
A FOREACH SPECIF. THIS COPIES CURRENT SATISFIER
VALUES INTO THEIR REAL USER CORE ADDRESSES (AS RECORDED
BY FORGO).
FRFAL -- WHEN BOOLEAN FAILS WITHIN FOREACH. FIRE UP SEARCHES AGAIN
DOAG -- CALLED AT THE BOTTOM OF THE FOREACH LOOP. CAUSES
THE SEARCHES TO BE FIRED UP TO FIND THE NEXT GROUP OF
SATISFIERS.
FOREC -- MAIN CALL TO START A TRIPLE SEARCH, AS SPECIFIED
IN THE FOREACH SPECIFICATION. A,O, AND V ARE ON THE
STACK.
LD1,LD2,LD3 -- CALLED BY "DERIVED SETS" INSIDE A FOREACH SPEC.
SPECIAL ADJUSTMENTS ARE MADE TO THE STACK (TO REORDER
OPERANDS).
;
LD3: MOVE B,(P) ;IN IS O,V,X
EXCH B,-2(P)
JRST LD22
LD2: MOVE B,(P) ;IN IS A,V,X
LD22: EXCH B,-1(P) ;MAKE IT A XOR X EQV V
MOVEM B,(P)
;COMPILER HAS FIXED UP THE BITS
;CORRECTLY ALREADY.
LD1:
^FOREC: MOVE FRTAB,FRLOC(USER); CURRENT SCB
SKIPE A,RUNNER ;ARE THERE PROCESSES?
MOVE FRTAB,CURSCB(A) ;THEN LOAD FROM PVAR AREA
SETZB LPSA,D ;MAIN FOREACH SPECIFICATION PROCESSOR.
GLOB <
NOSEC ;FAKE IT BACK. YOU ARE NOT
;CONSIDERED "ENTERED" WHEN RUNNING
;FOREACHES......
>;GLOB
ADD FLAG,INDEX4(FRTAB)
SETZM INDEX4(FRTAB)
JSP LPSA,FORSET ;SET UP THE SEARCH CONTROL BLOCK.
GO: ;LOOP BACK TO HERE TO DO SEARCHES.
GLOB <
MOVE FLAG,-1(FPD) ;PICK UP ROUTINE NAME.
MOVEI TABL,(USER)
TLNE FLAG,GLBSRC ;IF GLOBAL, THEN
MOVEI TABL,GLUSER ;REARRANGE.
JUMPL FLAG,BRACK ;AND GO IF BRACKETED TRIPLE SEARCH.
>;GLOB
NOGLOB <
SKIPG FLAG,-1(FPD) ;PICK UP ROUTINE NAME.
JRST BRACK ;BRACKETED SEARCH
>;NOGLOB
PUSHJ P,@SEROUT(FLAG) ;CALL THE ROUTINE.
JRST FAIL ;IT FAILED IF IT CAME HERE.
;BACK UP THE SEARCH TO NEXT OUTER.
SUCC: MOVEM FPD,FPDP(FRTAB) ;SAVE PUSH-DOWN POINTER
MOVE FPD,(FPD) ;RETURN ADDRESS (LEFT HALF HAS STUFF)
JRST (FPD) ;RETURN
;THIS DOES NOT RETURN THROUGH
;"LEAV".
GLOB <
;HENCE WE SEE THAT YOU ARE REALLY NOT "ENTERED"
;WHEN EXECUTING THIS CODE.
>;GLOB
FAIL: MOVE FLAG,-1(FPD) ;THE CONTROL WORD.
SKIPGE A,-SETP(FPD) ;IF SET NEEDS RECLAIMING
TLNN FLAG,SETOP ;WAS THIS A SET?
JRST FAIGO
MOVE B,FP1(USER) ;PREPARE TO RECLAIM TEMP SET.
HLRZ C,(A)
HRRZM B,(C) ;PUT IN DOWN POINTER.
HRRM A,FP1(USER) ;AND UPDATE FREE LIST.
FAIGO: SUB FPD,[XWD LENFPD,LENFPD]
JRST GO ;USE THE NEXT HIGHER ROUTINE.
BRACK: ;IF BRACKETED TRIPLE SEARCH.
PUSHJ P,@SEROUT(FLAG) ;CALL THE ROUTINE.
JRST FAIL ;FAIL....
URLEAP <
;ON SUCCESSFUL RETURN FROM SEARCH, A POINTS TO ASSOCIATION. WE HAVE TO
;SEE IF THERE IS A BRACKETED TRIPLE BLOCK INDICATING THAT THIS ASSOCIATION
;IS A BRACKETED TRIPLE
;L.H. OF A BETTER BE ZERO
MOVEI B,BRACKL(TABL) ;GET ADDRESS OF LIST OF B.T. BLOCKS
BRCK1: HRRZ B,(B) ;GET NEXT B.T. BLOCK (ITEM # IN L.H.)
JUMPE B,[HRRZ FLAG,-1(FPD) ;NO MORE B.T. BLOCKS ...
JRST BRACK] ;... LOOK FOR ANOTHER ASSOCIATION
CAME A,1(B) ;DOES THIS B.T. BLOCK REFER TO THIS ASSOC?
JRST BRCK1 ;NO - TRY ANOTHER B.T. BLOCK
HLRZ B,(B) ;GET ITEM # FOR THIS ASSOC FROM B.T. BLOCK
HLRZ C,(FPD) ;LOCAL # THAT REQUESTED IT
HRLM B,@MC(FRTAB) ;SAVE IT IN SATISFIER TABLE (LOCAL # IN C)
>;URLEAP
NOURLEAP <
HLRZ B,(A) ;A POINTS TO THING FOUND.
BRACKN B ;IS THIS A BRACKETED TRIPLE?
JRST [HRRZ FLAG,-1(FPD) ;NO -- GET CONTROL WORD AGAIN.
JRST BRACK] ;AND TRY AGAIN.
HRRZ B,(B) ;THIS IS THE ITEM ## BRACKET.
HLRZ C,(FPD) ;THIS IS THE LOCAL NUMBER
;FOR THE BRACKETED #
DPB B,MC(FRTAB) ;STORE AWAY THE LOCAL.
>;NOURLEAP
JRST SUCC ;GOOD-BYE
;JRST TO DOAG, FRFAL
^DOAG:
MOVE FRTAB,FRLOC(USER) ;CURRENT SCB
SKIPE A,RUNNER ;ARE THERE PROCESSES?
MOVE FRTAB,CURSCB(A) ;LOAD FROM PVAR AREA
HRRE A,SCNT(FRTAB) ;NUMBER OF SATS TO SAVE
MOVEI B,SATIS+1(FRTAB)
DOAGLP: AOJG A,FRFAL2 ;THROUGH GETTING CURRENT VALS?
URLEAP <
SKIPG OLDSAT-SATIS-1(B) ;WAS THIS A ? LOCAL ALREADY BOUND?
AOJA B,DOAGLP ;YES.
MOVE C,(B) ;GET THE CURRENT SATISFIER
HLRM C,OLDSAT-SATIS-1(B) ;DEPOSIT LATEST SATISFIER
>;URLEAP
NOURLEAP <
SKIPG C,(B) ;WAS THIS A ? LOCAL ALREADY BOUND?
AOJA B,DOAGLP ;YES.
HLRZM C,OLDSAT-SATIS-1(B) ;DEPOSIT LATEST SATISFIER
>;NOURLEAP
AOJA B,DOAGLP ;LOOP
^FRFAL:
MOVE FRTAB,FRLOC(USER) ;CURRENT SCB
SKIPE A,RUNNER ;ARE THERE PROCESSES?
MOVE FRTAB,CURSCB(A) ;LOAD FROM PVAR AREA
FRFAL2: MOVE FPD,FPDP(FRTAB) ;RESTORE PUSHDOWN POINTER.
JRST GO ;CALL THE RIGHT ROUTINE.
;JRST TO FORGO
^FORGO:
SKIPN B,SCBCHN(USER) ;FREE SCB'S?
JRST [PUSH P,TAC1 ;CORGET WILL DESTROY
LPCOR (<FRCHLEN>) ; NO GO GET ONE.
POP P,TAC1 ;RESTORE IT
JRST HAVSCB]
HRRZ A,SCBLNK(B) ;ADDRESS NEXT FREE SCB
MOVEM A,SCBCHN(USER) ;UPDATE FREE SCB CHAIN
HAVSCB: HRRZ A,FRLOC(USER) ;DYNAMIC NESTING SCB
SKIPE D,RUNNER
HRRZ A,CURSCB(D)
HRL A,(P) ;ADDRESS SCB POINTER
MOVEM A,SCBLNK(B) ;DYNAMIC SCB CHAIN
POP P,A ;ADDRESS SCB POINTER
MOVEM B,(A) ;PUT POINTER IN.
HRL B,A
MOVEM B,FRLOC(USER) ;HANDLE TO CURRENT SCB
SKIPE D,RUNNER
MOVEM B,CURSCB(D)
MOVEI FP,FREND ;IN LINE CALL TO FRGO
FRGO:
MOVEI A,FPDL-1(B) ;PUSHDOWN LIST.
HRLI A,-FPDLEN ;AND LENGTH.
HRRI C,SATIS(B) ;SATISFIER LIST.
HRLI C,(<HLRZ A,(A)>)
MOVEM C,MOVEA(B) ;THIS IS THE "UPDATE "A" INSTRUCTION".
HRLI C,(<HLRZ B,(B)>)
MOVEM C,MOVEB(B) ;AND FOR B.
URLEAP <
HRLI C,(<HRLM C,(C)>)
>;URLEAP
NOURLEAP <
HRLI C,(<POINT 12,(C),17>)
>;NOURLEAP
MOVEM C,MC(B) ;INDIRECT WORD (BYTE POINTER IF NOURLEAP) FOR
;PUTTING AWAY SATISFIERS.
PUSH A,[XWD 0,-1] ;TO CALL FDONE WHEN ALL DONE.
PUSH A,(TAC1) ;THIS IS THE JUMP OUT OF THE FOREACH.
;TAC1 THAT IS FRTAB CONTAINS ADDRESS OF SATISFIER INFO BLOCK FROM CALLER
MOVEM A,FPDP(B) ;AND SAVE THE PUSH-DOWN POINTER.
JRST (FP)
FREND: ADDI TAC1,1 ;INCREMENT OVER JRST WORD.
MOVEI D,SATIS+1(B) ;BEGINNING OF SATISFIER TABLE.
MOVN A,(TAC1) ; - COUNT OF LOCALS IN THIS LIST.
MOVEM A,SCNT(B) ;KEEP TRACK FOR THE POPPING OFF.
LOP: ADDI TAC1,1 ;THIS COUNTS UP!
AOJG A,LEAV ;DONE, BY GOOOLLY
MOVE C,(TAC1) ;THE LOCAL WORD
TLNN C,CDISP ;A DISPLAY NEEDED?
JRST NODISP ;NO.
;; #OW# !(1 OF 3) USED TO BE POINT,(C) BY MISTAKE
LDB B,[POINT 4,C,17] ;PICK UP DISPLAY DIFFERENCE
MOVEI LPSA,(RF) ;THE CURRENT DISPLAY
LPDISP:
;; #OW# !(2 OF 3) JRL USED TO BE MOVE. LH SCREWED UP TLNE C, BELOW
HRRZ LPSA,1(LPSA) ;BACK THE STATIC LINK
SOJG B,LPDISP ;COUNT DOWN DIFFERENCE
;; #OW# !(3 OF 3) JRL USED TO BE ADD LPSA,(C)
ADD LPSA,C ;ADD THE DISPLACEMENT
TLNE C,20 ;REFERENCE PARAMETER?
HRRZ LPSA,(LPSA) ;YES
JRST HAVEAD
NODISP: MOVEI LPSA,@C ;MUCH EASIER
HAVEAD: TLNN C,MPPAR ;A ? PARAMETER?
JRST CALPOT ;NO.
MOVE B,(LPSA)
TLZE B,20 ;BOUND?
MOVEI LPSA,(B) ;NO.
CALPOT:
HRRZ B,(LPSA) ;PICK UP CURRENT VALUE
MOVEM B,OLDSAT-SATIS-1(D) ;SAVE CURRENT VALUE FOR BACKUP
TLNE C,POTUNB ;A POTUNB LOCAL(?)
CAIN B,UNBND ;AND UNBOUND
CAIA
NOURLEAP <
TRO B,BNDFOR ;MARK AS BOUND ON ENTRY
>;NOURLEAP
URLEAP <
HRROS OLDSAT-SATIS-1(D) ;MARK OLDSAT INSTEAD
>;URLEAP
HRL LPSA,B ;GET CURRENT VALUE IF BOUND
MOVEM LPSA,(D) ;SAVE IN SATIS TABLE
AOJA D,LOP ;LOOP
;FDONE WHEN ALL TESTS EXHAUSTED END FOREACH
FDONE: MOVE FP,(FPD) ;RETURN ADDRESS.
;RESTORE LAST SUCCESSFUL SATISFIER GROUP
HRRE A,SCNT(FRTAB)
MOVEI B,SATIS+1(FRTAB)
LPDONE: AOJG A,RESTSCB
URLEAP <
SKIPG OLDSAT-SATIS-1(B) ;A ?LOCAL BOUND ON ENTRY?
AOJA B,LPDONE ;YES.
MOVE C,(B) ;GET LOCAL ADDRESS FROM SATISFIER TABLE
HRRZ D,OLDSAT-SATIS-1(B) ;PICK UP LATEST SATISFIER
>;URLEAP
NOURLEAP <
SKIPG C,(B) ;A ?LOCAL BOUND ON ENTRY?
AOJA B,LPDONE ;YES.
MOVE D,OLDSAT-SATIS-1(B) ;PICK UP LATEST SATISFIER
>;NOURLEAP
MOVEM D,(C) ;STORE INTO CORE
AOJA B,LPDONE
RESTSCB:
PUSHJ P,SCBRES ;RESTORE SCB TO FREE LIST
SUB P,X11 ;PAST FOREACH RETURN ADDRESS
JRST (FP) ;JUMP OUT OF FOREACH STATEMENT.
FDONS: MOVE FRTAB,FRLOC(USER);CURRENT SCB
;; #KP# BY JRL (11-28-72) FOLLOWING TWO INSTRS USED AND THUS DESTROYED AC A
SKIPE D,RUNNER
MOVE FRTAB,CURSCB(D)
PUSHJ P,SCBRES ;RESTORE SCB TO FREE LIST
MOVE FPD,FPDP(FRTAB) ;WE ARE ABOUT TO LEAVE, SO MAKE
FDX: MOVE D,-1(FPD) ;LOOK AT CONTROL WORD.
SKIPGE LPSA,-SETP(FPD) ;IF SET NEEDS RECLAIMING
TLNN D,SETOP ;THEN DO SO
JRST FDY
MOVE B,FP1(USER) ;PREPARE TO RECLAIM SET.
HLRZ C,(LPSA)
HRRZM B,(C)
HRRM LPSA,FP1(USER) ;DONE.
FDY: CAIN D,-1 ;THIS IS THE LAST.
POPJ P, ;DONE
SUB FPD,[XWD LENFPD,LENFPD]
JRST FDX ;AND GO FOR MORE.
SCBRES: ;RECLAIM AN SCB
;; #KP# THIS ROUTINE FORMERLY USED AC A INSTEAD OF PNT THUS
;; DESTROYING VALUE OF EXPRESSION RETURNED FROM FOREACH
HLR PNT,FRLOC(USER) ;ADDRESS OF SCB POINTER
SKIPE D,RUNNER
HLR PNT,CURSCB(D)
SETZM (PNT) ;ZERO IT
HRRZ PNT,FRLOC(USER) ;ADDRESS THIS SCB
SKIPE D
HRRZ PNT,CURSCB(D)
MOVE B,SCBLNK(PNT) ;ADDRESS PREVIOUS SCB
HLL B,SCBLNK(B) ;GET ADDR SCB POINTER
MOVEM B,FRLOC(USER) ;POP FOREACH
SKIPE D
MOVEM B,CURSCB(D)
MOVE B,SCBCHN(USER) ;WILL ADD TO FREE SCB CHAIN
MOVEM B,SCBLNK(PNT) ;ADD TO FREE LIST
MOVEM PNT,SCBCHN(USER);UPDATE FREE LIST
POPJ P, ;RETURN
DSCR FRPOP, CORPOP
FRPOP - MOVE SATISFIERS FROM SCB INTO CORE
CORPOP - MOVE FROM CORE TO SCB SATISFIER AREA
;
;PUSHJ TO FRPOP
^FRPOP: MOVE FRTAB,FRLOC(USER);CURRENT SCB
SKIPE D,RUNNER
MOVE FRTAB,CURSCB(D)
HRRE A,SCNT(FRTAB) ;COUNT OF LOCALS.
;PICKED UP WITH HRRE SINCE THE
;DEPOSITS OF SATISFIERS FOR "ANY" WILL BE WRONG.
MOVEI B,SATIS+1(FRTAB) ;START OF SATISFIERS.
LOPS: AOJG A,CPOPJ ;LOOP UNTIL ALL IN CORE.
URLEAP <
SKIPGE OLDSAT-SATIS-1(B) ;WAS IT BOUND ON ENTRY ?
AOJA B,LOPS ;IF SO DON'T RESTORE IT
MOVE C,(B) ;PICK UP VALUE,,ADDRESS
>;URLEAP
NOURLEAP <
SKIPG C,(B)
AOJA B,LOPS
>;NOURLEAP
HLRZM C,(C) ;STORE LEFT HALF IN CORE.
AOJA B,LOPS
;PUSHJ TO CORPOP
^CORPOP: MOVE FRTAB,FRLOC(USER);CURRENT SCB
SKIPE D,RUNNER
MOVE FRTAB,CURSCB(D)
HRRE A,SCNT(FRTAB) ;COUNT OF LOCALS
MOVEI B,SATIS+1(FRTAB) ;ADDR FIRST LOCAL
LOPCP: AOJG A,CPOPJ ;THROUGH?
URLEAP <
SKIPG OLDSAT-SATIS-1(B) ;POT UNB ACTUALLY BOUND
AOJA B,LOPCP ;YES
MOVE D,(B) ;PICK UP OLD VALUE,,ADDRESS
>;URLEAP
NOURLEAP <
SKIPG D,(B) ;POT UNB ACTUALLY BOUND
AOJA B,LOPCP ;YES
>;NOURLEAP
HRL D,(D) ;THE CURRENT VALUE
MOVEM D,(B) ;BACK INTO SATIS TABLE
AOJA B,LOPCP ;CONTINUE
DSCR ? LOCAL STACK ROUTINES,STK4LC,STK4VL
STK4LC: ;STACK FOREACH ? LOCAL AS PARM TO MATCHING PROCEDURE
;JRST'ED TO
MOVE FRTAB,FRLOC(USER)
SKIPE A,RUNNER ;PROCESSES AROUND?
MOVE FRTAB,CURSCB(A) ;GET FRCH TABLE FROM PROCESS VARIABLE AREA
POP P,A ;LOCAL NUMBER
MOVEI B,SATIS(FRTAB) ;START OF SATISFIER TABLE
ADDI B,(A) ;ADDRESS THIS SATISFIER
;;#TK# ! RHT 9-21-74 USED TO BE (D). AS NEAR AS I CAN SEE SHOULD BE B
URLEAP <
SKIPL OLDSAT-SATIS-1(B) ;BOUND ON ENTRY?
>;URLEAP
NOURLEAP <
SKIPL C,(B) ;BOUND ON ENTRY?
>;NOURLEAP
JRST STKREF ;NO.
XCT MOVEA(FRTAB) ;YES GET CURRENT VALUE
NOURLEAP <
TRZ A,BNDFOR ;TURN OFF "BOUND ON ENTRY" BIT
>;NOURLEAP
PUSH P,A ;LEAV ON STACK
JRST LEAV
STKREF:
URLEAP <
MOVE C,(B) ;GET SATISFIER TABLE ENTRY
>;URLEAP
HRLI C,20 ;MARK AS UNBOUND
PUSH P,C ;STACK ADDRESS OF LOCAL
JRST LEAV
STK4VL: ;FOREACH SEARCHES STACK LOCAL NUMBER OR VALUE
;JRST'ED TO
MOVE FRTAB,FRLOC(USER)
SKIPE A,RUNNER
MOVE FRTAB,CURSCB(A)
POP P,D ;THE DISPATCH INCREMENT AND TYPE BITS
MOVE A,(P) ;LOCAL NUMBER
MOVEI B,SATIS(FRTAB) ;ADDRESS SATISFIER TABLE
ADDI B,(A) ;ADDRESS THIS LOCAL
URLEAP <
SKIPG OLDSAT-SATIS-1(B) ;BOUND?
>;URLEAP
NOURLEAP <
SKIPG C,(B) ;BOUND?
>;NOURLEAP
JRST STK4V2 ;YES
TLZA D,BOUNDATTPOS!BOUNDOBJPOS!BOUNDVALPOS
STK4V2: AND D,[XWD BOUNDATTPOS!BOUNDOBJPOS!BOUNDVALPOS,0]
ADDM D,INDEX4(FRTAB)
JRST LEAV
DSCR BNDTRP- BINDING FORM OF BOOLEAN A XOR O EQV V
Top three elements of stack are A, O, and V. If the
element is being bound the corresponding bit in FLAG is on and
the stack entry contains the address of the itemvar being bound.
ANY is represented by the stack entry being zero.
BNDTRP: ;JRST'ED TO
MOVE FRTAB,LEABOT(USER) ;GET STATIC SCB
SETZM SATIS+1(FRTAB) ;CLEAR SATISFIER ENTRIES
SETZM SATIS+2(FRTAB)
SETZM SATIS+3(FRTAB)
TLNN FLAG,BINDINGATTPOS ;ATTRIBUTE UNBOUND?
JRST OPOS ;NO.
SKIPG B,-2(P) ;GET ATTRIBUTE ITEMVAR.
;POTUNB BIT IS SIGN BIT
JRST [TLZ B,POTUNB ;A ?ITMVR
MOVE C,(B)
CAIN C,UNBND ;BOUND?
JRST .+1 ;NO.
TLZ FLAG,BINDINGATTPOS ;NO WE'RE NOT BINDING IT
MOVEM C,-2(P) ;ACTUAL VALUE
JRST VPOS]
MOVEI C,1 ;FIRST SATISFIER
HRRZM B,SATIS+1(FRTAB) ;SAVE ADDR OF ATTRIB. ITMVR
HRRZM C,-2(P) ;FIRST SATISFIER IS ATTRIB
OPOS:
TLNN FLAG,BINDINGOBJPOS ;OBJECT UNBOUND?
JRST VPOS ;NO.
SKIPG B,-1(P) ;OBJECT ITEMVAR
JRST [TLZ B,POTUNB ;A ?ITMVR
MOVE C,(B)
CAIN C,UNBND ;ACTUALLY BOUND?
JRST .+1 ;NO.
TLZ FLAG,BINDINGOBJPOS
MOVEM C,-1(P)
JRST VPOS]
MOVEI C,1 ;ASSUME SAME AS ATTRIB
CAMN B,SATIS+1(FRTAB) ;IS IT REALLY?
JRST STOBJ ;YES
MOVEI C,2 ;ATTRIBOBJECT ITEMVAR
HRRZM B,SATIS+2(FRTAB) ;SAVE ADDR OF OBJECT ITMVAR
STOBJ: MOVEM C,-1(P) ;SATIS NO. FOR OBJECT
VPOS:
TLNN FLAG,BINDINGVALPOS ;VAL UNBOUND?
JRST SET.UP
SKIPG B,(P) ;VAL = ANY?
JRST [TLZ B,POTUNB
MOVE C,(B)
CAIN C,UNBND
JRST .+1
TLZ FLAG,BINDINGVALPOS
MOVEM C,(P)
JRST SET.UP]
MOVEI C,1 ;ASSUM SAME AS ATTRIB ITMVR
CAMN B,SATIS+1(FRTAB) ;IS IT
JRST STVAL ;YES, THE SAME
MOVEI C,2 ;SAME AS OBJECT ITMVR?
CAMN B,SATIS+2(FRTAB) ;
JRST STVAL ;YES, THE SAME
MOVEI C,3 ;DIFFERENT THAN THE OTHERS
HRRZM B,SATIS+3(FRTAB) ;SAVE ADDR VALUE ITMVR
STVAL: MOVEM C,(P) ;SATIS NO. FOR VALUE
SET.UP:
JSP LPSA,FORSET ;SET UP MASK,SCB ETC
;ALSO DOES BINDING BITS FOR "ANY"
PUSHJ P,@SEROUT(FLAG) ;DO SEARCH
JRST RETNO ;RETURN FALSE
SKIPE A,SATIS+1(FRTAB) ;FIRST SATIS USED?
HLRZM A,(A) ;YES.
SKIPE A,SATIS+2(FRTAB)
HLRZM A,(A)
SKIPE A,SATIS+3(FRTAB)
HLRZM A,(A)
JRST RETYES ;RETURN TRUE
DSCR ISIT,BRITM
ISIT - ASSOCIATIVE BOOLEAN WITH EVERYTHING BOUND (OR ANY)
A,O,V ON TOP OF STACK
BRITM - FIND BRACKETED TRIPLE ITEM (RETURN BINDIT IF NONE)
;
ISIT: ;JRST HERE FOR A XOR O EQV V ?
MOVE FRTAB,LEABOT(USER)
JSP LPSA,FORSET ;GO GET THINGS SET UP
;; FORSET HAS CHANGED THE RH OF FLAG FOR APPROPRIATE SEARCH
PUSHJ P,@SEROUT(FLAG);CALL ROUTINE.
RETNO: TDZA A,A ;FAILED
RETYES: SETOM A ;SUCCEEDED.
;RESULT LEFT IN REGISTER 1.
JRST LEAV
BRITM: ;JRST HERE FOR BRACKETED ITEM
;TO BE LEFT ON STACK.
MOVE FRTAB,LEABOT(USER)
JSP LPSA,FORSET ;GO START THINGS.
;; FORSET HAS STACKED ARGS AND COMPUTED ROUTINE NAME
BRGO: MOVE FLAG,-1(FPD) ;ROUTINE NAME.
PUSHJ P,@SEROUT(FLAG);CALL IT.
JRST [PUSH P,[NIC]
JRST LEAV]
URLEAP <
MOVE B,BRACKL(TABL) ;GET LIST OF B.T. BLOCKS
BRGO1: JUMPE B,BRGO ;IF NO MORE THIS WASN'T A B.T.
CAME A,1(B) ;DOES THIS B.T. BLOCK SAY THIS ASSOC IS A B.T.?
JRST [HRRZ B,(B) ;NOPE -- GET NEXT B.T. BLOCK
JRST BRGO1]
HLRZ B,(B) ;GET ITEM NUMBER
>;URLEAP
NOURLEAP <
HLRZ B,(A) ;VALUE POINTER.
BRACKN B ;BRACKETED?
JRST BRGO ;NO
HRRZ B,(B) ;YES -- THIS IS THE ITEM.
>;NOURLEAP
PUSH P,B ;ON STACK -- RESULT IS ITEM NUMBER.
JRST LEAV ;DONE.....
DSCR DERIVED SETS -- NOT IN FOREACH SPECIFICATIONS.
THESE ROUTINES COMPUTE DERIVED SETS. THEY CALL THE SEARCH
ROUTINES ABOVE, AFTER SETTING UP THE "FIXED" SEARCH CONTROL
BLOCK TO RELECT THE PARTICULAR SEARCH.
;
; A XOR O
D1: MOVE FRTAB,LEABOT(USER)
PUSH P,[1] ;FOR VALUE -- RESULT.
JRST DOIT ;READY TOGO
; O EQV V
D3: MOVE FRTAB,LEABOT(USER)
MOVEI A,1
EXCH A,-1(P)
JRST D2DO
; A'V
D2: MOVE FRTAB,LEABOT(USER)
MOVEI A,1
D2DO: EXCH A,(P)
PUSH P,A ;CHANGE ORDER OF ARGS.
DOIT:
JSP LPSA,FORSET
PUSH P,[0] ;THE SET WE WILL ACCUMULATE.
AGS: PUSHJ P,@SEROUT(FLAG) ;CALL THE SEARCH
JRST [HLRZ A,(P) ;FAILED, AND DONE!
MOVNS A ;CHANGE COUNT TO NEGATIVE
;TO INDIC. TEMP.
HRLM A,(P)
JRST LEAV]
HLRZ A,SATIS+1(FRTAB);RESULT IN FIRST SATISFIER
MOVEI TAC1,(P) ;PLACE OF SET
GLOB <
PUSH P,TABL
TLZ FLAG,GLBSRC ;ENTY NEEDS TO KNOWS....
>;GLOB
PUSH P,A ;ITEM FOR ENTY.
PUSHJ P,ENTY ;IN PUTIN
GLOB <
POP P,TABL
>;GLOB
MOVE FRTAB,LEABOT(USER) ;SINCE ENTY DESTROYED TAC1
MOVE FLAG,-1(FPD)
JRST AGS ;LOOP UNTIL DONE.
DSCR MAKE AND ERASE
THESE ARE THE ROUTINES TO MAKE AND ERASE ASSOCIATIONS IN THE
ASSOCIATIVE STORE.
NOURLEAP <
THE BIGGEST HAIR IN THESE ROUTINES HAS
TO DO WITH MULTIPLE VALUES. "MAKE" MAY HAVE TO EXPAND
A SINGLE ASSOCIATION INTO A MULTIPLE VALUE CONFIGURATION,
AND "ERASE" MAY HAVE TO CONTRACT IT.
>;NOURLEAP
MAKE AND ERASE ARE BOTH CALLED WITH THE THREE TOP OF STACK
ELEMENTS BEING THE ATTRIBUTE, OBJECT, AND VALUE PASSED
AS ARGUMENTS.
MAKE AND ERASE HAVE A "BREAKPOINT" FACILITY, FOR ACTIVATING
A SAIL PROCEDURE EACH TIME AN ASSOCIATION IS MADE OR ERASED.
THE A, O, AND V ARE PASSED BY VALUE IN THE STACK TO THE
BREAKPOINT ROUTINE.
PROBLEMS OCCUR WHEN AN ASSOCIATION IS ERASED WHICH IS POINTED
TO BY SOME POINTER IN THE FOREACH SEARCH TABLES. WE SHOULD
PROBABLY SEARCH ALL ACTIVE SCBS FOR SUCH POINTERS AND GIVE A WARNING
BUT EVEN THIS WAY WE COULD NOT FIND POINTERS IN OTHER JOBS SHARING
A GLOBAL STRUCTURE OR POINTERS IN AN ERASE SCB WHOSE ERASE WAS
INTERRUPTED BY A ERASE-BREAKPOINT.
MAKE -- CALLED WITH PUSHJ.
ERASE -- JRST TO IT; IT WILL JRST TO LEAV.
BMAKE -- JRST TO IT; IT WILL JRST TO LEAV. (BRACKETED TRIPLE MAKE).
URLEAP <
THE STRUCTURE BUILT BY MAKE IS AS FOLLOWS: THERE ARE TWO KINDS OF BLOCKS;
MULTIPLE HIT BLOCKS AND VALUE BLOCKS. THERE IS ONE MULTIPLE HIT BLOCK FOR
EACH ATTRIBUTE - OBJECT PAIR IN THE ASSOCIATIVE STORE. IT CONTAINS TWO
POINTERS IN ADDITION TO THE ATTRIBUTE AND THE OBJECT. THESE ARE THE CONFLICT
POINTER, WHICH (IF NON-ZERO) POINTS TO ANOTHER M.H. BLOCK WHOSE ATTRIBUTE AND
OBJECT HAVE THE SAME HASH VALUE AS THIS ONE, AND THE MULTIPLE HIT POINTER,
WHICH IS NEVER ZERO, AND POINTS TO A LIST OF VALUE BLOCKS, CALLED THE MULTIPLE
HIT LIST. EACH VALUE BLOCK
ON THAT LIST REPRESENTS AN ASSOCIATION WITH THE ATTRIBUTE AND OBJECT FROM THE
M.H. BLOCK. BESIDES THE VALUE, EACH VALUE BLOCK CONTAINS THREE POINTERS:
A BACK-POINTER TO THE M.H. BLOCK, A POINTER TO THE NEXT VALUE BLOCK FOR THIS
M.H. LIST, AND A POINTER TO THE NEXT VALUE BLOCK ON THE VALUE LIST, THAT
IS, THE NEXT VALUE BLOCK REPRESENTING AN ASSOCIATION WITH THE SAME VALUE BUT
DIFFERENT ATTRIBUTE OR OBJECT. TO RECAPITULATE, WE HAVE:
M.H. BLOCK: XWD M.H.PTR, CONFLICT PTR
XWD ATTRIBUTE, OBJECT
VALUE BLOCK: XWD M.H.PTR, VALUE PTR
XWD BACK PTR, VALUE
SEE BMAKE FOR WHAT HAPPENS WHEN THERE'S A BRACKETED TRIPLE.
>;URLEAP
;
;PUSHJ TO MAKE
; ON EXIT, "PNT" MUST POINT TO THE ASSOCIATION CREATED.
MAKE:
SKIPE A,-1(P) ;VALUE "ANY"?
CAIN A,UNBND ;OR VALUE UNBOUND?
JRST ERRMAK
SKIPE A,-2(P) ;OBJECT "ANY"?
CAIN A,UNBND ;OR OBJECT UNBOUND?
JRST ERRMAK
SKIPE A,-3(P) ;ATTRIB "ANY"?
CAIN A,UNBND ;ATTRIB UNBOUND?
ERRMAK: ERR <MAKE WITH UNBOUND ITEM>,1
GLOB <
WRITSEC ;ENTER A POINTER-DIDLING AREA!
TLNN FLAG,GLBSRC ;GLOBAL MAKE?
JRST LOCMAK ;NO.
;; CAN THE FOLLOWING TESTS BE EFFICIENTLY BE MERGED WITH TESTS ABOVE?
MOVEI A,GBRK ;GLOBAL LOCAL BREAK
CAMG A,-1(P) ;VALUE GLOBAL?
CAML A,-2(P) ;OBJECT LOCAL?
JRST .+2
CAML A,-3(P) ;ATTRIB LOCAL?
ERR <GLOBAL MAKE WITH LOCAL ITEM>,1
LOCMAK:
>;GLOB
SKIPE C,MKBP(USER) ;MAKE BREAK-POINT?
PUSHJ P,LPBRK1 ;GO TO A BREAKPOINT !
GLOB <
SKIPN FP,FP2(TABL) ;WE WILL CERTAINLY NEED SOME FRESS.
PUSHJ P,FP2DON ;GET SOME.
>;GLOB
NOGLOB<
MOVE FP,FP2(TABL)
>;NOGLOB
MOVE PNT,FP ;THIS IS THE ONE WE WILL USE.
URLEAP <
HRR C,-2(P) ;PICK UP OBJECT
HRL C,-3(P) ;AND ATTRIBUTE
>;URLEAP
NOURLEAP <
SETZM C ;FOR MAKING UP THE MAGIC WORD.
MOVE B,-2(P) ;OBJECT.
LSHC B,-ITLEN
MOVE B,-3(P) ;ATTRIBUTE
LSHC B,-ITLEN ; A-O-0 IS IN C.
>;NOURLEAP
HASH (D,<-3(P)>,<-2(P)>)
SKIPN A,(D) ;ANY THING THERE?
JRST GOM ;NO.
AG: MOVE B,1(A) ;GET A-O OF THIS LIST OF ASSOCATIONS
NOURLEAP < ;WE HAVE A-O-V IN THE OLD SYSTEM
TRZ B,7777 ;A-O
>;NOURLEAP
CAMN B,C ;SAME AS THE ONE WE ARE PUTTING IN?
JRST DONE ;YES -- MODULO MULTIPLE HITS.
MOVE D,A ;REMEMBER WHO POINTS TO US.
HRRZ A,(A) ;GO DOWN CONFLICT LIST.
JUMPN A,AG ;... IF THERE'S ANYTHING LEFT
;IF WE FALL THROUGH HERE, WE'VE COME TO THE END OF THE CONFLICT LIST WITHOUT
;FINDING A MATCHING A-O, SO WE HAVE TO BUILD A NEW M.H. BLOCK
GOM: SKIPN FP,(FP) ;BEFORE USING THIS FREE BLOCK ...
PUSHJ P,FP2DON ;... BE SURE THERE'S ANOTHER ONE
NOURLEAP <
SETZB (PNT) ;ZERO FIRST WORD OF ASS. CELL.
>;NOURLEAP
HRRM PNT,(D) ;LINK FROM CONFLICT LIST OR HASH TABLE
NOURLEAP <
IOR C,-1(P) ;GET VALUE THERE
>;NOURLEAP
MOVEM C,1(PNT) ;AND STORE A-O
NOURLEAP <
MOVE C,-1(P) ;GET VALUE AGAIN
>;NOURLEAP
URLEAP <
SETZM (PNT) ;DON'T LEAVE ANY GARBAGE
MOVE D,PNT ;REMEMBER LOCATION OF M.H. BLOCK ...
MOVE B,PNT ;... TWICE SO NEXT CAN KILL TWO
MOVE PNT,FP ;THIS WILL BE THE VALUE BLOCK
GOM1: SKIPN FP,(FP)
PUSHJ P,FP2DON
HRLM PNT,(B) ;LINK V-BLOCK TO M.H. BLOCK OR PREVIOUS V-BLOCK
HRLZM D,1(PNT) ;LINK M.H. BLOCK TO VALUE BLOCK
MOVE C,-1(P) ;GET VALUE.
HRRM C,1(PNT) ;STORE IT IN VALUE BLOCK
>;URLEAP
ADD C,INFOTAB(TABL) ;NEED TO UPDATE VALUE LINK
HLRZ D,(C) ;OLD ONE
URLEAP <
HRRM D,(PNT) ;STORE IN VALUE SPOT
>;URLEAP
NOURLEAP <
HRLM D,(PNT) ;STORE IN VALUE SPOT
>;NOURLEAP
HRLM PNT,(C) ;AND UPDATE INFO TABLE.
MOVEM FP,FP2(TABL) ;SAVE NEW FREE POINTER.
OUT111: SUB P,[XWD 4,4]
JRST @4(P) ;RETURN, AFTER ADJUSTING STACK.
OUT1A:
URLEAP <
MOVE PNT,C
>;URLEAP
NOURLEAP <
MOVE PNT,A
>;NOURLEAP
JRST OUT111 ;MUST HAVE PNT POINTING
;TO THING WE MADE.
URLEAP <
DONE: ;AT LEAST A AND O MATCH TO GET HERE.
;A POINTS TO THE M.H. BLOCK
MOVE D,A ;SAVE IT IN D FOR GOM1
HLRZ C,(A) ;GET FIRST V-BLOCK IN M.H. LIST
DONE1: HRRZ B,1(C) ;GET VALUE ITEM FROM V-BLOCK
CAMN B,-1(P) ;SEE IF IT'S THE ONE WE'RE LOOKING FOR
JRST OUT1A ;IT'S ALREADY THERE!
MOVE B,C ;REMEMBER IN CASE IT'S THE END OF THE LIST
HLRZ C,(C) ;GO DOWN THE M.H. LIST TO THE NEXT VALUE BLOCK
JUMPN C,DONE1 ;AND BACK AROUND UNLESS IT'S THE END OF THE LIST
JRST GOM1 ;GO BUILD A NEW VALUE BLOCK
>;URLEAP
NOURLEAP <
DONE: MOVE B,1(A) ;AT LEAST A AND O MATCH TO GET HERE.
TRNN B,7777 ;MULTIPLE VALUES?
JRST MULVAL ;YES
ANDI B,7777
CAMN B,-1(P) ;COMPARE WITH SPECIFIED VALUE
JRST OUT1A ;IT IS ALREADY THERE!!!
SKIPN FP,(FP) ;MUST NOW MAKE A MULTIPLE VALUE GUY
PUSHJ P,FP2DON
MOVE LPSA,FP ;ADDRESS ONE-WORD FREE
EXCH LPSA,PNT ;USE OLDER FREE FIRST
HRL A,(A) ;XWD CONF.LIST,,NEW MULT HIT LIST
MOVSM A,(LPSA) ;STORE XWD MH-LIST,,CONF LIST
MOVEM C,1(LPSA) ;STORE A-0 MH HEADER
HRRM LPSA,(D) ;LINK INTO CONFLICT LIST
HRRZ D,A ;FIRST ITEM ON CONFLICT LIST
JRST GOM
MULVAL: HLRZ A,(A) ;PICK UP POINTER TO MULT. VALS.
IN1: MOVE B,1(A) ;PICK UP A-O-V
ANDI B,7777 ;SAVE ONLY VALUE
CAMN B,-1(P) ;THE RIGHT VALUE?
JRST OUT1A ;YES -- IT'S THERE
MOVE D,A ;BACK-POINTER
HRRZ A,(A) ;GET NEXT POINTER
JUMPE A,GOM ;PUT ON END OF MH LIST
JRST IN1 ;LOOP UNTIL FOUND OR MH LIST EXHAUSTED
>;NOURLEAP
URLEAP <
;JRST TO BMAKE
;BRACKETED TRIPLES ARE EVIL, AND THEREFORE THEY WILL BE INEFFICIENT
;UNTIL I GET AROUND TO FIXING THIS UP.
;THEY ARE IDENTIFIED BY A LIST OF TWO-WORD BLOCKS, IN THE FOLLOWING FORMAT:
; XWD ITEM #, NEXT B.T. BLOCK
; XWD 0, VALUE BLOCK ADDRESS
;THE LIST HEADER IS BRACKL(TABL)
;ON EXIT, THE ITEM NUMBER WILL BE ON THE TOP OF THE STACK, AND PNT WILL
;CONTAIN THE ADDRESS OF THE ASSOCIATION
BMAKE: ;BRACKETED MAKE.......;;
PUSHJ P,MAKE ;GO MAKE IT.. ADDR OF ASSOC RETURNED IN PNT
HRRZI A,BRACKL(TABL) ;GET ADDRESS OF B.T. LIST
BM0: HRRZ A,(A) ;GO DOWN THE B.T. LIST
JUMPE A,BM1 ;... IF THERE ARE ANY LEFT
CAME PNT,1(A) ;IS THIS ASSOCIATION ALREADY A B.T.?
JRST BM0 ;NO, GO BACK AND TRY AGAIN
;IT WAS ALREADY A BRACKETED TRIPLE
HLRZ A,(A) ;GET THE ITEM NUMBER OF THE ASSOCIATION
PUSH P,A ;SAVE IT FOR CALLER
JRST LEAV ;SPLIT
BM1: PUSH P,PNT ;SAVE ASSOCIATION ADDRESS
NOGLOB <
HRLI FLAG,BRKITM ;SO NEW WILL INIT TYPE
> ;NOGLOB
GLOB <
TLZ FLAG,-1GLBSRC ;DON'T DESTROY GLOBAL BIT
TLO FLAG,BRKITM ;ITEM TYPE IS BRACKETED ITEM
> ;GLOB
PUSHJ P,NEWX ;GET A NEW ITEM.....
MOVE PNT,(P) ;PNT GETS NEW ITEM NUMBER
EXCH PNT,-1(P) ;PNT GETS ASSOCIATION ADDRESS
;-1(P) GETS ITEM NUMBER
POP P,B ;B GETS ITEM NUMBER, ITEM NUMBER AT TOP OF STACK
MOVE FP,FP2(TABL) ;GET A TWO-WORD FREE FOR A NEW B.T. BLOCK
MOVE A,FP ;SAVE ITS ADDRESS
SKIPN FP,(FP)
PUSHJ P,FP2DON
MOVEM FP,FP2(TABL) ;SAVE NEW FREE POINTER
MOVEM PNT,1(A) ;SAVE ASSOCIATION ADDRESS IN B.T. BLOCK
HRL B,BRACKL(TABL) ;PICK UP OLD FIRST B.T. BLOCK
MOVSM B,(A) ;STORE ITEM #,,NEXT B.T. PTR IN NEW B.T. BLOCK
MOVEM A,BRACKL(TABL) ;UPDATE LIST HEADER
ADD B,DATAB(TABL) ;PREPARE TO MAKE VALUE ENTRY
MOVEM PNT,(B) ;POINTER TO ASSOC
JRST LEAV
>;URLEAP
NOURLEAP <
;JRST TO BMAKE
BMAKE: ;BRACKETED MAKE.......;;
PUSHJ P,MAKE ;GO MAKE IT..
HLRZ A,(PNT) ;VALUE POINTER
BRACKP A ;IS IT ALREADY A BRACKETED?
JRST INALREADY ;YES
GLOB <
;MAKE HAS PUT JOB INTO WRITING SECTION
SKIPN FP,FP1(TABL) ;ONE-WORD FREES.
PUSHJ P,FP1DON ;NONE YET, GET SOME.
>;GLOB
NOGLOB <
MOVE FP,FP1(TABL) ;ONE-WORD FREES.
>;NOGLOB
MOVEI C,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON ;OUT OF FREE STORAGE.
HRRM FP,FP1(TABL)
HRLM A,(C) ;OLD VALUE LIST
TRC C,BRABIT ;TURN IT ON.(LOGICALLY)
HRLM C,(PNT)
PUSH P,PNT ;SAV ADDR OF IT
NOGLOB <
HRLI FLAG,BRKITM ;SO NEW WILL INIT TYPE
> ;NOGLOB
GLOB <
TLZ FLAG,-1GLBSRC ;DON'T DESTROY GLOBAL BIT
TLO FLAG,BRKITM ;ITEM TYPE IS BRACKETED ITEM
> ;GLOB
PUSHJ P,NEWX ;GET A NEW ITEM.....
MOVE PNT,(P)
EXCH PNT,-1(P)
POP P,B ;ITEM NUMBER.
HLR C,(PNT) ;THE BRACKET NODE
TRC C,BRABIT
HRRM B,(C) ;PUT ITEM NUMBER IN BRACKET NODE
ADD B,DATAB(TABL) ;PREPARE TO MAKE VALUE EENTRY
MOVEM PNT,(B) ;POINTER TO ASSOC
JRST LEAV
INALREADY:
HRRZ B,(A) ;ITEM NUMBER....
PUSH P,B
JRST LEAV
>;NOURLEAP
URLEAP <
;PUSHJ, TO ERASE
ERASE:
GLOB <
WRITSEC ;ANOTHER POINTER DIDDLING AREA !!
>;GLOB
POP P,PNT ;SAVE RETURN ADDRESS.
JSP LPSA,NOFOR ;IN LINE CALL
PUSH P,PNT ; ";" ADDED 5-3 DCS
TRY: MOVE FLAG,-1(FPD) ;ROUTINE NAME.
PUSHJ P,@SEROUT(FLAG) ;GET THE RIGHT SEARCH
POPJ P, ;DONE... (IT FAILED)
SKIPE C,ERBP(USER) ;ERASE BREAK-POINT?
PUSHJ P,LPBRK ;A LEAP BREAK POINT !!!
;FIRST CHECK IF IT'S A BRACKETED TRIPLE
SKIPN B,BRACKL(TABL) ;PICK UP LIST OF B.T. BLOCKS
JRST NBTE ;NO B.T.'S -- NO PROBLEMS
MOVEI C,BRACKL(TABL) ;GET ADDR OF B.T. LIST POINTER IN CASE FIRST
;BLOCK MATCHES
CMPE: CAMN A,1(B) ;DOES THIS B.T. BLOCK POINT TO THIS ASSOC ?
JRST YESE
MOVE C,B ;REMEMBER WHO POINTS TO US
HRRZ B,(B) ;GET POINTER TO NEXT B.T. BLOCK
JUMPN B,CMPE ;GO TRY AGAIN IF THERE IS ONE
NBTE: ;REMOVE THIS ASSOCIATION FROM ITS VALUE LIST
HRRZ B,1(A) ;GET THE VALUE ITEM
ADD B,INFOTAB(TABL) ;GET INFOTAB POINTER
HLRZ C,(B) ;FIRST VALUE BLOCK
CAMN C,A ;IS THE FIRST ONE THE ONE ?
JRST [HRRZ C,(C) ;GET ITS VALUE POINTER
HRLM C,(B) ;STORE IT IN INFOTAB
JRST ENXT] ;GO WORRY ABOUT M.H. LIST, ETC.
JUMPN C,ERS1 ;GO TAKE CARE OF THE USUAL CASE
ERERR: ERR <DRYROT -- ERASE2>
YESE: ;FIX UP BRACKETED TRIPLES LIST & DELETE B.T. ITEM
GLOB <
SKIPN FP,FP1(TABL) ;ANY FREES YET ?
PUSHJ P,FP1DON ;NO, GO GET SOME
>;GLOB
NOGLOB <
MOVE FP,FP1(TABL) ;GET A FREE TO LINK ONTO OLDITEMS
>;NOGLOB
MOVE PNT,FP ;ADDRESS OF NEW CELL
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON ;GET SOME MORE IF NECESSARY
HRRM FP,FP1(TABL) ;UPDATE FREE STORAGE LIST HEAD
HLRZ D,(B) ;GET ITEM NUMBER
ADD D,DATAB(TABL) ;MAKE POINTER TO DATUM TABLE ENTRY
SETZM (D) ;CLEAR IT
HLLZ D,(B) ;GET ITEM NUMBER AGAIN
HRR D,OLDITM(TABL) ;BUILD ENTRY FOR DELETED ITEMS LIST
MOVEM D,(PNT)
MOVEM PNT,OLDITM(TABL);FIX LIST HEAD
AOS FREITM(TABL) ;INCREASE COUNT OF FREE ITEMS
HRRZ FP,FP2(TABL) ;NEXT RETURN B.T. BLOCK TO FREE STORAGE
HRRZM FP,(B)
SETZM 1(B)
HRRZM B,FP2(TABL) ;UPDATE LIST HEAD
JRST NBTE ;GO WORRY ABOUT VALUE LIST, ETC.
ERS1: MOVE B,C ;REMEMBER WHO POINTS TO US
HRRZ C,(C) ;GET POINTER TO NEXT VALUE BLOCK
JUMPE C,ERERR ;IT HAS TO BE THERE
CAME C,A ;IS THIS THE ONE ?
JRST ERS1 ;GO BACK AND TRY AGAIN IF NOT
HRRZ C,(C) ;GET ITS VALUE POINTER
HRRM C,(B) ;LINK AROUND THIS VALUE BLOCK
ENXT: ;NOW FOR THE MULTIPLE HIT LIST
HLRZ C,1(A) ;GET THE BACK POINTER TO THE MULTIPLE HIT BLOCK
MHE: JUMPE C,ERERR ;IT HAS TO BE THERE
MOVE B,C ;REMEMBER WHO POINTS TO US
HLRZ C,(C) ;GET POINTER TO NEXT VALUE BLOCK
CAME C,A ;IS THIS THE ONE ?
JRST MHE ;IF NOT TRY AGAIN
HLRZ C,(C) ;GET POINTER TO NEXT VALUE BLOCK
HRLM C,(B) ;LINK AROUND THIS VALUE BLOCK
HLRZ C,1(A) ;GET THE M.H. BLOCK AGAIN FOR LATER
HRRZ FP,FP2(TABL) ;WE'RE GONNA RETURN THE VALUE BLOCK TO FREE STG
HRRZM FP,(A)
SETZM 1(A)
HRRZM A,FP2(TABL) ;FIX FREE LIST HEADER
HLRZ B,(C) ;THIS IS THE M.H. LIST POINTER
JUMPN B,TRY ;IF IT'S NON-ZERO WE'RE O.K.
;DELETE THE M.H. HEADER 'CAUSE THAT WAS THE ONLY ASSOCIATION ATTACHED TO IT
HRRZ B,1(C) ;GET THE OBJECT FROM THE M.H. HEADER
HLRZ A,1(C) ;GET ATTRIBUTE
HASH (A,A,B)
MHE1: MOVE B,A ;SAVE IT
HRRZ A,(A) ;GO DOWN CONFLICT LIST
CAMN A,C ;IS THIS THE ONE ?
JRST [HRRZ C,(C) ;FIX UP THE LINKS JUST AS BEFORE
HRRM C,(B)
HRRZ FP,FP2(TABL) ;RETURN IT TO FREE STORAGE
HRRZM FP,(A)
SETZM 1(A)
HRRZM A,FP2(TABL) ;FIX UP FREE LIST HEADER
JRST TRY]
JUMPN A,MHE1
ERR <DRYROT -- ERASE3>
>;URLEAP
NOURLEAP <
;PUSHJ, TO ERASE
ERASE:
GLOB <
WRITSEC ;ANOTHER POINTER DIDDLING AREA !!
>;GLOB
POP P,PNT ;SAVE RETURN ADDRESS.
JSP LPSA,NOFOR ;IN LINE CALL
PUSH P,PNT ; ";" ADDED 5-3 DCS
TRY: MOVE FLAG,-1(FPD) ;ROUTINE NAME.
PUSHJ P,@SEROUT(FLAG);GET THE RIGHT SEARCH
POPJ P, ;DONE... (IT FAILED)
SKIPE C,ERBP(USER) ;ERASE BREAK-POINT?
PUSHJ P,LPBRK ;A LEAP BREAK POINT !!!
HRRZ B,1(A) ;A POINTS TO ASS. CELL
TRZ B,770000 ;NOW WE HAVE THE VALUE
ADD B,INFOTAB(TABL) ;NONO
GOE: HLRZ C,(B) ;VALUE LINK.
BRACKP C ;TEST FOR BRACKETED TRIPLE
JFCL ;MACROS FORCE ONE OCCASIONALLY TO PARANOIA
CAIN C,(A) ;THE VERY SAME?
JRST YESE ;WE HAVE IT
MOVE B,C ;REMEMBER WHERE WE CAME FROM
JUMPN B,GOE
ERR <DRYROT -- ERASE1>;ASSOCIATION NOT ON VALUE LIST
YESE: HLRZ C,(A) ;AGAIN
BRACKN C ;A BRACKETED TRIPLE?
JRST Y1 ;NO
MOVE FP,OLDITM(TABL) ;PREPARE TO LINK ON LIST.
MOVE D,(C) ;THE ONE-WORD CELL
HRL FP,D ;ITEM NUMBER
MOVEM FP,(C) ;THIS IS THE THE OLD ITEM LIST.
HRRZM C,OLDITM(TABL)
AOS FREITM(TABL) ;COUNT THE NUMBER FREE
MOVEI C,(D) ;ITEM NUMBER
HLLZS @INFOTAB(TABL) ;ZERO INFOTAB ENTRY (WONDERS OF INDIRECT ADDR)
CAME A,@DATAB(TABL) ;SAME ASSOC. POINTER TO BRACKET INFO.
ERR <DRYROT -BRACKET CONFUSION>
SKIPA
Y1: HLLZ D,(A) ;OLD POINTER ELSEWISE
Y2: HLLM D,(B) ;CHAIN NEW VALUE LINK.
LDB C,[POINT ITLEN,1(A),ITLEN-1];ATTRIBUTE
LDB D,[POINT ITLEN,1(A),2*ITLEN-1];OBJECT
HASH (B,C,D)
MOVE C,1(A) ;PICK UP THE WORD WE SEARCH FOR
TRZ C,7777 ;AND TURN OFF VALUE.
MOVE PNT,(B) ;FIRST IN CONFLICT LIST
LOOK: CAIN PNT,(A) ;DO WE POINT THERE?
JRST THISIT ;YES
MOVE D,1(PNT) ;GET A-O-V
CAMN D,C
JRST MULVLL ;A-O MATCH AT LEAST
MOVE B,PNT ;REMEMBER WHO POINTED AT US
HRRZ PNT,(PNT) ;GO DOWN CONFLICT LIST.
JUMPN PNT,LOOK ;AND LOOP
ERR <DRYROT -- ERASE2> ;NOT ON CONFLICT LIST
THISIT: HRRZ PNT,(A) ;CONFLICT
HRRM PNT,(B) ;BYPASS AROUND US.
JRST LINK ;RECLAIM THE WORD OF CORE.
MULVLL:
HLRZ C,(PNT) ;POINTER TO MULTIPLE HITS.
CAIN C,(A) ;IS THIS IT?
JRST FIST ;-- YESS AND THEFIRST ONE.
M1: SKIPN B,C
ERR <DRYROT -- ERASE3>;RFS FORGOT THIS ERROR CHECK - KKP
HRRZ C,(C) ;GET NEXT MULTIPLE HIT.
CAIE C,(A)
JRST M1 ;LOOP UNTIL FOUND
JRST THISIT
FIST: HRRZ D,(A) ;NEXT IN LINE...
JUMPE D,MHDEL ;NONE LEFT WILL DELETE MH HDR
HRLM D,(PNT) ;MH LIST
JRST LINK ;RELEASE ASSOC TWO WORDS
MHDEL: MOVE FP,FP2(TABL)
HRRZM FP,(A)
HRRZM A,FP2(TABL)
SETZM 1(A)
MOVEI A,(PNT)
JRST THISIT ;DELETE MH HDR
LINK: HRRZ FP,FP2(TABL)
HRRZM FP,(A)
SETZM 1(A)
HRRZM A,FP2(TABL)
JRST TRY
>;NOURLEAP
; LEAP BREAKPOINTS EXIST.
; ENTRY IS WITH ROUTINE ADDRESS IN C.
LPBRK: PUSH P,A ;ENTRY FROM ERASE.
PUSH P,FPD ;A PNTS TO ASSOCIATION (I.E. VALUE BLOCK)
;TO BE ERASED.
NOURLEAP <
LDB B,[POINT 12,1(A),11]
PUSH P,B
LDB B,[POINT 12,1(A),23];OBJECT
PUSH P,B
LDB B,[POINT 12,1(A),35];VALUE
PUSH P,B
PUSH P,B ;STACKS NEED TO BE EQUAL
>;NOURLEAP
URLEAP <
HLRZ B,1(A) ;BACK POINTER TO M.H. HEADER
HLRZ FPD,1(B) ;ATTRIBUTE (USE FPD AS TEMP)
PUSH P,FPD ;REPLICATE STACK OF MAKE
HRRZ FPD,1(B) ;OBJECT
PUSH P,FPD
HRRZ B,1(A) ;VALUE (FROM VALUE BLOCK)
PUSH P,B
PUSH P,B ;STACKS NEED TO BE EQUAL.
MOVE FPD,-4(P) ;RESTORE FPD TO ITS VALUE ON ENTRY
>;URLEAP
PUSHJ P,LPBRK1 ;GO DO IT.
SUB P,[XWD 4,4] ;ALL GONE.
POP P,FPD
POP P,A
POPJ P,
LPBRK1: ;ENTRY FROM MAKE.
HRL TEMP,LEABOT(USER)
ADD P,[XWD FRCHLEN,FRCHLEN]
SKIPL P ;SEE IF WE OVERFLEW THE STACK.
JSP USER,$PDLOV ;YES, SIGH.
HRRI TEMP,1-FRCHLEN(P)
BLT TEMP,(P) ;SAVE WORK AREA. SINCE BRK MAY CALL LEAP
PUSH P,FLAG
PUSH P,UUO1(USER)
GLOB <
NOSEC ;SO BREAKPOINT ROUTINE CAN CALL LEAP
PUSH P,TABL
PUSH P,-7-FRCHLEN(P) ;ATTRIBUTE
PUSH P,-7-FRCHLEN(P) ;OBJECT
PUSH P,-7-FRCHLEN(P) ;VALUE
>;GLOB
NOGLOB<
PUSH P,-6-FRCHLEN(P) ;ATTRIBUTE
PUSH P,-6-FRCHLEN(P) ;OBJECT
PUSH P,-6-FRCHLEN(P) ;VALUE
>;NOGLOB
PUSHJ P,(C) ;CALL ROUTINE
GLOB <
POP P,TABL
>;GLOB
MOVE USER,GOGTAB ;SET UP AGAIN.
POP P,UUO1(USER)
SUB P,[XWD FRCHLEN+1,FRCHLEN+1];REMOVE OLD FLAG AND OLD SCB
HRLI TEMP,1(P)
HRR TEMP,LEABOT(USER)
HRRI FLAG,FRCHLEN-1(TEMP)
BLT TEMP,(FLAG) ;RESTORE OLD SCB
MOVE FLAG,FRCHLEN+1(P) ;RETRIEVE FLAG
GLOB <
WRITSEC ;IN CASE GLOBAL
>;GLOB
POPJ P,
INTERNAL BRKERS,BRKMAK,BRKOFF ;BREAKPOINT FOR ERASE,BREAKPOINT FOR MAKE.
HERE (BRKERS)
SKIPA TEMP,[ERBP]
HERE (BRKMAK)
MOVEI TEMP,MKBP;THE POSITIONS.
ADD TEMP,GOGTAB;HO HO.
POP P,USER
POP P,(TEMP);SUBROUTINE NAME.
JRST (USER)
HERE (BRKOFF) ;TURN OFF BREAKPOINTS
MOVE USER,GOGTAB
SETZM ERBP(USER)
SETZM MKBP(USER)
POPJ P, ;RETURN
DSCR ISTRIPLE, SELECTOR
;
; INITIALIZATION ROUTINE FOR THE ROUTINES THAT FOLLOW.
;ALL THESE ROUTINES ARE CALLED BY PUSHJ P,
INIT1:
; MOVE FRTAB,FRLOC(USER)
MOVE B,-2(P) ;ARGUMENT
; TLNE FLAG,BOUNDATTPOS
; XCT MOVEB(FRTAB)
MOVE C,B ;COPY ITEM NUMBER
ADD C,INFOTAB(TABL) ;ADDRESS OF TYPE FLAGS
LDB C,[POINT 9,(C),35];GET TYPE FLAGS
ADD B,DATAB(TABL) ;ADDRESS TRIPLE POINTER
POPJ P,
; ISTRIPLE
ISTRIPLE:
PUSHJ P,INIT1
CAIE C,BRKITM
TDZA A,A
SETOM A
RET: SUB P,X22
JRST @2(P)
SELECTOR: ;FOR COMPUTING FIRST,SECOND,THIRD.
PUSHJ P,INIT1
CAIE C,BRKITM ;IS IT BRACKETED
URLEAP <
ERR <NOT A BRACKETED TRIPLE>,1
HRRZ C,(B) ;GET ADDRESS OF VALUE BLOCK
SUBI FLAG,SELET1-ROUTABLE-2
;WE SHOULD NOW HAVE FLAG = 2 IF ATTRIBUTE WAS REQUESTED, 3 FOR OBJECT,
;OR 4 FOR VALUE.
TRNN FLAG,3 ;SKIP IF ATTRIBUTE OR OBJECT
JRST [HRRZ B,1(C) ;GET VALUE ITEM NUMBER
JRST SLCT1]
HLRZ B,1(C) ;BACK POINTER TO M.H. HEADER
MOVE B,1(B) ;ATT-OBJ WORD
TRNN FLAG,1 ;SKIP IF OBJECT DESIRED
MOVS B,B ;PUT ATTRIBUTE IN R.H.
SLCT1: HRRZM B,-1(P) ;STORE IT AS A RETURNED VALUE
>;URLEAP
NOURLEAP <
JRST ERR1 ;NO, ERROR
HRRZ C,(B)
MOVE B,1(C) ;GET A-O-V GUY.
TRNN B,-1
ERR1: ERR <NOT A BRACKETED TRIPLE>,1
SUBI FLAG,SELET1-ROUTABLE-2
TRNE FLAG,1
LSH B,ITLEN
TRNE FLAG,2
LSH B,-(2*ITLEN)
ANDI B,7777 ;A FULL-FLEDGED ITEM
MOVEM B,-1(P) ;STORE IT AS A RETURNED VALUE
>;NOURLEAP
POPJ P,
DSCR DELETE
DELETE -- ITEM PASSED IN STACK. IT IS DELETED. THIS INVOLVES
COPYING IT ONTO THE "RECENT FREE ITEM" LIST,
REMOVING ITS PRINTNAME IF ANY, RELEASING THE
ARRAY WHICH WAS ITS DATUM IF THAT WAS THE CASE.
IF IT'S A BRACKETED TRIPLE ITEM, WE DELETE THE
ITEM BUT LEAVE THE TRIPLE (I.E. IT'S NO LONGER A
BRACKETED TRIPLE BUT IT'S STILL IN THE STORE.
;
DELETE: ;JRST TO DELETE....
HRRZ A,HASHP(USER) ;IF THERE ARE PRINTNAMES.
JUMPE A,NOPRN ;NO
PUSH P,(P) ;ITEM NUMBER.
PUSHJ P,DEL.PNAME ;DELETE THE PNAMES.
NOPRN:
PUSH P,(P) ;COPY ITEM NUMBER
MOVE C,(P) ;GET ITEM NUMBER
;;#NZ# RHT 8-30-73 1 OF 1
CAIG C,7 ;IS THIS TURKEY DELETING ONE OF THE GOOD GUYS
ERR <DELETE OF A RESERVED ITEM>,1
;;#NZ#
GLOB <
TLNN FLAG,GLBSRC ;LOCAL DELETE?
CAIG C,GBRK ;HAD BETTER BE LOCAL ITEM.
JRST .+2
ERR <LOCAL DELETE OF GLOBAL ITEM>,1
TLNE FLAG,GLBSRC ;GLOBAL DELETE?
CAIL C,GBRK ;HAD BETTER BE GLOBAL ITEM.
JRST .+2
ERR <GLOBAL DELETE OF LOCAL ITEM>,1
>;GLOB
PUSHJ P,TYPEX ;GET ADDRESS OF DATUM,,TYPE
HLRZ B,A ;ADDRESS OF DATUM
HRRZS A ;TYPE
CAIE A,PRCTYP ;PROCESS TYPE?
JRST NTPRCT
PUSH P,UUO1(USER) ;SINCE TERMIN WILL DESTROY
PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,C ;ITEM PARAMETER TO TERMINATE
PUSHJ P,TERMIN
POP P,C
POP P,B
POP P,A
MOVE USER,GOGTAB
POP P,UUO1(USER)
GLOB <
MOVEI TABL,(USER) ;WE KNOW IT IS A LOCAL ITEM
>;GLOB
JRST CLRDAT
NTPRCT:
JUMPN A,.+2 ;ALREADY DELETED?
ERR <DELETE - DELETED NON-EXISTANT ITEM>
GLOB<
WRITSEC ;CRITICAL SECTION
>;GLOB
ADD C,INFOTAB(TABL) ;
HLLZS (C) ;MARK AS DELETED
CAIE A,BRKITM ;BRACKETED TRIPLE?
JRST NOBRACK ;NO
;BRACKETED TRIPLE
URLEAP <
HRRZ C,(B) ;ADDR ASSOC.
MOVEI A,BRACKL(TABL) ;LIST HEAD OF B.T. BLOCKS
DBT1: MOVE D,A ;REMEMBER WHO POINTS TO US
HRRZ A,(A) ;NEXT B.T. BLOCK
SKIPN A ;IF WE RUN OUT, WE'RE REALLY SCREWED UP
ERR <DRYROT -- BRACKETED TRIPLE DELETE>
CAME C,1(A) ;IS THIS THE BLOCK THAT HAS TO GO?
JRST DBT1 ;THIS IS WOEFULLY INEFFICIENT, BUT ...
HRRZ C,(A) ;NEXT POINTER FROM DOOMED B.T. BLOCK
HRRM C,(D) ;MAKE LIST GO AROUND IT
SETZM 1(A) ;CLEAR IT OUT IN PREPARATION FOR ...
HRRZ FP,FP2(TABL) ;... RETURNING IT TO THE TWO-WORD FREE LIST
HRRZM FP,(A)
HRRZM A,FP2(TABL) ;UPDATE LIST HEADER
JRST CONDEL
>;URLEAP
NOURLEAP <
MOVE C,(B) ;ADDR ASSOC.
HLRZ PNT,(C) ;A-O-V OF BRACKET
BRACKN (PNT) ;REALLY A BTRIP?
ERR <DRYROT-BRACKETED TRIPLE DELETE>,1 ; NO
HLRZ D,(PNT) ;NEXT IN VALUE LIST
HLRM D,(C) ;ASSOC NO LONGER BTRIP
JRST LINKOLD ;LINK BTRIP ITEM INTO FREELIST
>;NOURLEAP
NOBRACK:
CAIE A,RFITYP ;REFITM?
JRST NOTREF ;NO
; A REFITM
MOVE C,(B) ;GET THE DATUM OF REFITM
TLNE C,REFB ;BY REFERENCE?
JRST CLRDAT ;YES,EASIEST CASE OF ALL
TLNE C,ITEMB ;AN ITEM TYPE THING?
JRST RELONE ;YES, JUST NEED TO RELEASE THE ONE WORD FREE
;;#UC# (1) ! USED TO BE (C)
LDB D,[POINT 6,C,12] ;GET TYPEIT CODE
CAIN D,STTYPE ;IS THIS A STRING TEMP
JRST DLSREF ;YES
CAIE D,LSTYPE ;A LIST TYPE THING?
CAIN D,SETYPE
JRST DLSTREF
RELONE:
HRR FP,FP1(TABL)
HRRZM FP,(C) ;LINK THE FREE IN.
HRRM C,FP1(TABL) ;NEW FREE LIST
JRST CLRDAT ;REMAINDER OF DELETE
DLSREF: HLRZ D,HASHP(USER) ;FREE STRING DESCRIPTOR LIST
;;#TY# (CMU =E5=) LDE ! 2-10-75 ZERO FIRST WORD OF DESCRIPTOR
SETZM -1(C) ;SO GARBAGE COLLECTOR IS HAPPY
HRRZM D,(C)
HRLM C,HASHP(USER)
JRST CLRDAT ;REMAINDER OF DELETE
DLSTREF: ;SET OR LIST
;;#UC# (2) USED TO BE HLRZ D,(C)
HRRZ D,(C) ;ADDRESS OF LAST,,FIRST WORD
HLRZ D,(D) ;ADDRESS OF LAST WORD IN LIST
;;#UC# ^
HRR FP,FP1(TABL)
HRRZM FP,(D)
HRRM C,FP1(TABL) ;FREE THE TEMP AND LIST AT ONCE
JRST CLRDAT
NOTREF: ;CONTINUE TO CHECK SPECIAL CASES
REC <
;;#VG# DONT NEED TO DEREFERENCE ANY MORE
NORGC <
**** THIS SHOULD NOT ASSEMBLE ****
CAIE A,RECTYP ;A RECORD ITEM?
JRST NOTREC ;NOPE
RECUUO 0,(B) ;DEREFERENCE THIS ONE
JRST CLRDAT ;
NOTREC:
>;NORGC
>;REC
;;%BI% ! USED TO TEST ARRTYP
CAIG A,MXSTYP ;SEE IF ARRAY (IE GREATER THAN MAX SCALAR TYPE)
JRST CLRDAT ;NO CLEAR DATUM
CAIN A,INVTYP ;INVALID TYPE?
ERR <DRYROT - ITEM TYPE CONFUSION>
;; #ND# ! BETTER SAVE B ALSO
PUSH P,B ;SAVE B OVER ARRAY STUFF
CAIE A,LSTYPE+ARRTYP
CAIN A,SETYPE+ARRTYP
JRST [ PUSH P,A ;CALL WILL DESTROY
;; #ND# BAD CALLING SEQUENCE TO ARRRCL, WAS DOING MOVE A,(B) INSTEAD OF PUSH
PUSH P,(B) ;ARRAY DESCRIPTOR
;; #ND#
PUSHJ P,ARRRCL
POP P,A
JRST .+1]
SKIPN B,@(P) ;DATUM
ERR <DRYROT - DELETE MISSING ARRAY ITEM>,1
CAIE A,STTYPE+ARRTYP ;STRING ARRAY
JRST RELGO ;NO.
MOVEI LPSA,ARYLS(USER) ;LINKED LIST OF STRING ARRAYS
MOVE C,ARYLS(USER) ;
HLRZ D,(C) ;ARRAY POINTER
CAIE D,(B) ;RIGHT ONE?
JRST [MOVEI LPSA,(C)
HRRZ C,(C)
JUMPN C,.-2
ERR <STRING ARRAY ITEM CONFUSION>]
HRR D,(C) ;REMOVE FROM ARYL LIST
HRRM D,(LPSA)
HRR D,FP1(USER) ;LINK ONTO FREE LIST
HRRM D,(C)
HRRM C,FP1(USER) ;
SUBI B,1 ;ADDR STRING ARRAY ITEM
RELGO: HLRE C,-1(B) ;NUMBER OF DIMENSIONS
MOVMS A,C ;WILL DO 2 ADDS TO SIMUL. MULT BY 3
ADDI C,(C)
ADDI C,(A)
SUBI B,2(C) ;NOW A CORGET POINTER
PUSHJ P,CORREL ;RELEASE ARRAY SPACE
POP P,B ;DATUM ADDRESS
JRST CONDEL ;CONTINUE WITH REST OF DELETE
CLRDAT: CAIE A,LSTYPE ;A SIMPLE LIST?
CAIN A,SETYPE ;A SIMPLE SET
JRST [SKIPN A,(B) ;SEE IF NULL LIST OR SET
JRST .+1 ;NULL SO IGNORE
SKIPG A ;TEMP?
ERR <DRYROT-TEMP. CONTAINED IN ITEM LIST OR SET >
PUSH P,B ;SAVE DATUM ADDRESS
PUSHJ P,RECQQ ;RECLAIM LIST SPACE
POP P,B
JRST CONDEL]
CAIN A,CTXTYP ;A CONTEXT ITEM?
JRST [PUSH P,UUO1(USER) ;ALLFOR DESTROYS
PUSH P,B ;THE ADDRESS OF CONTEXT
PUSHJ P,ALLFOR
MOVE USER,GOGTAB
POP P,UUO1(USER)
JRST CONDEL]
CAIE A,STTYPE ;A STRING ITEM
JRST CONDEL ;NO.
MOVE A,(B) ;ADDRESS STRING DESCRITOR
SETZM -1(A) ;NULL STRING
HLRZ C,HASHP(USER) ;OLD STRING LIST
HRRM C,(A) ;LINK DELETED DESCRIPTOR ONTO IT
HRLM A,HASHP(USER) ;SAVE NEW LIST
CONDEL:
GLOB<
SKIPN FP,FP1(TABL) ;ANY FREES YET?
PUSHJ P,FP1DON ;NONE YET. GET SOME.
>;GLOB
NOGLOB <
MOVE FP,FP1(TABL) ;NEED TO MAKE FREE ITEM CELL
>;NOGLOB
MOVEI PNT,(FP) ;ADDRESS NEW CELL
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON ;GET SOME MORE IF NECESSARY
HRRM FP,FP1(TABL) ;UPDATE FREE STORAGE LIST HEAD
LINKOLD:
SETZM (B) ;MAKE SURE DATUM IS CLEARED
MOVS B,(P) ;ITEM NUMBER
HRR B,OLDITM(TABL)
MOVEM B,(PNT)
MOVEM PNT,OLDITM(TABL) ;UPDATE LIST OF DELETED ITEMS
AOS FREITM(TABL) ;INCREASE COUNT OF FREE
ALDDD:
POP P,A ;REMOVE ITEM
JRST LEAV ;EXIT
DSCR ARRRCL ;RECLAIM ARRAY OF SETS,LISTS
TO RECLAIM AN ARRAY OF LISTS OR SETS
ONLY RECLAIMS LIST SPACE, NOT ARRAY SPACE
ARRAY ADDR IN -1(P)
ROUTINE CALLED WITH PUSHJ
SAVES AC'S
HERE(ARRRCL) ;RECLAIM AN ARRAY OF LISTS
PUSHJ P,FSAV ;SAVE AC'S
MOVE B,-1(P) ;ADDRESS OF ARRAY
HRRZ C,-1(B) ;NUMBER OF ELEMENTS IN ARRAY
ARLOOP: MOVEI TAC1,(B) ;ADDRESS OF LIST
SKIPGE A,(TAC1) ;TEST IF TEMPORARY
ERR <ARRAY TEMP SET -CONFUSION>
JUMPE A,INCBC ;IF NULL, NO NEED TO RECLAIM
PUSH P,B ;SAVE AC
PUSH P,C ;SAVE AC
PUSHJ P,RECQQ ;RECLAIM SET
POP P,C ;RESTORE
POP P,B ;RESTORE
INCBC: ADDI B,1 ;TO NEXT ELEMENT ADDRESS
SOJG C,ARLOOP ;MORE?
PUSHJ P,FREST ;RESTORE CALLERS AC`S
SUB P,X22 ;ADJUST STACK
JRST @2(P) ;RETURN
DSCR NEW (VARIOUS KINDS), AND ARRAY ITEM CODE.
NEW AND NEWX -- RETURN WITH THE STACK BUMPED BY ONE, AND
THE TOP OF STACK HAS A SHINY NEW ITEM. THE
DATUM ENTRY IS ZEROED. THE INFOTAB ENTRY IS NOT
ZEROED IN CASE THERE ARE ERRONEOUS ASSOCIATIONS
STILL USING THAT VALUE LIST.THE RIGHT HALF OF INFOTAB
WILL CONTAIN 0 PROPS FIELD AND TYPE OF NEW ITEM (FROM
LEFT HALF OF FLAG)
NEWART -- CALL IS WITH ARITHMETIC VALUE IN STACK.
RETURNS A NEW ITEM NUMBER, WITH ARITHMETIC VALUE
STUFFED IN DATUM ENTRY.
NEWARY -- CALL IS WITH ARRAY DESCRIPTOR IN STACK.
RETURNS A NEW ITEM NUMBER, WITH DESCRIPTOR OF
COPIED ARRAY STUFFED IN DATUM ENTRY.
;
NEW: ;GET A NEW ITEM NUMBER.
NEWX:
GLOB <
WRITSEC ;ENTER CRITICAL SECTION.
>;GLOB
SKIPN C,OLDITM(TABL) ;SEE IF ANY DUSTY OLD ITEMS.
JRST NWITM ;CAN'T USE A LITERAL HERE
MOVEI B,(C) ;PREPARE TO FREE THE ONE WORD
MOVS C,(C)
HLRZM C,OLDITM(TABL) ;UPDATED POINTER.
HRR FP,FP1(TABL) ;WILL ADD WORD FROM OLDITM LIST
HRRM FP,(B) ;LINK ON
HRRM B,FP1(TABL) ;NEW HEAD OF ONE-WORD FREES
URLEAP <
HRRZ C,C ;CLEAR L.H., LEAVING ITEM NUMBER
>;URLEAP
NOURLEAP <
ANDI C,TOPITM ;ITEM NUMBER.
>;NOURLEAP
REITM:
URLEAP <
SOSGE FREITM(TABL) ;ONE LESS FREE
ERR <DRYROT - LEAP NEW FREITM BUG>,1
>;URLEAP
NOURLEAP<
SOS FREITM(TABL) ;CAN GO NEGATIVE BECAUSE OF ALLOCATION FUDGE
>;NOURLEAP
GLOB <
TLNN FLAG,GLBSRC
>;GLOB
SETZM @DATM ;ZERO THE DATUM.
GLOB <
TLNE FLAG,GLBSRC ;IF GLOBAL THEN
SETZM @GDATM ;ALSO ZERO THE GLOBAL DATUM.
>;GLOB
MOVE A,INFOTAB(TABL) ;ADDRESS INFOTAB
ADDI A,(C) ;ADDRESS THIS ITEM ENTRY
HLLZ B,FLAG ;GET TYPE CODE
GLOB< TLZ B,GLBSRC ;TURN OFF GLBSRC BIT
>;GLOB
HLRM B,(A) ;STORE TYPE CODE
EXCH C,(P) ;RECORD NEW ITEM NUMBER
;IN STACK.
JRST (C) ;EXIT.
NWITM: ;JRST HERE FROM ABOVE
GLOB <
NOURLEAP <
TLNE FLAG,GLBSRC;IF GLOBAL THEN
SOSA C,MAXITM(TABL);USE GLOBAL COUNT.
AOS C,MAXITM(USER);USE LOCAL ITEM NUMBER.
CAIGE C,GBRK ;ABOVE THE BREAK?
JRST [ TLNE FLAG,GLBSRC; WAS IT A GLOBAL SEARCH
ERR <GLOBALS OVERFLOWED INTO LOCALS>,1
JRST REITM] ;NO --PROCEED.
TLNN FLAG,GLBSRC ;IF GLOBAL REQUEST, OK.
ERR <LOCALS OVERFLOWED INTO GLOBALS>,1
CAIGE C,TOPITM ;IF GONE TOO HIGH.
>;NOURLEAP
URLEAP <
TLNE FLAG,GLBSRC;IF GLOBAL THEN
SOSA C,MAXITM(TABL);USE GLOBAL COUNT.
SOS C,ITMBOT ;USE LOCAL ITEM NUMBER
CAIL C,GBRK ;IF ABOVE BREAK,...
JRST REITM ;... NO ERROR POSSIBLE
TLNE FLAG,GLBSRC ;WAS IT A GLOBAL ITEM?
ERR <GLOBAL ITEM OVERFLOW>,1
CAMLE C,TPALLC ;IF GONE TOO LOW, THEN
>;URLEAP
>;GLOB
NOGLOB <
NOURLEAP <
AOS C,MAXITM(USER);USE LOCAL ITEM NUMBER.
CAMGE C,ITMTOP(USER);IF GONE TOO HIGH. THEN
>;NOURLEAP
URLEAP <
SOS C,ITMBOT ;USE LOCAL ITEM NUMBER
CAMLE C,TPALLC ;IF GONE TOO LOW, THEN
>;URLEAP
>;NOGLOB
JRST REITM
ERR <ITEM SPACE EXHAUSTED>
NEWART: ;PUSHJ HERE FOR NEW WITH ARITHMETIC TYPE
POP P,FRTAB ;RETURN ADDRESS.
HLRZ B,FLAG
CAIE B,STTYPE ;IF STRING THEN VALUE IS NOT ON PSTACK
POP P,FPD ;VALUE
PUSHJ P,NEWX ;GET NEW ITEM
MOVE PNT,(P)
ADD PNT,DATAB(TABL)
MOVEM FPD,(PNT) ;DATUM...
HLRZ B,FLAG
GLOB<
TRZ B,GLBSRC ;TURN IF OFF IF ON
>;GLOB
CAIE B,LSTYPE ;LIST?
CAIN B,SETYPE ;SET
JRST [PUSH P,FPD
PUSH P,FRTAB ;RETURN ADDRESS
MOVEI TAC1,(PNT)
JRST DUPSET] ;MUST COPY
CAIN B,RFITYP
JRST REFITM
CAIE B,STTYPE ;STRING?
JRST (FRTAB) ;NO,RETURN.
PUSH P,FRTAB ;RETURN ADDRESS
PUSHJ P,SDESCR ;GET AN NIL STRING DESCRIPTOR
POP P,A ;ADDRESS DESCRIPTOR
MOVEM A,(PNT) ;ADDRESS INTO DATAB
POP SP,(A)
POP SP,-1(A) ;STORE INITIAL STRING
POPJ P, ;RETURN
REFITM:
;; \UR#35\ BEGIN OF CROC FIX FOR ARRAYS
HLRZ B,(PNT) ;THE TYPE BITS
;; \UR#37\ BAD EXTRACTION OF TYPE BITS
;; TRZ B,MSK6BT ; GET SIX BIT TYPE
ANDI B,MSK6BT ; GET SIX BIT TYPE
LSH B,-5 ; SHIFT FOR COMPARISON
;; \UR#37\
CAIL B,ARRTYP ; AN ARRAY?
JRST [ ; YUP!
HRRZ B,(PNT);
HRRZ B,(B);
HRRM B,(PNT);
HLLZ B,(PNT)
JRST (FRTAB)]
;; end of \UR#35\
HLLZ B,(PNT) ;THE TYPE BITS
TLNE B,REFB ;REFERENCE?
JRST (FRTAB) ;EVERYTHING DONE
TLZ B,37 ;TURN OFF @ AND INDEX(FOR VALUE STRINGS)
HRROI C,@(PNT) ;THE ADDRESS OF A TEMP
TLNE B,ITEMB ;VALUE ITEMVAR?
JRST SMPL ;EASY
HLRZ D,B ;GET THE TYPE BITS
LSH D,-5 ;
ANDI D,77 ;JUST THE TYPEIT CODE
CAIN D,STTYPE ;STRING?
JRST SREF ;YES
CAIE D,LSTYPE ;LIST OR
CAIN D,SETYPE ;SET?
JRST STREF ;YES
SMPL:
; AT THIS POINT.
; PNT POINTS TO DATUM TABLE ENTRY
; LH(B) CONTAINS THE TYPE BITS
; RH(C) POINTS TO A CELL CONTAINING VALUE TO BE SAVED
; FRTAB CONTAINS RETURN ADDRESS
; THIS ROUTINE CAN'T USE AC D AS C MAY POINT TO AC D IN CASE OF LISTS
GLOB <
SKIPN FP,FP1(TABL) ;ANY FREE'S YET
PUSHJ P,FP1DON ;NO, GO GET SOME.
>;GLOB
NOGLOB <
MOVE FP,FP1(TABL) ;ADDRESS OF FREE
>;NOGLOB
HRRI B,(FP) ;SAVE ADDRESS OF FREE
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON
HRRM FP,FP1(TABL)
MOVEM B,(PNT) ;SAVE IN DATUM TABLE
MOVE PNT,(C) ;VALUE TO BE SAVED
MOVEM PNT,(B) ;SAVE IN ONE WORD FREE WE JUST GOT
JRST (FRTAB) ;RETURN
SREF: ;A VALUE STRING
PUSHJ P,SDESCR ;GET A STRING DESCRIPTOR
POP P,A ;POINTS TO DESCRIPTOR WE GOT
;; #SB# RHT VALUE STRINGS NOW ON SP STACK
POP SP,(A) ;COPY STRING
POP SP,-1(A)
;; #SB#
HRR B,A
MOVEM B,(PNT) ;INTO DATUM TABLE
JRST (FRTAB) ;RETURN
STREF: ;SET OR LIST
SKIPG D,(C) ;IF NULL OR TEMP SET
JRST SIMSET ;NO NEED TO COPY
PUSH P,B ;SAVE TYPE BITS
PUSH P,PNT ;AND DATUM TABLE POINTER OVER CALL TO CAT
PUSH P,(C)
PUSH P,[0]
PUSHJ P,CATLST ;LET CAT COPY SET
POP P,D
POP P,PNT
POP P,B
SIMSET: HLRE C,D ;THE TEMP SET INDICATOR
MOVMS C ;MAKE PERMANENT
HRL D,C ;NOW A PERM SET
MOVEI C,D ;SET UP FOR SMPL
JRST SMPL
NEWARY: ;JRST HERE
GLOB <
TLNE FLAG,GLBSRC
SETOM USCOR2(USER)
>;GLOB
PUSHJ P,ARCOP ;COPIES THE ARRAY IN -1(P)
;; #NW ! MAKE SURE LH(ARRAY PTR) ZERO,(AVOID DRYROT ON DELETING STRING ARRAY ITEM);
HRRZS A
PUSH P,A ;SAVE POINTER
;RETURNS POINTER IN A
PUSHJ P,NEW ;GET A NEW ITEM.
;ITEM IS ON TOP OF STACK.
MOVE A,-1(P) ;POINTER
MOVE PNT,(P) ;ITEM NUMBER
JSP FPD,ARYL ;MARK AN ARRAY; LINK INTO ARYLS.
POP P,A ;ITEM NUMBER
EXCH A,(P) ;EXCHANGE WITH ARRAY POINTER
HLRZ B,FLAG ;GET TYPE CODE OF NEW ARRAY
GLOB <
TRZ B,GLBSRC ;TURN OFF GLBSRC
>;GLOB
CAIE B,SETYPE+ARRTYP ;A SET ARRAY?
CAIN B,LSTYPE+ARRTYP ;A LIST ARRAY?
PUSHJ P,COPARR ;YES
GLOB <
SETZM USCOR2(USER)
>;GLOB
JRST LEAV
^COPARR:PUSH P,A ;ADDRESS BASE OF ARRAY
SOS (P) ;SO AOS WILL WORK BELOW
PUSH P,-1(A) ;SIZE OF ARRAY
HRRZS (P) ;REMOVE DIMENSION INFO.
LPCOPA: SOSGE (P) ;THROUGH COPYING?
JRST [ SUB P,X22
POPJ P,]
AOS TAC1,-1(P) ;ADDRESS THIS SET
PUSH P,(TAC1) ;SET TO BE COPIED
PUSHJ P,DUPSET ;COPY SET
JRST LPCOPA ;LOOP
;THIS IS THE "NEW ARRAY" CODE.
;THIS MAKES ARRAYS FOR ITEMS AND PUTS THE DESCRIPTOR IN THE
;DATUM TABLE
GLOB <
;IF FLAG HAS GLBSRC ON, THIS IS GOING TO BE A GLOBAL ARRAY.
;IF FLAG HAS THE ARRTYP BIT IN THE LEFT HALF, THIS IS A REAL LEAP
;ARRAY (MEANING IT IS THE DATUM OF SOME ITEM)
;IF FLAG DOES NOT HAVE THE ARRTYP BIT SET IN THE LEFT HALF,
;IT IS PRESUMABLY A GLOBAL ARRAY OF SOME SORT.
>;GLOB
ITMYR: ;COMPILED IN LOCAL ARRAY ITEM
HLRZ A,TEMP ;LEFT OVER FROM HRLI FOR
POP P,PNT ;ITEM NUMBER.
MOVEI FPD,LEAV ;IN LINE CALL.
JRST ARYPUT ;COMPILED IN ARRAY.
ITMRY: ;COMPILED IN GLOBAL ARRAY OR ARRAY ITEM
MOVE C,UUO1(USER) ;RETURN ADDRESS SINCE ARMAK WILL DESTROY.
GLOB <
HRRZ B,@UUO1(USER) ;THIS IS ADDRESS OF THE MOVEM ....
TLNE FLAG,ARRTYP ;THIS IS THE LPARRAY BIT
JRST [
>;GLOB
POP P,B ;ITEM NUMBER.....
MOVE D,B ;ITEM NUMBER
ADD B,DATAB(TABL) ;NOW INDEX TO DATUM.
GLOB <
JRST .+1]
TLNE FLAG,GLBSRC ;SEE IF GLBMODEL
JRST [SKIPE (B) ;IS IT THERE ALREADY?
JRST FIXUP ;YES -- FIXUP STACK FOR EXIT.
SETOM USCOR2(USER);GET IT NOW
JRST .+1]
>;GLOB
PUSHJ P,ARMAK ;MAKE AN ARRAY
;RETURNS DESCRIPTOR IN A.
;; #OE ! AVOID DRYROT WHEN DELETING STRING ARRAY ITEM
HRRZS A
MOVEM A,(B) ;AND RECORD ANSWER SINCE AC B WAS SAVED.
MOVEM C,UUO1(USER) ;AND PUT THIS BACK.
GLOB <
SETZM USCOR2(USER) ;PUT IT BACK.
TLNN FLAG,ARRTYP ;THIS IS ON IF A LEAP ARRAY.
JRST LEAV ;GO AWAY -- IT WAS A SIMPLE GLOBAL ARRAY.
>;GLOB
MOVE PNT,D ;IT WAS AN ARRAY ITEM -- THIS IS THE ITEM
MOVEI FPD,LEAV ;IN LINE CALL.
;STUFF BELOW IS CALLED AS SUBROUTINE.
; ARYL RECORDS THE ARRAY IN A IN LIST OF STRING ARRAY ITEMS ARYLS
; IT ALSO SETS UP THE DATUM AND INFOTAB ENTRIES CORRECTLY.
;INPUT --- A HAS THE ARRAY DESCRIPTOR
; PNT HAS THE ITEM NUMBER (PASSED AS PARAM).
GLOB <
; FLAG HAS THE GLBSRC BIT ON IF THIS IS A GLOBAL ARRAY.
>;GLOB
ARYL:
GLOB <
TLNE FLAG,GLBSRC
JRST NOGLH ;DO NOT PUT ON LISTS.
>;GLOB
HLRZ C,FLAG ;GET TYPE OF ARRAY
CAIE C,STTYPE+ARRTYP ;STRING ARRAY?
JRST NOGLH ;NO.
GLOB <
SKIPN FP,FP1(TABL) ;FOR ARRAY LISTS
PUSHJ P,FP1DON ;NONE YET, GET SOME.
HRRZ C,FP
SKIPN FP,(FP)
>;GLOB
NOGLOB <
HRRZ C,FP1(TABL) ;FOR ARRAY LISTS
SKIPN FP,(C)
>;NOGLOB
PUSHJ P,FP1DON
;; #RM# ! (CMU =B3=) LDE WAS PREVIOUSLY A MOVEM
HRRM FP,FP1(TABL)
HRRZ D,A ;STRING ARRAY POINTER
HRL D,ARYLS(USER) ;CURRENT LINKED LIST OF ARRAYS.
MOVSM D,(C) ;IN NEW BLOCK.
HRRZM C,ARYLS(USER) ;AND UPDATE LIST
NOGLH:
ARYPUT: HRRZ B,PNT ;ITEMNUMBER
ADD B,DATAB(TABL) ;POINTER TO DATUM
MOVEM A,(B) ;PUT DOWN DESCRIPTOR.
JRST (FPD) ;RETURN.
GLOB <
FIXUP: ;FIXUP THE ARMAK CALL....
MOVM B,(P) ;NUMBER OF PARAMS.
LSH B,1 ;MULT. BY TWO.
ADDI B,1
HRLI B,(B) ;XWD PARAM+1,PARAM+1
SUB P,B ;O GOD.
TLNN FLAG,ARRTYP
AOS UUO1(USER) ;PAST THE MOVEM......
JRST LEAV
>;GLOB
NOEXPO <
INTERNAL IFGLOBAL
HERE (IFGLOBAL)
GLOB <
PUSH P,C ;SAVE B
MOVE C,-2(P) ;ITEM TO BE TESTED
CAIL C,TOPITM ;TOO HIGH?
JRST NTGLB
CAMGE C,MAXITM+GLUSER ;TOO LOW?
JRST NTGLB
LDB C,GINFTB ;ALLOC?
SKIPN C
;; #JI# BY JRL 10-2-72
NTGLB: TDZA A,A
;; #JI#
MOVNI A,1
POP P,C
>;GLOB
NOGLOB <
MOVEI A,0 ;NO GLOBAL ITEMS
>;NOGLOB
SUB P,X22
JRST @2(P)
>;NOEXPO
DSCR SET AND ITEM STORING OPERATIONS.
IF THE TOP OF THE STACK IS AN ITEM, WE OCCASIONALLY CALL
"STORE" TO STORE IT INTO SOME CORE LOCATION. THE COMPILER
SHOULD BE FIXED TO SIMPLY "POP" THE THING OFF INTO THE RIGHT
SPOT.
HOWEVER, IF THE TOP OF THE STACK IS A SET, WE REALLY DO NEED
TO DO SOME SCREWING AROUND. HENCE, CALLING "STORE" IS MORE
OR LESS NEEDED.
ALL ENTRIES NEED: TAC1 HAS ADDRESS OF TARGET LOCATION.
IF LH (TAC1) = -1, THEN THE TARGET IS A SET DESCRIPTOR.
THE VARIOUS ENTRIES ARE:
STORITM -- MAIN STORE ROUTINE. STORE ITEM OR SET ON TOP OF
STACK. SUBTRACT STACK WHEN DONE.
POPSET -- STORE TOP OF STACK (MUST BE SET) INTO AC 1.
(NO LONGER COMPILED), MAY BE DELETED WHEN SAISG5 IS
STORBUTDONTREMOVE -- SAME AS STORITM, BUT STACK IS NOT
SUBTRACTED.
SETCOP -- THE SET AT THE ADDRESS SPECIFIED BY TAC1 IS
COPIED OVER INTO ITSELF. THIS IS FOR SETS
PASSED AS VALUE PARAMETERS TO PROCEDURES. IF
THE ACTUAL IS A "TEMP SET", THEN NO ACTUAL
COPY IS MADE. THE INVERSE OF SETCOP IS:
SETRCL -- RECLAIM THE SET POINTED TO BY TAC1. THE STORAGE
IS LINKED BACK ON THE FREE STORAGE LIST.
;
SETCOP: PUSH P,(TAC1) ;THE SET TO BE COPIED.
TLZ TAC1,777
JRST SETGO ;ALWAYS RECOPY.
POPSET: SETZM RACS+1(USER) ;TO MAKE TARGET SET LOOK NULL.
HRROI TAC1,RACS+1(USER)
JRST STORITM
STORBUTDONTREMOVE:
TLOA TAC1,777 ;THESE BITS WILL TELL US WHETHER
STORITM: ;TO ADJUST THE STACK ON EXIT.
TLZ TAC1,777
JUMPL TAC1,SETSTOR
MOVE B,(P) ;ITEM ARGUMENT.
TLNE FLAG,BOUNDATTPOS
PUSHJ P,BSATIS ;FOR IMBEDDED STORES IN FOREACHES
MOVEM B,(TAC1) ;STORE IT.
JRST DECIDE ;ARRANGE STACK ACCORDINGLY.
BSATIS: PUSH P,FRTAB ;SAVE AC
PUSH P,C
MOVE FRTAB,FRLOC(USER) ;CURRENT FOR EACH TABLE
SKIPE C,RUNNER
MOVE FRTAB,CURSCB(C)
POP P,C
XCT MOVEB(FRTAB) ;GET SATISFIER
NOURLEAP <
TRZ B,BNDFOR
>;NOURLEAP
POP P,FRTAB ;RESTORE AC
POPJ P, ;RETURN
SETSTOR: ;SET IS TO BE STORED.
GLOB <
TRNE TAC1,400000 ;A SECOND SEGMENT SET??
JRST [MOVSI FLAG,GLBSRC
MOVEI TABL,GLUSER;FIX IT UP
JRST .+3]
TLNE FLAG,GLBSRC
WRITSEC ;ENTER CRITICAL SECTION.
>;GLOB
SKIPE A,(TAC1) ;IS OLD SET THERE?
CAMN A,(P) ;IF NULL SET, OR SAME AS ON STACK.
JRST SETGO ;DO NOT RECLAIM OLD ONE.
MOVE FP,FP1(TABL)
HLRZ B,(A) ;RECLAIM STORAGE
HRRM FP,(B)
HRRM A,FP1(TABL) ;VERY FAST !
SETGO:
GLOB <
TLNE FLAG,GLBSRC ;IF GLOBAL SEARCH, THEN
JRST [MOVE A,(P) ;GET SET....
JRST COPYQ] ;AND COPY IT.
>;GLOB
SKIPGE A,(P) ;GET ARGUMENT.
JRST TEMPSET ;A TEMPORARY -- NO NEED TO COPY.
COPYQ: JUMPE A,NULLSET
PUSH P,[0] ;LET UNION DO THE WORK.
PUSHJ P,UNION ;MAGIC.
MOVE A,(P) ;RESULTS.
TEMPSET:
HLRE B,A ;GET COUNT FROM TEMP SET.
MOVMS B ;MAKE IT POSITIVE (I.E. PERMANENT SET)
HRL A,B ;ABSOLUTE COUNT.
MOVEM A,(TAC1) ;STORE IN DESCRIPTOR.
MOVEM A,(P) ;IN CASE OF STORBUTDONTREMOVE.
SKIPA
NULLSET:
SETZM (TAC1) ;TARGET SET IS EASY !
DECIDE: MOVE A,RACS+1(USER) ;IN CASE OF POPTOP'S
TLNN TAC1,777 ;LEAVE TOP OF STACK ON?
POP P,B ;NO --THROW OUT.
JRST LEAV ;YES
SETRCL: SKIPGE A,(TAC1) ;IF TEMP SET, CRASH
ERR <PROC EXIT WITH TEMP SET>,1
JUMPE A,LEAV ;NOT IF NULL SET.
PUSHJ P,RECQQ ;RECLAIM A SET IN A.
JRST LEAV ;AND RETURN.
DSCR DUPSET - COPY A SET OR LIST
-1(P) CONTAINS A SET DESCRIPTOR OF A SET TO BE COPIED
TAC1 CONTAINS THE ADDRESS OF THE DESTINATION OF THE COPIED SET.
IF THE SET IS NULL WE SIMPLY ZERO THE DESTINATION. IF THE
SET IS PERMANENT WE COPY IT INTO THE APPROPRIATE SEGMENT.
IF TEMP SET (NEG. LENGTH) AND LOCAL DESTINATION WE CHANGE
THE TEMP TO A PERM. SET. IF GLOBAL DEST. WE MUST COPY
THE TEMP INTO THE UPPER SEGMENT, SINCE ALL TEMPS ARE IN TH
LOWER SEGMENT. ALL AC'S EXCEPT USER MAY BE CHANGED.
DUPSET: SKIPN A,-1(P) ;NULL SET?
JRST [SETZM (TAC1) ;YES
SUB P,X22
JRST @2(P)]
JUMPL A,TMPSTC ;TEMP SET?
MSTCOP: ;HAVE TO COPY SET
GLOB <
JSP B,GQSET ;GLOBAL SET?
>;GLOB
PUSH P,A ;SET TO BE COPIED
PUSH P,[0] ;NULL SET
PUSHJ P,CATLST
EXTCOP: HLRE A,(P) ;MAKE INTO PERM. SET
MOVMS A
HRLM A,(P)
POP P,(TAC1)
SUB P,X22
JRST @2(P)
TMPSTC: ;TEMP SET TO BE COPIED
GLOB <
TRNE TAC1,400000 ;GLOBAL DESTINATION?
JRST MSTCOP ;THEN MUST COPY.
>;GLOB
PUSH P,-1(P)
JRST EXTCOP
DSCR PUTIN REMOV
PUTIN -- PUT TOP OF STACK IN SET POINTED TO BY TAC1.
THIS MAKES A PERMANENT SET (I.E. COUNT IN SET
DESCRIPTOR IS KEPT POSITIVE).
REMOV -- REMOVE THE ITEM MENTIONED IN TOP OF STACK FROM
THE SET POINTED TO BY TAC1.
;
;SET OPERATIONS.
;INITIALIZER FOR ALL SETS.
INSET:
SETZB LPSA ;FOR COUNTING PURPOSES.
;ALSO RIGHT HALF OF REGISTER
;0 MUST BE 0.
GLOB <
SKIPN FP,FP1(TABL) ;ONE-WORD FREES IF ANY
PUSHJ P,FP1DON ;NONE YET, GET SOME.
HRRZS FP
>;GLOB
NOGLOB <
HRRZ FP,FP1(TABL) ;ONE-WORD FREES IF ANY
>;NOGLOB
MOVEI FPD,(FP) ;ANOTHER COPY
HRROI PNT,(FP) ;AND ANOTHER COPY.
JRST (B) ;RETURN
GLOB <
GQSET: TRNE TAC1,400000 ;SECOND SEGMENT??
JRST [TLO FLAG,GLBSRC
MOVEI TABL,GLUSER
WRITSEC
JRST (B)]
MOVEI TABL,(USER)
NOSEC ;IN CASE IT WAS ON
TLZ FLAG,GLBSRC
JRST (B)
>;GLOB
;PUT AND REMOVE ----
; ITEM IS IN -1(P)
; => SET IN TAC1
PUTIN:
MOVE A,-1(P) ;ITEM. ;REPLACES BELOW
ENTY:
GLOB <
JSP B,GQSET ;GET SET FOR GLOBAL MODEL.
>;GLOB
GLOB <
SKIPN FP,FP1(TABL)
PUSHJ P,FP1DON ;NONE YET, GET SOME.
HRRZS FP
>;GLOB
NOGLOB <
HRRZ FP,FP1(TABL)
>;NOGLOB
MOVEI PNT,(FP)
SKIPN B,(TAC1) ;HEADER FOR SET.
JRST INS1 ;BRAND NEW
LOPSET: MOVE C,B ;REMEMBER WHO POINTED AT US.
HRRZ B,(B) ;GO DOWN SET.
JUMPE B,INSRT ;GOT TO END AND NOT FOUND.
HLRZ D,(B) ;GET ITEM NUMBER
CAIGE D,(A) ;COMPARE TO ONE BEING INSERTED
JRST LOPSET ;NOT FAR ENOUGH
CAIN D,(A)
JRST RETQ ;ALREADY THERE.
INSRT: SKIPN FP,(FP) ;GET FREE STORAGE.
PUSHJ P,FP1DON ;NONE LEFT.
HRLM A,(PNT) ;STORE THE NEW ITEM
HRRM PNT,(C) ;PUT IN POINTER.
HRRM B,(PNT) ;DOWN POINTER
TRNE B,-1 ;WAS THIS THE LAST?
JRST COUTUP ;NO
MOVE B,(TAC1) ;GET SET AGAIN.
HRLM PNT,(B) ;PUT IN "LAST" POINTER.
COUTUP: MOVSI B,1
ADDM B,(TAC1) ;BUMP COUNTER
JRST RETQ
INS1: MOVEI PNT,(FP) ;POINTER TO FIRST FREE.
SKIPN FP,(FP)
PUSHJ P,FP1DON
MOVEI B,(FP) ;POINTER TO SECOND FREE.
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLZM A,(B) ;ITEM INSERTED
HRLM B,(PNT)
MOVEM PNT,(TAC1)
JRST COUTUP
;REMOVE
;SAME CALLING SITUATION AS PUT.
REMOV:
GLOB <
JSP B,GQSET
>;GLOB
JSP B,INSET
SETZM .SKIP.
HRRZ A,-1(P) ;THE ITEM
MOVE B,(TAC1) ;SET HEADER
LOPSS1: MOVE C,B
HRRZ B,(B)
JUMPE B,ERRS1 ;IT WAS NOT THERE
HLRZ D,(B) ;ITEM NUMBER
CAIE D,(A) ;COMPARE
JRST LOPSS1 ;GO FARTHER
ENREMX: CAMN C,(TAC1) ;THE FIRST ELEMENT?
JRST ZEROS ;YES
REG: HRRZ D,(B) ;DOWN POINTER.
HRRM D,(C) ;BYPASS THE CELL BEING DELETED.
HRRZ LPSA,(TAC1) ;POINTER TO SET HEADER.
HLRZ D,(LPSA) ;NOW THE POINTER TO LAST OF LIST.
CAIN D,(B) ;SAME AS ONE WE FOUND?
HRLM C,(LPSA) ;YES -- INSTALL NEW "LAST" ELEMENT.
HRRM FP,(B) ;LINK ON FREE STORAGE LIST
HRLZI C,-1
ADDM C,(TAC1) ;DECREMENT COUNTER.
GOREM: MOVE FP,B
RETQ: HRRM FP,FP1(TABL) ;
JRST RET0 ;ALL DONE.
ZEROS: TLNE C,-2 ;THE VERY LASTELEMENT OF LIST.
JRST REG ;NO -- DO A REGULAR REMOVE.
;; #OA ENZERO ERRONEOUSLY LABELED THE HRRZ
ENZERO: HRRM FP,(B) ;LINK WHOLE THING ON FS LIST.
HRRZ B,(TAC1) ;THIS IS NOW THE FS LIST.
SETZM (TAC1) ;AND ZERO THE DESCRIPTOR
JRST GOREM
ERRS1: SETOM .SKIP.
JRST RETQ
DSCR SIP ,LSTMAK
SIP -- FOR MAKING UP SETS FROM LISTS OF ITEMS SETC A,B,C SETO .
CALL IS WITH TOP OF STACK HAVING ITEM IN IT,
NEXT ELEMENT IN STACK IS THE SET WE ARE BUILDING.
; SIP -- FOR MAKING UP SETS OF ITEMS.
;CALL IS WITH ITEM IN -1(P)
;SET STAYS IN -2(P) ..
SIP:
MOVE B,-1(P) ;ITEM
TLNE FLAG,(BOUND!BINDING)ATTPOS ;THIS AND NEXT INSTRUCTION PROBABLY
PUSHJ P,BSATIS ;GET SATIS ; NO LONGER NECESSARY
MOVEI TAC1,-2(P) ;THE SET DESCRIPTOR.
PUSH P,B ;ITEM TO BE INSERTED
HLRE B,(TAC1) ;COUNT
MOVMS B
HRLM B,(TAC1) ;MAKE POSITIVE.
PUSHJ P,PUTIN ;SEE PUTIN
HLRE A,(TAC1) ;COUNT OF SET.
MOVNS A
HRLM A,(TAC1) ;AND MAKE A TEMP.
SUB P,X22 ;RETRN ADDRESS AND ITEM, LEAVE SET ON STACK
JRST @2(P) ;RETURN
DSCR LSTMAK
FOR MAKING UP LISTS OF ITEMS
CALL IS WITH ITEM IN -1(P)
LIST STAYS IN -2(P)
LSTMAK:
MOVE B,-1(P) ;ITEM
TLNE FLAG,(BOUND!BINDING)ATTPOS
PUSHJ P,BSATIS ;GET SATISFIER
;;#RF# THE OLD CODE DID NOT INSERT AT END OF LIST (DID A BAG INSERTION)
COMMENT THIS WAS THE BAD OLD CODE ---
MOVEI TAC1,-2(P) ;ADDRESS OF SET
PUSH P,B ;SAVE
PUSH P,[0] ;WILL USE PUTA
HLRE B,(TAC1) ;COUNT
MOVMS B ;MAKE POSITIVE
HRLM B,(TAC1) ;STORE IN LIST DESCRIPTOR
PUSHJ P,PUTAFT ;INSERT ITEM INTO LIST AT TAIL
HLRE A,(TAC1) ;GET COUNT AGAIN
MOVNS A ;MAKE NEGATIVE
HRLM A,(TAC1) ;MAKE A TEMP
SUB P,X22
JRST @2(P)
GLOB <
SKIPN FP,FP1(TABL)
PUSHJ P,FP1DON
HRRZ FP,FP
>;GLOB
NOGLOB <
HRRZ FP,FP1(TABL)
>;NOGLOB
HRRZ PNT,FP ;
SKIPN C,-2(P) ;LIST EMPTY
JRST FI ;YUP
HRLZI TAC1,-1 ;FIX COUNT
ADDM TAC1,-2(P) ;
HLRZ TAC1,(C) ;TAC1 POINTS AT CURR LAST ELT
;AT THIS POINT, TAC1 POINTS AT LAST ELT
;C POINTS AT LAST,,FIRST WORD
;PNT IS A FREE CELL
;LIST LENGTH IS UPDATED
IB: SKIPN FP,(FP) ;INSERT B, AS SOON AS
PUSHJ P,FP1DON ;MAKE ROOM FOR POSTERITY
HRLZM B,(PNT) ;STICK ON END
HRRM PNT,(TAC1) ;OLD END POINTS HERE
HRLM PNT,(C) ;THIS IS THE END
JRST RETQ ; THIS DOES A HRRM FP,FP1(TABL)
; SUB P,X22
; JRST @2(P)
FI: SKIPN FP,(FP) ;NEED ANOTHER CELL
PUSHJ P,FP1DON
HRRO C,FP ;LEN,,[LAST,,FIRST]
MOVEM C,-2(P)
MOVE TAC1,C ;WILL CHAIN BOTH WAYS
JRST IB
;;#RF#
DSCR STIN, LSTIN
STIN -- BOOLEAN TO SEE IF ITEM (SECOND ELEMENT DOWN IN
STACK) IS MEMBER OF SET (TOP OF STACK).
LSTIN -- BOOLEAN TO SEE IF ITEM (-2(P)) IS MEMBER OF LIST (-1(P))
;
; STIN -- A BOOLEAN OF THE FORM X IN SET
;CALL IS WITH X IN -2(P)
; SET IN -1(P)
STIN:
MOVE B,-2(P) ;ITEM
TLNE FLAG,BOUNDATTPOS
PUSHJ P,BSATIS ;GET SATIS
SKIPN C,-1(P) ;IS THE SET EMPTY?
JRST NOPE ;SET EMPTY, THEREFORE ITEM CAN'T IN IT
HRRZ C,(C) ;POINT TO FIRST REAL NODE IN SET
SLOPT2:
HLRZ D,(C)
CAIL D,(B) ;FURTHER DOWN IN SET?
JRST [CAIE D,(B) ;ACTUALLY IN THE SET?
JRST NOPE ;NO.
JRST YUP] ;YES.
HRRZ C,(C) ;CDR DOWN THE SET
JUMPN C,SLOPT2 ;IF CDR=NULL THEN FAILURE
NOPE:
TDZA C,C
YUP: SETO C, ;RESULT IN C SINCE RECL1 USES A
PUSHJ P,RECL1 ;RECLAIM IF NECESSARY.
RET3C: HRREM C,A ;SAVE IN REG 1 AS RESULT.
RET3: SUB P,X33
JRST @3(P)
; LSTIN -- A BOOLEAN X IN LIST
LSTIN:
MOVE B,-2(P) ;ITEM
TLNE FLAG,BOUNDATTPOS
PUSHJ P,BSATIS ;GET SATISFIER
SKIPN C,-1(P) ;LIST EMPTY?
JRST NOPE ;LIST WAS EMPTY, THEREFORE FAIL
HRRZ C,(C) ;POINT TO FIRST REAL NODE IN LIST
LOPT2:
HLRZ D,(C)
CAIN D,(B) ;THIS THE ONE?
JRST YUP ;YESSIR
HRRZ C,(C) ;CDR DOWN THE LIST
JUMPN C,LOPT2
JRST NOPE
DSCR COUNT,UNIT,STLOP
COUNT -- RETURNS IN AC1 THE LENGTH OF THE SET (OR LIST) ON TOP
OF STACK.
UNIT -- RETURNS ON TOP OF STACK THE FIRST ELEMENT OF THE
SET (OR LIST) WHICH IS ON THE TOP OF STACK.
STLOP -- LOP OFF AN ELEMENT OF THE SET (OR LIST) POINTED TO BY
TAC1, RETURN RESULTANT ITEM IN TOP OF STACK.
;
; COUNT ....
; CALL IS WITH SET (OR LIST) IN -1(P)
COUNT:
HLRE C,-1(P)
PUSHJ P,RECL1 ;RECLAIM -1(P) IF NECESSARY.
MOVMM C,A
RET0:
SUB P,X22
JRST @2(P)
; UNIT ...
; CALL IS WITH SET (OR LIST) IN -1(P)
UNIT:
MOVE A,-1(P)
TLNN A,-1
ERR <LOP OR COP OF NULL SET OR LIST UNDEFINED>,1
HRRZ A,(A)
HLRZ PNT,(A) ;THING TO RETURN
PUSHJ P,RECL1 ;RECLAIM IF NECESSARY.
EXCH PNT,-1(P)
POPJ P,
; STLOP
; TAC1 PTS TO SET OR LIST, JRST TO STLOP
STLOP:
PUSH P,(TAC1) ;THE SET.
PUSHJ P,UNIT ;GO GET THE FIRST ELEMENT IN (P)
PUSH P,[1] ;REMOVE FIRST
PUSHJ P,REMX ;REMOVE IT
JRST LEAV ;RETURN AND LEAVE ITEM ON TOP OF STACK.
DSCR SETEST
SETEST -- CODE FOR TESTING SET BOOLEANS, I.E. SET CONTAINMENT,
EQUALITY, INEQUALITY, ETC.
;
;SET RELATIONS......
;VARIOUS LOCAL BITS.
TESNEQ__40 ;TEST NOT EQUAL
TESEQL__20 ;TEST EQUAL
TES12 __10 ;TEST 1 CONTAINED IN 2
TES21 __ 4 ;TEST 1 CONTAINS 2
TESMAY__ 2 ;IMPROPER SUBSETS.
ANSWER__ 1 ;THE ANSWER 0 FOR FALSE, 1 FOR TRUE
;FALSE UNTIL PROVEN TRUE.
RELTAB:
TES12
TES21
TESEQL
TESNEQ
TES12!TESMAY
TES21!TESMAY
SETEST:
MOVE RELTAB-RELSTART+ROUTAB(FLAG) ;BITS!!!!
TRNN TES21
JRST .+4
MOVE B,-2(P) ;EXCHANGE THE OPERANDS.
EXCH B,-1(P)
MOVEM B,-2(P)
HLRE A,-2(P) ;EXAMINE COUNTS.
HLRE B,-1(P)
MOVMS A
MOVMS B
TRNN TESNEQ!TESEQL ;THESE GUYS WANT THE EQUAL TEST
JRST CONTES
CAIE A,(B)
JRST TESE
EQTST: JUMPE A,TESME ;IF NULL SETS, CLEARLY EQUAL
MOVE A,-2(P)
MOVE B,-1(P)
EQLOP: HRRZ A,(A) ;NEXT ELEMENT.
JUMPE A,TESME
HRRZ B,(B)
HLRZ D,(A)
HLRZ LPSA,(B) ;ITEMS
CAIN LPSA,(D) ;EQUAL?
JRST EQLOP
TESE: TRNE TESNEQ
SETYES: TRC ANSWER
SETNO:
SETANS: SETOM C
TRNN ANSWER
SETZM C
PUSHJ P,RECL2 ;RECLAIM....
JRST RET3C
TESME: TRNN TESNEQ
TRC ANSWER
JRST SETANS
CONTES: CAIE A,(B)
JRST TESREL ;NOT SAME LENGTH.
TRZN TESMAY
JRST SETNO ;NOT POSSIBLY CONTAINED.
JRST EQTST
TESREL: CAIL A,(B) ;POSSIBLY CONTAINED :: COUNT(1) < COUNT(2)?
JRST SETNO
JUMPE A,SETYES ;NULL SET CONTAINED IN ANY SET.
MOVE A,-2(P)
MOVE B,-1(P)
COMLP: HRRZ A,(A)
COMLP1: HRRZ B,(B)
JUMPE A,SETYES ;ALL DONE AND NOT KICKED OUT.
JUMPE B,SETNO ;TRY TO GO PAST END ? -- NOT FEASIBLE.
HLRZ D,(A)
HLRZ LPSA,(B)
CAIGE D,(LPSA) ;CONTAINED?
JRST SETANS ;NO -- RETURN NO.
CAIE D,(LPSA) ;THE VERY SAME?
JRST COMLP1
JRST COMLP
DSCR UNION, INTERSECTION, SUBTRACTION
IN EACH CASE, ARGUMENTS ARE PASSED IN TOP TWO STACK
POSITIONS. RESULT IS LEFT AS A TEMPORARY SET ON THE
TOP OF THE STACK.
;
; UNION
; CALL IS WITH SETS IN -1 AND -2 (P)
UNION:
JSP B,INSET
MOVE A,-1(P)
MOVE B,-2(P) ;THE SETS
HRRZ A,(A)
HRRZ B,(B) ;AND PAST THE HEADERS.
LOPA1: JUMPE A,AEXH ;A IS EXHAUSTED
LOPA2: JUMPE B,BEXH
HLRZ C,(A) ;ITEM
HLRZ D,(B) ;THE OTHER ITEM
MOVEI PNT,(FP) ;THIS IS A FREE STOR. CELL.
SKIPN FP,(FP)
PUSHJ P,FP1DON
CAILE C,(D) ;WHICH ONE IS INSERTED?
SOJA LPSA,[HRLM D,(PNT) ;PUT IN ITEM
HRRZ B,(B)
JRST LOPA2]
HRLM C,(PNT)
CAIN C,(D) ;THE SAME ITEM?
HRRZ B,(B)
HRRZ A,(A)
SOJA LPSA,LOPA1 ;LOOP
AEXH: JUMPE B,DONN ;IF BOTH EXHAUSTED, DONE
HLRZ D,(B) ;NEXT ITEM
MOVEI PNT,(FP) ;FREE STORAGE CELL.
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM D,(PNT)
HRRZ B,(B)
SOJA LPSA,AEXH
BEXH: JUMPE A,DONN
HLRZ D,(A)
MOVEI PNT,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM D,(PNT)
HRRZ A,(A)
SOJA LPSA,BEXH
;INTERSECTION.....
; CALL IS WITH SETS IN -1 AND -2 (P)
INTER:
JSP B,INSET
MOVE A,-1(P) ;FIRST SET
MOVE B,-2(P)
LOPS0: HRRZ A,(A)
LOPS1: HRRZ B,(B) ;GO ON DOWN....
LOPS2: JUMPE A,DONN ;IF EITHER A OR B DONE,
LOPS3: JUMPE B,DONN ;THEN WE ARE REALLY DONE.
HLRZ C,(A) ;ITEM
HLRZ D,(B) ;OTER ITEM
CAIN C,(D) ;THE SAME?
JRST YES4 ;YES
CAIL C,(D) ;IS THE A LIST LOWER?
JRST LOPS1 ;NO
HRRZ A,(A) ;YES
JRST LOPS2
YES4: MOVEI PNT,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM C,(PNT)
SOJA LPSA,LOPS0 ;GO PAST BOTH OF THEM.
; SUBRACTION .
; CALL IS WITH SUBTRAHEND IN -1(P), OTHER IN -2(P)
SUBTRA:
JSP B,INSET
MOVE A,-1(P)
MOVE B,-2(P) ;LARGER SET
LOPR1: HRRZ A,(A) ;PAST SET HEADER & DOWN THE LIST.
JUMPE A,[ADDI LPSA,1
JRST BCOP1] ;COPY THE REST OF B
HLRZ C,(A) ;THE ITEM
LOPR2: HRRZ B,(B)
JUMPE B,DONN
HLRZ D,(B) ;THE OTHER ITEM
LOPR3: CAIN C,(D) ;THE SAME?
JRST LOPR1 ;YES -- WALK ON BY.
CAIL D,(C) ;IS B LIST LOWER?
JRST [HRRZ A,(A)
JUMPE A,BCOP ;ALL DONE
HLRZ C,(A)
JRST LOPR3]
MOVEI PNT,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM D,(PNT)
SOJA LPSA,LOPR2
BCOP: JUMPE B,DONN
MOVEI PNT,(FP)
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRLM D,(PNT) ;THERE WAS A THING IN D TO BE
;DISPOSED OF.
BCOP1: HRRZ B,(B) ;ON DOWN B.
HLR D,(B) ;ITEM NUMBER.
SOJA LPSA,BCOP
; LIST OR SET ELEMENT SELECTION. LIST OR SET
; DESCRIPTOR IN -1(P). SELECTOR INDEX ON TOP OF STACK
; ERROR DETECTED IF SELECTOR OUT OF RANGE
; ITEM RETURNED ON TOP OF STACK.
; ROUTINE IS JRST'ED TO.
SELFETCH: SKIPG A,(P) ;GET INDEX AMOUNT
JRST SELERR ;ERROR IF <=0
MOVE C,-1(P) ;SET ARGUMENT
HLRE B,C ;GET COUNT
MOVM B,B ;ABS. LENGTH OF SET
CAMG B,A ;TEST IF IN RANGE
JRST LSTELM ;LAST ELEM. OR ERROR
LPSEL: MOVE C,(C) ;NEXT NODE
SOJG A,LPSEL ;COUNT DOWN
COMSEL: HLRZ PNT,(C) ;ITEM TO BE RETURNED
PUSHJ P,RECL1 ;RECLAIM SET IF NECESSARY
MOVEM PNT,-1(P) ;VAL. TO BE RETURNED
POP P, ;POP OFF ARG.
JRST LEAV ;RETURN
LSTELM: CAME B,A ;SKIP IF LAST ELEMENT
JRST SELERR ;RANGE ERROR
HLRZ C,(C) ;ADDR LAST WORD IN LIST
JRST COMSEL ;NORMAL RETURN
SELERR: ERR <LIST SELECTOR OUT OF RANGE>
;CATLST CONCATENATES THE TWO LISTS ON THE TOP OF STACK
;FIRST LIST IS IN -2(P). SECOND LIST IS IN -1(P)
;RETURN ADDRESS IS IN (P).
^CATLST: JSP B,INSET ;INITIALIZE
HLRE LPSA,-1(P) ;GET LENGTH FIRST LIST
MOVM LPSA,LPSA ;COUNT
HLRE A,-2(P) ;LENGTH OF SECOND LIST
MOVM A,A ;COUNT
ADD LPSA,A ;LENGTH OF NEW LIST
MOVN LPSA,LPSA ;NEGATIVE LENGTH OF NEW LIST
MOVEI B,2 ;CAT TWO LISTS
MOVE A,-2(P) ;FIRST LIST
PASTHD: HRRZ A,(A) ;BYPASS HEADER
JUMPE A,AEXCAT ;IF NULL LIST IGNORE
LPCAT: HLRZ C,(A) ;GET ITEM
MOVEI PNT,(FP) ;GET A FREE
SKIPN FP,(FP) ;FOR NEXT FREE
PUSHJ P,FP1DON ;GET NEW FREES
HRLM C,(PNT) ;COPY ITEM
HRRZ A,(A) ;CDR OF LIST
JUMPN A,LPCAT ;LOOP IF NOT THROUGH
AEXCAT: SOJE B,DONN ;IF SECOND SET, END
MOVE A,-1(P) ;SECOND SET
JRST PASTHD ;CAT IT
DSCR PUTAFTER,PUTBEFORE
PUTAFTER: SKIPA LPSA,[0];LPSA=0 IF AFTER
PUTBEFOR: SETO LPSA, ;LPSA=-1 IF BEFORE
GLOB <
JSP B,GQSET ;GET LIST FOR GLOBAL MODEL
SKIPN FP,FP1(TABL) ;ANY FREES YET
PUSHJ P,FP1DON ; NO GET SOME
HRRZS FP ; A FREE
>;GLOB
NOGLOB <
HRRZ FP,FP1(TABL) ;A FREE NODE
>;NOGLOB
MOVE A,-1(P) ;SEARCH ITEM
POP P,-1(P) ;MAKE IT LOOK LIKE CALL TO PUTIN
MOVEI PNT,(FP) ;POINTER TO FIRST FREE
SKIPN B,(TAC1) ;NULL LIST?
JRST NEWLST ;YES.
LOPLST: MOVE C,B ;REMEMBER WHO POINTED TO US
HRRZ B,(B) ;CURRENT NODE
JUMPE B,LSTEXH ;LIST EXHAUSTED?
HLRZ D,(B) ;GET ITEM
CAIE D,(A) ;ONE WE'RE LOOKING FOR?
JRST LOPLST ;NO.
; AT THIS POINT NODE POINTED TO BY B CONTAINS THE ITEM WE
; WERE LOOKING FOR. C POINTS TO PREVIOUS NODE IN LIST.
MOVE A,-1(P)
JUMPN LPSA,INSRT ;BEFORE THEN INSERT
MOVE C,B
HRRZ B,(B) ;FOR AFTER
JRST INSRT ;INSERT IT
NEWLST: MOVE A,-1(P) ;ITEM TO BE INSERTED
JRST INS1 ;INSERT IN NEW LIST
LSTEXH: MOVE A,-1(P) ;GET ITEM
JUMPE LPSA,INSRT ;AT END OF LIST
HRRZ C,(TAC1) ;GET LIST HEADER
HRRZ B,(C) ;INSERT AT HEAD OF LIST
JRST INSRT ;INSERT IT
; LIST [EXPR1 FOR EXPR2]
; LIST IN -3(P)
; expr1 IN -2(P)
; expr2 IN -1(P)
FSBLST:
SKIPGE A,-1(P) ;GET FOR EXPR
ERR <INVALID "FOR" INDEX IN SUBLIST>,1
ADD A,-2(P) ;CHANGE TO TO
SOJA A,TSBLST+1 ;NOW A TO EXPR.
; LIST [expr1 TO expr2]
; LIST IN -3(P)
; expr1 in -2(P)
; expr2 IN -1(P)
TSBLST: MOVE A,-1(P) ;GET TO EXPR VALUE
JSP B,INSET ;INITIALIZE NEW SET
SKIPG B,-2(P) ;EXPR1
ERR <INDEX FOR SUBLISTING LEQ 0>,1
LENLST: HLRE C,-3(P) ;GET LENGTH OF LIST
MOVM C,C ;ABS VAL. LENGTH
CAMLE A,C ;TO > LENGTH?
ERR <INVALID SUBLIST OPERATION,LIST NOT LONG ENOUGH>,1
STKMOD: POP P,-2(P) ;MODIFY STACK
SUB P,[XWD 1,1] ;MOD STACK
CAMLE B,A ;NULL SUBLIST?
JRST NULSUB ;YES.
;PREPARE TO BYPASS HEADER
SETZ C, ;COUNTER FOR LIST POSITION
MOVE D,-1(P) ;GET LIST HEADER
HDLST: HRRZ D,(D) ;NEXT
AOS C ;INC PLACE COUNTER
CAIGE C,(B) ;THROUGH?
JRST HDLST ; NO.
; (D) POINTS TO FIRST NODE TO BE COPIED
; CALCULATE NUMBER TO BE COPIED
SUB A,B
AOS A ;NUMBER OF NODES TO BE COPIED
MOVN LPSA,A ;NEGATIVE LENGTH FOR TEMP. SET
LPCPY: HLRZ B,(D) ;GET ITEM
MOVEI PNT,(FP) ;GET FREE
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON ;NEED SOME NEW FREES
HRLM B,(PNT) ;COPY ITEM
HRRZ D,(D) ;TO NEXT NODE
SOJG A,LPCPY ;IF NOT THROUGH LOOP
HLLZS (PNT) ;ZERO LAST PNTR.
MOVEI A,(PNT) ;ADDR LAST WORD IN LIST
MOVEI PNT,(FP) ;GET A FREE
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON ;IF OUT, GET SOME MORE
HRRM FPD,(PNT) ;ADDR. FIRST LIST NODE
HRLM A,(PNT) ;ADDR LAST LIST NODE
HRRM FP,FP1(TABL) ;FREE LIST UPDATE
HRLM LPSA,PNT ;STORE LIST LENGTH
RETLST: PUSHJ P,RECL1 ;RECLAIM SET IF NECESSARY
MOVEM PNT,-1(P) ;LIST TO BE RETURNED
POPJ P, ;RETURN
NULSUB: SETZ PNT, ;RETURN NULL LIST
JRST RETLST
; THE EXIT CODE
DONN:
JUMPL PNT,[SETZM PNT ;IF NOTHING DONE,
JRST RECLM2] ;RETURN NULL SET.
HLLZS (PNT) ;ZERO THE POINTER IN LAST CELL.
MOVEI A,(PNT) ;LAST WORD ALLOCATED.
MOVEI PNT,(FP) ;AND A NEW ONE -- FOR HEADER.
SKIPN FP,(FP)
PUSHJ P,FP1DON
HRRM FPD,(PNT) ; PTR TO FIRST OF SET LIST.
HRLM A,(PNT) ;PUT IN THE "LAST" LINK
HRLM LPSA,PNT ;LPSA IS NEGATIVE, TO INDICATE TEMP.
HRRM FP,FP1(TABL) ;....
; JRST RECLM2 ;NEXT PAGE.
DSCR SET RECLAMATION ROUTINES.
RECLM2 -- RECLAIMS TOP TWO STACK ELEMENTS, SUBTRACTS FROM
STACK, THEN PUSH'ES "PNT" (A RESULT) ONTO STACK.
RECL2 -- RECLAIMS SETS IN -1(P) AND -2(P) .. THOSE ARE
THE STACK POSITIONS BEFORE THE CALL TO RECL2.
RECQQ -- RECLAIMS SET MENTIONED IN REGISTER "A".
CLOBBERES ACS: FP AND B.
;
RECLM2: PUSHJ P,RECL2
ALLD:
SUB P,X33
PUSH P,PNT
JRST @2(P) ;RETURN.
RECL2: SKIPGE A,-3(P) ;...
PUSHJ P,RECQQ
RECL1: SKIPL A,-2(P) ;RECLAIM IF NECESSARY.
POPJ P,
^^RECQQ:
GLOB <
TRNE A,400000 ;IF SECOND SEGMENT, THEN
JRST SECRCL ;DO SPECIALLY
>;GLOB
;;#RU# ! MAY BE CALLED WITH THIS MUNGED
MOVE USER,GOGTAB
MOVE FP,FP1(USER)
HLRZ B,(A)
HRRM FP,(B) ;LINK AT THE END OF LIST.
HRRM A,FP1(USER)
POPJ P,
GLOB <
SECRCL: PUSH P,LKSTAT ;SAVE INTERLOCK STATUS
PUSH P,FLAG ;SAVE FLAG
TLO FLAG,GLBSRC
WRITSEC ;GAIN ACCESS TO POINTERS.
MOVE FP,FP1+GLUSER
HLRZ B,(A)
HRRM FP,(B)
HRRM A,FP1+GLUSER
POP P,FLAG ;RESTORE FLAG
POP P,A
CAMN A,LKSTAT ;SAME STATUS AS WHEN ENTERED
POPJ P, ;YES
JUMPN A,[RDSEC
POPJ P,]
NOSEC
POPJ P,
>;GLOB
; TRANSFER FUNCTION SET_ LIST
; LIST IN (P) . RESULTANT SET WILL BE LEFT ON TOP OF STACK
; ROUTINE JRST`ED TO
SETLXT:
SKIPN A,(P) ;THE LIST
JRST LEAV ;RETURN IF NULL
JSP B,INSET ;INITIALIZE NEW SET
; GET A FREE FOR LAST,FIRST NODE
MOVEI PNT,(FP)
SKIPN FP,(FP) ; FOR NEXT TIME
PUSHJ P,FP1DON ; GET SOME MORE IF HAVE RUN OUT
;LEFT HALF WILL CONTAIN ADDR. LAST NODE IN SET.
SETZM (PNT)
;AN IMPORTANT THING TO REMEMBER IN THIS AND ALL OTHER SET-LIST BUILDING
;CODE IS THAT INSET SETS AC 0 TO 0.
LPOUTR: HRRZ A,(A) ;POINT TO NEXT NODE IN LIST
JUMPE A,LTHRU ;IF THROUGH THEN EXIT LOOP
HLRZ D,(A) ;GET ITEM
MOVEI C,(FPD) ;REMEMBER WHO POINTED TO US
HRRZ B,(C) ;ADDR FIRST CANDIDATE
LPINNR: HLRZ PNT,(B) ;GET ITEM FROM SET
CAIG D,(PNT) ;SHOULD WE CONTINUE DOWN CDR
JRST FNDITM ;NO
JUMPE B,FNDITM ;FOR FIRST TIME
MOVEI C,(B) ;YES
HRRZ B,(B) ;NEXT NODE
JRST LPINNR ;LOOP
;NOTICE ABOVE THAT NO EXPLICIT TEST WAS MADE TO DETERMINE IF WE
;HAD EXHAUSTED THE SET. THAT IS TAKEN CARE OF BY THE FACT AC 0 CONTAINS 0
FNDITM: CAIN D,(PNT) ;ALREADY THERE?
JRST LPOUTR ;YES
MOVEI PNT,(FP) ;GET A FREE FOR THIS NEW NODE
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP1DON ;IF OUT, GET SOME MORE
HRRM B,(PNT) ;LINK TO NEXT NODE
HRLM D,(PNT) ;ITEM
HRRM PNT,(C) ;LINK IN FORMER NODE
SOS LPSA ;COUNT OF NUMBER OF ITEMS IN SET
JUMPN B,LPOUTR ;IF NOT LAST NODE IN CHAIN CONTINUE
HRLM PNT,(FPD) ;RECORD NEW LAST NODE
JRST LPOUTR ;LOOP
LTHRU: HRRM FP,FP1(TABL) ;REPLACE FREE LIST POINTER
PUSH P,FPD ;RESULTANT SET TO BE RETURNED
HRLM LPSA,(P) ;STORE COUNT
PUSHJ P,RECL1 ;RECLAIM LIST IF NECESSARY
POP P,-1(P) ;ADJUST STACK
JRST LEAV ;RETURN
DSCR RPLAC
<listvariable> [N] _ <item>
TAC1 POINTS TO LIST!VARIABLE
N IS IN -1(P)
ITEM IN -2(P)
CALLED WITH PUSHJ P,
ITEM REMAINS IN AC 1
RPLAC:
MOVE A,-2(P) ;ITEM
GLOB<
JSP B,GQSET ;IN CASE GLOBAL SET
>;GLOB
SKIPG B,-1(P) ;N LEQ 0?
ERR <REPLACE - INDEX LEQ 0>
POP P,-1(P) ;MAKE STACK LOOK LIKE CALL
;TO PUT IN WHEN WE GO TO INS1
GLOB<
SKIPN FP,FP1(TABL) ;ANY FREE`S YET
PUSHJ P,FP1DON ;NO GET SOME
HRRZS FP
>;GLOB
NOGLOB<
HRRZ FP,FP1(TABL)
>;NOGLOB
HLRE C,(TAC1)
CAMG B,C ;INDEX HIGH?
JRST RPLAC1 ;NORMAL REPLACE
ADDI C,1 ;LENGTH + 1
CAME B,C
ERR <REPLACE - INDEX TOO HIGH>
NLAST: CAIN B,1 ;NEW LIST?
JRST INS1 ;YES
MOVEI PNT,(FP)
HRRZ C,(TAC1)
HLRZ C,(C)
SETZ B, ;END OF LIST?
JRST INSRT ;LET PUT HANDLE IT
RPLAC1: HRRZ D,(TAC1)
LPRPLAC: HRRZ D,(D) ;DOWN LIST
SOJG B,LPRPLAC ;LOOP
HRLM A,(D) ;REPLACE ITEM
JRST RETQ ;RETURN
DSCR TYPEX-to determine the type of an item
CALLING SEQUENCE:
PUSH P,[ITEM#]
PUSHJ P,TYPEX
RETURNS WITH THE STACK APPROPRIATELY DECREMENTED
AND RIGHT HALF OF AC 1 CONTAINING TYPE CODE.
LEFT HALF OF AC 1 CONTAINS ADDRESS OF DATUM ENTRY IF ANY.
TYPE CODES ARE:
0 - item not allocated or ANY
1 - untyped
2 - bracketed triple
3 - string
4 - real
5 - integer
6 - set
7 - list
10 - procedure item
11 - process item
12 - event item
13 - context item
20 - string array
21 - real array
22 - integer array
23 - set array
24 - list array
30 - context array
31 - invalid code
HERE(TYPEX) ;CALLED WITH PUSHJ FROM USER
PUSH P,TABL ;SAVE AC
PUSH P,B ;SAVE AN AC
SKIPN A,-3(P) ;ITEM #
JRST NTALLOC ;ANY IS NOT CONSIDERED ALLOCATED
MOVE TABL,GOGTAB ;INITIALIZE TO LOCAL MODE
GLOB<
CAIGE A,GBRK ;GLOBAL ITEM?
JRST LCLTYP ;LOCAL
MOVEI TABL,GLUSER ;FOR GLOBAL
CAMGE A,ITMTOP(TABL) ;ALLOCATED?
JRST NTALLOC ;NO
JRST WASALLOC ;YES.
>;GLOB
LCLTYP: CAMLE A,ITMTOP(TABL) ;ALLOCATED?
JRST NTALLOC ;NO.
JUMPLE A,NTALLOC ;INVALID ITEM #?
WASALLOC: MOVEI B,(A) ;COPY ITEM #
ADD A,INFOTAB(TABL) ;ADDRESS INFOTAB ENTRY
ADD B,DATAB(TABL) ;ADDRESS DATAB ENTRY
LDB A,[POINT 6,(A),35] ;GET TYPE CODE
CAILE A,INVTYP ;VALID TYPE
NTVALID: MOVEI A,INVTYP ;INVALID CODE
HRL A,B
POP P,B ;RESTORE AC
POP P,TABL ;RESTORE AC
SUB P,[XWD 2,2]
JRST @2(P) ;RETURN
NTALLOC: SETZ A, ;NOT ALLOCATED TYPE CODE
JRST NTVALID+1 ;RETURN
DSCR TYPEIT -same as TYPEX except does not return datum address in left
half
HERE(TYPEIT) ;ENTRY POINT
PUSH P,-1(P) ;ITEM NUMBER
PUSHJ P,TYPEX ;GET TYPE
HRRZS A ;ZERO DATUM ADDRESS
SUB P,X22
JRST @2(P) ;RETURN
MOVE FLAG,USER; DUMMY
DSCR REMX -- REMOVE <list!variable> <index>
list!variable pointed to by TAC1
INDEX IN -1(P)
CALLED WITH PUSHJ P,
REMX:
GLOB<
JSP B,GQSET ;FOR GLOBAL SETS
>;GLOB
JSP B,INSET ;FREE LIST POINTERS ETC.
SKIPG A,-1(P) ;INDEX > 0
ERR <REMOVE - INDEX LEQ 0>
HLRE D,(TAC1) ;LENGTH OF LIST
CAMLE A,D ;INDEX > LENGTH?
ERR <REMOVE - INDEX GTR LENGTH>
MOVE B,(TAC1)
LPREMX: MOVE C,B ;REMEMBER PRECEDING NODE
HRRZ B,(B) ;DOWN-LIST
SOJG A,LPREMX ;COUNT-DOWN
JRST ENREMX ;REST OF CODE WITHIN REMOVE
DSCR REMALL
REMOVE ALL <item> FROM <list!variable>
TAC1 POINTS TO LIST-VARIABLE
ITEM IN -1(P)
CALLED WITH PUSHJ P,
REMALL:
GLOB<
JSP B,GQSET ;FOR GLOBAL SETS
>;GLOB
JSP B,INSET ;INITIALIZE AC`S FOR LIST CREATION
HRRZ A,-1(P) ;ITEM
MOVE B,(TAC1)
LOPRA1: MOVE C,B ;ADDR PRECEDING NODE
HRRZ B,(B) ;NEXT IN LIST
JUMPE B,RETQ ;NO MORE
HLRZ D,(B) ;ITEM
CAIE D,(A) ;ONE TO BE REMOVED?
JRST LOPRA1 ;NO.
HRRZ D,(B) ;NEXT LINK
CAMN C,(TAC1) ;FIRST ELEMENT?
JRST RAFIRST ;YES.
RACMN: HRRM D,(C) ;DELETE ITEM
HRRM FP,(B) ;ONTO FREE LIST
MOVEI FP,(B) ;NEW HEAD OF FREE LIST
MOVSI B,-1 ;TO DECREMENT LENGTH COUNT
ADDM B,(TAC1) ;DEC COUNT
MOVE B,C ;WILL CONTINUE DOWN LIST
JUMPN D,LOPRA1 ;GO.
MOVE D,(TAC1) ;END OF LIST
HRLM C,(D) ;NEW END OF LIST
JRST RETQ ;RETURN
RAFIRST: JUMPN D,RACMN ;IF LIST NOT NOW NULL BRANCH
JRST ENZERO ;NULL LIST. LET REMOVE HANDLE IT
DSCR LISTX
RETURNS THE INDEX OF THE N TH OCCURRENCE OF ITEM WITHIN
THE LIST OR 0 IF THERE ARE NOT AT LEAST N OCCURRENCES OF
THE ITEM WITHIN THE LIST.
LIST IN -3(P)
ITEM IN -2(P)
N IN -1(P)
CALLED WITH PUSHJ DIRECTLY FROM USER.
HERE(LISTX)
MOVE D,-1(P) ;N
MOVE B,-2(P) ;ITEM
MOVE C,-3(P) ;LIST
SETZB 0,A ;ZERO AC 0 AND A
LPLSTX: HRRZ C,(C) ;GO DOWN LIST
JUMPE C,ZRETRN ;NOT N DIFFERENT OCCURENCES?
ADDI A,1 ;KEEP TRACK OF INDEX
HLRZ LPSA,(C) ;ITEM
CAIE B,(LPSA) ;ONE WE`RE LOOKING FOR?
JRST LPLSTX ;NO
SOJG D,LPLSTX ;N TH OCCURRENCE?
SKIPA
ZRETRN: SETZ A, ;CLEAR INDEX
EXCH A,-3(P) ;SWAP RESULT AND LIST.
MOVEM A,-1(P) ;PREPARE FOR RECL1
PUSHJ P,RECL1 ;RECLAIM LIST IF NECESSARY
SUB P,X33 ;DEC. STACK
POP P,A ;RESULT
JRST @4(P)
DSCR PUTXA,PUTXB
PUT ITEM IN LIST AFTER(BEFORE) INDEX;
ITEM IN -2(P)
ITEM IN -1(P)
INDEX IN -1(P)
CALLED WITH PUSHJ P,
PUTXA: MOVE D,-1(P) ;INDEX
AOSA D ;WILL USE PUTXB ROUTINE
PUTXB: MOVE D,-1(P) ;INDEX
MOVE A,-2(P) ;ITEM
JSP B,INSET ;INITIALIZE FREE STORAGE PNTRS
POP P,-1(P) ;MAKE IT LOOK LIKE CALL TO PUT
JUMPLE D,ERRPUT ;INDEX LEQ 0 ?
HLRE C,(TAC1) ;LENGTH OF LIST
CAMLE D,C ;INDEX LEQ LENGTH
JRST PTLAST ;NO
HRRZ B,(TAC1) ;NEW LAST OR ERROR
LPPUTX: MOVE C,B
HRRZ B,(B) ;DOWN THE LIST
SOJG D,LPPUTX ;LOOP
JRST INSRT ;
PTLAST: ADDI C,1 ;NEW LAST ELEMENT?
CAME D,C
ERRPUT: ERR <PUT- BAD INDEX>
MOVE B,D ;PREPARE TO JUMP
JRST NLAST ;USE PUTAFTER ROUTINE
DSCR INITTP - INITIALIZE ITEM TYPE.
ITEM IS IN -2(P)
TYPE IS IN -1(P)
CALLED WITH PUSHJ P,
INITTP:
MOVE A,-2(P)
ADD A,INFOTAB(TABL) ;INFOTAB ENTRY ADDRESS
MOVE B,-1(P) ;TYPE
HRRM B,(A) ;STORE CODE
MOVE A,-2(P) ; WILL RETURN ORIGINAL ITEM
SUB P,X33 ;DEC STACK
JRST @3(P) ;RETURN
DSCR INTNAM,CVSI,CVIS,DEL.PNAME,NEW.PNAME
; PRINT NAME HANDLING FOR THE WORLD.
; FIRST THE ROUTINE TO HASH THINGS UP, THEN
; THE RETRIEVAL ROUTINES.
INTNAM: ;INITIALIZE DECLARED ITEM PNAMES
;;# # DCS 5-3-72 LEQ 0 THEN NO PNAMES
SKIPG (A) ;ANY TO BE INITED?
;;# # DCS
POPJ P, ;NO.
PUSH P,(A) ;NUMBER OF ITEMS IN LIST
ADDI A,1
PUSH P,A ;SAVE ADDRESS OF CURRENT ITEM.
INT1: MOVE A,@(P) ;XWD ITEM NUMBER,, ADDR. STRING DESCRIPTOR
PUSH SP,(A)
PUSH SP,1(A) ;STRING IS THERE.
HLRZS A
PUSH P,A
PUSHJ P,ENTR ;PUT IT IN.....(NEW.PNAME)
AOS (P) ;INDEX THE ADDRESS.
SOSE -1(P) ;ITEM COUNT.
JRST INT1
SUB P,X22
INT4: POPJ P, ;RETURN
INITNM: ;INITIALIZE HASH TABLE
LPCOR (PHASLN) ;ITEM AND STRING HASH TABLE
HRRM B,HASHP(USER)
POPJ P, ;RETURN
; LEFT HALF OF HASH TABLE IS FOR ITEMS
; RIGHT HALF OF HASH TABLE IS FOR STRINGS
IFE ALWAYS, <
EXTERNAL OUTSTR
>
HERE(NEW.PNAME) ;
ENTR: ;ENTRY POINT FOR INTNAME
MOVE USER,GOGTAB
SKIPN HASMSK(USER) ;LEAP INITED?
PUSHJ P,LPINI ;NO, GO INITIALIZE LEAP
MOVE A,HASHP(USER) ;SEE IF PRINTNAMES INITIALIZED
TRNN A,-1 ;HASH TABLE ALLOCATED
PUSHJ P,INITNM ;NO, GO DO IT.
;IF ITEM NOT ALLOCATED NO GOOD
NOGLOB <
SKIPE C,-1(P) ;THE ITEM
LDB C,INFTB ;GET THE TYPE
>;NOGLOB
GLOB <
SKIPN C,-1(P)
JRST PHAVT ;HAV ITEM TYPE
CAIGE C,GBRK ;A GLOBAL?
JRST [LDB C,INFTB
JRST .+2]
LDB C,GINFTB
PHAVT:
>;GLOB
SKIPN C
ERR <ATTEMPT TO GIVE UNALLOCATED ITEM A PNAME>,1
;SEE IF ITEM ALREADY HAS PNAME
PUSH P,[0] ;WILL SERVE AS FLAG PARAM TO CVIS
PUSH P,-2(P) ;ITEM
MOVEI TAC1,-1(P) ;ADDR. FLAG
PUSH P,TAC1 ;FLAG PARM.
PUSHJ P,CVIS ;ALREADY HAVE NAME
SUB SP,X22 ;REMOVE STRING RETURNED BY CVIS
SKIPN (P) ;FLAG TRUE?
JRST [ADD SP,X22 ;RESTORE STRING RETURNED BY CVIS
PUSH SP,-3(SP) ;OUR STRING
PUSH SP,-3(SP)
PUSH SP,-3(SP) ;STRING RETURNED BY CVIS
PUSH SP,-3(SP)
PUSHJ P,EQU ;STRINGS EQUAL?
MOVE USER,GOGTAB;SINCE EQU DESTROYS
JUMPN A,RTRNEW ;IF EQUAL THEN WE MUST RETURN
PRINT <
WARNING ITEM >
PUSHJ P,OUTSTR ;PRINT IT
PRINT < RENAMED TO >
PUSH SP,-1(SP)
PUSH SP,-1(SP)
PUSHJ P,OUTSTR
TERPRI
PUSH P,-2(P) ;ITEM NUMBER(FLAG STILL ON STACK)
PUSHJ P,DEL.PNAME ;REMOVE OLD PNAME
JRST .+1]
;NOW SEE IF STRING ALREADY EXISTS.
PUSH SP,-1(SP) ;COPY STRING
PUSH SP,-1(SP)
MOVEI TAC1,(P) ;ADDRESS OF "FLAG"
PUSH P,TAC1 ;PARAM TO CVSI
PUSHJ P,CVSI
MOVE USER,GOGTAB ;CVSI WILL DESTROY
SUB P,X11 ;REMOVE "FLAG"
SKIPN 1(P) ;SKIP IF NOT ALREADY THERE
JRST [CAMN A,-1(P) ;SAME ITEM?
JRST [ SUB P,X22
SUB SP,X22
JRST @2(P)]
PRINT <ERROR - >
PUSHJ P,OUTSTR ;TYPE PRINTNAME
ERR < USED AS PNAME FOR TWO DIFFERENT ITEMS>,1
PUSH P,A
PUSHJ P,DEL.PNAME
JRST .+1
]
PUSHJ P,SDESCR ;GET A FREE STRING DESCRIPTOR
POP P,C ;ADDR. DESCRIPTOR
POP SP,(C) ;STRING
POP SP,-1(C)
SKIPN FP,FP2(USER) ;FOR A TWO-WORD FREE
PUSHJ P,FP2DON ;IF NONE YET GO GET SOME
MOVEI D,(FP) ;OUR NEW FREE
SKIPN FP,(FP) ;FOR NEXT TIME
PUSHJ P,FP2DON ;GET SOME MORE IF NEEDED
MOVEM FP,FP2(USER) ;CDR FREE LIST
HRLM C,1(D) ;STRING
MOVE A,-1(P) ;ITEM
HRLM A,(D) ;STORE IT
ANDI A,PHASLN-1 ;ITEM HASH
ADD A,HASHP(USER) ;TABLE LOC.
HLR C,(A) ;OLD CLASH LIST
HRRM C,(D) ;ADD NEW ELEM.
HRLM D,(A) ;UPDATE CLASH LIST
;STRING HASH
HRRZ C,1(SP) ;STRING LENGTH
SKIPN C ;TEST IF NULL STRING
JRST [ERR <ERROR - NULL PNAME>,1
SUB P,X22
JRST @2(P)]
MOVE B,2(SP) ;BYTE POINTER
ILDB A,B ;FIRST CHARACTER
ILDB B,B ;SECOND CHARACTER IF ANY
LSH A,3 ;HIGH ORDER BIT CARRIES NO INFO
CAIE C,1 ;LENGTH= 1?
XORI A,(B)
ANDI A,PHASLN-1 ;TABLE INDEX
; THIS HASH REALLY COULD STAND SOME IMPROVEMENT.
ADD A,HASHP(USER)
HRR C,(A)
HRRM C,1(D)
HRRM D,(A)
SUB P,X22
JRST @2(P)
RTRNEW: SUB SP,[XWD 4,4]
SUB P,X33
JRST @2(P)
HERE(DEL.PNAME) ;DELETE PNAME IF ANY
MOVE USER,GOGTAB
SKIPN HASMSK(USER) ;LEAP INITIALIZED?
PUSHJ P,LPINI ;GO DO IT
HRRZ A,HASHP(USER) ;PNAMES YET?
JUMPE A,EXDELP ;NO. SIMPLY EXIT
MOVE A,-1(P) ;ITEM NUMBER
ANDI A,PHASLN-1 ;HASH HA HA
ADD A,HASHP(USER) ;HASH POSITION
HRROS (P) ;FLAG INDICATES FIRST IN CONFLICT LIST
MOVEI D,(A) ;ADDRESS THIS BUCKET
HLRZ A,(A)
LPDELP: SKIPN A ;END OF LIST?
JRST [SUB P,X22
HRRZ A,2(P)
JRST (A)] ;RETURN, NO SUCH PNAME
HLRZ B,(A) ;ITEM NUMBER
CAMN B,-1(P) ;ONE WE'RE LOOKING FOR?
JRST DELFND ;YES
MOVEI D,(A)
HRRZS (P)
HRRZ A,(A) ;CDR CONFLICT LIST
JRST LPDELP
DELFND: MOVE C,(A) ;NEXT LINK IN CONFLICT LIST
SKIPG (P) ;NOT FIRST IN CONFLICT LIST?
JRST [HRRZS (P)
HRLM C,(D)
JRST .+2]
HRRM C,(D) ;DELETE NODE FROM LIST
HLRZ C,1(A) ;ADDRESS STRING DESC.
PUSH SP,-1(C) ;SAVE STRING SO CAN DELETE FROM
;STRING HASH TABLE
PUSH SP,(C)
SETZM -1(C) ;SO GARB. COLLECT. WILL IGNORE
HLRZ D,HASHP(USER) ;FREE LIST
HRRM D,(C) ;LINK IT ON
HRLM C,HASHP(USER) ;SAVE UPDATED FREE LIST
ILDB B,(SP) ;FIRST CHAR.
ILDB C,(SP) ;SECOND CHAR
HRRZ D,-1(SP) ;STRING LENGTH
LSH B,3
CAIE D,1
XORI B,(C)
ANDI B,PHASLN-1 ;TABLE INDEX
ADD B,HASHP(USER) ;STRING HASH TABLE POSITION
MOVEI D,(B)
HRRZ B,(B) ;FIRST IN CONFLICT LIST
LPSTRD: SKIPN B
ERR <DRYROT- PNAMES DELETE>
CAIN B,(A) ;ONE WE'RE LOOKING FOR
JRST FNDSBK ;FOUND STRING BUCKET
MOVEI D,1(B)
HRRZ B,1(B) ;CDR CONFLICT LIST
JRST LPSTRD
FNDSBK: HRRZ B,1(B) ;CDR OF CONFLICT LIST
HRRM B,(D) ;PUT IT DOWN
MOVE FP,FP2(USER)
HRRM FP,(A)
MOVE A,FP2(USER)
SUB SP,X22
EXDELP: SUB P,X22
JRST @2(P) ;RETURN
HERE(CVSI) ;STRING TO ITEM
MOVE USER,GOGTAB
SKIPN HASMSK(USER) ;LEAP INITED?
PUSHJ P,LPINI ;GO DO IT
HRRZ A,HASHP(USER) ;PNAMES INITED?
JUMPE A,CVSNO ;CAN'T SUCCEED
MOVE B,(SP) ;BYTE POINTER
ILDB A,B
ILDB B,B
HRRZ C,-1(SP) ;STRING LENGTH
LSH A,3
CAIE C,1
XORI A,(B)
ANDI A,PHASLN-1 ;OUR HASH
ADD A,HASHP(USER)
HRRZ B,(A) ;FIRST IN CONFLICT LIST
LPCVSI: SKIPN B ;END OF LIST?
JRST CVSNO ;STRING NOT FOUND
HLRO C,1(B) ;STRING ADDRESS
PUSH SP,-1(SP)
PUSH SP,-1(SP)
PUSH SP,-1(C)
PUSH SP,(C)
PUSH P,B ;IN CASE EQU DESTROYS
PUSHJ P,EQU ;STRINGS EQUAL?
MOVE USER,GOGTAB
POP P,B
JUMPN A,CVSYES ;FOUND RIGHT STRING
HRRZ B,1(B) ;NO. TRY AGAIN
JRST LPCVSI
CVSYES: SETZM @-1(P) ;FLAG_FALSE
HLRZ A,(B) ;ITEM NUMBER
JRST CVSIRT
CVSNO: SETOM @-1(P)
MOVEI A,-1 ;JUST TO BE REPEATABLE
CVSIRT: SUB SP,X22
SUB P,X22
JRST @2(P)
HERE(CVIS) ;ITEM TO STRING
MOVE USER,GOGTAB
SKIPN HASMSK(USER) ;LEAP INITED?
PUSHJ P,LPINI ;NO GO DO IT
HRRZ A,HASHP(USER) ;ANY PNAMES?
JUMPE A,CVINO ;IF NONE, CAN'T SUCCEED
MOVE A,-2(P) ;ITEM NUMBER
ANDI A,PHASLN-1
ADD A,HASHP(USER)
HLRZ B,(A)
LPCVIS: SKIPN B
JRST CVINO ;NO SUCH PNAME
HLRZ A,(B) ;ITEM NUMBER
CAMN A,-2(P) ;SAME AS OURS?
JRST CVIYES ;SUCCESS
HRRZ B,(B) ;CDR OF CONFLICT LIST
JRST LPCVIS ;TRY AGAIN
CVIYES: HLRZ C,1(B) ;STRING ADDR
PUSH SP,-1(C) ;RETURN ON STRING STACK
PUSH SP,(C)
SETZM @-1(P) ;FLAG_FALSE
JRST CVIRET
CVINO: ADD SP,X22 ;RETURN GARBAGE STRING
;;#HP#! 6-8-72 DCS GARBAGE STRING MUST BE GARBAGE COLLECTABLE!
SETZM -1(SP) ;CONSTANT, NULL STRING -- HARMLESS
SETOM @-1(P) ;FLAG_TRUE
CVIRET: SUB P,X33
JRST @3(P)
DSCR MATCHING PROCEDURE ROUTINES, CALMP,RESMP,SUCFA1;
;CALMP ON STACK IS PLACE FOR ITEM,PROCEDURE CALL WITH PDA AT VERY
;TOP OF STACK. ROUTINE IS JRSTED TO
SOPTS __ 11 ;SPROUT OPTIONS,SUSPEND HIM LET ME CONTINUE
ROPTS __ 0 ;RESUME OPTIONS
CALMP: ;SPROUT MATCHING PROCEDURE
GLOB <
NOSEC ;NOT "ENTERED" INSIDE FOREACH'S
>;GLOB
PUSHJ P,FRPOP ;POP SATIS INTO CORE, ALSO LOADS FRTAB
MOVE FPD,FPDP(FRTAB) ;FOREACH PUSH DOWN LIST
ADD FPD,[XWD LENFPD,LENFPD] ;MAKE AN ENTRY ON PDL
SKIPL FPD
JSP USER,$PDLOV
MOVEM FPD,FPDP(FRTAB) ;REPLACE PDL POINTER
HRRI FLAG,CALINDX-SEROUT ;SEROUT # FOR RESUME MP
MOVEM FLAG,-1(FPD) ;PUT DOWN ROUTINE NAME
MOVE D,UUO1(USER) ;PICKUP RETURN ADDRRESS
MOVEM D,(FPD) ;PUT IT DOWN
SETOM -TT1(FPD) ;BE CONSISTENT WITH OTHERS
SETZM -T2(FPD)
PUSHJ P,NEW ;GET AN ITEM FOR PROCESS
POP P,D ;THE ITEM
MOVEM D,-ATTP(FPD) ;SAVE IN FPD ENTRY
MOVE C,(P) ;PICK-UP PDA
HLRZ LPSA,PD.NPW(C) ;NUMBER OF STRING ENTRIES
HRRZ B,PD.NPW(C) ;NON STRING ENTRIES
ADD LPSA,B ;DISPLACEMENT
MOVNS LPSA
ADDI LPSA,(P) ;ADDR OF ITEM SLOT
MOVEM D,(LPSA) ;PUT ITEM DOWN
PUSH P,[SOPTS] ;THE OPTIONS FOR SPROUT
HRRZI LPSA,-MASK(FPD) ;THE"KILL-SET"
SETZM -MASK(FPD) ;MAKE NIL
PUSH P,LPSA
PUSHJ P,SPROUT ;SPROUT IT
MOVE USER,GOGTAB
MOVE FRTAB,FRLOC(USER)
SKIPE A,RUNNER
MOVE FRTAB,CURSCB(A)
MOVE FPD,FPDP(FRTAB)
JRST GO ;RESUME IT
RESMP: ;RESUME THE MATCHING PROCEDURE
MOVEM FPD,FPDP(FRTAB) ;SAVE PDP
PUSH P,-ATTP(FPD) ;PROCESS!ITEM
PUSH P,[0] ;NULL PARAM
PUSH P,[ROPTS] ;RESUME OPTIONS
PUSHJ P,RESUME ;RESUME IT
MOVE USER,GOGTAB
MOVE FRTAB,FRLOC(USER)
SKIPE D,RUNNER
MOVE FRTAB,CURSCB(D)
MOVE FPD,FPDP(FRTAB)
JUMPE 1,MPFAIL ;WAS IT SUCCESS
PUSHJ P,CORPOP ;GET CORE INTO SATIS TABLE
AOS (P) ;SUCCESS, SKIP RETURN
POPJ P, ;YES
MPFAIL: PUSH P,-ATTP(FPD) ;THE ITEM
MOVEI D,MPDEL ;PREPARE FOR CALL TO DELETE
MOVEM D,UUO1(USER)
GLOB <
MOVEI TABL,(USER)
>;GLOB
JRST DELETE
MPDEL:
GLOB<
NOSEC
>;GLOB
MOVE USER,GOGTAB
MOVE FRTAB,FRLOC(USER) ;SINCE DELETE DESTROYED
SKIPE A,RUNNER
MOVE FRTAB,CURSCB(A)
MOVE FPD,FPDP(FRTAB)
POPJ P, ;REPORT FAILURE
DSCR .SUCCE,.FAIL
SUCCEED OR FAIL
WE DO A SKIP RETURN IF A PROCESS,OTHERWISE WE SIMPLY
RETURN, WHICH WILL JUMP TO END OF MATCHING PROCEDURE AND
GIVE A NORMAL RETURN
PDA OF MATCHING PROCEDURE ON TOP OF STACK
INTERNAL .FAIL,.SUCCE
SFOPTS __ 0 ;SUCCEED FAIL OPTIONS
HERE(.FAIL)
TDZA A,A
HERE(.SUCCE)
SETOM A
POP P,TEMP ;THE RETURN ADDRESS
EXCH TEMP,(P) ;THE PDA
MOVE D,RF ;CURRENT DISPLAY
LPSFA: HLRZ C,1(D) ;PDA THIS DISPLAY LEVEL
MOVE D,(D) ;BACK ONE LEVEL
CAIE C,(TEMP) ;THIS THE ONE?
JRST LPSFA ;NO.
HLRZ C,1(D) ;PDA OF "FATHER"
CAIE C,SPRPDA ;SPROUTER?
POPJ P, ;NO.
;PUSH ITEM NUMBER OF "SPROUTER"
MOVE D,RUNNER ;BASE OF PROCESS STACK
PUSH P,DADDY(D) ;WHO SPROUTED ME
PUSH P,1 ;VAL TO BE RETURNED
PUSH P,[SFOPTS] ;OPTIONS
PUSHJ P,RESUME ;RESUME
AOS (P)
POPJ P, ;SKIP RETURN
NOGLOB <
BEND LEAP
>;NOGLOB
IFE ALWAYS,<
END
>