File: BITSET.LS of Disk: V50/Source/Source-Listing-FORTRAN-2
(Source file text)
RALF V50A 24-JUL-20 PAGE 1
SECT BTSET
ENTRY ISHFT
ENTRY BITSET
ENTRY #ANDER
EXTERN #RETRN
EXTERN #FIX
SECT8 BITTER
00000 1235 #ANDER, TAD #XR /Simple masking
00001 0236 AND #XR+1
00002 3235 DCA #XR
00003 6203 CIF CDF
00004 5637 JMP% #XR+2 / Return
/FPP code here; using the rest of the SECT8 page.
00005 1100 #RET, SETX #XR /Traceback
00006 0035
00007 1110 SETB #BASE
00010 0016
00011 1030 JA .+3
00012 0014
00013 0211 SECNAM, TEXT +BITSET+ /For traceback
00014 2423
00015 0524
#BASE, ORG .+3 /Base 0
N, ORG .+3 /Base 1 - value
L, ORG .+3
00027 0211 #BSET, TEXT +BITSET+ /Base 2 - section name
00030 2423
00031 0524
00032 1123 #ISH, TEXT +ISHFT + /Base 3
00033 1006
00034 2440
/ Now at address 23, past autoindex registers.
00035 0040 #XR, FNOP /Base 5: XR 0
00036 0000 ADDR #RETRN / XR 1; XR2 return to FRTS address.
00037 0000
00040 0001 1;2;3 /Base 6: XR3-5
00041 0002
00042 0003
00043 0002 TWO, F 2.0 /Base 7
00044 2000
00045 0000
ORG #BASE+30
00046 0040 FNOP
00047 1030 JA #RET
00050 0005
00051 0040 FNOP
00052 0000 #GOBAK, 0;0
00053 0000
#LBL=.
COMMON MISCOM
LINUSE, ORG .+0003
RALF V50A 24-JUL-20 PAGE 1-1
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
RALF V50A 24-JUL-20 PAGE 1-2
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
00057 0001 ONE, F 1.0
00060 2000
00061 0000
/BITSET(L,N) = (COND(L).AND.ISHFT(1,N)) .NE.0
BASE #BASE
00062 0203 BITSET, FLDA #BSET /Section name
RALF V50A 24-JUL-20 PAGE 1-3
00063 1120 JSA GETARG /Common setup
00064 0157
00065 0602 FLDA% L /Get array index
00066 0027 ATX 7
00067 0470 FLDA COND-0003,7 /COND(L)
00070 2362
00071 6400 FSTA ITEST / COND(L)
00072 0130
00073 0100 LDX 1,0 /Put 1 into shift value
00074 0001
00075 0601 FLDA% N /Get N value
00076 1000 JEQ #1 /No shift if zero
00077 0107
00100 0003 FNEG /Negate
00101 0021 ATX 1 /Into register
00102 0030 XTA 0 /Get the "1" back
00103 0006 STARTD
00104 0011 ALN 1 /Do the shift
00105 0005 STARTF
00106 0020 ATX 0 /Put result in place
00107 0030 #1, XTA 0 /Get result
00110 1120 JSA #FIX
00111 0000
00112 0020 ATX 0 /One mask value
00113 0400 FLDA ITEST
00114 0130
00115 1120 JSA #FIX
00116 0000
00117 0021 ATX 1 /The other
00120 3000 TRAP3 #ANDER /AND it
00121 0000
00122 0030 XTA 0 /Restore value
00123 1000 JEQ #GOBAK /Return if zero
00124 0052
00125 0213 FLDA ONE /Else one
00126 1030 JA #GOBAK /Done.
00127 0052
ITEST, ORG .+3 /Test value
00133 0204 ISHFT, FLDA #ISH /Section name
00134 1120 JSA GETARG /Common setup
00135 0157
00136 0601 FLDA% N /Get shift count
00137 1000 JEQ #SKIP /No need to shift
00140 0154
00141 0003 FNEG /Negative shift count goes left
00142 0021 ATX 1 /Into XR 1
00143 0602 FLDA% L /Get value to shift
00144 0010 ALN 0 /Align to right
00145 0006 STARTD
00146 0011 ALN 1 /Shift
00147 0005 STARTF /Done
00150 1120 JSA #FIX
00151 0000
00152 1030 JA #GOBAK /Done
RALF V50A 24-JUL-20 PAGE 1-4
00153 0052
00154 0602 #SKIP, FLDA% L /Get value back
00155 1030 JA #GOBAK /Done
00156 0052
00157 0000 GETARG, 0;0 /Common setup routine
00160 0000
00161 6400 FSTA SECNAM /AC has section name
00162 0013
00163 1100 SETX #XR /Set up index registers
00164 0035
00165 0006 STARTD
00166 0210 0210 /Get caller's prolog
00167 6400 FSTA #GOBAK,0
00170 0052
00171 0200 0200 /Get arg list
00172 1110 SETB #BASE /Set up base page
00173 0016
00174 6200 FSTA #BASE /Set up arg list
00175 0630 FLDA% #BASE,3 /Get first arg
00176 6202 FSTA L
00177 0640 FLDA% #BASE,4 /Second arg
00200 6201 FSTA N
00201 0005 STARTF
00202 1030 JA GETARG /Return
00203 0157
RALF V50A 24-JUL-20 PAGE 1-5
NO ERRORS
126 SYMBOLS, NO ABS REFS
# C 00000 #ANDER 00000 #BASE 00016 #BSET 00027
#FIX X 00000 #GOBAK 00052 #ISH 00032 #LBL 00054
#MAIN S 00000 #RET 00005 #RETRN X 00000 #SKIP 00154
#XR 00035 #1 00107 ABBNUM 04774 ACTSPK 02214
AXE 04620 BACK 04717 BATTER 04653 BEAR 04642
BIRD 04535 BITSET 00062 BITTER 8 00204 BONUS 05013
BOTTLE 04601 BTSET S 00000 CAGE 04521 CAVE 04725
CHAIN 04714 CHASM 04631 CHEST 04664 CHLOC 04430
CHLOC2 04433 CLAM 04557 CLOCK1 05016 CLOCK2 05021
CLOSED 05032 CLOSNG 05024 CLSSES 00006 COINS 04661
COND 02365 COUNT 00054 CVAL 00017 DALTLC 04505
DETAIL 04771 DFLAG 04460 DKILL 05005 DLOC 04463
DOOR 04540 DPRSSN 04736 DRAGON 04626 DSEEN 04436
DWARF 04570 EGGS 04667 EMRALD 04700 ENTRNC 04733
FIND 04752 FISSUR 04551 FIXD 01540 FOOBAR 05010
FOOD 04576 GAVEUP 05035 GETARG 00157 GRATE 04516
HINTLC 04334 HINTS 03267 HNTMAX 03647 INVENT 04755
ISHFT 00133 ITEST 00130 KEY 00162 KEYS 04510
KNFLOC 04766 KNIFE 04573 L 00024 LAMP 04513
LINUSE 00000 LMWARN 04763 LOC 00014 LOCK 04744
LOOK 04722 MAGZIN 04565 MAXDIE 05002 MESSAG 04645
MIRROR 04623 MISCOM C 05073 N 00021 NEWLOC 00157
NUGGET 04656 NULL 04730 NUMDIE 04777 ODLOC 05043
OIL 04607 OLDLOC 00011 ONE 00057 OYSTER 04562
PANIC 05027 PEARL 04706 PILLOW 04543 PLAC 01064
PLANT 04612 PLANT2 04615 PROP 03652 PYRAM 04703
ROD 04524 ROD2 04527 RUG 04711 SAY 04741
SCORNG 05040 SECNAM 00013 SNAKE 04546 SPICES 05070
STEPS 04532 STREAM 05065 TABLET 04554 TALLY 04326
TALLY2 04331 THROW 04747 TK 00063 TRIDNT 04672
TROLL 04634 TROLL2 04637 TRVS 00003 TURNS 04760
TWO 00043 VASE 04675 VEND 04650 WATER 04604