gforth/kernel/int.fs - view

File: [gforth] / gforth / kernel / int.fs
Revision 1.22: download - view: text, annotated - select for diffs
Sun Feb 21 14:55:44 1999 UTC (25 years, 2 months ago) by anton
Branches: MAIN
CVS tags: HEAD

gforth-ditc is now installed with "make install"
bugfix in print-backtrace
rewrote number output: now uses a fixed buffer HOLDBUF; added <<# and
	#>> to deal with nested number output (e.g., AT-XY), and fixed
	ud.r and d.r (and thus all the "." words) and DUMP to use
	them.  Other words using <# still have to be fixed.
removed COMPACT// and its use; it did not work, and anyway, it's a bad
	idea for Cygwin, Domain/OS (Apollo's OS), and possibly other OSs.

1: \ definitions needed for interpreter only 2: 3: \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. 4: 5: \ This file is part of Gforth. 6: 7: \ Gforth is free software; you can redistribute it and/or 8: \ modify it under the terms of the GNU General Public License 9: \ as published by the Free Software Foundation; either version 2 10: \ of the License, or (at your option) any later version. 11: 12: \ This program is distributed in the hope that it will be useful, 13: \ but WITHOUT ANY WARRANTY; without even the implied warranty of 14: \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15: \ GNU General Public License for more details. 16: 17: \ You should have received a copy of the GNU General Public License 18: \ along with this program; if not, write to the Free Software 19: \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. 20: 21: \ \ Revision-Log 22: 23: \ put in seperate file 14sep97jaw 24: 25: \ \ input stream primitives 23feb93py 26: 27: : tib ( -- c-addr ) \ core-ext 28: \ obsolescent 29: >tib @ ; 30: 31: Defer source ( -- addr count ) \ core 32: \ used by dodefer:, must be defer 33: 34: : (source) ( -- addr count ) 35: tib #tib @ ; 36: ' (source) IS source 37: 38: : (word) ( addr1 n1 char -- addr2 n2 ) 39: dup >r skip 2dup r> scan nip - ; 40: 41: \ (word) should fold white spaces 42: \ this is what (parse-white) does 43: 44: \ word parse 23feb93py 45: 46: : sword ( char -- addr len ) \ gforth 47: \G parses like @code{word}, but the output is like @code{parse} output 48: \ this word was called PARSE-WORD until 0.3.0, but Open Firmware and 49: \ dpANS6 A.6.2.2008 have a word with that name that behaves 50: \ differently (like NAME). 51: source 2dup >r >r >in @ over min /string 52: rot dup bl = IF drop (parse-white) ELSE (word) THEN 53: 2dup + r> - 1+ r> min >in ! ; 54: 55: : word ( char -- addr ) \ core 56: sword here place bl here count + c! here ; 57: 58: : parse ( char -- addr len ) \ core-ext 59: >r source >in @ over min /string over swap r> scan >r 60: over - dup r> IF 1+ THEN >in +! ; 61: 62: \ name 13feb93py 63: 64: [IFUNDEF] (name) \ name might be a primitive 65: 66: : (name) ( -- c-addr count ) 67: source 2dup >r >r >in @ /string (parse-white) 68: 2dup + r> - 1+ r> min >in ! ; 69: \ name count ; 70: [THEN] 71: 72: : name-too-short? ( c-addr u -- c-addr u ) 73: dup 0= -&16 and throw ; 74: 75: : name-too-long? ( c-addr u -- c-addr u ) 76: dup $1F u> -&19 and throw ; 77: 78: \ \ Number parsing 23feb93py 79: 80: \ number? number 23feb93py 81: 82: hex 83: const Create bases 10 , 2 , A , 100 , 84: \ 16 2 10 character 85: 86: \ !! protect BASE saving wrapper against exceptions 87: : getbase ( addr u -- addr' u' ) 88: over c@ [char] $ - dup 4 u< 89: IF 90: cells bases + @ base ! 1 /string 91: ELSE 92: drop 93: THEN ; 94: 95: : sign? ( addr u -- addr u flag ) 96: over c@ '- = dup >r 97: IF 98: 1 /string 99: THEN 100: r> ; 101: 102: : s>unumber? ( addr u -- ud flag ) 103: base @ >r dpl on getbase 104: 0. 2swap 105: BEGIN ( d addr len ) 106: dup >r >number dup 107: WHILE \ there are characters left 108: dup r> - 109: WHILE \ the last >number parsed something 110: dup 1- dpl ! over c@ [char] . = 111: WHILE \ the current char is '.' 112: 1 /string 113: REPEAT THEN \ there are unparseable characters left 114: 2drop false 115: ELSE 116: rdrop 2drop true 117: THEN 118: r> base ! ; 119: 120: \ ouch, this is complicated; there must be a simpler way - anton 121: : s>number? ( addr len -- d f ) 122: \ converts string addr len into d, flag indicates success 123: sign? >r 124: s>unumber? 125: 0= IF 126: rdrop false 127: ELSE \ no characters left, all ok 128: r> 129: IF 130: dnegate 131: THEN 132: true 133: THEN ; 134: 135: : s>number ( addr len -- d ) 136: \ don't use this, there is no way to tell success 137: s>number? drop ; 138: 139: : snumber? ( c-addr u -- 0 / n -1 / d 0> ) 140: s>number? 0= 141: IF 142: 2drop false EXIT 143: THEN 144: dpl @ dup 0< IF 145: nip 146: ELSE 147: 1+ 148: THEN ; 149: 150: : number? ( string -- string 0 / n -1 / d 0> ) 151: dup >r count snumber? dup if 152: rdrop 153: else 154: r> swap 155: then ; 156: 157: : number ( string -- d ) 158: number? ?dup 0= abort" ?" 0< 159: IF 160: s>d 161: THEN ; 162: 163: \ \ Comments ( \ \G 164: 165: : ( ( compilation 'ccc<close-paren>' -- ; run-time -- ) \ core,file paren 166: \G ** this will not get annotated. The alias in glocals.fs will instead ** 167: [char] ) parse 2drop ; immediate 168: 169: : \ ( -- ) \ core-ext,block-ext backslash 170: \G ** this will not get annotated. The alias in glocals.fs will instead ** 171: [ has? file [IF] ] 172: blk @ 173: IF 174: >in @ c/l / 1+ c/l * >in ! 175: EXIT 176: THEN 177: [ [THEN] ] 178: source >in ! drop ; immediate 179: 180: : \G ( -- ) \ gforth backslash-gee 181: \G Equivalent to @code{\} but used as a tag to annotate definition 182: \G comments into documentation. 183: POSTPONE \ ; immediate 184: 185: \ \ object oriented search list 17mar93py 186: 187: \ word list structure: 188: 189: struct 190: cell% field find-method \ xt: ( c_addr u wid -- nt ) 191: cell% field reveal-method \ xt: ( nt wid -- ) \ used by dofield:, must be field 192: cell% field rehash-method \ xt: ( wid -- ) \ re-initializes a "search-data" (hashtables) 193: cell% field hash-method \ xt: ( wid -- ) \ initializes "" 194: \ \ !! what else 195: end-struct wordlist-map-struct 196: 197: struct 198: cell% field wordlist-map \ pointer to a wordlist-map-struct 199: cell% field wordlist-id \ linked list of words (for WORDS etc.) 200: cell% field wordlist-link \ link field to other wordlists 201: cell% field wordlist-extend \ wordlist extensions (eg bucket offset) 202: end-struct wordlist-struct 203: 204: : f83find ( addr len wordlist -- nt / false ) 205: wordlist-id @ (f83find) ; 206: 207: : initvoc ( wid -- ) 208: dup wordlist-map @ hash-method perform ; 209: 210: \ Search list table: find reveal 211: Create f83search ( -- wordlist-map ) 212: ' f83find A, ' drop A, ' drop A, ' drop A, 213: 214: here G f83search T A, NIL A, NIL A, NIL A, 215: AValue forth-wordlist \ variable, will be redefined by search.fs 216: 217: AVariable lookup forth-wordlist lookup ! 218: \ !! last is user and lookup?! jaw 219: AVariable current ( -- addr ) \ gforth 220: \G VARIABLE: holds the wid of the current compilation word list. 221: AVariable voclink forth-wordlist wordlist-link voclink ! 222: lookup AValue context ( -- addr ) \ gforth 223: \G VALUE: @code{context} @code{@@} is the wid of the word list at the 224: \G top of the search order stack. 225: 226: forth-wordlist current ! 227: 228: \ \ header, finding, ticks 17dec92py 229: 230: $80 constant alias-mask \ set when the word is not an alias! 231: $40 constant immediate-mask 232: $20 constant restrict-mask 233: 234: \ higher level parts of find 235: 236: : flag-sign ( f -- 1|-1 ) 237: \ true becomes 1, false -1 238: 0= 2* 1+ ; 239: 240: : compile-only-error ( ... -- ) 241: -&14 throw ; 242: 243: : (cfa>int) ( cfa -- xt ) 244: [ has? compiler [IF] ] 245: dup interpret/compile? 246: if 247: interpret/compile-int @ 248: then 249: [ [THEN] ] ; 250: 251: : (x>int) ( cfa b -- xt ) 252: \ get interpretation semantics of name 253: restrict-mask and 254: if 255: drop ['] compile-only-error 256: else 257: (cfa>int) 258: then ; 259: 260: : name>string ( nt -- addr count ) \ gforth head-to-string 261: \g @var{addr count} is the name of the word represented by @var{nt}. 262: cell+ count $1F and ; 263: 264: : ((name>)) ( nfa -- cfa ) 265: name>string + cfaligned ; 266: 267: : (name>x) ( nfa -- cfa b ) 268: \ cfa is an intermediate cfa and b is the flags byte of nfa 269: dup ((name>)) 270: swap cell+ c@ dup alias-mask and 0= 271: IF 272: swap @ swap 273: THEN ; 274: 275: : name>int ( nt -- xt ) \ gforth 276: \G @var{xt} represents the interpretation semantics of the word 277: \G @var{nt}. Produces @code{' compile-only-error} if 278: \G @var{nt} is compile-only. 279: (name>x) (x>int) ; 280: 281: : name?int ( nt -- xt ) \ gforth 282: \G Like name>int, but throws an error if compile-only. 283: (name>x) restrict-mask and 284: if 285: compile-only-error \ does not return 286: then 287: (cfa>int) ; 288: 289: : (name>comp) ( nt -- w +-1 ) \ gforth 290: \G @var{w xt} is the compilation token for the word @var{nt}. 291: (name>x) >r 292: [ has? compiler [IF] ] 293: dup interpret/compile? 294: if 295: interpret/compile-comp @ 296: then 297: [ [THEN] ] 298: r> immediate-mask and flag-sign 299: ; 300: 301: : (name>intn) ( nfa -- xt +-1 ) 302: (name>x) tuck (x>int) ( b xt ) 303: swap immediate-mask and flag-sign ; 304: 305: : head? ( addr -- f ) 306: \G heuristic check whether addr is a name token; may deliver false 307: \G positives; addr must be a valid address 308: \ we follow the link fields and check for plausibility; two 309: \ iterations should catch most false addresses: on the first 310: \ iteration, we may get an xt, on the second a code address (or 311: \ some code), which is typically not in the dictionary. 312: 2 0 do 313: dup @ dup 314: if ( addr addr1 ) 315: dup rot forthstart within 316: if \ addr1 is outside forthstart..addr, not a head 317: drop false unloop exit 318: then ( addr1 ) 319: else \ 0 in the link field, no further checks 320: 2drop true unloop exit 321: then 322: loop 323: \ in dubio pro: 324: drop true ; 325: 326: const Create ??? 0 , 3 c, char ? c, char ? c, char ? c, 327: \ ??? is used by dovar:, must be created/:dovar 328: 329: : >head ( cfa -- nt ) \ gforth to-head 330: $21 cell do ( cfa ) 331: dup i - count $9F and + cfaligned over alias-mask + = 332: if ( cfa ) 333: dup i - cell - dup head? 334: if 335: nip unloop exit 336: then 337: drop 338: then 339: cell +loop 340: drop ??? ( wouldn't 0 be better? ) ; 341: 342: ' >head ALIAS >name 343: 344: : body> 0 >body - ; 345: 346: : (search-wordlist) ( addr count wid -- nt / false ) 347: dup wordlist-map @ find-method perform ; 348: 349: : search-wordlist ( c-addr count wid -- 0 / xt +-1 ) \ search 350: \G Search the word list identified by wid 351: \G for the definition named by the string at c-addr count. 352: \G If the definition is not found, return 0. If the definition 353: \G is found return 1 (if the definition is immediate) or -1 354: \G (if the definition is not immediate) together with the xt. 355: \G The xt returned represents the interpretation semantics. 356: (search-wordlist) dup if 357: (name>intn) 358: then ; 359: 360: : find-name ( c-addr u -- nt/0 ) \ gforth 361: \g Find the name @var{c-addr u} in the current search 362: \g order. Return its nt, if found, otherwise 0. 363: lookup @ (search-wordlist) ; 364: 365: : sfind ( c-addr u -- 0 / xt +-1 ) \ gforth-obsolete 366: find-name dup 367: if ( nt ) 368: state @ 369: if 370: (name>comp) 371: else 372: (name>intn) 373: then 374: then ; 375: 376: : find ( c-addr -- xt +-1 / c-addr 0 ) \ core,search 377: \G Search all word lists in the current search order 378: \G for the definition named by the counted string at c-addr. 379: \G If the definition is not found, return 0. If the definition 380: \G is found return 1 (if the definition is immediate) or -1 381: \G (if the definition is not immediate) together with the xt. 382: dup count sfind dup 383: if 384: rot drop 385: then ; 386: 387: \ ticks 388: 389: : (') ( "name" -- nt ) \ gforth 390: name find-name dup 0= 391: IF 392: drop -&13 bounce 393: THEN ; 394: 395: : ' ( "name" -- xt ) \ core tick 396: \g @var{xt} represents @var{name}'s interpretation 397: \g semantics. Performs @code{-14 throw} if the word has no 398: \g interpretation semantics. 399: (') name?int ; 400: 401: \ \ the interpreter loop mar92py 402: 403: \ interpret 10mar92py 404: 405: Defer parser 406: Defer name ( -- c-addr count ) \ gforth 407: \ get the next word from the input buffer 408: ' (name) IS name 409: Defer compiler-notfound ( c-addr count -- ) 410: Defer interpreter-notfound ( c-addr count -- ) 411: 412: : no.extensions ( addr u -- ) 413: 2drop -&13 bounce ; 414: ' no.extensions IS compiler-notfound 415: ' no.extensions IS interpreter-notfound 416: 417: : interpret ( ?? -- ?? ) \ gforth 418: \ interpret/compile the (rest of the) input buffer 419: BEGIN 420: ?stack name dup 421: WHILE 422: parser 423: REPEAT 424: 2drop ; 425: 426: \ interpreter 30apr92py 427: 428: \ not the most efficient implementations of interpreter and compiler 429: | : interpreter ( c-addr u -- ) 430: 2dup find-name dup 431: if 432: nip nip name>int execute 433: else 434: drop 435: 2dup 2>r snumber? 436: IF 437: 2rdrop 438: ELSE 439: 2r> interpreter-notfound 440: THEN 441: then ; 442: 443: ' interpreter IS parser 444: 445: \ \ Query Evaluate 07apr93py 446: 447: has? file 0= [IF] 448: : sourceline# ( -- n ) 1 ; 449: [THEN] 450: 451: : refill ( -- flag ) \ core-ext,block-ext,file-ext 452: [ has? file [IF] ] 453: blk @ IF 1 blk +! true 0 >in ! EXIT THEN 454: [ [THEN] ] 455: tib /line 456: [ has? file [IF] ] 457: loadfile @ ?dup 458: IF read-line throw 459: ELSE 460: [ [THEN] ] 461: sourceline# 0< IF 2drop false EXIT THEN 462: accept true 463: [ has? file [IF] ] 464: THEN 465: 1 loadline +! 466: [ [THEN] ] 467: swap #tib ! 0 >in ! ; 468: 469: : query ( -- ) \ core-ext 470: \G obsolescent 471: [ has? file [IF] ] 472: blk off loadfile off 473: [ [THEN] ] 474: tib /line accept #tib ! 0 >in ! ; 475: 476: \ save-mem extend-mem 477: 478: has? os [IF] 479: : save-mem ( addr1 u -- addr2 u ) \ gforth 480: \g copy a memory block into a newly allocated region in the heap 481: swap >r 482: dup allocate throw 483: swap 2dup r> -rot move ; 484: 485: : extend-mem ( addr1 u1 u -- addr addr2 u2 ) 486: \ extend memory block allocated from the heap by u aus 487: \ the (possibly reallocated piece is addr2 u2, the extension is at addr 488: over >r + dup >r resize throw 489: r> over r> + -rot ; 490: [THEN] 491: 492: \ EVALUATE 17may93jaw 493: 494: has? file 0= [IF] 495: : push-file ( -- ) r> 496: tibstack @ >r >tib @ >r #tib @ >r 497: >tib @ tibstack @ = IF r@ tibstack +! THEN 498: tibstack @ >tib ! >in @ >r >r ; 499: 500: : pop-file ( throw-code -- throw-code ) 501: r> 502: r> >in ! r> #tib ! r> >tib ! r> tibstack ! >r ; 503: [THEN] 504: 505: : evaluate ( c-addr len -- ) \ core,block 506: push-file #tib ! >tib ! 507: >in off 508: [ has? file [IF] ] 509: blk off loadfile off -1 loadline ! 510: [ [THEN] ] 511: ['] interpret catch 512: pop-file throw ; 513: 514: \ \ Quit 13feb93py 515: 516: Defer 'quit 517: 518: Defer .status 519: 520: : prompt state @ IF ." compiled" EXIT THEN ." ok" ; 521: 522: : (Query) ( -- ) 523: [ has? file [IF] ] 524: loadfile off blk off loadline off 525: [ [THEN] ] 526: refill drop ; 527: 528: : (quit) BEGIN .status cr (query) interpret prompt AGAIN ; 529: 530: ' (quit) IS 'quit 531: 532: \ \ DOERROR (DOERROR) 13jun93jaw 533: 534: 8 Constant max-errors 535: Variable error-stack 0 error-stack ! 536: max-errors 6 * cells allot 537: \ format of one cell: 538: \ source ( addr u ) 539: \ >in 540: \ line-number 541: \ Loadfilename ( addr u ) 542: 543: : dec. ( n -- ) \ gforth 544: \G Display n as a signed decimal number, followed by a space. 545: base @ decimal swap . base ! ; 546: 547: : hex. ( u -- ) \ gforth 548: \G Display u as an unsigned hex number, prefixed with a "$" and 549: \G followed by a space. 550: '$ emit base @ swap hex u. base ! ; 551: 552: : typewhite ( addr u -- ) \ gforth 553: \ like type, but white space is printed instead of the characters 554: bounds ?do 555: i c@ #tab = if \ check for tab 556: #tab 557: else 558: bl 559: then 560: emit 561: loop ; 562: 563: DEFER DOERROR 564: Defer dobacktrace ( -- ) 565: ' noop IS dobacktrace 566: 567: : .error-frame ( addr1 u1 n1 n2 addr2 u2 -- ) 568: cr error-stack @ 569: IF 570: ." in file included from " 571: type ." :" dec. drop 2drop 572: ELSE 573: type ." :" dec. 574: cr dup 2over type cr drop 575: nip -trailing 1- ( line-start index2 ) 576: 0 >r BEGIN 577: 2dup + c@ bl > WHILE 578: r> 1+ >r 1- dup 0< UNTIL THEN 1+ 579: ( line-start index1 ) 580: typewhite 581: r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 582: [char] ^ emit 583: loop 584: THEN 585: ; 586: 587: : (DoError) ( throw-code -- ) 588: [ has? os [IF] ] 589: >stderr 590: [ [THEN] ] 591: sourceline# IF 592: source >in @ sourceline# 0 0 .error-frame 593: THEN 594: error-stack @ 0 ?DO 595: -1 error-stack +! 596: error-stack dup @ 6 * cells + cell+ 597: 6 cells bounds DO 598: I @ 599: cell +LOOP 600: .error-frame 601: LOOP 602: dup -2 = 603: IF 604: "error @ ?dup 605: IF 606: cr count type 607: THEN 608: drop 609: ELSE 610: .error 611: THEN 612: dobacktrace 613: normal-dp dpp ! ; 614: 615: ' (DoError) IS DoError 616: 617: : quit ( ?? -- ?? ) \ core 618: rp0 @ rp! handler off clear-tibstack >tib @ >r 619: BEGIN 620: [ has? compiler [IF] ] 621: postpone [ 622: [ [THEN] ] 623: ['] 'quit CATCH dup 624: WHILE 625: <# \ reset hold area, or we may get another error 626: DoError r@ >tib ! r@ tibstack ! 627: REPEAT 628: drop r> >tib ! ; 629: 630: \ \ Cold Boot 13feb93py 631: 632: : (bootmessage) 633: ." GForth " version-string type 634: ." , Copyright (C) 1998 Free Software Foundation, Inc." cr 635: ." GForth comes with ABSOLUTELY NO WARRANTY; for details type `license'" 636: [ has? os [IF] ] 637: cr ." Type `bye' to exit" 638: [ [THEN] ] ; 639: 640: defer bootmessage 641: defer process-args 642: 643: ' (bootmessage) IS bootmessage 644: 645: Defer 'cold ( -- ) \ gforth tick-cold 646: \ hook (deferred word) for things to do right before interpreting the 647: \ command-line arguments 648: ' noop IS 'cold 649: 650: include ../chains.fs 651: 652: Variable init8 653: 654: : cold ( -- ) \ gforth 655: [ has? file [IF] ] 656: pathstring 2@ fpath only-path 657: init-included-files 658: [ [THEN] ] 659: 'cold 660: init8 chainperform 661: [ has? file [IF] ] 662: process-args 663: loadline off 664: [ [THEN] ] 665: bootmessage 666: quit ; 667: 668: : clear-tibstack ( -- ) 669: [ has? glocals [IF] ] 670: lp@ forthstart 7 cells + @ - 671: [ [ELSE] ] 672: [ has? os [IF] ] 673: r0 @ forthstart 6 cells + @ - 674: [ [ELSE] ] 675: sp@ $10 cells + 676: [ [THEN] ] 677: [ [THEN] ] 678: dup >tib ! tibstack ! #tib off >in off ; 679: 680: : boot ( path **argv argc -- ) 681: main-task up! 682: [ has? os [IF] ] 683: stdout TO outfile-id 684: stdin TO infile-id 685: \ !! [ [THEN] ] 686: \ !! [ has? file [IF] ] 687: argc ! argv ! pathstring 2! 688: [ [THEN] ] 689: sp@ sp0 ! 690: clear-tibstack 691: rp@ rp0 ! 692: [ has? floating [IF] ] 693: fp@ fp0 ! 694: [ [THEN] ] 695: ['] cold catch DoError cr 696: [ has? os [IF] ] 697: bye 698: [ [THEN] ] 699: ; 700: 701: has? os [IF] 702: : bye ( -- ) \ tools-ext 703: [ has? file [IF] ] 704: script? 0= IF cr THEN 705: [ [ELSE] ] 706: cr 707: [ [THEN] ] 708: 0 (bye) ; 709: [THEN] 710: 711: \ **argv may be scanned by the C starter to get some important 712: \ information, as -display and -geometry for an X client FORTH 713: \ or space and stackspace overrides 714: 715: \ 0 arg contains, however, the name of the program. 716: