Annotation of gforth/kernal.fs, revision 1.1
1.1 ! anton 1: \ KERNAL.FS ANS figFORTH kernal 17dec92py
! 2: \ $ID:
! 3: \ Idea and implementation: Bernd Paysan (py)
! 4: \ Copyright 1992 by the ANSI figForth Development Group
! 5:
! 6: \ Log: ', '- usw. durch [char] ... ersetzt
! 7: \ man sollte die unterschiedlichen zahlensysteme
! 8: \ mit $ und & zumindest im interpreter weglassen
! 9: \ schon erledigt!
! 10: \ 11may93jaw
! 11: \ name> 0= nicht vorhanden 17may93jaw
! 12: \ nfa can be lfa or nfa!
! 13: \ find splited into find and (find)
! 14: \ (find) for later use 17may93jaw
! 15: \ search replaced by lookup because
! 16: \ it is a word of the string wordset
! 17: \ 20may93jaw
! 18: \ postpone added immediate 21may93jaw
! 19: \ to added immediate 07jun93jaw
! 20: \ cfa, header put "here lastcfa !" in
! 21: \ cfa, this is more logical
! 22: \ and noname: works wothout
! 23: \ extra "here lastcfa !" 08jun93jaw
! 24: \ (parse-white) thrown out
! 25: \ refill added outer trick
! 26: \ to show there is something
! 27: \ going on 09jun93jaw
! 28: \ leave ?leave somebody forgot UNLOOP!!! 09jun93jaw
! 29: \ leave ?leave unloop thrown out
! 30: \ unloop after loop is used 10jun93jaw
! 31:
! 32: HEX
! 33:
! 34: \ Bit string manipulation 06oct92py
! 35:
! 36: Create bits 80 c, 40 c, 20 c, 10 c, 8 c, 4 c, 2 c, 1 c,
! 37: DOES> ( n -- ) + c@ ;
! 38:
! 39: : >bit ( addr n -- c-addr mask ) 8 /mod rot + swap bits ;
! 40: : +bit ( addr n -- ) >bit over c@ or swap c! ;
! 41:
! 42: : relinfo ( -- addr ) forthstart dup @ + ;
! 43: : >rel ( addr -- n ) forthstart - ;
! 44: : relon ( addr -- ) relinfo swap >rel cell / +bit ;
! 45:
! 46: \ here allot , c, A, 17dec92py
! 47:
! 48: : here ( -- here ) dp @ ;
! 49: : allot ( n -- ) dp +! ;
! 50: : c, ( c -- ) here 1 chars allot c! ;
! 51: : , ( x -- ) here cell allot ! ;
! 52: : 2, ( w1 w2 -- ) \ general
! 53: here 2 cells allot 2! ;
! 54:
! 55: : aligned ( addr -- addr' )
! 56: [ cell 1- ] Literal + [ -1 cells ] Literal and ;
! 57: : align ( -- ) here dup aligned swap ?DO bl c, LOOP ;
! 58:
! 59: : A! ( addr1 addr2 -- ) dup relon ! ;
! 60: : A, ( addr -- ) here cell allot A! ;
! 61:
! 62: \ on off 23feb93py
! 63:
! 64: : on ( addr -- ) true swap ! ;
! 65: : off ( addr -- ) false swap ! ;
! 66:
! 67: \ name> found 17dec92py
! 68:
! 69: : (name>) ( nfa -- cfa ) count $1F and + aligned ;
! 70: : name> ( nfa -- cfa )
! 71: dup (name>) swap c@ $80 and 0= IF @ THEN ;
! 72:
! 73: : found ( nfa -- cfa n ) cell+
! 74: dup c@ >r (name>) r@ $80 and 0= IF @ THEN
! 75: \ -1 r@ $40 and IF 1- THEN
! 76: -1 r> $20 and IF negate THEN ;
! 77:
! 78: \ (find) 17dec92py
! 79:
! 80: \ : (find) ( addr count nfa1 -- nfa2 / false )
! 81: \ BEGIN dup WHILE dup >r
! 82: \ cell+ count $1F and dup >r 2over r> =
! 83: \ IF -text 0= IF 2drop r> EXIT THEN
! 84: \ ELSE 2drop drop THEN r> @
! 85: \ REPEAT nip nip ;
! 86:
! 87: \ place bounds 13feb93py
! 88:
! 89: : place ( addr len to -- ) over >r rot over 1+ r> move c! ;
! 90: : bounds ( beg count -- end beg ) over + swap ;
! 91:
! 92: \ input stream primitives 23feb93py
! 93:
! 94: : tib >tib @ ;
! 95: Defer source
! 96: : (source) ( -- addr count ) tib #tib @ ;
! 97: ' (source) IS source
! 98:
! 99: \ (word) 22feb93py
! 100:
! 101: : scan ( addr1 n1 char -- addr2 n2 ) >r
! 102: BEGIN dup WHILE over c@ r@ <> WHILE 1 /string
! 103: REPEAT THEN rdrop ;
! 104: : skip ( addr1 n1 char -- addr2 n2 ) >r
! 105: BEGIN dup WHILE over c@ r@ = WHILE 1 /string
! 106: REPEAT THEN rdrop ;
! 107:
! 108: : (word) ( addr1 n1 char -- addr2 n2 )
! 109: dup >r skip 2dup r> scan nip - ;
! 110:
! 111: \ (word) should fold white spaces
! 112: \ this is what (parse-white) does
! 113:
! 114: \ word parse 23feb93py
! 115:
! 116: : parse-word ( char -- addr len )
! 117: source 2dup >r >r >in @ /string
! 118: rot dup bl = IF drop (parse-white) ELSE (word) THEN
! 119: 2dup + r> - 1+ r> min >in ! ;
! 120: : word ( char -- addr )
! 121: parse-word here place bl here count + c! here ;
! 122:
! 123: : parse ( char -- addr len )
! 124: >r source >in @ /string over swap r> scan >r
! 125: over - dup r> IF 1+ THEN >in +! ;
! 126:
! 127: \ name 13feb93py
! 128:
! 129: : capitalize ( addr -- addr )
! 130: dup count chars bounds
! 131: ?DO I c@ toupper I c! 1 chars +LOOP ;
! 132: : (name) ( -- addr ) bl word ;
! 133:
! 134: \ Literal 17dec92py
! 135:
! 136: : Literal ( n -- ) state @ 0= ?EXIT postpone lit , ;
! 137: immediate
! 138: : ALiteral ( n -- ) state @ 0= ?EXIT postpone lit A, ;
! 139: immediate
! 140:
! 141: : char ( 'char' -- n ) bl word char+ c@ ;
! 142: : [char] ( 'char' -- n ) char postpone Literal ; immediate
! 143: ' [char] Alias Ascii immediate
! 144:
! 145: : (compile) ( -- ) r> dup cell+ >r @ A, ;
! 146: : postpone ( "name" -- )
! 147: name find dup 0= abort" Can't compile "
! 148: 0> IF A, ELSE postpone (compile) A, THEN ;
! 149: immediate restrict
! 150:
! 151: \ Use (compile) for the old behavior of compile!
! 152:
! 153: \ digit? 17dec92py
! 154:
! 155: : digit? ( char -- digit true/ false )
! 156: base @ $100 = ?dup ?EXIT
! 157: toupper [char] 0 - dup 9 u> IF
! 158: [ 'A '9 1 + - ] literal -
! 159: dup 9 u<= IF
! 160: drop false EXIT
! 161: THEN
! 162: THEN
! 163: dup base @ u>= IF
! 164: drop false EXIT
! 165: THEN
! 166: true ;
! 167:
! 168: : accumulate ( +d0 addr digit - +d1 addr )
! 169: swap >r swap base @ um* drop rot base @ um* d+ r> ;
! 170: : >number ( d addr count -- d addr count )
! 171: 0 ?DO count digit? WHILE accumulate LOOP 0
! 172: ELSE 1- I' I - UNLOOP THEN ;
! 173:
! 174: \ number? number 23feb93py
! 175:
! 176: Create bases 10 , 2 , A , 100 ,
! 177: \ 16 2 10 Zeichen
! 178: \ !! this saving and restoring base is an abomination! - anton
! 179: : getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u<
! 180: IF cells bases + @ base ! 1 /string ELSE drop THEN ;
! 181: : number? ( string -- string 0 / n -1 ) base @ >r
! 182: dup count over c@ [char] - = dup >r IF 1 /string THEN
! 183: getbase dpl on 0 0 2swap
! 184: BEGIN dup >r >number dup WHILE dup r> - WHILE
! 185: dup dpl ! over c@ [char] . = WHILE
! 186: 1 /string
! 187: REPEAT THEN 2drop 2drop rdrop false r> base ! EXIT THEN
! 188: 2drop rot drop rdrop r> IF dnegate THEN
! 189: dpl @ dup 0< IF nip THEN r> base ! ;
! 190: : s>d ( n -- d ) dup 0< ;
! 191: : number ( string -- d )
! 192: number? ?dup 0= abort" ?" 0< IF s>d THEN ;
! 193:
! 194: \ space spaces ud/mod 21mar93py
! 195: decimal
! 196: Create spaces bl 80 times \ times from target compiler! 11may93jaw
! 197: DOES> ( u -- ) swap
! 198: 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ;
! 199: hex
! 200: : space 1 spaces ;
! 201:
! 202: : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r
! 203: um/mod r> ;
! 204:
! 205: : pad ( -- addr )
! 206: here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ;
! 207:
! 208: \ hold <# #> sign # #s 25jan92py
! 209:
! 210: : hold ( char -- ) pad cell - -1 chars over +! @ c! ;
! 211:
! 212: : <# pad cell - dup ! ;
! 213:
! 214: : #> ( 64b -- addr +n ) 2drop pad cell - dup @ tuck - ;
! 215:
! 216: : sign ( n -- ) 0< IF [char] - hold THEN ;
! 217:
! 218: : # ( +d1 -- +d2 ) base @ 2 max ud/mod rot 9 over <
! 219: IF [ char A char 9 - 1- ] Literal + THEN [char] 0 + hold ;
! 220:
! 221: : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ;
! 222:
! 223: \ print numbers 07jun92py
! 224:
! 225: : d.r >r tuck dabs <# #s rot sign #>
! 226: r> over - spaces type ;
! 227:
! 228: : ud.r >r <# #s #> r> over - spaces type ;
! 229:
! 230: : .r >r s>d r> d.r ;
! 231: : u.r 0 swap ud.r ;
! 232:
! 233: : d. 0 d.r space ;
! 234: : ud. 0 ud.r space ;
! 235:
! 236: : . s>d d. ;
! 237: : u. 0 ud. ;
! 238:
! 239: \ catch throw 23feb93py
! 240: \ bounce 08jun93jaw
! 241:
! 242: \ !! what about the other stacks (FP, locals) anton
! 243: \ !! allow the user to add rollback actions anton
! 244: \ !! use a separate exception stack? anton
! 245:
! 246: : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error )
! 247: >r sp@ r> swap \ don't count xt! jaw
! 248: >r handler @ >r rp@ handler ! execute
! 249: r> handler ! rdrop 0 ;
! 250: : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn )
! 251: dup 0= IF drop EXIT THEN
! 252: handler @ rp! r> handler ! r> swap >r sp! r> ;
! 253: \ Bouncing is very fine,
! 254: \ programming without wasting time... jaw
! 255: : bounce ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn )
! 256: \ a throw without data stack restauration? anton !! stack diagram bad
! 257: dup 0= IF drop EXIT THEN
! 258: handler @ rp! r> handler ! r> drop ;
! 259:
! 260: \ ?stack 23feb93py
! 261:
! 262: : ?stack ( ?? -- ?? ) sp@ s0 @ > IF -4 throw THEN ;
! 263: \ ?stack should be code -- it touches an empty stack!
! 264:
! 265: \ interpret 10mar92py
! 266:
! 267: Defer parser
! 268: Defer name ' (name) IS name
! 269: Defer notfound
! 270:
! 271: : no.extensions ( string -- ) IF &-13 bounce THEN ;
! 272:
! 273: ' no.extensions IS notfound
! 274:
! 275: : interpret
! 276: BEGIN ?stack name dup c@ WHILE parser REPEAT drop ;
! 277:
! 278: \ interpreter compiler 30apr92py
! 279:
! 280: : interpreter ( name -- ) find ?dup
! 281: IF 1 and IF execute EXIT THEN -&14 throw THEN
! 282: number? 0= IF notfound THEN ;
! 283:
! 284: ' interpreter IS parser
! 285:
! 286: : compiler ( name -- ) find ?dup
! 287: IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup
! 288: IF 0> IF swap postpone Literal THEN postpone Literal
! 289: ELSE notfound THEN ;
! 290:
! 291: : [ ['] interpreter IS parser state off ; immediate
! 292: : ] ['] compiler IS parser state on ;
! 293:
! 294: \ Structural Conditionals 12dec92py
! 295:
! 296: : ?struc ( flag -- ) abort" unstructured " ;
! 297: : sys? ( sys -- ) dup 0= ?struc ;
! 298: : >mark ( -- sys ) here 0 , ;
! 299: : >resolve ( sys -- ) here over - swap ! ;
! 300: : <resolve ( sys -- ) here - , ;
! 301:
! 302: : BUT sys? swap ; immediate restrict
! 303: : YET sys? dup ; immediate restrict
! 304:
! 305: \ Structural Conditionals 12dec92py
! 306:
! 307: : AHEAD postpone branch >mark ; immediate restrict
! 308: : IF postpone ?branch >mark ; immediate restrict
! 309: : ?DUP-IF \ general
! 310: \ This is the preferred alternative to the idiom "?DUP IF", since it can be
! 311: \ better handled by tools like stack checkers
! 312: postpone ?dup postpone IF ; immediate restrict
! 313: : ?DUP-NOT-IF \ general
! 314: postpone ?dup postpone 0= postpone if ; immediate restrict
! 315: : THEN sys? dup @ ?struc >resolve ; immediate restrict
! 316: ' THEN alias ENDIF immediate restrict \ general
! 317: \ Same as "THEN". This is what you use if your program will be seen by
! 318: \ people who have not been brought up with Forth (or who have been
! 319: \ brought up with fig-Forth).
! 320:
! 321: : ELSE sys? postpone AHEAD swap postpone THEN ;
! 322: immediate restrict
! 323:
! 324: : BEGIN here ; immediate restrict
! 325: : WHILE sys? postpone IF swap ; immediate restrict
! 326: : AGAIN sys? postpone branch <resolve ; immediate restrict
! 327: : UNTIL sys? postpone ?branch <resolve ; immediate restrict
! 328: : REPEAT over 0= ?struc postpone AGAIN postpone THEN ;
! 329: immediate restrict
! 330:
! 331: \ Structural Conditionals 12dec92py
! 332:
! 333: Variable leavings
! 334:
! 335: : (leave) here leavings @ , leavings ! ;
! 336: : LEAVE postpone branch (leave) ; immediate restrict
! 337: : ?LEAVE postpone 0= postpone ?branch (leave) ;
! 338: immediate restrict
! 339:
! 340: : DONE ( addr -- ) leavings @
! 341: BEGIN 2dup u<= WHILE dup @ swap >resolve REPEAT
! 342: leavings ! drop ; immediate restrict
! 343:
! 344: \ Structural Conditionals 12dec92py
! 345:
! 346: : DO postpone (do) here ; immediate restrict
! 347:
! 348: : ?DO postpone (?do) (leave) here ;
! 349: immediate restrict
! 350: : FOR postpone (for) here ; immediate restrict
! 351:
! 352: : loop] dup <resolve 2 cells - postpone done postpone unloop ;
! 353:
! 354: : LOOP sys? postpone (loop) loop] ; immediate restrict
! 355: : +LOOP sys? postpone (+loop) loop] ; immediate restrict
! 356: : S+LOOP \ general
! 357: \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" will iterate as often as "high low ?DO inc S+LOOP". For positive increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for negative increments.
! 358: sys? postpone (s+loop) loop] ; immediate restrict
! 359: : NEXT sys? postpone (next) loop] ; immediate restrict
! 360:
! 361: \ Strings 22feb93py
! 362:
! 363: : ," ( "string"<"> -- ) [char] " parse
! 364: here over char+ allot place align ;
! 365: : "lit ( -- addr )
! 366: r> r> dup count + aligned >r swap >r ; restrict
! 367: : (.") "lit count type ; restrict
! 368: : (S") "lit count ; restrict
! 369: : SLiteral postpone (S") here over char+ allot place align ;
! 370: immediate restrict
! 371: : S" [char] " parse state @ IF postpone SLiteral THEN ;
! 372: immediate
! 373: : ." state @ IF postpone (.") ," align
! 374: ELSE [char] " parse type THEN ; immediate
! 375: : ( [char] ) parse 2drop ; immediate
! 376: : \ source >in ! drop ; immediate
! 377:
! 378: \ error handling 22feb93py
! 379: \ 'abort thrown out! 11may93jaw
! 380:
! 381: : (abort") "lit >r IF r> "error ! -2 throw THEN
! 382: rdrop ;
! 383: : abort" postpone (abort") ," ; immediate restrict
! 384:
! 385: \ Header states 23feb93py
! 386:
! 387: : flag! ( 8b -- ) last @ cell+ tuck c@ xor swap c! ;
! 388: : immediate $20 flag! ;
! 389: \ : restrict $40 flag! ;
! 390: ' noop alias restrict
! 391:
! 392: \ Header 23feb93py
! 393:
! 394: \ input-stream, nextname and noname are quite ugly (passing
! 395: \ information through global variables), but they are useful for dealing
! 396: \ with existing/independent defining words
! 397:
! 398: defer header
! 399:
! 400: : name, ( "name" -- )
! 401: name c@ 1+ chars allot align ;
! 402: : input-stream-header ( "name" -- )
! 403: \ !! this is f83-implementation-dependent
! 404: align here last ! -1 A,
! 405: name, $80 flag! ;
! 406:
! 407: : input-stream ( -- ) \ general
! 408: \ switches back to getting the name from the input stream ;
! 409: ['] input-stream-header IS header ;
! 410:
! 411: ' input-stream-header IS header
! 412:
! 413: \ !! make that a 2variable
! 414: create nextname-string 2 cells allot \ should we use a buffer that keeps the name?
! 415:
! 416: : nextname-header ( -- )
! 417: \ !! f83-implementation-dependent
! 418: nextname-string 2@
! 419: align here last ! -1 A,
! 420: dup c, here swap chars dup allot move align
! 421: $80 flag!
! 422: input-stream ;
! 423:
! 424: \ the next name is given in the string
! 425: : nextname ( c-addr u -- ) \ general
! 426: nextname-string 2!
! 427: ['] nextname-header IS header ;
! 428:
! 429: : noname-header ( -- )
! 430: 0 last !
! 431: input-stream ;
! 432:
! 433: : noname ( -- ) \ general
! 434: \ the next defined word remains anonymous. The xt of that word is given by lastxt
! 435: ['] noname-header IS header ;
! 436:
! 437: : lastxt ( -- xt ) \ general
! 438: \ xt is the execution token of the last word defined. The main purpose of this word is to get the xt of words defined using noname
! 439: lastcfa @ ;
! 440:
! 441: : Alias ( cfa "name" -- )
! 442: Header reveal , $80 flag! ;
! 443:
! 444: : name>string ( nfa -- addr count )
! 445: cell+ count $1F and ;
! 446:
! 447: Create ??? ," ???"
! 448: : >name ( cfa -- nfa )
! 449: $21 cell do
! 450: dup i - count $9F and + aligned over $80 + = if
! 451: i - cell - unloop exit
! 452: then
! 453: cell +loop
! 454: drop ??? ( wouldn't 0 be better? ) ;
! 455:
! 456: \ indirect threading 17mar93py
! 457:
! 458: : cfa, ( code-address -- )
! 459: here lastcfa !
! 460: here 0 A, 0 , code-address! ;
! 461: : compile, ( xt -- ) A, ;
! 462: : !does ( addr -- ) lastcfa @ does-code! ;
! 463: : (;code) ( R: addr -- ) r> /does-handler + !does ;
! 464: : dodoes, ( -- )
! 465: here /does-handler allot does-handler! ;
! 466:
! 467: \ direct threading is implementation dependent
! 468:
! 469: : Create Header reveal [ :dovar ] ALiteral cfa, ;
! 470:
! 471: \ DOES> 17mar93py
! 472:
! 473: : DOES> state @ IF postpone (;code) dodoes,
! 474: ELSE dodoes, here !does 0 ] THEN ; immediate
! 475:
! 476: \ Create Variable User Constant 17mar93py
! 477:
! 478: : Variable Create 0 , ;
! 479: : AVariable Create 0 A, ;
! 480: : 2VARIABLE ( "name" -- ) \ double
! 481: create 0 , 0 , ;
! 482:
! 483: : User Variable ;
! 484: : AUser AVariable ;
! 485:
! 486: : (Constant) Header reveal [ :docon ] ALiteral cfa, ;
! 487: : Constant (Constant) , ;
! 488: : AConstant (Constant) A, ;
! 489: : 2CONSTANT ( w1 w2 "name" -- ) \ double
! 490: (constant) 2, ;
! 491:
! 492: \ IS Defer What's Defers TO 24feb93py
! 493:
! 494: : Defer Create ['] noop A, DOES> @ execute ;
! 495:
! 496: : IS ( addr "name" -- )
! 497: ' >body
! 498: state @
! 499: IF postpone ALiteral postpone !
! 500: ELSE !
! 501: THEN ; immediate
! 502: ' IS Alias TO immediate
! 503:
! 504: : What's ( "name" -- addr ) ' >body
! 505: state @ IF postpone ALiteral postpone @ ELSE @ THEN ;
! 506: immediate
! 507: : Defers ( "name" -- ) ' >body @ compile, ;
! 508: immediate restrict
! 509:
! 510: \ : ; 24feb93py
! 511:
! 512: : : ( -- colon-sys ) Header [ :docol ] ALiteral cfa, 0 ] ;
! 513: : ; ( colon-sys -- ) ?struc postpone exit reveal postpone [ ;
! 514: immediate restrict
! 515: : :noname ( -- xt colon-sys ) here [ ' : @ ] ALiteral cfa, 0 ] ;
! 516:
! 517: \ Search list handling 23feb93py
! 518:
! 519: AVariable current
! 520:
! 521: : last? ( -- false / nfa nfa ) last @ ?dup ;
! 522: : (reveal) ( -- ) last?
! 523: IF dup @ 0<
! 524: IF current @ @ over ! current @ !
! 525: ELSE drop THEN THEN ;
! 526:
! 527: \ object oriented search list 17mar93py
! 528:
! 529: \ Search list table: find reveal
! 530:
! 531: Create f83search ' (f83find) A, ' (reveal) A,
! 532: Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A,
! 533: AVariable search G forth-wordlist search T !
! 534: G forth-wordlist current T !
! 535:
! 536: : (search-wordlist) ( addr count wid -- nfa / false )
! 537: dup @ swap cell+ @ @ execute ;
! 538:
! 539: : search-wordlist ( addr count wid -- 0 / xt +-1 )
! 540: (search-wordlist) dup IF found THEN ;
! 541:
! 542: Variable warnings G -1 warnings T !
! 543:
! 544: : check-shadow ( addr count wid -- )
! 545: \ prints a warning if the string is already present in the wordlist
! 546: \ !! should be refined so the user can suppress the warnings
! 547: >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if
! 548: ." redefined " name>string 2dup type
! 549: compare 0<> if
! 550: ." with " type
! 551: else
! 552: 2drop
! 553: then
! 554: space space EXIT
! 555: then
! 556: 2drop 2drop ;
! 557:
! 558: : find ( addr -- cfa +-1 / string false ) dup
! 559: count search @ search-wordlist dup IF rot drop THEN ;
! 560:
! 561: : reveal ( -- )
! 562: last? if
! 563: name>string current @ check-shadow
! 564: then
! 565: current @ cell+ @ cell+ @ execute ;
! 566:
! 567: : ' ( "name" -- addr ) name find 0= no.extensions ;
! 568: : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate
! 569: \ Input 13feb93py
! 570:
! 571: 07 constant #bell
! 572: 08 constant #bs
! 573: 7F constant #del
! 574: 0D constant #cr \ the newline key code
! 575: 0A constant #lf
! 576:
! 577: : bell #bell emit ;
! 578:
! 579: : backspaces 0 ?DO #bs emit LOOP ;
! 580: : >string ( span addr pos1 -- span addr pos1 addr2 len )
! 581: over 3 pick 2 pick chars /string ;
! 582: : type-rest ( span addr pos1 -- span addr pos1 back )
! 583: >string tuck type ;
! 584: : (del) ( max span addr pos1 -- max span addr pos2 )
! 585: 1- >string over 1+ -rot move
! 586: rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ;
! 587: : (ins) ( max span addr pos1 char -- max span addr pos2 )
! 588: >r >string over 1+ swap move 2dup chars + r> swap c!
! 589: rot 1+ -rot type-rest 1- backspaces 1+ ;
! 590: : ?del ( max span addr pos1 -- max span addr pos2 0 )
! 591: dup IF (del) THEN 0 ;
! 592: : (ret) type-rest drop true space ;
! 593: : back dup IF 1- #bs emit ELSE #bell emit THEN 0 ;
! 594: : forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ;
! 595:
! 596: Create crtlkeys
! 597: ] false false back false false false forw false
! 598: ?del false (ret) false false (ret) false false
! 599: false false false false false false false false
! 600: false false false false false false false false [
! 601:
! 602: : decode ( max span addr pos1 key -- max span addr pos2 flag )
! 603: dup #del = IF drop #bs THEN \ del is rubout
! 604: dup bl < IF cells crtlkeys + @ execute EXIT THEN
! 605: >r 2over = IF rdrop bell 0 EXIT THEN
! 606: r> (ins) 0 ;
! 607:
! 608: \ decode should better use a table for control key actions
! 609: \ to define keyboard bindings later
! 610:
! 611: : accept ( addr len -- len )
! 612: dup 0< IF abs over dup 1 chars - c@ tuck type
! 613: \ this allows to edit given strings
! 614: ELSE 0 THEN rot over
! 615: BEGIN key decode UNTIL
! 616: 2drop nip ;
! 617:
! 618: \ Output 13feb93py
! 619:
! 620: DEFER type \ defer type for a output buffer or fast
! 621: \ screen write
! 622:
! 623: : (type) ( addr len -- )
! 624: bounds ?DO I c@ emit LOOP ;
! 625:
! 626: ' (TYPE) IS Type
! 627:
! 628: \ DEFER Emit
! 629:
! 630: \ ' (Emit) IS Emit
! 631:
! 632: \ : form ( -- rows cols ) &24 &80 ;
! 633: \ form should be implemented using TERMCAPS or CURSES
! 634: \ : rows form drop ;
! 635: \ : cols form nip ;
! 636:
! 637: \ Query 07apr93py
! 638:
! 639: : refill ( -- flag )
! 640: tib /line
! 641: loadfile @ ?dup
! 642: IF dup file-position throw linestart 2!
! 643: read-line throw
! 644: ELSE linestart @ IF 2drop false EXIT THEN
! 645: accept true
! 646: THEN
! 647: 1 loadline +!
! 648: swap #tib ! >in off ;
! 649:
! 650: : Query ( -- ) loadfile off refill drop ;
! 651:
! 652: \ File specifiers 11jun93jaw
! 653:
! 654:
! 655: \ 1 c, here char r c, 0 c, 0 c, 0 c, char b c, 0 c,
! 656: \ 2 c, here char r c, char + c, 0 c,
! 657: \ 2 c, here char w c, char + c, 0 c, align
! 658: 4 Constant w/o
! 659: 2 Constant r/w
! 660: 0 Constant r/o
! 661:
! 662: \ BIN WRITE-LINE 11jun93jaw
! 663:
! 664: \ : bin dup 1 chars - c@
! 665: \ r/o 4 chars + over - dup >r swap move r> ;
! 666:
! 667: : bin 1+ ;
! 668:
! 669: create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos
! 670: \ or not unix environments if
! 671: \ bin is not selected
! 672:
! 673: : write-line dup >r write-file ?dup IF r> drop EXIT THEN
! 674: nl$ count r> write-file ;
! 675:
! 676: \ include-file 07apr93py
! 677:
! 678: : include-file ( i*x fid -- j*x )
! 679: linestart @ >r loadline @ >r loadfile @ >r
! 680: blk @ >r >tib @ >r #tib @ dup >r >in @ >r
! 681:
! 682: >tib +! loadfile !
! 683: 0 loadline ! blk off
! 684: BEGIN refill WHILE interpret REPEAT
! 685: loadfile @ close-file throw
! 686:
! 687: r> >in ! r> #tib ! r> >tib ! r> blk !
! 688: r> loadfile ! r> loadline ! r> linestart ! ;
! 689:
! 690: : included ( i*x addr u -- j*x )
! 691: r/o open-file throw include-file ;
! 692:
! 693: \ HEX DECIMAL 2may93jaw
! 694:
! 695: : decimal a base ! ;
! 696: : hex 10 base ! ;
! 697:
! 698: \ DEPTH 9may93jaw
! 699:
! 700: : depth ( -- +n ) sp@ s0 @ swap - cell / ;
! 701:
! 702: \ INCLUDE 9may93jaw
! 703:
! 704: : include
! 705: bl word count included ;
! 706:
! 707: \ RECURSE 17may93jaw
! 708:
! 709: : recurse last @ cell+ name> a, ; immediate restrict
! 710: \ !! does not work with anonymous words; use lastxt compile,
! 711:
! 712: \ */MOD */ 17may93jaw
! 713:
! 714: : */mod >r m* r> sm/rem ;
! 715:
! 716: : */ */mod nip ;
! 717:
! 718: \ EVALUATE 17may93jaw
! 719:
! 720: : evaluate ( c-addr len -- )
! 721: linestart @ >r loadline @ >r loadfile @ >r
! 722: blk @ >r >tib @ >r #tib @ dup >r >in @ >r
! 723:
! 724: >tib +! dup #tib ! >tib @ swap move
! 725: >in off blk off loadfile off -1 linestart !
! 726:
! 727: BEGIN interpret >in @ #tib @ u>= UNTIL
! 728:
! 729: r> >in ! r> #tib ! r> >tib ! r> blk !
! 730: r> loadfile ! r> loadline ! r> linestart ! ;
! 731:
! 732:
! 733: : abort -1 throw ;
! 734:
! 735: \+ environment? true ENV" CORE"
! 736: \ core wordset is now complete!
! 737:
! 738: \ Quit 13feb93py
! 739:
! 740: Defer 'quit
! 741: Defer .status
! 742: : prompt state @ IF ." compiled" EXIT THEN ." ok" ;
! 743: : (quit) BEGIN .status cr query interpret prompt AGAIN ;
! 744: ' (quit) IS 'quit
! 745:
! 746: \ DOERROR (DOERROR) 13jun93jaw
! 747:
! 748: DEFER DOERROR
! 749:
! 750: : (DoError) ( throw-code -- )
! 751: LoadFile @ IF ." Error in line: " Loadline @ . cr THEN
! 752: cr source type cr
! 753: source drop >in @ -trailing
! 754: here c@ 1F min dup >r - 1- 0 max nip
! 755: dup spaces IF ." ^" THEN r> 0 ?DO ." -" LOOP ." ^"
! 756: dup -2 =
! 757: IF "error @ ?dup IF cr count type THEN drop
! 758: ELSE .error THEN ;
! 759:
! 760: ' (DoError) IS DoError
! 761:
! 762: : quit r0 @ rp! handler off >tib @ >r
! 763: BEGIN postpone [ ['] 'quit catch dup WHILE
! 764: DoError r@ >tib !
! 765: REPEAT drop r> >tib ! ;
! 766:
! 767: \ Cold 13feb93py
! 768:
! 769: \ : .name ( name -- ) cell+ count $1F and type space ;
! 770: \ : words listwords @
! 771: \ BEGIN @ dup WHILE dup .name REPEAT drop ;
! 772:
! 773: : >len ( cstring -- addr n ) 100 0 scan 0 swap 100 - /string ;
! 774: : arg ( n -- addr count ) cells argv @ + @ >len ;
! 775: : #! postpone \ ; immediate
! 776:
! 777: Variable env
! 778: Variable argv
! 779: Variable argc
! 780:
! 781: : get-args ( -- ) #tib off
! 782: argc @ 1 ?DO I arg 2dup source + swap move
! 783: #tib +! drop bl source + c! 1 #tib +! LOOP
! 784: >in off #tib @ 0<> #tib +! ;
! 785:
! 786: : script? ( -- flag ) 0 arg 1 arg dup 3 pick - /string compare 0= ;
! 787:
! 788: : cold ( -- ) argc @ 1 >
! 789: IF script?
! 790: IF 1 arg ['] included ELSE get-args ['] interpret THEN
! 791: catch ?dup IF dup >r DoError cr r> (bye) THEN THEN
! 792: ." ANS FORTH-93 (c) 1993 by the ANS FORTH-93 Team" cr quit ;
! 793:
! 794: : boot ( **env **argv argc -- )
! 795: argc ! argv ! env !
! 796: sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ;
! 797:
! 798: : bye cr 0 (bye) ;
! 799:
! 800: \ **argv may be scanned by the C starter to get some important
! 801: \ information, as -display and -geometry for an X client FORTH
! 802: \ or space and stackspace overrides
! 803:
! 804: \ 0 arg contains, however, the name of the program.
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>