Powered by ViewCVS 1.0-dev
| 1 : | anton | 1.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. |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |