File: BITSET.RA of Disk: V50/Source/Source-Listing-FORTRAN-2
(Source file text)
SECT BTSET ENTRY ISHFT ENTRY BITSET ENTRY #ANDER EXTERN #RETRN EXTERN #FIX SECT8 BITTER #ANDER, TAD #XR /Simple masking AND #XR+1 DCA #XR CIF CDF JMP% #XR+2 / Return /FPP code here; using the rest of the SECT8 page. #RET, SETX #XR /Traceback SETB #BASE JA .+3 SECNAM, TEXT +BITSET+ /For traceback #BASE, ORG .+3 /Base 0 N, ORG .+3 /Base 1 - value L, ORG .+3 #BSET, TEXT +BITSET+ /Base 2 - section name #ISH, TEXT +ISHFT + /Base 3 / Now at address 23, past autoindex registers. #XR, FNOP /Base 5: XR 0 ADDR #RETRN / XR 1; XR2 return to FRTS address. 1;2;3 /Base 6: XR3-5 TWO, F 2.0 /Base 7 ORG #BASE+30 FNOP JA #RET FNOP #GOBAK, 0;0 #LBL=. COMMON MISCOM LINUSE, ORG .+0003 TRVS, ORG .+0003 CLSSES, ORG .+0003 OLDLOC, ORG .+0003 LOC, ORG .+0003 CVAL, ORG .+0044 TK, ORG .+0074 NEWLOC, ORG .+0003 KEY, ORG .+0702 PLAC, ORG .+0454 FIXD, ORG .+0454 ACTSPK, ORG .+0151 COND, ORG .+0702 HINTS, ORG .+0360 HNTMAX, ORG .+0003 PROP, ORG .+0454 TALLY, ORG .+0003 TALLY2, ORG .+0003 HINTLC, ORG .+0074 CHLOC, ORG .+0003 CHLOC2, ORG .+0003 DSEEN, ORG .+0022 DFLAG, ORG .+0003 DLOC, ORG .+0022 DALTLC, ORG .+0003 KEYS, ORG .+0003 LAMP, ORG .+0003 GRATE, ORG .+0003 CAGE, ORG .+0003 ROD, ORG .+0003 ROD2, ORG .+0003 STEPS, ORG .+0003 BIRD, ORG .+0003 DOOR, ORG .+0003 PILLOW, ORG .+0003 SNAKE, ORG .+0003 FISSUR, ORG .+0003 TABLET, ORG .+0003 CLAM, ORG .+0003 OYSTER, ORG .+0003 MAGZIN, ORG .+0003 DWARF, ORG .+0003 KNIFE, ORG .+0003 FOOD, ORG .+0003 BOTTLE, ORG .+0003 WATER, ORG .+0003 OIL, ORG .+0003 PLANT, ORG .+0003 PLANT2, ORG .+0003 AXE, ORG .+0003 MIRROR, ORG .+0003 DRAGON, ORG .+0003 CHASM, ORG .+0003 TROLL, ORG .+0003 TROLL2, ORG .+0003 BEAR, ORG .+0003 MESSAG, ORG .+0003 VEND, ORG .+0003 BATTER, ORG .+0003 NUGGET, ORG .+0003 COINS, ORG .+0003 CHEST, ORG .+0003 EGGS, ORG .+0003 TRIDNT, ORG .+0003 VASE, ORG .+0003 EMRALD, ORG .+0003 PYRAM, ORG .+0003 PEARL, ORG .+0003 RUG, ORG .+0003 CHAIN, ORG .+0003 BACK, ORG .+0003 LOOK, ORG .+0003 CAVE, ORG .+0003 NULL, ORG .+0003 ENTRNC, ORG .+0003 DPRSSN, ORG .+0003 SAY, ORG .+0003 LOCK, ORG .+0003 THROW, ORG .+0003 FIND, ORG .+0003 INVENT, ORG .+0003 TURNS, ORG .+0003 LMWARN, ORG .+0003 KNFLOC, ORG .+0003 DETAIL, ORG .+0003 ABBNUM, ORG .+0003 NUMDIE, ORG .+0003 MAXDIE, ORG .+0003 DKILL, ORG .+0003 FOOBAR, ORG .+0003 BONUS, ORG .+0003 CLOCK1, ORG .+0003 CLOCK2, ORG .+0003 CLOSNG, ORG .+0003 PANIC, ORG .+0003 CLOSED, ORG .+0003 GAVEUP, ORG .+0003 SCORNG, ORG .+0003 ODLOC, ORG .+0022 STREAM, ORG .+0003 SPICES, ORG .+0003 ORG #LBL COUNT, ORG .+3 ONE, F 1.0 /BITSET(L,N) = (COND(L).AND.ISHFT(1,N)) .NE.0 BASE #BASE BITSET, FLDA #BSET /Section name JSA GETARG /Common setup FLDA% L /Get array index ATX 7 FLDA COND-0003,7 /COND(L) FSTA ITEST / COND(L) LDX 1,0 /Put 1 into shift value FLDA% N /Get N value JEQ #1 /No shift if zero FNEG /Negate ATX 1 /Into register XTA 0 /Get the "1" back STARTD ALN 1 /Do the shift STARTF ATX 0 /Put result in place #1, XTA 0 /Get result JSA #FIX ATX 0 /One mask value FLDA ITEST JSA #FIX ATX 1 /The other TRAP3 #ANDER /AND it XTA 0 /Restore value JEQ #GOBAK /Return if zero FLDA ONE /Else one JA #GOBAK /Done. ITEST, ORG .+3 /Test value ISHFT, FLDA #ISH /Section name JSA GETARG /Common setup FLDA% N /Get shift count JEQ #SKIP /No need to shift FNEG /Negative shift count goes left ATX 1 /Into XR 1 FLDA% L /Get value to shift ALN 0 /Align to right STARTD ALN 1 /Shift STARTF /Done JSA #FIX JA #GOBAK /Done #SKIP, FLDA% L /Get value back JA #GOBAK /Done GETARG, 0;0 /Common setup routine FSTA SECNAM /AC has section name SETX #XR /Set up index registers STARTD 0210 /Get caller's prolog FSTA #GOBAK,0 0200 /Get arg list SETB #BASE /Set up base page FSTA #BASE /Set up arg list FLDA% #BASE,3 /Get first arg FSTA L FLDA% #BASE,4 /Second arg FSTA N STARTF JA GETARG /Return END