├── notes on FORTX assem code.pdf ├── README.md ├── FORTH68lst.txt ├── FORTH68asm.txt └── FORTH-68_notes.txt /notes on FORTX assem code.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/monsonite/1968-FORTH/HEAD/notes on FORTX assem code.pdf -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # 1968-FORTH 2 | Original Forth for IBM 1130 written by Charles Moore in 1968. 3 | 4 | This implementation consists of 2 parts, a 645 line file written in IBM 1130 assembly language, and a 235 line text file listing, dumped from the IBM 1130 disk, but originally created as a deck of punched cards. 5 | 6 | 7 | These listings came to light sometime around 2011, and in March 2018 attracted the interest of Carl Claunch, an IBM 1130 restoration enthusiast. Most of the detective work concerning the operation of this Forth has been performed and documented by Carl Claunch. 8 | 9 | Please see FORTH-68_notes.txt and "notes on FORTH assem code.pdf" for Carl's invaluable doccumentation. 10 | 11 | 12 | Part of the difficulty in understanding the listings, was the use of the IBM proprietary EBCDIC (Extended Binary Coded Decimal Interchange Code) on the IBM 1130. Charles Moore created his own character coding to make the use of hexadecimal numbers easier and to facilitate alphabetical dictionary searches. Neither of these character coding schemes are compatible with ascii. 13 | 14 | 15 | The IBM 1130 was a fairly simple 16-bit computer, with a load-store architecture, a single accumulator and three index registers X1, X2, X3, stored at locations 01, 02, 03 in the core memory. 16 | 17 | 18 | Moore used X1 as a pointer to a 28 word workspace. X2 was used as the data stack pointer, and X3 had various minor uses. 19 | 20 | 21 | The assembly language listing implements a text interpreter and provides the kernel from which the Forth language can be built. It implements 28 primitive functions and generates the dictionary structure to allow further words to be added. 22 | 23 | Forth words are entered into memory as packed character strings. Two characters are packed into each 16-bit word of memory. Words are deliminated by whitespace, the blank or space character. Moore's character encoding allocated the hexadecimal digits 0-F to character codes $00 to $0F. This allowed the easy conversion of typed characters to binary literals. 24 | 25 | The remainder of the uppercase characters are encoded from $10 (G) to $22 (Z). 26 | 27 | New Forth words are defined with a statement beginning with a dot and ending with a comma. This was later changed to the more familiar colon and semicolon notation. 28 | -------------------------------------------------------------------------------- /FORTH68lst.txt: -------------------------------------------------------------------------------- 1 | // JOB 2 | // DUP 3 | *DELETE CARL8 4 | *STOREDATAE CD FX CARL8 0224 5 | .DEP LOC DEPOSIT, .DEPOSIT IC INC=, 6 | .INST OR DEPOSIT, 7 | 8 | .LD C000, .ST D000, 9 | .ADD 8000, .SUB 9000, 10 | .MUL A000, .DIV A800, 11 | .LX 6000, .SX 6800, .MX 7000, 12 | .B 7000, .BL 4800, .BSI 4000, 13 | .XIO 800, 14 | .X1 100 OR, .X2 200 OR, .X3 300 OR, 15 | 16 | .MDM 7400 INST DEPOSIT, 17 | .ZERO 1810 DEPOSIT, 18 | .XCH 18D0 DEPOSIT, 19 | .I 480 INST DEPOSIT, .L 400 INST, 20 | .LONG L DEPOSIT, 21 | .STORE ST LONG, .LOAD LD LONG, .CALL BSI LONG, 22 | .ACC 1 B INST DEPOSIT FE INST, 23 | 24 | .GDEP IC 1 MDM IC ST I, 25 | .GOR E800, .GAND E000, .GWAIT 3000 DEPOSIT, 26 | .REL X3 LONG, .RELS X3 INST, .BASE LX REL, 27 | .BASA 1 ST INST 0 BASE, 28 | .TOD 1880 INST, .TOM 1000 INST, 29 | .TXD 1880 INST, .TXM 1080 INST, 30 | .TAD 1800 INST, 31 | .ZF 10A0 DEPOSIT, .LF ZF LOAD, 32 | 33 | .FS X2 INST, 34 | .LS LD FS, .SS ST FS, .LSI LD X2 I, .SSI ST X2 I, 35 | .MS MX FS, 36 | .RETURN BL I, 37 | 38 | OPERATION CONSTANT E1 LX X3 I LD LOC LIT ACC 39 | 2 ST X3 INST 0 LS 3 ST X3 INST RETURN 40 | 41 | OPERATION REVERT E LOAD E1 STORE E1 FC MDM RETURN 42 | OPERATION TOP E1 LOAD E STORE E 4 MDM RETURN 43 | 44 | OPERATION DUP 0 LS 1 MS 0 SS RETURN 45 | OPERATION VALUE 0 LSI 0 SS RETURN 46 | OPERATION DROP FF MS RETURN 47 | OPERATION RAISE 1 MS RETURN 48 | OPERATION SWAP 0 LS XCH FF LS 0 SS XCH FF SS RETURN 49 | .MSI LD SWAP ACC DUP ADD FS SS, 50 | 51 | OPERATION + 0 LS FF MS 0 ADD FS 0 SS RETURN 52 | OPERATION AND 0 LS FF MS 0 E000 FS 0 SS RETURN 53 | .DISP FF AND, 54 | OPERATION - FF MS 0 LS 1 SUB FS 0 SS RETURN 55 | OPERATION MINUS ZERO 0 SUB FS 0 SS RETURN 56 | OPERATION / FF LS 1890 DEPOSIT 0 DIV FS FF SS 57 | XCH 0 SS RETURN 58 | OPERATION * FF LS 0 MUL FS XCH FF MS 0 SS RETURN 59 | 60 | OPERATION PUSH 0 LSI ADD 1 ACC 0 SSI 0 SS FF LS 0 SSI 61 | FE MS RETURN 62 | OPERATION PULL 0 LSI 1 SS SUB 1 ACC 0 SSI 1 63 | LSI 0 SS RETURN 64 | .STACK 1 MS LOAD 0 SS, 65 | .LITS LD SWAP ACC 1 MS 0 SS, 66 | OPERATION VECTOR 0 LS GDEP IC STACK LOC CONSTANT CALL 67 | FF ADD FS IC STORE FE MS RETURN 68 | .XS 4 VECTOR, XS XS XS= 69 | .TRANSIENT IC INC XS PUSH, 70 | OPERATION EXECUTE LD BL 480 OR ACC GDEP XS LD I GDEP 71 | XS LX X3 I 0 BSI X3 I XS LITS LOC PULL CALL 72 | SUB 1 ACC IC STORE FF MS RETURN 73 | 74 | .BACK IC VALUE - DISP B INST, 75 | .MARK IC VALUE SWAP LX X3 INST, 76 | .LOOP FF MX X3 INST BACK, 77 | .START 2 B INST DEPOSIT IC INC 78 | FD LD INST FD ST INST, 79 | .STOP DUP FF MDM 1+ BACK, 80 | 81 | .CONDITION 0 LS FF MS BSI OR L LOC NEXT DEPOSIT RETURN, 82 | OPERATION NONZERO 18 CONDITION 83 | OPERATION FALSE 20 CONDITION 84 | OPERATION EVEN 04 CONDITION 85 | .IF BL 400 OR INST IC INC, .THEN IC VALUE 1+ SWAP=, 86 | .ELSE IC VALUE 3+ SWAP= 0 IF, 87 | .POSITIVE 8, .NEGATIVE 10, .EQUAL 20, .NOT 18, 88 | 89 | .PROGRAM 1 B INST 0 DEPOSIT, 90 | OPERATION QUEUE 1- PROGRAM GWAIT BACK 91 | .ENQUEUE LOAD LOC QUEUE 2+ STORE 92 | LD 1 B OR ACC LOC QUEUE 1+ STORE LOC QUEUE 1+ BL LONG, 93 | .REACTIVATE LD BL 400 OR ACC LOC QUEUE 1+ STORE, 94 | .BNZ BL 20 OR, 95 | 96 | .BUFFER DUP DUP DUP DUP VALUE 2/ DROP+ 2+ 97 | SWAP 1+= 2+ SWAP=, 98 | OPERATION EXCHANGE 0 LS ADD 1 ACC 1 SS 0 LSI 99 | XCH 1 LSI 0 SSI XCH 1 SSI FF MS RETURN 100 | .CLEAR LOAD 4840 I, 101 | .NOP B DEPOSIT, 102 | .ALIGN IC VALUE EVEN NOP, 103 | .GXIO ALIGN 1 XIO INST 2 B INST DEPOSIT DEPOSIT, 104 | .WTC 1+ 2*, 105 | 106 | OPERATION FILL 0 LS FF MS 1 ST INST 0 START LOC NEXT CALL 107 | LOC HEX CALL 0 LS GDEP FF MS STOP RETURN 108 | .DATA IC VALUE 1+ CONSTANT DROP, 109 | .CSKB 40 DATA FILL 2000 1000 800 400 200 100 80 40 20 10 110 | 9000 8800 8400 8200 8100 8080 8040 8020 8010 5000 4800 4400 4200 4100 111 | 4080 4040 4020 4010 2800 2400 2200 2100 2080 2040 2020 2010 0000 112 | 8820 0420 8220 8120 80A0 8060 8000 4820 4420 4220 4120 40A0 4060 113 | 4000 3000 2420 2220 2120 20A0 2060 0820 8420 0220 0120 00A0 0060 114 | 0000, CSKB 115 | .CSCP 40 DATA FILL C400 FC00 D800 DC00 F000 F400 D000 D400 E400 E000 116 | 3C00 1800 1C00 3000 3400 1000 1400 2400 2000 7C00 5800 5C00 7000 117 | 7400 5000 5400 6400 6000 9800 9C00 B000 B400 9000 9400 A400 A000 118 | 2100 0200 C000 DE00 FE00 DA00 C600 4400 4200 4000 D600 F600 D200 119 | F200 8400 BC00 8000 0600 BD00 4600 8600 8200 0000 0400 E600 C200 120 | E200 8600, CSCP 121 | .A 2 VECTOR, A 122 | .RESTORE A 2+ STORE 0F01 0 GXIO, 123 | .CONTINUE A 2+ CLEAR, 124 | OPERATION READY RESTORE REACTIVATE CONTINUE 125 | .CHA A 1+ STORE 0900 A 1+ GXIO LD LOC READY ACC 0C STORE, 126 | OPERATION CHARACTER RESTORE 0A00 A 1+ GXIO A 1+ LOAD 127 | ST X1 DEPOSIT LOC CONVERT CALL CSCP LD REL CHA CONTINUE 128 | OPERATION ACCEPT LD LOC CHARACTER ACC 0C STORE 0C00 0 GXIO ENQUEUE 129 | OPERATION CONSOLE LD CSKB 3F+ ACC FF ST X1 INST LD LOC ACCEPT ACC 130 | FE ST X1 INST RETURN 131 | 132 | OPERATION TYP CHA ENQUEUE 133 | .RED 900, .BLACK 500, 134 | OPERATION RIBBON 0 LS FF MS LOC TYPE CALL LD 8100 ACC 135 | LOC TYP CALL RETURN 136 | OPERATION TYPE 137 | 0 LS 1 ST INST 0 START FF LS LOC FETCH CALL 138 | BASA SUB 3F ACC POSITIVE IF 3F BASE THEN 139 | CSCP LD REL LOC TYP CALL FF 1 MSI STOP FE MS RETURN 140 | .MESSAGE BLACK RIBBON TYPE RED RIBBON, 141 | .ALPHA 14 VECTOR, ALPHA 142 | .REPLY ALPHA WTC ALPHA VALUE MESSAGE, 143 | 144 | .D 3 VECTOR, D 145 | .QUERY 8F01 0 GXIO, 146 | OPERATION DONE D STORE QUERY REACTIVATE D CLEAR 147 | OPERATION HOME ZERO D 1+ ST LONG QUERY GAND 0800 ACC 148 | DUP BNZ I 8C04 C8 GXIO ENQUEUE 149 | .IN 154 VECTOR, IN 141 IN= 150 | .BZ BL 18 OR, 151 | 152 | .M LD, .CS MS, .ZLT ZERO, 153 | .TS SS, .TM STORE, .TR ST INST, .TA ST REL, 154 | .ST FS, .MT LONG, .RT INST, .AT REL, .LT SWAP ACC, 155 | 156 | .FIXUP 6 M RT 3 TAD 3 TXM 3 TR, 157 | OPERATION CYLINDER 3 TOD 2 TS D 1+ SUB MT DUP BZ I 158 | POSITIVE IF 3 TOM 3 TXD 159 | ELSE 1 TS 10 TXD ZLT 1 SUB ST 160 | THEN ALIGN NOP 6 TR 161 | FIXUP 8C00 0 GXIO 2 M ST D 1+ TM 162 | 8 M LT D 2+ TM ENQUEUE 163 | OPERATION SECTOR 0 M ST LOC CYLINDER CALL 0 M ST FF CS 164 | 7 GAND LT 1 TS D 2+ SUB MT DUP BZ I 1 M ST D 2+ TM 165 | 3 TXD ALIGN FIXUP 8E00 IN GXIO ENQUEUE 166 | OPERATION WRITE D 2+ M MT 3 TXD ALIGN FIXUP 8D00 IN GXIO ENQUEUE 167 | .CHARACTER FFFE BSI X1 I FD M X1 RT 1 ADD LT FD X1 TR, 168 | .REP FE M ST 2 TR 0 M X1 RT 3C SUB LT SWAP DUP BZ I SWAP 169 | 0 M ST DEP CALL 0 1 MSI, 170 | 171 | OPERATION FILL 28 START CHARACTER REP STOP 172 | 8100 M LT LOC TYP CALL RETURN 173 | OPERATION BLANK 0 M ST 1 TOD FF CS LX X3 GOR LT 174 | 0 TR 0 M ST 1 TOD 1 SUB LT 5 TR 2424 M LT 0 MARK 175 | 0 TA LOOP RETURN 176 | OPERATION LIZ ALPHA WTC M LT 1 TS 2 TS 177 | 28 M LT 3 TS 3 CS LOC BLANK CALL 178 | LOC FILL CALL 0 M ST FF SUB ST ALPHA TM FD CS RETURN 179 | OPERATION ' 3C M LT 1 TS 1 CS LOC LIZ CALL RETURN 180 | OPERATION ( 2F M LT 1 TS 1 CS LOC LIZ CALL RETURN 181 | .$ 'OK' REPLY, 182 | .FILE 7 VECTOR, FILE .LINE INTEGER, 183 | OPERATION POSITION 0 M ST 4 TOD 1 CS 0 TS 184 | LOC SECTOR CALL 0 M ST F GAND LT 14 MUL LT XCH 185 | IN ADD LT 0 TS RETURN 186 | OPERATION FILL 28 START LOC ACCEPT CALL REP STOP RETURN 187 | .L LINE VALUE, .RELATIVE FILE 5+ VALUE+, 188 | .T DUP LINE= RELATIVE POSITION WTC 28 MESSAGE, 189 | .EXAMINE SWAP IN WTC + SWAP MESSAGE, 190 | .EMPLACE 3C IN WTC+ 28 FILL DROP DROP DROP WRITE, 191 | .S INTEGER, .SV S VALUE, 192 | .MOVE TRANSIENT MARK SWAP M AT SWAP TA LOOP EXECUTE, 193 | .COMPARE 2 TR MARK 0 M AT SWAP SUB AT EQUAL IF SWAP LOOP ELSE, 194 | OPERATION SEARCH IN 6- M LT S TM IN 1+ M MT 1 TR 0 START 195 | S 7 MDM S M MT ALPHA 4 COMPARE SWAP STOP THEN 1 CS 196 | 0 TS RETURN 197 | .CREATE 2E0 SECTOR IN 1+ DUP INC 1- 7*+ S= SV VALUE 1+ SV 5+= 198 | RAISE SV 6+= RAISE F+ SV 7+= SV ALPHA 4 MOVE WRITE, 199 | .WARN 'NO SUCH FILE' REPLY, 200 | .ACTIVATE 2E0 SECTOR SEARCH NONZERO WARN FILE SV 7 MOVE, 201 | .DELETE 2E0 SECTOR 0 SV 1+= WRITE, 202 | 203 | .SEC INTEGER, 204 | OPERATION STRAIGHT FD X1 M RT IN 140+ WTC SUB LT EQUAL IF 205 | SEC 1 MDM SEC M MT 1 CS 0 TS LOC SECTOR CALL 206 | IN WTC M LT FD X1 TR THEN 207 | FD X1 M RT LOC FETCH CALL RETURN 208 | OPERATION SET LOC STRAIGHT M LT FE X1 TR 209 | 0 M ST FF CS FD X1 TR RETURN 210 | .INTERPRET TOP FILE 5+ VALUE 10/ 14* IN+ WTC 211 | SWAP DUP SEC= SECTOR SET, 212 | .RETRIEVE ACTIVATE INTERPRET, 213 | 214 | .XT SX INST 0 M LT, 215 | OPERATION FORGET 1 X3 XT E TM 4 SUB LT E1 TM 3 X3 M RT 216 | IC TM RETURN 217 | OPERATION REMEMBER LOC ENTRY CALL 218 | LOC FORGET M LT 2 X3 TR IC M MT 3 X3 TR RETURN 219 | 220 | LOC DONE 0A= HOME 'HI THERE' REPLY CONSOLE 221 | 222 | 223 | 224 | 225 | 226 | 227 | 228 | 229 | 230 | *DUMPFLET 231 | // JOB 232 | *DEFINE FIXED AREA 0004 0211 233 | *DUMPLET 234 | *DELETE 1DUMY 0211 235 | *DFILE FX CARL9 0040 0211 -------------------------------------------------------------------------------- /FORTH68asm.txt: -------------------------------------------------------------------------------- 1 | // JOB 2 | // ASM 3 | *LIST ALL 4 | ABS FORTH 5 | ORG /900 6 | CONVE DC CONVERT EDBCDIC TO FORTH 7 | LD 1 -1 CHARACTER SET 8 | STO CV1+1 9 | LDX 3 -63 10 | CV1 LD L3 11 | S 1 A 12 | BZ CV2 13 | MDX 3 1 14 | B CV1 15 | CV2 MDX 3 63 16 | NOP 17 | STX 3 TEMP 18 | LD TEMP 19 | STO 1 A 20 | B I CONVE 21 | ACCEP DC NEXT CHARACTER FROM DISK 22 | LD 1 -3 C 23 | S L C2 24 | BSI L RECOR,+- NEXT RECORD 25 | LD 1 -3 C 26 | BSI FETCH 27 | BSI CONVE 28 | B I ACCEP 29 | RETRY DC FROM CORE 30 | LD 1 -3 C 31 | BSI FETCH 32 | B I RETRY 33 | NEXT DC NEXT WORD 34 | LD 1 -6 W1 35 | STO 1 2 W 36 | LD BL2 37 | STO 1 4 WORD+1 38 | NE1 BSI I1 -2 ACCEPT 39 | LD 1 A 40 | S BL 41 | BNZ NE2 42 | LD 1 -3 C 43 | A ONE 44 | STO 1 -3 C 45 | B NE1 46 | NE2 S SC 47 | BNP ALPHA 48 | S THREE 49 | BN SPECI 50 | S TWO 51 | BNZ SPECI 52 | ALPHA LD 1 2 W ALPHABETIC 53 | BSI DEPOS 54 | BSI I1 -4 SAVE 55 | LD 1 -3 C 56 | A ONE 57 | STO 1 -3 C 58 | LD 1 2 W 59 | A ONE 60 | STO 1 2 61 | BSI I1 -2 ACCEP 62 | LD 1 A 63 | S BL 64 | BZ AL1 65 | BP I NEXT 66 | B ALPHA 67 | AL1 BSI I1 -4 SAVE 68 | LD 1 -3 C 69 | A ONE 70 | STO 1 -3 C 71 | B I NEXT 72 | SPECI LD 1 2 W SPECIAL CHARACTER 73 | BSI DEPOS 74 | BSI I1 -4 SAVE 75 | LD 1 -3 C 76 | A ONE 77 | STO 1 -3 C 78 | B I NEXT 79 | SC DC 20 80 | TWO DC 2 81 | THREE DC 3 82 | BL2 DC /2424 83 | BL DC /24 84 | SAVE DC BUILD MEMORY 85 | LD 1 -5 D 86 | A ONE 87 | STO 1 -5 D 88 | BSI DEPOS 89 | B I SAVE 90 | SAVE0 DC DUMMY 91 | B I SAVE0 92 | ONE DC 1 93 | TEMP DC 0 94 | FETCH DC 0 FETCH CHARACTER 95 | SRT 1 96 | STO TEMP 97 | SLT 1 98 | BOD FE1 99 | LD I TEMP EVEN CHARACTER 100 | SRA 8 101 | B FE2 102 | FE1 LD I TEMP ODD CHARACTER 103 | AND FF 104 | FE2 STO 1 A 105 | B I FETCH 106 | FF DC /00FF 107 | DEPOS DC DEPOSIT CHARACTER 108 | SRT 1 109 | STO TEMP 110 | SLT 1 111 | BOD DE1 112 | LD 1 A EVEN CHARACTERS 113 | SLA 10 114 | SRA 2 115 | OR BL 116 | B DE2 117 | DE1 LD I TEMP ODD CHARACTER 118 | AND FF00 119 | OR 1 A 120 | DE2 STO I TEMP 121 | B I DEPOS 122 | FF00 DC /FF00 123 | DO DC INTERPRET WORD 124 | LDX I3 E 125 | DO1 MDX 3 -4 126 | LD 3 127 | BZ I DO 128 | S 1 3 WORD 129 | BNZ DO1 130 | LD 3 1 131 | S 1 4 WORD+1 132 | BNZ DO1 133 | B I DO 134 | UNDEF DC UNDEFINED SYMBOL 135 | LD 1 3 WORD 136 | AND F000 137 | BSI L HEX,+- 138 | B I UNDEF 139 | F000 DC /F000 140 | HEX DC HEXADECIMAL LITERAL 141 | LD 1 2 W 142 | S 1 -6 W1 143 | STO TEMP 144 | LDX I3 TEMP 145 | MDX 2 1 146 | SRA 16 147 | STO 2 148 | LD 1 -6 W1 149 | HE1 STO 1 2 W 150 | BSI FETCH 151 | LD 2 152 | SLA 4 153 | OR 1 A 154 | STO 2 155 | LD 1 2 W 156 | A ONE 157 | MDX 3 -1 158 | B HE1 159 | B I HEX 160 | ENTRY DC INITIAL ENTRY 161 | BSI L NEXT 162 | MDM L E1,4 163 | LDX I3 E1 164 | STX L3 E 165 | MDM L E,4 166 | LD 1 3 WORD 167 | STO 3 168 | LD 1 4 WORD+1 169 | STO 3 1 170 | B I ENTRY 171 | ENTER DC ADD TO SYMBOL TABLE 172 | BSI ENTRY 173 | LD L INTER 174 | STO 3 2 175 | LD L IC 176 | SLA 1 177 | A ONE 178 | STO 1 -5 D 179 | A ONE 180 | STO 3 3 181 | LD ASAVE SKIP OVER DEFINITION 182 | STO 1 -4 SAVE 183 | EN1 BSI L NEXT 184 | LD COMMA 185 | S L WORD 186 | BNZ EN2 187 | EN3 LD 1 -5 D 188 | SRA 1 189 | STO L IC 190 | LD ASAV0 191 | STO 1 -4 SAVE 192 | B I ENTER 193 | EN2 LD DOT 194 | S L WORD 195 | BNZ EN1 196 | B EN3 197 | ASAVE DC SAVE 198 | ASAV0 DC SAVE0 199 | DOT DC /3024 SEMICOLON 200 | COMMA DC /3424 , 201 | X3 DC 202 | STX 3 X3 203 | START LDX L2 STACK+1 RESTART LOCATION 204 | LDX L1 A 205 | LDX L3 INTST 206 | STX L3 R 207 | LDX L3 E2 208 | STX L3 E1 209 | MDX 3 4 210 | STX L3 E 211 | LDX L3 2*SECT+74 212 | STX L3 STACK 213 | STX L3 C2 214 | LDX L3 /B3 215 | STX L3 /A 216 | LDX L3 FORTH 217 | STX L3 STACK+1 218 | LDX L3 ACCEP 219 | STX L3 A-2 220 | LDX L3 BCD+63 221 | STX L3 A-1 222 | LDX L3 SAVE0 223 | STX L3 A-4 224 | LDX L3 /19FF 225 | STX L3 IC 226 | LDX L3 /0268 ORIGINALLY /10EE CHANGED CVC 227 | STX L3 SECT 228 | BSI RECUR 229 | LINK BALO 230 | FORTH MDX 2 -1 231 | LD 2 1 232 | STO 1 -3 C 233 | FO1 BSI L NEXT 234 | BSI L DO 235 | BSI I3 2 236 | B FO1 237 | RECUR DC 238 | LD RECUR 239 | STO I R 240 | MDM L R,1 241 | MDX 2 -1 242 | B I2 1 243 | RETUR DC 244 | MDM L R,-1 245 | LDX I3 R 246 | B I3 0 247 | INC DC INCREMENT COUNTER 248 | LD I2 249 | A L ONE 250 | STO I2 251 | STO 2 252 | B I INC 253 | INTER DC * 254 | DC INTERPRET 255 | LD L E 256 | STO I R 257 | STX L3 E 258 | MDM L R,1 259 | LD 1 -3 C 260 | STO I R 261 | MDM L R,1 262 | LD 3 3 263 | STO 1 -3 C 264 | LD 1 -2 ACCEPT 265 | STO I R 266 | MDM L R,1 267 | LD ARETR 268 | STO 1 -2 ACCEP 269 | B I INTER+1 270 | ARETR DC RETRY 271 | COM DC END INTERRUPT 272 | MDM L R,-3 273 | LDX I3 R 274 | LD 3 1 275 | STO 1 -3 C 276 | LD 3 2 277 | STO 1 -2 ACCEPT 278 | LD 3 279 | S L E 280 | BNP I COM 281 | LD 3 0 282 | STO L E 283 | B I COM 284 | LOC DC LOCATION OF CODE 285 | BSI L NEXT 286 | BSI L DO 287 | LD 3 2 288 | MDX 2 1 289 | STO 2 290 | B I LOC 291 | OR DC OR TOP OF STACK 292 | LD 2 293 | MDX 2 -1 294 | OR 2 295 | STO 2 296 | B I OR 297 | STORE DC STORE TO T.O.S. 298 | LD 2 -1 299 | STO I2 300 | MDX 2 -2 301 | B I STORE 302 | SD DC STACK TO DEPOSIT 303 | LD 2 304 | MDM L IC,1 305 | STO I IC 306 | MDX 2 -1 307 | B I SD 308 | ADDR DC * 309 | DC PLACE ADDRESS ON STACK 310 | MDX 2 1 311 | STX L3 TEMP 312 | MDM L TEMP,3 313 | LD L TEMP 314 | STO 2 315 | B I ADDR+1 316 | LITER DC * 317 | DC PLACE VALUE ON STACK 318 | MDX 2 1 319 | LD 3 3 320 | STO 2 321 | B I LITER+1 322 | OPER DC OPERATION 323 | BSI L ENTRY 324 | MDM L IC,1 325 | LD L IC 326 | MDX 2 1 327 | STO 2 328 | STO 3 2 329 | B I OPER 330 | CONS DC CONSTANT 331 | BSI L NEXT 332 | BSI L ENTRY 333 | LD LITER 334 | STO 3 2 335 | LD 2 336 | STO 3 3 337 | MDX 2 -1 338 | B I CONS 339 | INTEG DC DECLARE INTEGER 340 | LDX I3 E 341 | LD ADDR 342 | STO 3 2 343 | BSI ADDR+1 344 | B I INTEG 345 | E1 DC TOP OR SYMBOL TABLE 346 | E DC THE PLACE TO START SEARCHES 347 | W1 DC 2*WORD -6 348 | DC D -5 SAVE CHARACTER 349 | DC -4 SAVE OPERATION 350 | DC C -3 CURRENT CHARACTER 351 | DC -2 ACCEPT 352 | DC -1 CHARACTER TABLE 353 | A DC A XR1 CURRENT CHARACTER 354 | N DC 1 355 | DC W 2 WORD CHARACTER 356 | WORD BSS 20 3 357 | STACK BSS 16 358 | R DC 359 | INTST BSS 32 360 | C1 DC 2*SECT+642+72 RESET CHARACTER 361 | C2 DC CHARACTER BEYOND RECORD 362 | C3 DC 2*SECT+74 VHARACTER BEYOND SECTOR 363 | ERROR DC 0 364 | B I ERROR 365 | RECOR DC 0 NEXT REcORD 366 | LD 1 -3 C 367 | S C3 368 | BSI L BLOCK,+- NEXT BLOCK 369 | LD 1 -3 C 370 | S D152 371 | STO 1 -3 372 | MDM L C2,-80 373 | BSI FIXUP 374 | B I RECOR 375 | D152 DC 152 376 | BLOCK DC 0 NEXT BLOCK 377 | LDX I3 X3 378 | LIBF DISK1 379 | DC /1000 380 | DC BUF 381 | DC ERROR 382 | BL1 LIBF DISK1 383 | DC /0000 384 | DC BUF 385 | B BL1 386 | MDM L SECT,1 387 | LD L C1 388 | STO 1 -3 C 389 | STO L C2 390 | B I BLOCK 391 | FIXUP DC RE-ARRANGE RECORD 392 | LD 1 -3 C 393 | SRA 1 394 | STO L FX1 395 | STO L FX2 396 | MDM L FX2,39 397 | LDX 3 20 398 | FI1 LD I FX1 399 | STO L TEMP 400 | LD I FX2 401 | STO I FX1 402 | LD L TEMP 403 | STO I FX2 404 | MDM L FX1,1 405 | MDM L FX2,-1 406 | MDX 3 -1 407 | B FI1 408 | B I FIXUP 409 | FX1 DC 410 | FX2 DC 411 | PUT DC OUTPUT CHARACTER 412 | LD 1 A 413 | STO AP 414 | LDX I3 AP 415 | LD L3 BCD 416 | STO 1 A 417 | LD L DP 418 | BSI L DEPOS 419 | MDM L DP,1 420 | LD DP 421 | S DP1 422 | BSI L PRINT,+- 423 | LD AP 424 | STO 1 A 425 | B I PUT 426 | PRINT DC 0 PRINT RECORD 427 | LD L BCDBL 428 | STO 1 A 429 | PR2 LD DP 430 | S DP1 431 | BZ PR3 432 | LD L DP 433 | BSI L DEPOS 434 | MDM L DP,1 435 | B PR2 436 | PR3 LDX I3 X3 437 | LIBF PRNT1 438 | DC /2000 439 | DC PRN 440 | DC ERROR 441 | PR1 LIBF PRNT1 442 | DC /0000 443 | B PR1 444 | LD DP0 445 | STO DP 446 | B I PRINT 447 | AP DC 448 | DP0 DC 2*PRN+2 449 | DP DC 2*PRN+2 450 | DP1 DC 2*PRN+74 451 | PRN DC 36 452 | BSS 36 453 | BCD DC 240 0 454 | DC 241 1 455 | DC 242 2 456 | DC 243 3 457 | DC 244 4 458 | DC 245 5 459 | DC 246 6 460 | DC 247 7 461 | DC 248 8 462 | DC 249 9 463 | DC 193 A 464 | DC 194 B 465 | DC 195 C 466 | DC 196 D 467 | DC 197 E 468 | DC 198 F 469 | DC 199 G 470 | DC 200 H 471 | DC 201 I /12 472 | DC 209 J 473 | DC 210 K 474 | DC 211 L 475 | DC 212 M 476 | DC 213 N 477 | DC 214 O /18 478 | DC 215 P 479 | DC 216 Q 480 | DC 217 R 481 | DC 226 S /1C 482 | DC 227 T 483 | DC 228 U 484 | DC 229 V 485 | DC 230 W 486 | DC 231 X 487 | DC 232 Y 488 | DC 233 Z 489 | DC 64 BLANK /24 490 | DC 74 CENTS 491 | DC 123 NUMBER 492 | DC 76 LESS THAN 493 | DC 77 ( 494 | DC 78 + 495 | DC 79 STROKE 496 | DC 80 AMPERSAND /2B 497 | DC 90 EXCLAME 498 | DC 91 $ 499 | DC 92 * 500 | DC 93 ) 501 | DC 94 SEMI COLON 502 | DC 95 NOT 503 | DC 96 - 504 | DC 97 / 505 | DC 107 , 506 | DC 108 PERCENT 507 | DC 109 UNDERSCORE 508 | DC 110 GREATER THAN 509 | DC 111 QUESTION 510 | DC 122 COLON 511 | DC 75 . 512 | DC 124 AT 513 | DC 125 ' 514 | DC 126 = 515 | DC 127 QUOTE 516 | BCDBL DC 64 BL 517 | BUF DC 320 SECTOR BUFFER 518 | SECT DC 519 | BSS 320 520 | DC 521 | DC 522 | DC UNDEF 523 | DC 524 | DC /0F18 FORTH 525 | DC /1B1D 526 | DC FORTH 527 | DC 528 | DC /1B0E RECURSE 529 | DC /0C1E 530 | DC LITER+1 531 | DC R 532 | DC /0F12 FIND 533 | DC /170D 534 | DC DO 535 | DC 536 | DC /0A0D ADDRESS 537 | DC /0D1B 538 | DC ADDR+1 539 | DC 540 | DC /0E17 END 541 | DC /0D24 542 | DC COM 543 | DC 544 | DC /110E HEX 545 | DC /2124 546 | DC HEX 547 | DC 548 | DC /181B OR 549 | DC /2424 550 | DC OR 551 | DC 552 | DC /3D24 = 553 | DC /2424 554 | DC STORE 555 | DC 556 | DC /3924 COLON 557 | DC /2424 558 | DC ENTER 559 | DC 560 | DC /3A24 . 561 | DC /2424 562 | DC ENTER 563 | DC 564 | DC /3024 SEMI COLON 565 | DC /2424 566 | DC COM 567 | DC 568 | DC /3424 , 569 | DC /2424 570 | DC COM 571 | DC 572 | DC /120C IC 573 | DC /2424 574 | DC ADDR+1 575 | IC DC 576 | DC /2524 CENT 577 | DC /2424 578 | DC OPER 579 | DC 580 | DC /1819 OPERATION 581 | DC /0E1B 582 | DC OPER 583 | DC 584 | DC /0E17 ENTRY 585 | DC /1D1B 586 | DC ENTRY 587 | DC 588 | DC /1217 INTEGER 589 | DC /1D0E 590 | DC INTEG 591 | DC 592 | DC /1217 INC 593 | DC /0C24 594 | DC INC 595 | DC 596 | DC /1C0D SD 597 | DC /2424 598 | DC SD 599 | DC 600 | DC /0C18 CONVERT 601 | DC /171F 602 | DC CONVE 603 | DC 604 | DC /0F0E FETCH 605 | DC /1D0C 606 | DC FETCH 607 | DC 608 | DC /0D0E DEPOSIT 609 | DC /1918 610 | DC DEPOS 611 | DC 612 | DC /191E PUT 613 | DC /1D24 614 | DC PUT 615 | DC 616 | DC /191B PRINT 617 | DC /1217 618 | DC PRINT 619 | DC 620 | DC /170E NEXT 621 | DC /211D 622 | DC NEXT 623 | DC 624 | DC /1518 LOC 625 | DC /0C24 626 | DC LOC 627 | DC 628 | DC /0E24 E 629 | DC /2424 630 | DC LITER+1 631 | DC E 632 | DC /1512 LIT 633 | DC /1D24 634 | DC LITER+1 635 | DC 636 | E2 DC /0E01 E1 637 | DC /2424 638 | DC LITER+1 639 | DC E1 640 | END START-1 641 | // DUP 642 | *DELETE FORTX 643 | *STORE 1 WS UA FORTX 644 | // JOB 645 | *DELETE FORTX 646 | -------------------------------------------------------------------------------- /FORTH-68_notes.txt: -------------------------------------------------------------------------------- 1 | Notes on the IBM 1130 Forth assembler and text files - Carl Claunch, March 2018 2 | 3 | 4 | -------------------------------------------------------------------------------- 5 | These are the primitives in the assembler program 6 | -------------------------------------------------------------------------------- 7 | 8 | Primitives used by FORTH code 9 | 10 | E - will put the next location in dictionary variable section (+4 from E1) on stack 11 | 12 | E1 - will put the highest valid entry in dictionary variable section onto the stack 13 | 14 | IC - will push the current instruction counter (of forth instructions) onto stack 15 | 16 | LIT - will put the literal value onto the stack 17 | 18 | OR - will OR together the top two values on stack and replace with single result 19 | 20 | LOC - will fetch next name in stream and look it up in the dictionary 21 | pushing the execution address of that item onto the stack 22 | this is the ’ verb to look up a word in the dictionary 23 | 24 | NEXT - will find next word, interpret it and execute 25 | 26 | INC - will bump up the value of a variable by 1 - variable address on top of stack 27 | and will also place that value on the stack in place of variable address 28 | 29 | HEX - sets space on variable part of dictionary for a hex variable 30 | 31 | ; or , or END - finishes a definition and switches back to execute mode 32 | : or . - switches into definition mode, storing the remaining text up to 33 | the ; in the variable entry for this word, and causing it to be 34 | interpreted whenever it is used 35 | 36 | ¢ or OPERATION - generates 1130 machine language as a callable routine 37 | to be executed when this word is used 38 | more modern versions used CODE instead 39 | 40 | ENTRY - makes a dictionary entry - grabbing the next word from the input stream 41 | and establishing an entry in the fixed part of the dictionary 42 | 43 | INTEGER - sets space on variable part of dictionary for an integer variable, 44 | putting the variable name in the fixed dictionary and when it is used 45 | the code executed will put its address from variable part onto the stack 46 | 47 | CONVERT - switches packed EBCDIC words to packed FORTH code words 48 | uses a 64 word table that is organized by FORTH code values 49 | and the entries in that table are EBCDIC codes 50 | 51 | DEPOSIT - put next char in work area - OVERRIDDEN BY FORTH DISK FILE 52 | so that DEPOSIT 53 | 54 | FETCH - get next character from startup disk buffer, typewriter buffer or 55 | the user disk buffer 56 | 57 | 58 | primitives not found in the bootup FORTH code 59 | 60 | FIND - look up an entry in the dictionary 61 | 62 | RECURSE - Push down return address and start execution 63 | 64 | FORT - will start basic FORTH loop getting words, interpreting and executing 65 | 66 | PUT - will put a character from stack into print line 67 | 68 | PRINT - will print the current print line 69 | 70 | ADDRESS - store an address (e.g. to a variable or code pointer (IC) 71 | this is called by E, E1 and IC which are called by FORTH code 72 | SD - Replaces top of stack value with the current code pointer (IC) 73 | 74 | -------------------------------------------------------------------------------- 75 | Important synonyms used for more widely recognized forth characters 76 | -------------------------------------------------------------------------------- 77 | 78 | The actual file written by Chuck Moore used: 79 | . as a synonym for : 80 | , as a synonym for ; 81 | OPERATION as a synonym for ¢(cent-sign) or CODE 82 | 83 | "In charts below, (a b -- c) is change in stack, var: is addition to variable dictionary entry" 84 | gen: is what it will generate when compiled 85 | 86 | 87 | -------------------------------------------------------------------------------- 88 | THE SECTION BELOW COVERS METHOD OF STORING INSTRUCTIONS AND MANAGING THE FORTH PROGRAM COUNTER (IC) 89 | -------------------------------------------------------------------------------- 90 | :DEP LOC DEPOSIT; ( -- execaddr(DEPOSIT)) var: () same as ’ DEPOSIT in modern FORTH 91 | find the execution address of DEPOSIT (builtin) and put on stack 92 | 93 | :DEPOSIT IC INC=; (n -- ) gen: (n) and bumps IC by 1 94 | pick up the pseudo instruction counter IC address and put on stack 95 | bump the contents of that address by one 96 | save the top word on the stack into the variable dictionary 97 | this stores instructions to variable dictionary and advances IC 98 | 99 | :INST OR DEPOSIT; (n m -- ) gen: (n OR m) 100 | OR the two words on the stack (to form an instruction) and DEPOSIT 101 | 102 | THE SECTION BELOW COVERS GENERATION OF VALID 1130 INSTRUCTIONS FOR COMPILED CODE 103 | -------------------------------------------------------------------------------- 104 | :LD C000; ( -- C000) gen: () 105 | C000 is basis of 1130 Load Accumulator instruction 106 | 107 | :ST D000; ( -- D000) gen: () 108 | D000 is basis of 1130 Store Accumulator inst 109 | 110 | :ADD 8000; ( -- 8000) gen: () 111 | 8000 is basis of 1130 Add to Accumulator inst 112 | 113 | :SUB 9000; ( -- 9000) gen: () 114 | 9000 is basis of 1130 Subtract from Accumulator inst 115 | 116 | :MUL A000; ( -- A000) gen: () 117 | A000 is basis of 1130 Multiply Accumulator inst 118 | 119 | :DIV A800; ( -- A800) gen: () 120 | A800 is basis of 1130 Divide, into Accumulator+Extension inst 121 | 122 | :LX 6000; ( -- 6000) gen: () 123 | 6000 is basis of 1130 Load index register inst 124 | 125 | :SX 6800; ( -- 6800) gen: () 126 | 6800 is basis of 1130 Store index reg inst 127 | 128 | :MX 7000; ( -- 7000) gen: () 129 | 7000 with an IX specified is basis of 1130 Modify index reg inst 130 | 131 | :B 7000; ( -- 7000) gen: () 132 | 7000 with 0 IX specifiedis an 1130 short Branch inst 133 | 134 | :BL 4800; ( -- 4800) gen: () 135 | 4800 is basis of 1130 Branch long inst 136 | 137 | :BSI 4000; ( -- 7=4000) gen: () 138 | 4000 is basis of 1130 Branch and Store IAR (branch to subroutine) inst 139 | 140 | :XIO 800; ( -- 0800) gen: () 141 | 0800 is basis 1130 XIO (execute I/O) inst 142 | 143 | :X1 1000 OR; (n1 -- n1 OR 1000) gen: () 144 | OR by 1000 adds value 01 to the index register field bits 6 and 7 145 | thus it means IX1 is part of address computation of the instruction 146 | 147 | :X2 200 OR; (n1 -- n1 OR 2000) gen: () 148 | OR by 2000 adds value 10 to the index register field bits 6 and 7 IX2 149 | 150 | :X3 300 OR; (n1 -- n1 OR 3000) gen: () 151 | OR by 3000 adds value 11 to the index register field bits 6 and 7 IX3 152 | 153 | :MDM 7400 INST DEPOSIT; (n1 n2 -- ) gen: (7400 OR n2, n1) 154 | 7400 is the basis for a modify memory (long MDX with no register) 155 | Add/sub the displacement to a memory location. Entered with address 156 | of the memory location on stack, pushes MDM to variable then address 157 | 158 | :ZERO 1810 DEPOSIT; ( -- ) gen: (1810) 159 | 1810 is an 1130 shift right arithmetic 16 bits (clears word) 160 | 161 | :XCH 18D0 DEPOSIT; ( -- ) gen: (18D0) 162 | 18D0 is an 1130 rotate acc and ext 16 bits (exchange ACC and EXT contents) 163 | 164 | :I 480 INST DEPOSIT; (n1 n2 -- ) gen: (n2 OR 0480, n1) 165 | 0480 added to 1130 instruction sets long field (bit 5) and 166 | indirect address flag (bit 8), saves top of stack as address 167 | after saving indirect instruction. 168 | 169 | :L 400 INST; (n1 -- ) gen: (n1 OR 0400) 170 | 0400 added to 1130 instruction sets long field (bit 5) to indicate 171 | 32 bit instruction 172 | 173 | :LONG L DEPOSIT; (n1 n2 -- ) gen: (n2 OR 0400, n1) 174 | make an instruction long and stick in variable dictionary entry 175 | then stick top of stack (an address) in variable entry 176 | 177 | :STORE ST LONG; (n1 -- ) gen: (D400, n1) 178 | sticks a Store Accumulator long instruction in variable dictionary entry 179 | plus address is top of stack goes to variable entry 180 | 181 | :LOAD LD LONG; (n1 -- ) gen: (C400, n1) 182 | sticks a Load Accumulator long instruction in variable dictionary entry 183 | plus address is top of stack goes to variable entry 184 | 185 | :CALL BSI LONG; (n1 -- ) gen: (4400, n1) 186 | sticks a BSI long instruction in variable dictionary entry 187 | plus address in top of stack goes to variable entry 188 | 189 | :ACC 1 B INST DEPOSIT FE INST; (n1 n2 -- ) gen: (7001, n2, instruction OR n1) 190 | 1130 branch over next word put in variable dictionary entry, 191 | deposit first stack value as a constant into variable dictionary entry, 192 | then take stack-1 word as the beginning of an instruction, 193 | OR it with pattern 00FE to make it a short inst referencing 194 | our stored constant and deposit both into the dictionary entry 195 | Essentially puts a constant inline for use with an instruction on stack 196 | 197 | :GDEP IC 1 MDM IC ST I; ( -- ) gen: (7401, IC, D480, IC) bumps IC and stores ACC to new loc 198 | update IC (variable directory pointer) to next cell, 199 | create inst to bump the contents of that pointer by 1, 200 | then deposits the current accumulator content into new location 201 | 202 | 203 | :GOR E800; ( -- E800) gen: () 204 | 1130 logical OR 205 | 206 | :GAND E000; ( -- E000) gen: () 207 | 1130 logical AND 208 | 209 | :GWAIT 3000 DEPOSIT; ( -- ) gen: (3000) 210 | 1130 Wait (halt) instruction 211 | 212 | :REL X3 LONG; (n1 n2 -- ) gen: (n2 OR 0700, n1) 213 | make instruction on stack long and using IX3 214 | 215 | :RELS X3 INST; (n -- ) gen: (n OR 0300) 216 | make instruction short and using IX3 217 | 218 | :BASE LX REL; (n -- ) gen: (6700, n) 219 | Load IX register 3 (long instruction) with next word 220 | 221 | :BASA 1 ST INST 0 BASE; ( -- ) gen: (D001, 6700, hole) 222 | Store accumulator in next word of variable dictionary, 223 | deposit instruction to load IX 3 from that address 224 | 225 | :TOD 1880 INST; ( -- ) gen: (1880) 226 | shift right acc and ext arithmetic (sign bit stays untouched) 227 | 228 | :TOM 1000 INST; ( -- ) gen: (1000) 229 | shift left accumulator instruction 230 | 231 | :TXD 1880 INST; ( -- ) gen: (1880) 232 | shift right ACC and EXT arithmetically (sign stays untouched) 233 | presumably these will use IX for shift count (be ORed with IX code) 234 | 235 | :TXM 1080 INST; ( -- ) gen: (1080) 236 | shift left accum + extension instruction 237 | 238 | :TAD 1800 INST; ( -- ) gen: (1800) 239 | Shift right accumulator logical (sign bit moves too) 240 | 241 | :ZF 10A0 DEPOSIT; ( -- ) gen: (10A0) 242 | shift left ACC plus EXT 32 (zero out) 243 | 244 | :LF ZF LOAD: ( -- ) gen: (10A0, C400, IC) 245 | zero out ACC and EXT, 246 | load current position in variable dictionary (IC) 247 | 248 | :FS X2 INST; (n -- ) gen: (n OR 0200) 249 | Stores an instruction modified to use Index Register 2 (stack pointer) 250 | 251 | :LS LD FS; (n -- ) gen: (C200 OR n) 252 | Load Stack - does a Load instruction w/ IX2 253 | 254 | :SS ST FS; (n -- ) gen: (D200 OR n) 255 | Store stack - stores accumulator in stack (using IX2) 256 | 257 | :LSI LD X2 I; (n -- ) gen: (C680, n) 258 | Load indirect pointed to by stack (e.g. get value of address on stack) 259 | 260 | :SSI ST X2 I; (n -- ) gen: (D680, n) 261 | Store indirect pointed to by stack 262 | 263 | :MS MX FS; (n -- ) gen: (6200 OR n) 264 | Modify the IX2 (stack pointer), should be ORed with displacement from stack 265 | 266 | :RETURN BL I; (n -- ) gen: (4C80, n) 267 | 1130 return from subroutine (Branch Long Indirect) 268 | 269 | 270 | ---------------------------------------------------- 271 | THE SECTION BELOW CREATES MAJOR FORTH OPERATORS in 1130 code 272 | ---------------------------------------------------- 273 | ¢ CONSTANT E1 LX X3 I LD LOC LIT ACC 274 | 2 ST X3 INST 0 LS 3 ST X3 INST RETURN (n -- ) var: ( 6780, E1, 7001, 275 | execaddr(LITER), C0FE, D302, 276 | C203, D303, 4C80, return) 277 | Load IX3 Indirect with address of last used entry in fixed dictionary (E1) 278 | Look up execution address of LIT and load accumulator 279 | store this in word 2 of fixed dictionary entry 280 | load cell at top of stack (value of constant to save) == n 281 | store this in word 3 of fixed dictionary entry 282 | This will define a name and at execution stick the constant n on the stack 283 | 284 | ¢ REVERT E LOAD E1 STORE E1 FC MDM RETURN ( -- ) var: (C400, E, D400 E1, 74FC, E1, 4C80, return) 285 | load address of next free entry into accumulator, 286 | store it as the last used address E1, 287 | decrement last used entry address by 4 288 | regenerates the last used entry properly based on next free address 289 | 290 | ¢ TOP E1 LOAD E STORE E 4 MDM RETURN ( -- ) var: (C400, E1, D400, E, 7404, E, 4C80, return) 291 | load last used entry into accumulator 292 | store it as the next free space 293 | bump up next free space by one entry 294 | regenerates the next free entry properly based on last used address 295 | 296 | ¢ DUP 0 LS 1 MS 0 SS RETURN (n1 -- n1 n1) var: (C200, 7201, D200, 4C80, return) 297 | duplicate the value at top of stack. load top stack word to acc 298 | bump stack pointer up by 1 and 299 | store the acc into stack 300 | 301 | ¢ VALUE 0 LSI 0 SS RETURN (n -- contents(n)) var: (C680, n, D200, 4C80, return) 302 | load value pointed to by addr at top of stack using Load Indirect 303 | store in stack replacing address 304 | 305 | ¢ DROP FF MS RETURN (n -- ) var: (72FF, 4C80, return) 306 | drop top item from stack by decrementing stack pointer by 1 307 | 308 | ¢ RAISE 1 MS RETURN ( -- x) var: (7201, 4C80, return) 309 | bump stack pointer by 1 to leave a hole and return to caller 310 | 311 | ¢ SWAP 0 LS XCH FF LS 0 SS XCH FF SS RETURN (n1 n2 -- n2 n1) var: (C200, 18D0, C2FF, 312 | D200, 18D0, D2FF, 4C80, return) 313 | swap top two words in stack. load top of stack to accumulator 314 | rotate it to extension, load stack-1 to acc, store to stack, 315 | rotate ext back to acc, store to stack - 1 316 | 317 | :MSI LD SWAP ACC DUP ADD FS SS; (n1 n2 -- stack+n1 + n2) gen: (7001, n2, C0FE, 82n1, D2n1) 318 | Entered with two values on the stack (A and B) 319 | Load instuction, swapped to stack-1, 320 | A value saved inline and used with LD instruction. 321 | adds stack + B to the accumulator 322 | stores result at stack + B (updates that position) 323 | 324 | ¢ + 0 LS FF MS 0 ADD FS 0 SS RETURN (n1 n2 -- n1+n2) var: (C200, 72FF, 8200, 325 | D200, 4C80, return) 326 | load top of stack, decrement stack pointer, add new top of stack 327 | store result in new top of stack 328 | add top two words and leave result at top of stack 329 | 330 | ¢ AND 0 LS FF MS 0 E000 FS 0 SS RETURN (n1 n2 -- n1 AND n2) var: (C200, 72FF, E200, 331 | D200, 4C80, return) 332 | and top two words and leave result at top of stack 333 | 334 | :DISP FF AND; (n -- low 8 bits of n) gen: (E0FF) 335 | Disp will AND off top half of cell on stack to get displacement of short instruction 336 | 337 | ¢ - FF MS 0 LS 1 SUB FS 0 SS RETURN (n1 n2 -- n2-n1) var: (72FF, C200, 9201, 338 | D200, 4C80, return) 339 | subtract top two words and leave result at top of stack 340 | 341 | ¢ MINUS ZERO 0 SUB FS 0 SS RETURN (n -- -n) var: (1810, 9200, D200, 4C80, return) 342 | zero out accumulator, subtract top of stack and store result 343 | 344 | ¢ / FF LS 1890 DEPOSIT 0 DIV FS FF SS XCH 0 SS RETURN (n1 n2 -- n2/n1) var: (C2FF, 1890, A800, 345 | D2FF, 18D0, D200, 4C80, return) 346 | divide top two words and leave result at top of stack 347 | 348 | ¢ * FF LS 0 MUL FS XCH FF MS 0 SS RETURN (n1 n2 -- n1*n2) var: (C2FF, A000, 1890, 72FF, 349 | D200, 4C80, return) 350 | multiply top two words and leave result at top of stack 351 | 352 | ¢ PUSH 0 LSI ADD 1 ACC 0 SSI 0 SS FF LS 0 SSI 353 | FE MS RETURN (n1 n2 -- ) var: (C680, 0000, 7001, 0001, 354 | 80FE, D680, 0000, D200, C2FF, 355 | D680, 0000, 72FE, 4C80, return) 356 | load value from address at top of stack (n2) to accumulator 357 | e.g. n2 is a pointer to head of user stack 358 | add 1 to the value in accumulator (advanced stack pointer) 359 | store result in location whose address is top of stack 360 | store also in stack+0 replacing original value of n2 361 | load stack - 1 (n1) 362 | store into location whose address is on stack one past original n2 363 | remove two items from stack 364 | top of stack is n2, a pointer to the user stack 365 | this bumps user pointer and stores n1 into the new location 366 | 367 | ¢ PULL 0 LSI 1 SS SUB 1 ACC 0 SSI 1 LSI 0 SS RETURN (n -- contents(n-1), contents(n)) 368 | var: (C680, 0000, D201, 369 | 7001, 0001, 90FE, 370 | D680, 0000, C680, 371 | 0001, D200, 4C80, return) 372 | loads value in address n2 from stack (stack pointer) 373 | stores in stack + 1 (beyond top of stack) 374 | subtract 1 from accumulator (lowers user stack pointer value) 375 | store new stack pointer value in address n2 376 | pick up next value from user stack +1 377 | store in top of stack 378 | this grabs n1 from stack, lowers pointer by 1 379 | has side effect of old value in stack+1 380 | 381 | :STACK 1 MS LOAD 0 SS; (n1 -- n1 n1) gen: (7201, C400, n, D200) 382 | bump stack pointer, load original top of stack and store in new position 383 | this is same as a DUP but not a callable routine, instead inline 384 | 385 | :LITS LD SWAP ACC 1 MS 0 SS; (n1 -- n1 contents(n1)) gen: (7001, n, C0FE, 7201, D200 ) 386 | load address n1 into accumulator, 387 | set up load instruction C000 388 | swap so stack is address n1 then c000 389 | stick address n as constant and load the contents (7001 n C0FE) 390 | bump top of stack 391 | store value of address n1 into new top of stack 392 | like VALUE but not callable, inline instead 393 | ¢ VECTOR 0 LS GDEP IC STACK LOC CONSTANT CALL 394 | FF ADD FS IC STORE FE MS RETURN (n -- ) var: (C200, 7401, IC, D480, IC, 395 | make space for the number of entries 7201, C400, IC, D200, 396 | load top of stack to accumulator 4400, CONSTANT, 82FF, 397 | bump up IC by one and save n on stack D400, IC, 72FE, 4C80, return) 398 | find execution address of CONSTANT 399 | call CONSTANT to convert addr to value 400 | add n to IC and store into IC, pull 2 from stack 401 | When executed, it pushes the current IC onto variable 402 | dictionary entry then reserves n cells by bumping IC 403 | 404 | :XS 4 VECTOR; ( -- ) gen: () 405 | define XS as a four deep vector. 406 | 407 | XS XS XS= ( -- ) var (address of XS, 0000, 0000, 0000, 0000) 408 | create one XS vector 409 | 410 | :TRANSIENT IC INC XS PUSH; ( -- ) gen: () 411 | get address of current variable entry, bump by 1, 412 | push this value into the XS stack 413 | this sets up temp code into XS stack to be executed 414 | 415 | ¢ EXECUTE LD BL 480 OR ACC GDEP XS LD I GDEP ( -- ) var: (7001, 4C80, C0FE, 7401, 0D83, 416 | XS LX X3 I 0 BSI X3 I XS LITS LOC PULL CALL D480, 0D83, C480, XS, 7401, 0D83, 417 | SUB 1 ACC IC STORE FF MS RETURN D480, 0D83, 6780, XS, 4780, 0000, 418 | as this executes, it pushes 7001, XS, C0FE, 7201, D200, 419 | 4C80 in variable dictionary, 4400, PULL, 7001, 0001, 90FE, 420 | loads address of XS vector D400, IC, 72FF, 4C80, return) 421 | stores that in variable dictionary 422 | loads IX3 with first word of XS 423 | Calls routine pointed to by IX3 424 | loads XS to accumlator 425 | bump stack and store XS there 426 | Calls PULL routine 427 | Subtracts 1 from accumulator 428 | Store as IC 429 | drop top of parameter stack 430 | This will execute routine at top of XS stack 431 | then pull from XS stack 432 | 433 | 434 | :BACK IC VALUE - DISP B INST; (n -- ) gen: (B relative IC - n) 435 | stick address of IC on stack, replace with contents 436 | subtract that from n which is stack-1 437 | AND with 00FF to get 8 bit signed integer 438 | OR together 7000 (Branch) and displacement, 439 | stick this branch relative on variable dictionary 440 | 441 | :MARK IC VALUE SWAP LX X3 INST; (n -- IC of LX instruction) gen: (7201, 63nn) 442 | push IC address on stack, replace with contents 443 | swap n and IC contents - stack now IC, n 444 | builds LX 6000, IX3, and n 445 | push that 63nn instruction to variable dictionary 446 | This updates IC to point to next free location 447 | and loads IX3 with a count (n) 448 | 449 | :LOOP FF MX X3 INST BACK; ( -- ) gen: (73FF, B relative to marked instruction) 450 | modify IX3 as loop counter 451 | branch back unless it becomes 452 | zero or neg, then skip branch 453 | and branch back to last IC address 454 | 455 | :START 2 B INST DEPOSIT IC INC (n -- ) gen: (7201, 7002, n, C0FE, C0FD, D0FD) 456 | FD LD INST FD ST INST; ???? 457 | Branch over next two cells in variable dictionary 458 | save top of stack in variable dictionary as one word 459 | second word is empty 460 | increment IC value, Load first word in accumulator 461 | Store into second word of the entry 462 | 463 | :STOP DUP FF MDM 1+ BACK; (n -- ) gen: (74FF, n, 70back to ) 464 | duplicate top of stack, decrement that address, 465 | add 1 to the duplicated value and branch back 466 | 467 | 468 | :CONDITION 0 LS FF MS BSI OR L LOC NEXT DEPOSIT RETURN; (n1 n2 -- ) gen: (7201, C200, 72FF, 469 | 44nn, NEXT, 4C80, return) 470 | builds up and executes a branch conditional, which will call NEXT 471 | to fetch another word if condition is matched 472 | 473 | ¢ NONZERO 18 CONDITION (n -- ) var: (7201, C200, 72FF, 4418, NEXT, 4C80, return) 474 | branch conditional flags for nonzero test 475 | 476 | ¢ FALSE 20 CONDITION (n -- ) var: (7201, C200, 72FF, 4420, NEXT, 4C80, return) 477 | branch conditional flags for notequal test 478 | 479 | ¢ EVEN 04 CONDITION (n -- ) var: (7201, C200, 72FF, 4404, NEXT, 4C80, return) 480 | branch conditional flags for even test 481 | 482 | :IF BL 400 OR INST IC INC; (n -- ) gen: (4Cnn, IC+1) 483 | uses top of stack as condition for branch conditional long, 484 | branch is to next logic instruction on variable dictionary 485 | 486 | :THEN IC VALUE 1+ SWAP=; (n -- ) gen: () 487 | gets value of current IC, bumps by 1, swaps with TOS n 488 | and stores that word in new IC location 489 | 490 | :ELSE IC VALUE 3+ SWAP= 0 IF; (n -- ) gen: () 491 | get value of current IC, bump by 3, swap and store n there 492 | set condition of 0 in stack and implement IF 493 | 494 | :POSITIVE 8; ( -- 9) gen: () 495 | 496 | :NEGATIVE 10; ( -- 10) gen: () 497 | 498 | :EQUAL 20; ( -- 20) gen: () 499 | 500 | :NOT 18; ( -- 18) var: () 501 | 502 | :PROGRAM 1 B INST 0 DEPOSIT; ( -- ) var: (7001, 0) 503 | Stick in a branch over next word 504 | 505 | 506 | ¢ QUEUE 1- PROGRAM GWAIT BACK ( -- ) var: (0000, 7001, 0929, 3000, 70FC) 507 | branch over saved word unless this op code is altered 508 | issue 1130 WAIT instruction 509 | loop back to wait again 510 | caller ENQUEUE will update the word 0000 to be an address and word 1 as an instruction 511 | I suspect that the 0929 was pushed in by a caller to ENQUEUE 512 | 513 | :ENQUEUE LOAD LOC QUEUE 2+ STORE (n -- ) var: (C400, n, D400, queue+2, 7001, 7001, C0FE, 514 | LD 1 B OR ACC LOC QUEUE 1+ STORE LOC QUEUE 1+ BL LONG; D400, queue+1, 4C00, queue+1, 4C80, return ) 515 | picks up address n from stack and loads its contents 516 | store content of address in QUEUE word 2 517 | load 7001 (B 1 instruction) 518 | store in QUEUE word 1 519 | Branch to QUEUE, then return 520 | 521 | :REACTIVATE LD BL 400 OR ACC LOC QUEUE 1+ STORE; ( -- ) var: (7001, 4C00, C0FE, D400, queue+1) 522 | will plug a branch long into word 1 of queue, causing a branch to 523 | the address that was previously stored in word 2 of queue by ENQUEUE 524 | 525 | :BNZ BL 20 OR; ( -- 4820) var: () 526 | sets up the first word of a branch long instruction with condition 20 527 | 528 | :BUFFER DUP DUP DUP DUP VALUE 2/ DROP+ 2+ (n -- ) var: () 529 | SWAP 1+= 2+ SWAP=; 530 | is passed an address of a buffer which has a length in n - characters, 2X words 531 | This will get the address from the first word and fetch its value 532 | divide length by 2 to get words, then add 2 to form the address of tne next line 533 | That address of the next line is stored in n+1 location then n is 534 | updated to point to n+2 (skipping over the pointer to next line) 535 | this would be used to manage lines in a disk buffer 536 | 537 | ¢ EXCHANGE 0 LS ADD 1 ACC 1 SS 0 LSI (n -- ) var: (0000, C200, 7001, 0001, 80FE, D200, 538 | XCH 1 LSI 0 SSI XCH 1 SSI FF MS RETURN C680, 0000, 18D0, C680, 0001, 539 | D680, 0000, 18D0, D680, 0001, 72FF, 4C80, return) 540 | passed in an address on stack, will bump up n by 1 and save it at stack + 1 (temp) 541 | then swaps the two values at stack and stack+1 542 | finally, drops original value from stack and returns 543 | Pass address of two word area and swap the values in those locations. 544 | 545 | 546 | 547 | :CLEAR LOAD 4840 I; (n1 n2 -- ) var: (C400, n2, 4CC0, n1) 548 | will produce code on variable dictionary stack to load the value at address n2 549 | and BOSC back to n1 (BOSC resets any pending interrupts) 550 | 551 | :NOP B DEPOSIT; ( -- ) var: (7000) 552 | produces a NOP on the variable dictionary stack 553 | 554 | 555 | :ALIGN IC VALUE EVEN NOP; ( -- ) var: (either 7000 or nothing) 556 | fetches IC address then its value (next location in variable dictionary) 557 | does an even condition, e.g if the value is even, gobble up next word 558 | before it is processed. Thus, if odd, NOP is interpreted 559 | 560 | :GXIO ALIGN 1 XIO INST 2 B INST DEPOSIT DEPOSIT; (n1 n2 -- ) var: (align with 7000 if needed, 561 | First aligns to an even (doubleword) address 0801, 7002, n2, n1) 562 | the issues XIO pointing at two words on stack 563 | which are the IOCC, then branch over the IOCC 564 | 565 | :WTC 1+ 2*; (n -- 2*(n+1)) var: () 566 | calculates (n+1)*2 and leaves on stack 567 | converts word address to pseudo character address (2x real address) 568 | used with verbs that access packed character fields 569 | 570 | ¢ FILL 0 LS FF MS 1 ST INST 0 START LOC NEXT CALL (n -- ) var: (0000, C200, 72FF, D001, 571 | LOC HEX CALL 0 LS GDEP FF MS STOP RETURN 7002, 0040, 0000 (target), 572 | C0FD, D0FD, 4400, next, 573 | 4400, hex, C200, 574 | 7401, IC, D480, IC, 72FF, 575 | 74FF, target, 70F3, 4C80, return) 576 | removes n from stack, stores it as starting count 577 | loads 0040 (template) but actually n2 and stores it in target variable 578 | grabs next word from stream 579 | makes it a hex constant on stack 580 | load that constant from stack, bump IC, 581 | stick on variable dictionary, drop from stack, 582 | decrement target and loop until it hits zero then return 583 | 584 | :DATA IC VALUE 1+ CONSTANT DROP; ( -- ) var: () 585 | this is an odd duck. it picks up the address of the next entry 586 | of the variable dictionary (value of IC), bumps it, saves that 587 | in stack + 1 but does not increment stack thus it is invisible 588 | 589 | :CSKB 40 DATA FILL 2000 1000 800 400 200 100 80 40 20 10 ( -- ) gen: (call FILL to set up 64 char table) 590 | 9000 8800 8400 8200 8100 8080 8040 8020 8010 5000 4800 4400 4200 4100 591 | 4080 4040 4020 4010 2800 2400 2200 2100 2080 2040 2020 2010 0000 592 | 8820 0420 8220 8120 80A0 8060 8000 4820 4420 4220 4120 40A0 4060 593 | 4000 3000 2420 2220 2120 20A0 2060 0820 8420 0220 0120 00A0 0060 594 | 0000; 595 | 596 | CSKB ( -- ) var: (Data area CSKB with these values) 597 | This is a table of hollerith code constants, with rows 12, 11, 0 then 1 to 9 598 | left justified in each word. The relative position corresponds to Forth code, 599 | for example the letter A is the value x0A in FORTH code, the tenth entry 600 | here, 9000, which signifies a 12 and a 1 punch 601 | 602 | :CSCP 40 DATA FILL C400 FC00 D800 DC00 F000 F400 D000 D400 E400 E000 ( -- ) gen: (call FILL to set 603 | 3C00 1800 1C00 3000 3400 1000 1400 2400 2000 7C00 5800 5C00 7000 up 64 char table) 604 | 7400 5000 5400 6400 6000 9800 9C00 B000 B400 9000 9400 A400 A000 605 | 2100 0200 C000 DE00 FE00 DA00 C600 4400 4200 4000 D600 F600 D200 606 | F200 8400 BC00 8000 0600 BD00 4600 8600 8200 0000 0400 E600 C200 607 | E200 8600; 608 | 609 | CSCP ( -- ) gen: (data area CSCP with these values 610 | This is a table of Selectric PTTC/8 constants, 8 bits left justified 611 | The relative position corresponds to Forth code, 612 | for example the letter A is the value x0A in FORTH code, the tenth entry 613 | here, 3C00, causes the typeball to tilt and rotate to type an A 614 | 615 | :A 2 VECTOR; ( -- ) gen: (size cell plus 2 cells) 616 | 617 | A ( -- ) var: (2 word vector stored in variable 618 | dictionary under name A) 619 | 620 | :RESTORE A 2+ STORE 0F01 0 GXIO; ( -- ) gen: (D400, A(2), optional NOP, 0801, 7002, 0000, 0F01) 621 | This will store the accumulator contents in the second word of vector A, then 622 | builds code to issue an XIO instruction with IOCC 0000 0F01 which clears status of console 623 | 624 | :CONTINUE A 2+ CLEAR; (n -- ) gen: (C400, A(2), 4CC0, n) 625 | This will load word 2 of vector A into the accumulator 626 | then will branch indirect (return) to address in n, with the interrupt 627 | level clear bit on. This is the normal return from an interrupt handle 628 | 629 | ¢ READY RESTORE REACTIVATE CONTINUE (n -- ) var: (D400, A(2), optional NOP, 0801, 630 | 7002, 0000, 0F01, 7001, 4C00, C0FE, 631 | D400, queue+1, C400, A(2), 4CC0, n) 632 | saves accumulator in word 2 of vector A, clear the console, 633 | clear out the QUEUE, reload the saved accumulator and BOSC back 634 | 635 | :CHA A 1+ STORE 0900 A 1+ GXIO LD LOC READY ACC 0C STORE, ( -- ) gen: (D400, A(1), optional NOP, 636 | 0801, 7002, A(1), 0900, 637 | 7001, ready, C0FE, D400, 000C) 638 | store accumulator in first word of vector A, 639 | issue XIO to type character in address in A(1) to console printer 640 | look up address of READY verb and load it to accumulator 641 | then set it up as interrupt level handler for IL4 642 | thus READY is the IL4 interrupt handler during typing 643 | this should be called and then pause FORTH with ENQUEUE 644 | 645 | 646 | ¢ CHARACTER RESTORE 0A00 A 1+ GXIO A 1+ LOAD ( -- ) var: (0000, D400, A(2), 647 | ST X1 DEPOSIT LOC CONVERT CALL CSCP LD REL CHA CONTINUE optional NOP, 0801, 7002, 0000, 0F01, 0801, 7002, A(1), 0A00, 648 | C400, A(1), D100, 4400, conve, 649 | C700, CSCP, D400, A(1), 650 | optional NOP, 0801, 7002, 651 | A(1), 0900, 7001, ready, 652 | C0FE, D400, 000C, 653 | C400, A(2), 4CC0, return) 654 | this routine processes each character as it is keyed on console 655 | acting as the IL4 interrupt handler after a console read has been issued 656 | the system should be waiting with ENQUEUE for this 657 | 658 | ¢ ACCEPT LD LOC CHARACTER ACC 0C STORE 0C00 0 GXIO ENQUEUE ( -- ) var: (0000, 7001, character, C0FE, 659 | D400, 000C, optional NOP, 0801, 660 | 7002, 0000, 0C00, C400, accept, 661 | D400, queue+2, 7001, 7001, C0FE, 662 | D400, queue+1, 4C00, queue+1) 663 | load the address of CHARACTER, the IL4 interrupt level routine 664 | then store it in 000C to make it active. Issue a read on the 665 | console keyboard and wait for completion 666 | 667 | 668 | ¢ CONSOLE LD CSKB 3F+ ACC FF ST X1 INST LD LOC ACCEPT ACC ( -- ) var: (0000, 7001, CSKB+3F, C0FE, 669 | FE ST X1 INST RETURN D1FF, 7001, accept, COFE, 670 | D1FE, 4C80, return) 671 | load address of the end of the keyboard translation table into accumulator 672 | store in work area -1 (character table). load the address of ACCEPT 673 | routine and store in work area -2 (accept). return to caller 674 | this sets up the parser to read and convert from the console 675 | 676 | ¢ TYP CHA ENQUEUE ( -- ) var: (0000, D400, A(1), optional NOP, 0801, 677 | 7002, A(1), 0900, 7001, ready, C0FE, 678 | D400, 000C, 7001, typ, C0FE, 679 | D400, queue+2, 7001, 7001, C0FE, 680 | D400, queue+1, 4C00, queue+1) 681 | takes word in accumulator and types to console, waiting until it is done 682 | 683 | :RED 900; ( -- 0900) gen: () 684 | stores in stack character code to shift the console printer to red ribbon 685 | 686 | :BLACK 500; ( -- 0500) gen: () 687 | stores in stack character code to shift the console printer to black ribbon 688 | 689 | ¢ RIBBON 0 LS FF MS LOC TYP CALL LD 8100 ACC (n -- ) var: (0000, C200, 72FF, 4400, typ, 690 | LOC TYP CALL RETURN 7001, 8100, C0FE, 4400, typ, 691 | 4C80, return) 692 | loads the top of stack as a selectric typewriter code and calls TYP to output it, 693 | then sets up selectric code for CR and calls TYP to output it 694 | 695 | ¢ TYPE (n1 n2 -- ) var: (0000, C200, D001, 7002, 0008 (init), 696 | 0 LS 1 ST INST 0 START FF LS LOC FETCH CALL 0000 (index), C0FD, D0FD, C2FF (loop), 697 | BASA SUB 3F ACC POSITIVE IF 3F BASE THEN 4400, fetch, D001, 6700, 000E, 698 | CSCP LD REL LOC TYP CALL FF 1 MSI STOP FE MS RETURN 7001, 003F, 90FE, 4C08, skip, 6700, 699 | 003F, C700 (skip), cscp, 4400, typ, 700 | 7001, 0001, C0FE, 82FF, D2FF, 701 | 74FF, index, 70E7 (B to loop), 702 | 72FE, 4C80, return) 703 | Call with memory location and length in stack, will type out the contents as characters 704 | load top of stack n2, update init location, set index to initial value (0008 replaced by TOS) 705 | load n1, call fetch routine store over 000E, load IX3 with result of fetch, 706 | subtract 003F. If positive, load IX3 with 003F, then load CSCP + IX3, 707 | call typ to type the character, load 1, add n1, store as n1, reduce index by 1, 708 | return to loop again. Once index goes to zero, drop two stack values and return 709 | 710 | :MESSAGE BLACK RIBBON TYPE RED RIBBON; (n1 n2 -- ) gen: () 711 | will set ribbon to black, do CR, type characters from n1 for length n2 712 | then set ribbon to red and do another CR 713 | 714 | :ALPHA 14 VECTOR; ( -- ) gen: (load 14 instack and execute VECTOR) 715 | 716 | ALPHA ( -- ) var: (instantiate vector ALPHA, 0008 + 14 cells) 717 | 718 | :REPLY ALPHA WTC ALPHA VALUE MESSAGE; ( -- ) gen: () 719 | converts address of alpha from word to character (2x) and put on stack 720 | sticks size of alpha on stack 721 | calls message 722 | 723 | :D 3 VECTOR; ( -- ) gen: (load 3 in stack and call VECTOR) 724 | 725 | D ( -- ) var: (instantiate D as 0003 and 3 cells) 726 | D(1) holds current track number 727 | 728 | :QUERY 8F01 0 GXIO; ( -- ) gen: (optional NOP, 0801, 7002, 0, 8F01) 729 | does an XIO to fetch disk2 status (DSK1 of simulator) and reset conditions 730 | 731 | ¢ DONE D STORE QUERY REACTIVATE D CLEAR ( -- ) var: (0000, D400, D, optional NOP, 0801, 732 | 7002, 0000, 8F01, 7001, 4C00, C0FE, 733 | D400, query+1, C400, D, 4CC0, return) 734 | This is the interrupt handler that saves and restores the accumulator in D 735 | then reads and resets disk status, restores the queue and does a BOSC out of interrupt 736 | 737 | ¢ HOME ZERO D 1+ ST LONG QUERY GAND 0800 ACC ( -- ) var: (0000, 1810, D400, D(1), optional NOP, 0801, 738 | DUP BNZ I 8C04 C8 GXIO ENQUEUE 7002, 0000, 8F01, 7001, 0800, E0FE, 739 | 4CA0, return, optional NOP, 0801, 740 | 7002, 00C8, 8C04, C400, home, 741 | D400, query+2, 7001, 7001, C0FE, 742 | D400, query+1, 4C00, query+1) 743 | This zeroes the accumulator, tests the status of disk 2 (DSK1 in simulator) 744 | verifies bit 4 (carriage home) to test if the drive is at track 0 already 745 | if not, it issues a seek backwards to ensure it is at the home location 746 | sticking the address of this routine in the queue and lets it wait until 747 | the disk command finishes 748 | 749 | 750 | :IN 154 VECTOR; ( -- ) gen: (sticks 154 on stack and calls VECTOR) 751 | 752 | IN 141 IN= ( -- ) var: (instantiates IN as 154 cell vector, the 753 | stores 141 in the first cell 754 | 755 | :BZ BL 18 OR; ( -- 4818) gen: () 756 | produces a branch long condition (branch on zero) into stack 757 | 758 | :M LD; ( -- C000) gen: () 759 | produces a load instruction into stack 760 | 761 | :CS MS; ( -- 7200) gen: () 762 | produces a modify stack (MDX IX2 into stack 763 | 764 | :ZLT ZERO; ( -- ) gen: (1810) 765 | produces a shift left A+E 32 instruction (zeroes ACC and EXT) into variable dictionary 766 | 767 | :TS SS; (n -- ) gen: (D2nn) 768 | produces a store stack STO IX2 instruction into variable dictionary 769 | 770 | :TM STORE; (n -- ) gen: (D400, n) 771 | produces a store long instruction onto variable dictionary entry 772 | 773 | :TR ST INST; (n -- ) gen: (D0nn) 774 | produces a store instruction relative n onto variable dictionary 775 | 776 | :TA ST REL; (n -- ) gen: (D700, n) 777 | produces a store instruction to IX3 plus n, put onto variable dictionary 778 | 779 | :ST FS; (n1 n2 -- ) gen: (n1 OR 0200, n2) 780 | produces an instruction of type n1 to address n2 using IX2 onto variable dictionary 781 | 782 | :MT LONG; (n1, n2 -- ) gen: (n2 OR 0400, n1) 783 | produces a long instruction of type n2, address n1, onto variable dictionary 784 | 785 | :RT INST; (n1 n2 -- ) gen: (n1 OR n2) 786 | produces an n1 instruction with relative displacement n2 onto variable dictionary 787 | 788 | :AT REL; (n1 n2 -- ) gen: (n2 OR 0700, n1) 789 | produces a long instruction using IX3 onto variable dictionary 790 | 791 | :LT SWAP ACC; (n1 n2 -- ) gen: (7001, n1, n2FE) 792 | This will apply an n2 instruction against the constant n1 793 | 794 | :FIXUP 6 M RT 3 TAD 3 TXM 3 TR; ( -- ) gen: (C006, 1803, 1083, D003) 795 | this will be part of the next verb, where it grabs a 796 | value later in the verb entry, clears the top and bottom 797 | two bits and replaces the value it had fetched 798 | 799 | ¢ CYLINDER 3 TOD 2 TS D 1+ SUB MT DUP BZ I (n -- ) var: (0000, 1883, D202, 9400, D(1), 4C98, return, 800 | POSITIVE IF 3 TOM 3 TXD 4C08, else, 1003 (if), 1883, 4C00, then, 801 | ELSE 1 TS 10 TXD ZLT 1 SUB ST D201 (else), 1890, 1810, 9201, 802 | THEN ALIGN NOP 6 TR 7000 (then), 7000, D006, C006, 803 | FIXUP 8C00 0 GXIO 2 M ST D 1+ TM 1803, 1083, D003, 0801, 7002, 804 | 8 M LT D 2+ TM ENQUEUE 0000, 8C00, C202, D400, D(1), 7001, 0008, 805 | C0FE, D400, D(2), C400, cylinder, D400, 806 | queue+2, 7001, 7001, C0FE, D400, queue+1, 807 | 4C00, queue+1 808 | shift accumultor contents right 3, converting sector to cylinder, store in stack+2, 809 | this was called from SECTOR who has sector number n at top of stack, so 810 | this temporarily uses stack+1 and stack+2 as work areas 811 | subtract D(1), return if not positive (think this is a limit check, 2E0 or higher sector) 812 | if not positive, go to else 813 | if positive, Shift ACC left 3, shift ACC+E right 3, go to then 814 | else - store stack+1, swap, zero acc, subtract stack+1, go to then 815 | then - store in location IOCC word 1, the number of cylinders 816 | load from IOCC word 2 (command), shift both right 3 and left both 3 817 | store as command word, XIO with newly created seek IOCC, 818 | load stack+2, store in D(1) which I believe is current track 819 | load 0008 and store in D(2), stick cylinder and 7001 in queue 820 | to wait until the seek I/O completes 821 | 822 | 823 | 824 | ¢ SECTOR 0 M ST LOC CYLINDER CALL 0 M ST FF CS (n -- ) var: (0000, C200, 4400, cylinder, C200, 72FF, 825 | 7 GAND LT 1 TS D 2+ SUB MT DUP BZ I 1 M ST D 2+ TM 7001, 0007, E0FE, D201, 9400, D(2), 826 | 3 TXD ALIGN FIXUP 8E00 IN GXIO ENQUEUE 4C98, sector, C201, D400, D(2), 1883, 827 | 7000, C006, 1803, 1083, D003, 0801, 828 | 7002, in, 8E00, in, C400, sector, 829 | D400, queue+2, 7001, 7001, C0FE, 830 | D400, queue+1, 4C00, queue+1 831 | take n off stack and call cylinder 832 | return, top of stack is sector number 833 | drop n from stack 834 | AND 0007 with sector number to get 835 | head and sector within track 836 | load n once again and store in D(2) 837 | shift right 3 to get pure cylinder number 838 | load buffer address, shift left and right by 3 839 | and store in IOCC word 1 then do XIO to initiate read 840 | this reads in 141 words (full sector of disk, first 841 | word is sector number then 320 cells of data) 842 | put SECTOR command in queue and jump to wait till I/O done 843 | 844 | ¢ WRITE D 2+ M MT 3 TXD ALIGN FIXUP 8D00 IN GXIO ENQUEUE ( -- ) var: (0000, C400, D(2), 1883, 7000, 845 | C006, 1803, 1083, D003, 0801, 846 | 7002, in, 8D00, C400, write, 847 | D400, queue+2, 7001, 7001, C0FE, 848 | D400, queue+1, 4C00, queue+1) 849 | load D(2), shift right 3 in accumulator 850 | load buffer address IN, shift right then left 3 851 | and save in IOCC word 1. XIO to Initiate Write 852 | stick address of WRITE in queue+2 and 7001 in 853 | queue+1, then jump into wait routine (QUEUE) 854 | This writes the buffer IN to disk 855 | 856 | :CHARACTER FFFE BSI X1 I FD M X1 RT 1 ADD LT FD X1 TR; ( -- ) gen: (4580, FFFE, C1FD, 7001, 0001, 80FE, D1FD) 857 | call routine at workarea (IX1)-2, the accept routine 858 | load IX1 with current character pointer (workarea-3) 859 | add 1 to tht value and store back in workarea-3 860 | This will accept a character from the current input stream, 861 | which is disk or console, bumping the character pointer 862 | 863 | 864 | :REP FE M ST 2 TR 0 M X1 RT 3C SUB LT SWAP DUP BZ I SWAP (n1 n2 n3 -- n1 n2 n3) gen: (C2FE, D002, C100, 865 | 0 M ST DEP CALL 0 1 MSI; 7001, 003C, 90FE, 4C98, n1, C200, 866 | 4400, deposit, 867 | 7001, 0001, C0FE, 868 | 8200, D200) 869 | n1 is the test character 870 | n2 is the routine to branch to if the character is a match 871 | n3 is a character to deposit as a replacement 872 | grab stack -2 (n1) and store as test character (replace 3C) 873 | load current character (IX1 is workarea) 874 | subtract the test value (3C normally) 875 | branch indirect to n2 if not positive 876 | load top of stack (n3) and call deposit 877 | bump n3 and save in stack 878 | 879 | 880 | ¢ FILL 28 START CHARACTER REP STOP (n1 n2 n3 -- ) var: (0000, 7002, 0028, 0020 (index), C0FD, D0FD, 881 | 8100 M LT LOC TP CALL RETURN (loop) 4580, FFFE, C1FD, 7001, 0001, 80FE, D1FD, 882 | C2FE, D002, C100, 7001, 003C, 90FE, 4C98, fill, 883 | C200, 4400, deposit, 7001, 0001, C0FE, 8200, D200, 884 | 74FF, index, 70E6, 7001, 8100, C0FE, 4400, typ, 885 | 4C80, return) 886 | n1 is test value 887 | 888 | set up loop count to initial value of 0028 (40 decimal) and loop till it reaches zero 889 | branch to workarea (IX1) - 2, the accept routine. Load character pointer at IX1 -3 890 | bump address by 1 and store in IX1-3. load n1 and store as test value 891 | pick up the current character value, subtract test value, and return if not positive 892 | get n3, call deposit, bump up n3 by 1, decrement the index and loop unless zero 893 | if zero, load 8100 (CR), call typ, and return 894 | This loops to fill the input area with 40 characters 895 | 896 | ¢ BLANK 0 M ST 1 TOD FF CS LX X3 GOR LT (n -- n) var: (0000, C200, 1881, 72FF, 7001, 6300, E8FE, 897 | 0 TR 0 M ST 1 TOD 1 SUB LT 5 TR 224 M LT 0 MARK D000, 6314, 1881, 7001, 0001, 90FE, D005, 898 | 0 TA LOOP RETURN 7001, 2424, C0FE, 6300, D700, 3189, 73FF, 899 | 70FC, 4C80, return) 900 | load top of stack (n), shift acc+ext right 1, drop, OR with 6300, store as value 901 | to load in IX3. Load IX3 with that value. divide by 2 and subtract 1. use this as 902 | word (cell) address for storing characters. load two blanks, load IX3 with 0, 903 | store into the calculated address, decrement IX3, skip the loop and return 904 | 905 | ¢ LIZ ALPHA WTC M LT 1 TS 2 TS ( -- ) var: () 906 | 28 M LT 3 TS 3 CS LOC BLANK CALL 907 | LOC FILL CALL 0 M ST FF SBU ST ALPHA TM FD CS RETURN 908 | 909 | ¢ ' 3C M LT 1 TS 1 CS LOC LIZ CALL RETURN ( -- ) var: () 910 | 911 | ¢ ( 2F M LT 1 TS 1 CS LOC LIZ CALL RETURN ( -- ) var: () 912 | 913 | :$ 'OK' REPLY; ( -- ) gen: (creates string with OK and ) 914 | 915 | :FILE 7 VECTOR; ( -- ) gen: () 916 | 917 | FILE ( -- ) var: () 918 | 919 | :LINE INTEGER; ( -- ) gen: () 920 | 921 | ¢ POSITION 0 M ST 4 TOD 1 CS 0 TS ( -- ) var: () 922 | LOC SECTOR CALL 0 M ST F GAND LT 14 MUL LT XCH 923 | IN ADD LT 0 TS RETURN 924 | 925 | ¢ FILL 28 START LOC ACCEPT CALL REP STOP RETURN ( -- ) var: () 926 | 927 | :L LINE VALUE; ( -- ) gen: () 928 | 929 | :RELATIVE FILE 5+ VALUE+; ( -- ) gen: () 930 | 931 | :T DUP LINE= RELATIVE POSITION WTC 28 MESSAGE; ( -- ) gen: () 932 | 933 | :EXAMINE SWAP IN WTC + SWAP MESSAGE; ( -- ) gen: () 934 | 935 | :EMPLACE 3C IN WTC+ 28 FILL DROP DROP DROP WRITE; ( -- ) gen: () 936 | 937 | :S INTEGER; ( -- ) gen: () 938 | 939 | :SV S VALUE; ( -- ) gen: () 940 | 941 | :MOVE TRANSIENT MARK SWAP M AT SWAP TA LOOP EXECUTE; ( -- ) gen: () 942 | 943 | :COMPARE 2 TR MARK 0 M AT SWAP SUB AT EQUAL IF SWAP LOOP ELSE; ( -- ) gen: () 944 | 945 | ¢ SEARCH IN 6- M LT S TM IN 1+ M MT 1 TR 0 START ( -- ) var: () 946 | S 7 MDM S M MT ALPHA 4 COMPARE SWAP STOP THEN 1 CS 947 | 0 TS RETURN 948 | 949 | :CREATE 2E0 SECTOR IN 1+ DUP INC 1- 7*+ S= SV VALUE 1+ SV 5+= ( -- ) gen: () 950 | RAISE SV 6+= RAISE F+ SV 7+= SV ALPHA 4 MOVE WRITE; card 200 951 | 952 | :WARN 'NO SUCH FILE' REPLY; ( -- ) gen: () 953 | 954 | :ACTIVATE 2E0 SECTOR SEARCH NONZERO WARN FIL SV 7 MOVE; ( -- ) gen: () 955 | 956 | :DELETE 2E0 SECTOR 0 SV 1+= WRITE; ( -- ) gen: () 957 | 958 | :SEC INTEGER; ( -- ) gen: () 959 | 960 | OPERATON STRAIGHT FD X1 M RT IN 140+ WTC SUB LT EQUAL IF ( -- ) var: () 961 | SEC 1 MDM SEC M MT 1 CS 0 TS LOC SECTOR CALL 962 | IN WTC M LT FD X1 TR THEN 963 | FD X1 M RT LOC FETCH CALL RETURN 964 | 965 | ¢ SET LOC STRAIGHT M LT FE X1 TR ( -- ) var: () 966 | 0 M ST FF CS FD X1 TR RETURN 967 | 968 | :INTERPRET TOP FILE 5+ VALUE 10/ 14* IN+ WTC ( -- ) gen: () 969 | SWAP DUP SEC= SECTOR SET; 970 | 971 | :RETRIEVE ACTIVATE INTERPRET; ( -- ) gen: () 972 | 973 | :XT SX INST 0 M LT; ( -- ) gen: () 974 | 975 | ¢ FORGET 1 X3 XT E TM 4 SUB LT E1 TM 3 X3 M RT ( -- ) var: () 976 | IC TM RETURN 977 | 978 | ¢ REMEMBER LOC ENTRY CALL ( -- ) var: () 979 | LOC FORGET M LT 2 X3 TR IC M MT 3 X3 TR RETURN 980 | 981 | LOC DONE 0A= HOME 'HI THERE' REPLY CONSOLE 982 | --------------------------------------------------------------------------------