snobol4th

1 * Snobol4th - a Forth written in Snobol4 2 * Dave Gauer 2024 - ratfactor.com 3 4 * Data Stack 5 6 * Data stack and data head index 7 data = array(10,null) 8 * Note that "data head" always points to the 9 * top value and 0 is blank. 10 dh = 0 11 12 * Compile Mode Flag 13 compile_mode = null 14 compiling_name = '' 15 16 * Input state 17 dict_pos = 0 18 stdin_pos = 0 19 stdin_line = '' 20 readfrom = 'stdin_line' 21 storepos = 'stdin_pos' 22 23 * Infinite loop prevention while experimenting: 24 * max_tokens = 4000 25 * token_count = 0 26 27 28 * Dictionary 29 * ************************************* 30 * dtab entries point to positions in 31 * the dict string (dictionary storage) 32 dict = '' 33 dtab = table() 34 35 * (Test for dictionary entries with 36 * differ(dtab['no-exist']) :f(nodict) 37 * |n|_| - native 38 * |_|i| - immediate 39 * |_|_|55 - 'compiled' word position in dict 40 * |_|_|dup - native function to call 41 dtab['.'] = 'n_' 'dot' 42 dtab['."'] = 'ni' 'dotquote' 43 dtab['.S'] = 'n_' 'dotstack' 44 dtab['"'] = 'n_' 'quote' 45 dtab['SPACE'] = 'n_' 'space' 46 dtab['CR'] = 'n_' 'cr' 47 dtab['DUP'] = 'n_' 'dup' 48 dtab['SWAP'] = 'n_' 'swap' 49 dtab['DROP'] = 'n_' 'drop' 50 dtab['+'] = 'n_' 'plus' 51 dtab['-'] = 'n_' 'minus' 52 dtab['1-'] = 'n_' 'oneminus' 53 dtab[':'] = 'n_' 'colon' 54 dtab[';'] = 'ni' 'semicolon' 55 dtab['EXIT'] = 'n_' 'exit' 56 dtab['HERE'] = 'n_' 'here' 57 dtab['('] = 'ni' 'comment' 58 dtab['?DUP'] = 'n_' 'ifdup' 59 dtab['IF'] = 'n_' 'if' 60 dtab['ELSE'] = 'n_' 'else' 61 dtab['THEN'] = 'n_' 'then' 62 dtab['DO'] = 'n_' 'do' 63 dtab['I'] = 'n_' 'i' 64 dtab['LOOP'] = 'n_' 'loop' 65 dtab['+LOOP'] = 'n_' 'plusloop' 66 dtab['-LOOP'] = 'n_' 'minusloop' 67 68 69 * Output line 70 * ************************************* 71 * Since SNOBOL4 wants to print whole lines, let's 72 * collect printed strings and wait for "CR" 73 stdout = '' 74 75 * Return stack 76 * ************************************* 77 * rs stores return positions in the 78 * dictionary string. 79 * 80 * dict: ddddddddddddddd 81 * ^ ^ 82 * stdin: ss|s|ssssssssss 83 * ^ | | 84 * rs = 0 1 2 (rh=3) 85 * 86 * If rh is 0, read from stdin 87 rs = array(10,null) 88 rh = 0 89 90 91 * DUP duplicates head of stack 92 define('dup()') :(enddup) 93 dup 94 x = pop() 95 push(x) 96 push(x) 97 :(return) 98 enddup 99 100 * SWAP duplicates head of stack 101 define('swap()') :(endswap) 102 swap 103 x = pop() 104 y = pop() 105 push(x) 106 push(y) 107 :(return) 108 endswap 109 110 * DROP drops the head item of stack 111 define('drop()') :(enddrop) 112 drop 113 pop() 114 :(return) 115 enddrop 116 117 * '.' (dot) pops head of stack and prints it 118 define('dot()') :(enddot) 119 dot 120 x = pop() 121 stdout = stdout x ' ' 122 :(return) 123 enddot 124 125 * CR prints whatever we've collected in stdout 126 * as a new line. (Snobol4 has no way to print 127 * without printing a whole line.) 128 define('cr()') :(endcr) 129 cr 130 output = stdout 131 stdout = '' 132 :(return) 133 endcr 134 135 * SPACE prints a space character 136 define('space()') :(endspace) 137 space 138 stdout = stdout ' ' 139 :(return) 140 endspace 141 142 * '+' (plus) pops 2 digits, adds them, pushes result 143 define('plus()') :(endplus) 144 plus 145 x = pop() 146 y = pop() 147 push(x + y) 148 :(return) 149 endplus 150 151 * '-' (minus) pops 2 digits, - them, pushes result 152 define('minus()') :(endminus) 153 minus 154 x = pop() 155 y = pop() 156 push(y - x) 157 :(return) 158 endminus 159 160 * '1-' (oneminus) decrements top of stack by one 161 define('oneminus()') :(endoneminus) 162 oneminus 163 x = pop() 164 push(x - 1) 165 :(return) 166 endoneminus 167 168 * ":" (colon) starts compile mode, gathers name 169 define('colon()') :(endcolon) 170 colon 171 compiling_name = get_token() 172 dtab[compiling_name] = '__' size(dict) 173 compile_mode = 1 174 :(return) 175 endcolon 176 177 * ";" (semicolon) starts compile mode, gathers name 178 define('semicolon()') :(endsemicolon) 179 semicolon 180 dict = dict ' EXIT' 181 compile_mode = null 182 :(return) 183 endsemicolon 184 185 * EXIT starts compile mode, gathers name 186 define('exit()') :(endexit) 187 exit 188 rh = rh - 1 189 lt(rh,1) :s(return) 190 dict_pos = rs[rh] 191 :(return) 192 endexit 193 194 * HERE pushes current input pos 195 define('here()') :(endhere) 196 here 197 push(pos) 198 :(return) 199 endhere 200 201 in_comment = 0 202 * '(' is a comment...it throws away input until ')' 203 commentpat = tab(*stdin_pos) break(')') @stdin_pos 204 define('comment()') :(endcomment) 205 comment 206 stdin_line commentpat :f(cget_more) 207 stdin_pos = stdin_pos + 1 208 :(return) 209 cget_more 210 stdin_pos = 0 211 stdin_line = input :f(theend) s(comment) 212 endcomment 213 214 * '.S' prints the parameter stack 215 define('dotstack()') :(enddotstack) 216 dotstack 217 lt(dh,1) :s(printstackempty) 218 i = 0 219 next_si 220 lt(i,dh) :f(return) 221 i = i + 1 222 stdout = stdout data[i] ' ' 223 :(next_si) 224 printstackempty 225 stdout = stdout '<Stack empty>' 226 :(return) 227 enddotstack 228 229 * '."' declares and prints a string! 230 * quotepat = tab(*$storepos) (break('"') @$storepos) . quotestr 231 quotepat = tab(*$storepos) (break('"') @epos) . quotestr 232 define('dotquote()') :(enddotquote) 233 dotquote 234 * output = $readfrom 235 * output = dupl(' ',epos) '^' 236 $readfrom quotepat :f(endquote_notfound) 237 $storepos = epos + 1 238 * output = '"' quotestr '"' 239 * output = 'storing pos ' storepos '=' $storepos 240 eq(1, compile_mode) :s(dotquote_compile) 241 stdout = stdout quotestr 242 :(return) 243 dotquote_compile 244 dict = dict ' ." ' quotestr '"' 245 :(return) 246 endquote_notfound 247 output = "ERROR: No matching end quote." 248 output = $readfrom 249 output = dupl(' ',$storepos) '^' 250 :(end) 251 enddotquote 252 253 * '?DUP' duplicates the top of stack if it's a 'truthy' value 254 define('ifdup()') :(endifdup) 255 ifdup 256 x = data[dh] 257 eq(x,0) :s(return) 258 dup() 259 :(return) 260 endifdup 261 262 * 'IF' skips instructions until THEN when top of stack is false 263 elsethenpat = tab(*dict_pos) arb ('ELSE' | 'THEN') @dict_pos 264 define('if()') :(endif) 265 if 266 * If return stack empty, we are not in a 267 * dictionary definition. 268 lt(rh,1) :s(no_stdin) 269 * If the top of stack value is true, then 270 * start executing the next instruction. 271 eq(0,pop()) :s(if_false) 272 :(return) 273 if_false 274 * If it's false, scan to an ELSE or THEN. 275 dict elsethenpat 276 dictpos = dictpos + 1 277 :(return) 278 no_stdin output = "ERROR: Cannot execute 'IF' outside of a word definition." :(theend) 279 endif 280 281 * 'ELSE' skips instructions until THEN 282 elsepat = tab(*dict_pos) break('THEN') @dict_pos 283 define('else()') :(endelse) 284 else 285 dict elsethenpat 286 dictpos = dictpos + 1 287 :(return) 288 endelse 289 290 * 'THEN' itself is a non-action in this Forth! 291 define('then()') :(endthen) 292 then 293 :(return) 294 endthen 295 296 * DO LOOP, I, and DO +LOOP 297 * This Forth doesn't do nested loops because 298 * it has just one variable for the "I" index. 299 * If desired, this could be fixed with a 300 * stack (traditionally the return stack). 301 302 * 'DO' 303 define('do()') :(enddo) 304 do 305 * If return stack empty, we are not in a 306 * dictionary definition. 307 lt(rh,1) :s(no_stdin2) 308 loop_startpos = dict_pos 309 loop_ivar = pop() 310 loop_endvar = pop() 311 :(return) 312 no_stdin2 output = "ERROR: Cannot execute 'DO...LOOP' outside of a word definition." :(theend) 313 enddo 314 315 * 'i' 316 define('i()') :(endi) 317 i 318 push(loop_ivar) 319 :(return) 320 endi 321 322 * 'loop' 323 define('loop()') :(endloop) 324 loop 325 loop_ivar = loop_ivar + 1 326 le(loop_endvar, loop_ivar) :s(return) 327 dict_pos = loop_startpos 328 :(return) 329 endloop 330 331 * 'plusloop' 332 define('plusloop()') :(endplusloop) 333 plusloop 334 loop_inc = pop() 335 loop_ivar = loop_ivar + loop_inc 336 le(loop_endvar, loop_ivar) :s(return) 337 dict_pos = loop_startpos 338 :(return) 339 endplusloop 340 341 * 'minusloop' 342 define('minusloop()') :(endminusloop) 343 minusloop 344 loop_dec = pop() 345 loop_ivar = loop_ivar - loop_dec 346 ge(loop_endvar, loop_ivar) :s(return) 347 dict_pos = loop_startpos 348 :(return) 349 endminusloop 350 351 352 * Internal functions 353 * ************************************* 354 355 * pop() pops head of stack 356 define('pop()') :(endpop) 357 pop 358 lt(0,dh) :f(popunderflow) 359 pop = data[dh] 360 dh = dh - 1 361 :(return) 362 popunderflow output = 'Stack underflow.' :(theend) 363 endpop 364 365 * push(6) pushes 6 to head of stack 366 define('push(v)') :(endpush) 367 push 368 * output = "push starting with dh=" dh 369 dh = dh + 1 370 * output = 'pushing data[' dh ']:' v 371 data[dh] = v 372 :(return) 373 endpush 374 375 376 377 * Patterns for getting tokens 378 * Note the *p delays the evaluation of cursor position p until pattern used 379 anyspace = (span(' ') | '') 380 wordpat = tab(*pos) anyspace (break(' ') | rem) . token anyspace @pos 381 * get_token() returns next token from input 382 define('get_token()') :(endget_token) 383 get_token 384 * If return stack not empty, we are 385 * reading from the dictionary. 386 lt(rh,1) :s(read_stdin) 387 readfrom = 'dict' 388 storepos = 'dict_pos' 389 pos = dict_pos 390 :(read2) 391 read_stdin 392 readfrom = 'stdin_line' 393 storepos = 'stdin_pos' 394 pos = stdin_pos 395 lt(stdin_pos, size(stdin_line)) :s(read2) 396 * If the pos is not less than input size, read more 397 * And if reading from input fails, we're done! 398 &trim = 1 399 stdin_line = input :f(theend) 400 stdin_pos = 0 401 pos = 0 402 read2 403 $readfrom wordpat :f(fail) 404 $storepos = pos 405 get_token = token 406 407 * TEMP debug output: 408 * $readfrom tab(pos) rem . restofit 409 * output = "*** Read token '" token "', now pos(" storepos ")=" pos "(" restofit ")" 410 411 :(return) 412 endget_token 413 414 415 * Main - read tokens of input 416 * ************************************* 417 418 next_token 419 * Infinite loop prevention while experimenting: 420 * token_count = token_count + 1 421 * lt(token_count, max_tokens) :f(theend) 422 423 token = get_token() 424 425 * Test if token is in dictionary 426 token_data = dtab[token] 427 differ(token_data) :f(nodict) 428 429 * It is, are we compiling? If not, execute it. 430 differ(compile_mode) :f(exec_word) 431 432 * Yes, we're compiling. Is token an immediate word? 433 token_data pos(1) 'i' :s(exec_word) 434 435 * Compiling and not immediate, 'compile' to word 436 dict = dict ' ' token 437 :(next_token) 438 439 exec_word 440 * Is it a native word or dictionary word? 441 token_data pos(0) 'n' :s(exec_native) 442 443 * Is a dictionary word, execute it... 444 token_data tab(2) rem . dict_pos 445 rs[rh] = pos 446 rh = rh + 1 447 448 pos = dict_pos 449 :(next_token) 450 451 exec_native 452 token_data tab(2) rem . native_fn 453 apply(native_fn, null) :(next_token) 454 455 nodict 456 * Test if token is an integer (or empty) 457 differ(token) :f(next_token) 458 integer(token) :f(bad_input) 459 * It is, are we compiling? 460 differ(compile_mode) :f(push_int) 461 * Compile int into dict word definition 462 dict = dict ' ' token 463 :(next_token) 464 push_int 465 push(token) 466 :(next_token) 467 fail output = "FAIL!" :(theend) 468 bad_input output = "ERROR: '" token "' not in dictionary." :(next_token) 469 470 theend 471 * Print any remaining buffered output 472 differ(stdout) :f(end) 473 output = stdout 474 end