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 : | anton | 1.5 | : dp ( -- addr ) dpp @ ; |
| 49 : | anton | 1.1 | : here ( -- here ) dp @ ; |
| 50 : | : allot ( n -- ) dp +! ; | ||
| 51 : | : c, ( c -- ) here 1 chars allot c! ; | ||
| 52 : | : , ( x -- ) here cell allot ! ; | ||
| 53 : | : 2, ( w1 w2 -- ) \ general | ||
| 54 : | here 2 cells allot 2! ; | ||
| 55 : | |||
| 56 : | : aligned ( addr -- addr' ) | ||
| 57 : | [ cell 1- ] Literal + [ -1 cells ] Literal and ; | ||
| 58 : | : align ( -- ) here dup aligned swap ?DO bl c, LOOP ; | ||
| 59 : | |||
| 60 : | anton | 1.8 | : faligned ( addr -- f-addr ) |
| 61 : | [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; | ||
| 62 : | |||
| 63 : | : falign ( -- ) | ||
| 64 : | here dup faligned swap | ||
| 65 : | ?DO | ||
| 66 : | bl c, | ||
| 67 : | LOOP ; | ||
| 68 : | |||
| 69 : | |||
| 70 : | |||
| 71 : | anton | 1.1 | : A! ( addr1 addr2 -- ) dup relon ! ; |
| 72 : | : A, ( addr -- ) here cell allot A! ; | ||
| 73 : | |||
| 74 : | \ on off 23feb93py | ||
| 75 : | |||
| 76 : | : on ( addr -- ) true swap ! ; | ||
| 77 : | : off ( addr -- ) false swap ! ; | ||
| 78 : | |||
| 79 : | \ name> found 17dec92py | ||
| 80 : | |||
| 81 : | : (name>) ( nfa -- cfa ) count $1F and + aligned ; | ||
| 82 : | pazsan | 1.9 | : name> ( nfa -- cfa ) cell+ |
| 83 : | anton | 1.1 | dup (name>) swap c@ $80 and 0= IF @ THEN ; |
| 84 : | |||
| 85 : | : found ( nfa -- cfa n ) cell+ | ||
| 86 : | dup c@ >r (name>) r@ $80 and 0= IF @ THEN | ||
| 87 : | pazsan | 1.9 | -1 r@ $40 and IF 1- THEN |
| 88 : | r> $20 and IF negate THEN ; | ||
| 89 : | anton | 1.1 | |
| 90 : | \ (find) 17dec92py | ||
| 91 : | |||
| 92 : | \ : (find) ( addr count nfa1 -- nfa2 / false ) | ||
| 93 : | \ BEGIN dup WHILE dup >r | ||
| 94 : | \ cell+ count $1F and dup >r 2over r> = | ||
| 95 : | \ IF -text 0= IF 2drop r> EXIT THEN | ||
| 96 : | \ ELSE 2drop drop THEN r> @ | ||
| 97 : | \ REPEAT nip nip ; | ||
| 98 : | |||
| 99 : | \ place bounds 13feb93py | ||
| 100 : | |||
| 101 : | : place ( addr len to -- ) over >r rot over 1+ r> move c! ; | ||
| 102 : | : bounds ( beg count -- end beg ) over + swap ; | ||
| 103 : | |||
| 104 : | \ input stream primitives 23feb93py | ||
| 105 : | |||
| 106 : | : tib >tib @ ; | ||
| 107 : | Defer source | ||
| 108 : | : (source) ( -- addr count ) tib #tib @ ; | ||
| 109 : | ' (source) IS source | ||
| 110 : | |||
| 111 : | \ (word) 22feb93py | ||
| 112 : | |||
| 113 : | : scan ( addr1 n1 char -- addr2 n2 ) >r | ||
| 114 : | BEGIN dup WHILE over c@ r@ <> WHILE 1 /string | ||
| 115 : | REPEAT THEN rdrop ; | ||
| 116 : | : skip ( addr1 n1 char -- addr2 n2 ) >r | ||
| 117 : | BEGIN dup WHILE over c@ r@ = WHILE 1 /string | ||
| 118 : | REPEAT THEN rdrop ; | ||
| 119 : | |||
| 120 : | : (word) ( addr1 n1 char -- addr2 n2 ) | ||
| 121 : | dup >r skip 2dup r> scan nip - ; | ||
| 122 : | |||
| 123 : | \ (word) should fold white spaces | ||
| 124 : | \ this is what (parse-white) does | ||
| 125 : | |||
| 126 : | \ word parse 23feb93py | ||
| 127 : | |||
| 128 : | : parse-word ( char -- addr len ) | ||
| 129 : | source 2dup >r >r >in @ /string | ||
| 130 : | rot dup bl = IF drop (parse-white) ELSE (word) THEN | ||
| 131 : | 2dup + r> - 1+ r> min >in ! ; | ||
| 132 : | : word ( char -- addr ) | ||
| 133 : | parse-word here place bl here count + c! here ; | ||
| 134 : | |||
| 135 : | : parse ( char -- addr len ) | ||
| 136 : | >r source >in @ /string over swap r> scan >r | ||
| 137 : | over - dup r> IF 1+ THEN >in +! ; | ||
| 138 : | |||
| 139 : | \ name 13feb93py | ||
| 140 : | |||
| 141 : | : capitalize ( addr -- addr ) | ||
| 142 : | dup count chars bounds | ||
| 143 : | ?DO I c@ toupper I c! 1 chars +LOOP ; | ||
| 144 : | : (name) ( -- addr ) bl word ; | ||
| 145 : | pazsan | 1.12 | \ : (cname) ( -- addr ) bl word capitalize ; |
| 146 : | anton | 1.1 | |
| 147 : | \ Literal 17dec92py | ||
| 148 : | |||
| 149 : | anton | 1.8 | : Literal ( n -- ) state @ IF postpone lit , THEN ; |
| 150 : | anton | 1.1 | immediate |
| 151 : | anton | 1.8 | : ALiteral ( n -- ) state @ IF postpone lit A, THEN ; |
| 152 : | anton | 1.1 | immediate |
| 153 : | |||
| 154 : | : char ( 'char' -- n ) bl word char+ c@ ; | ||
| 155 : | : [char] ( 'char' -- n ) char postpone Literal ; immediate | ||
| 156 : | ' [char] Alias Ascii immediate | ||
| 157 : | |||
| 158 : | : (compile) ( -- ) r> dup cell+ >r @ A, ; | ||
| 159 : | : postpone ( "name" -- ) | ||
| 160 : | name find dup 0= abort" Can't compile " | ||
| 161 : | 0> IF A, ELSE postpone (compile) A, THEN ; | ||
| 162 : | immediate restrict | ||
| 163 : | |||
| 164 : | \ Use (compile) for the old behavior of compile! | ||
| 165 : | |||
| 166 : | \ digit? 17dec92py | ||
| 167 : | |||
| 168 : | : digit? ( char -- digit true/ false ) | ||
| 169 : | anton | 1.8 | base @ $100 = |
| 170 : | IF | ||
| 171 : | true EXIT | ||
| 172 : | THEN | ||
| 173 : | anton | 1.1 | toupper [char] 0 - dup 9 u> IF |
| 174 : | [ 'A '9 1 + - ] literal - | ||
| 175 : | dup 9 u<= IF | ||
| 176 : | drop false EXIT | ||
| 177 : | THEN | ||
| 178 : | THEN | ||
| 179 : | dup base @ u>= IF | ||
| 180 : | drop false EXIT | ||
| 181 : | THEN | ||
| 182 : | true ; | ||
| 183 : | |||
| 184 : | : accumulate ( +d0 addr digit - +d1 addr ) | ||
| 185 : | swap >r swap base @ um* drop rot base @ um* d+ r> ; | ||
| 186 : | : >number ( d addr count -- d addr count ) | ||
| 187 : | 0 ?DO count digit? WHILE accumulate LOOP 0 | ||
| 188 : | ELSE 1- I' I - UNLOOP THEN ; | ||
| 189 : | |||
| 190 : | \ number? number 23feb93py | ||
| 191 : | |||
| 192 : | Create bases 10 , 2 , A , 100 , | ||
| 193 : | \ 16 2 10 Zeichen | ||
| 194 : | \ !! this saving and restoring base is an abomination! - anton | ||
| 195 : | : getbase ( addr u -- addr' u' ) over c@ [char] $ - dup 4 u< | ||
| 196 : | IF cells bases + @ base ! 1 /string ELSE drop THEN ; | ||
| 197 : | pazsan | 1.12 | : s>number ( addr len -- d ) base @ >r dpl on |
| 198 : | over c@ '- = dup >r IF 1 /string THEN | ||
| 199 : | anton | 1.1 | getbase dpl on 0 0 2swap |
| 200 : | BEGIN dup >r >number dup WHILE dup r> - WHILE | ||
| 201 : | dup dpl ! over c@ [char] . = WHILE | ||
| 202 : | 1 /string | ||
| 203 : | pazsan | 1.12 | REPEAT THEN 2drop rdrop dpl off ELSE |
| 204 : | 2drop rdrop r> IF dnegate THEN | ||
| 205 : | THEN r> base ! ; | ||
| 206 : | : number? ( string -- string 0 / n -1 / d 0> ) | ||
| 207 : | dup count s>number dpl @ 0= IF 2drop false EXIT THEN | ||
| 208 : | rot drop dpl @ dup 0> 0= IF nip THEN ; | ||
| 209 : | anton | 1.1 | : s>d ( n -- d ) dup 0< ; |
| 210 : | : number ( string -- d ) | ||
| 211 : | number? ?dup 0= abort" ?" 0< IF s>d THEN ; | ||
| 212 : | |||
| 213 : | \ space spaces ud/mod 21mar93py | ||
| 214 : | decimal | ||
| 215 : | Create spaces bl 80 times \ times from target compiler! 11may93jaw | ||
| 216 : | DOES> ( u -- ) swap | ||
| 217 : | 0 max 0 ?DO I' I - &80 min 2dup type +LOOP drop ; | ||
| 218 : | hex | ||
| 219 : | : space 1 spaces ; | ||
| 220 : | |||
| 221 : | : ud/mod ( ud1 u2 -- urem udquot ) >r 0 r@ um/mod r> swap >r | ||
| 222 : | um/mod r> ; | ||
| 223 : | |||
| 224 : | : pad ( -- addr ) | ||
| 225 : | here [ $20 8 2* cells + 2 + cell+ ] Literal + aligned ; | ||
| 226 : | |||
| 227 : | \ hold <# #> sign # #s 25jan92py | ||
| 228 : | |||
| 229 : | : hold ( char -- ) pad cell - -1 chars over +! @ c! ; | ||
| 230 : | |||
| 231 : | : <# pad cell - dup ! ; | ||
| 232 : | |||
| 233 : | : #> ( 64b -- addr +n ) 2drop pad cell - dup @ tuck - ; | ||
| 234 : | |||
| 235 : | : sign ( n -- ) 0< IF [char] - hold THEN ; | ||
| 236 : | |||
| 237 : | : # ( +d1 -- +d2 ) base @ 2 max ud/mod rot 9 over < | ||
| 238 : | IF [ char A char 9 - 1- ] Literal + THEN [char] 0 + hold ; | ||
| 239 : | |||
| 240 : | : #s ( +d -- 0 0 ) BEGIN # 2dup d0= UNTIL ; | ||
| 241 : | |||
| 242 : | \ print numbers 07jun92py | ||
| 243 : | |||
| 244 : | : d.r >r tuck dabs <# #s rot sign #> | ||
| 245 : | r> over - spaces type ; | ||
| 246 : | |||
| 247 : | : ud.r >r <# #s #> r> over - spaces type ; | ||
| 248 : | |||
| 249 : | : .r >r s>d r> d.r ; | ||
| 250 : | : u.r 0 swap ud.r ; | ||
| 251 : | |||
| 252 : | : d. 0 d.r space ; | ||
| 253 : | : ud. 0 ud.r space ; | ||
| 254 : | |||
| 255 : | : . s>d d. ; | ||
| 256 : | : u. 0 ud. ; | ||
| 257 : | |||
| 258 : | \ catch throw 23feb93py | ||
| 259 : | \ bounce 08jun93jaw | ||
| 260 : | |||
| 261 : | \ !! allow the user to add rollback actions anton | ||
| 262 : | \ !! use a separate exception stack? anton | ||
| 263 : | |||
| 264 : | anton | 1.5 | : lp@ ( -- addr ) |
| 265 : | laddr# [ 0 , ] ; | ||
| 266 : | |||
| 267 : | anton | 1.1 | : catch ( x1 .. xn xt -- y1 .. ym 0 / z1 .. zn error ) |
| 268 : | anton | 1.5 | >r sp@ r> swap >r \ don't count xt! jaw |
| 269 : | fp@ >r | ||
| 270 : | lp@ >r | ||
| 271 : | handler @ >r | ||
| 272 : | rp@ handler ! | ||
| 273 : | execute | ||
| 274 : | pazsan | 1.6 | r> handler ! rdrop rdrop rdrop 0 ; |
| 275 : | |||
| 276 : | anton | 1.5 | : throw ( y1 .. ym error/0 -- y1 .. ym / z1 .. zn error ) |
| 277 : | anton | 1.10 | ?DUP IF |
| 278 : | [ here 4 cells ! ] | ||
| 279 : | handler @ rp! | ||
| 280 : | r> handler ! | ||
| 281 : | r> lp! | ||
| 282 : | r> fp! | ||
| 283 : | r> swap >r sp! r> | ||
| 284 : | THEN ; | ||
| 285 : | pazsan | 1.6 | |
| 286 : | anton | 1.1 | \ Bouncing is very fine, |
| 287 : | \ programming without wasting time... jaw | ||
| 288 : | anton | 1.5 | : bounce ( y1 .. ym error/0 -- y1 .. ym error / y1 .. ym ) |
| 289 : | \ a throw without data or fp stack restauration | ||
| 290 : | ?DUP IF | ||
| 291 : | handler @ rp! | ||
| 292 : | r> handler ! | ||
| 293 : | r> lp! | ||
| 294 : | rdrop | ||
| 295 : | rdrop | ||
| 296 : | THEN ; | ||
| 297 : | anton | 1.1 | |
| 298 : | \ ?stack 23feb93py | ||
| 299 : | |||
| 300 : | : ?stack ( ?? -- ?? ) sp@ s0 @ > IF -4 throw THEN ; | ||
| 301 : | \ ?stack should be code -- it touches an empty stack! | ||
| 302 : | |||
| 303 : | \ interpret 10mar92py | ||
| 304 : | |||
| 305 : | Defer parser | ||
| 306 : | Defer name ' (name) IS name | ||
| 307 : | Defer notfound | ||
| 308 : | |||
| 309 : | pazsan | 1.12 | : no.extensions ( string -- ) IF -&13 bounce THEN ; |
| 310 : | anton | 1.1 | |
| 311 : | ' no.extensions IS notfound | ||
| 312 : | |||
| 313 : | : interpret | ||
| 314 : | BEGIN ?stack name dup c@ WHILE parser REPEAT drop ; | ||
| 315 : | |||
| 316 : | \ interpreter compiler 30apr92py | ||
| 317 : | |||
| 318 : | : interpreter ( name -- ) find ?dup | ||
| 319 : | IF 1 and IF execute EXIT THEN -&14 throw THEN | ||
| 320 : | number? 0= IF notfound THEN ; | ||
| 321 : | |||
| 322 : | ' interpreter IS parser | ||
| 323 : | |||
| 324 : | : compiler ( name -- ) find ?dup | ||
| 325 : | IF 0> IF execute EXIT THEN compile, EXIT THEN number? dup | ||
| 326 : | IF 0> IF swap postpone Literal THEN postpone Literal | ||
| 327 : | pazsan | 1.2 | ELSE drop notfound THEN ; |
| 328 : | anton | 1.1 | |
| 329 : | : [ ['] interpreter IS parser state off ; immediate | ||
| 330 : | : ] ['] compiler IS parser state on ; | ||
| 331 : | |||
| 332 : | anton | 1.8 | \ locals stuff needed for control structures |
| 333 : | |||
| 334 : | : compile-lp+! ( n -- ) | ||
| 335 : | dup negate locals-size +! | ||
| 336 : | 0 over = if | ||
| 337 : | else -4 over = if postpone -4lp+! | ||
| 338 : | else 8 over = if postpone 8lp+! | ||
| 339 : | else 16 over = if postpone 16lp+! | ||
| 340 : | else postpone lp+!# dup , | ||
| 341 : | then then then then drop ; | ||
| 342 : | |||
| 343 : | : adjust-locals-size ( n -- ) | ||
| 344 : | \ sets locals-size to n and generates an appropriate lp+! | ||
| 345 : | locals-size @ swap - compile-lp+! ; | ||
| 346 : | |||
| 347 : | |||
| 348 : | here 0 , \ just a dummy, the real value of locals-list is patched into it in glocals.fs | ||
| 349 : | AConstant locals-list \ acts like a variable that contains | ||
| 350 : | anton | 1.10 | \ a linear list of locals names |
| 351 : | anton | 1.8 | |
| 352 : | |||
| 353 : | variable dead-code \ true if normal code at "here" would be dead | ||
| 354 : | |||
| 355 : | : unreachable ( -- ) | ||
| 356 : | \ declares the current point of execution as unreachable | ||
| 357 : | dead-code on ; | ||
| 358 : | |||
| 359 : | \ locals list operations | ||
| 360 : | |||
| 361 : | : common-list ( list1 list2 -- list3 ) | ||
| 362 : | \ list1 and list2 are lists, where the heads are at higher addresses than | ||
| 363 : | \ the tail. list3 is the largest sublist of both lists. | ||
| 364 : | begin | ||
| 365 : | 2dup u<> | ||
| 366 : | while | ||
| 367 : | 2dup u> | ||
| 368 : | if | ||
| 369 : | swap | ||
| 370 : | then | ||
| 371 : | @ | ||
| 372 : | repeat | ||
| 373 : | drop ; | ||
| 374 : | |||
| 375 : | : sub-list? ( list1 list2 -- f ) | ||
| 376 : | \ true iff list1 is a sublist of list2 | ||
| 377 : | begin | ||
| 378 : | 2dup u< | ||
| 379 : | while | ||
| 380 : | @ | ||
| 381 : | repeat | ||
| 382 : | = ; | ||
| 383 : | |||
| 384 : | : list-size ( list -- u ) | ||
| 385 : | \ size of the locals frame represented by list | ||
| 386 : | 0 ( list n ) | ||
| 387 : | begin | ||
| 388 : | over 0<> | ||
| 389 : | while | ||
| 390 : | over | ||
| 391 : | pazsan | 1.11 | name> >body @ max |
| 392 : | anton | 1.8 | swap @ swap ( get next ) |
| 393 : | repeat | ||
| 394 : | faligned nip ; | ||
| 395 : | |||
| 396 : | : set-locals-size-list ( list -- ) | ||
| 397 : | dup locals-list ! | ||
| 398 : | list-size locals-size ! ; | ||
| 399 : | |||
| 400 : | : check-begin ( list -- ) | ||
| 401 : | \ warn if list is not a sublist of locals-list | ||
| 402 : | locals-list @ sub-list? 0= if | ||
| 403 : | \ !! print current position | ||
| 404 : | ." compiler was overly optimistic about locals at a BEGIN" cr | ||
| 405 : | \ !! print assumption and reality | ||
| 406 : | then ; | ||
| 407 : | |||
| 408 : | \ Control Flow Stack | ||
| 409 : | \ orig, etc. have the following structure: | ||
| 410 : | \ type ( defstart, live-orig, dead-orig, dest, do-dest, scopestart) ( TOS ) | ||
| 411 : | \ address (of the branch or the instruction to be branched to) (second) | ||
| 412 : | \ locals-list (valid at address) (third) | ||
| 413 : | |||
| 414 : | \ types | ||
| 415 : | 0 constant defstart | ||
| 416 : | 1 constant live-orig | ||
| 417 : | 2 constant dead-orig | ||
| 418 : | 3 constant dest \ the loopback branch is always assumed live | ||
| 419 : | 4 constant do-dest | ||
| 420 : | 5 constant scopestart | ||
| 421 : | |||
| 422 : | : def? ( n -- ) | ||
| 423 : | defstart <> abort" unstructured " ; | ||
| 424 : | |||
| 425 : | : orig? ( n -- ) | ||
| 426 : | dup live-orig <> swap dead-orig <> and abort" expected orig " ; | ||
| 427 : | |||
| 428 : | : dest? ( n -- ) | ||
| 429 : | dest <> abort" expected dest " ; | ||
| 430 : | |||
| 431 : | : do-dest? ( n -- ) | ||
| 432 : | do-dest <> abort" expected do-dest " ; | ||
| 433 : | |||
| 434 : | : scope? ( n -- ) | ||
| 435 : | scopestart <> abort" expected scope " ; | ||
| 436 : | |||
| 437 : | : non-orig? ( n -- ) | ||
| 438 : | dest scopestart 1+ within 0= abort" expected dest, do-dest or scope" ; | ||
| 439 : | |||
| 440 : | : cs-item? ( n -- ) | ||
| 441 : | live-orig scopestart 1+ within 0= abort" expected control flow stack item" ; | ||
| 442 : | |||
| 443 : | 3 constant cs-item-size | ||
| 444 : | |||
| 445 : | : CS-PICK ( ... u -- ... destu ) | ||
| 446 : | 1+ cs-item-size * 1- >r | ||
| 447 : | r@ pick r@ pick r@ pick | ||
| 448 : | rdrop | ||
| 449 : | dup non-orig? ; | ||
| 450 : | |||
| 451 : | : CS-ROLL ( destu/origu .. dest0/orig0 u -- .. dest0/orig0 destu/origu ) | ||
| 452 : | 1+ cs-item-size * 1- >r | ||
| 453 : | r@ roll r@ roll r@ roll | ||
| 454 : | rdrop | ||
| 455 : | dup cs-item? ; | ||
| 456 : | |||
| 457 : | : cs-push-part ( -- list addr ) | ||
| 458 : | locals-list @ here ; | ||
| 459 : | |||
| 460 : | : cs-push-orig ( -- orig ) | ||
| 461 : | cs-push-part dead-code @ | ||
| 462 : | if | ||
| 463 : | dead-orig | ||
| 464 : | else | ||
| 465 : | live-orig | ||
| 466 : | then ; | ||
| 467 : | |||
| 468 : | anton | 1.1 | \ Structural Conditionals 12dec92py |
| 469 : | |||
| 470 : | : ?struc ( flag -- ) abort" unstructured " ; | ||
| 471 : | : sys? ( sys -- ) dup 0= ?struc ; | ||
| 472 : | anton | 1.8 | : >mark ( -- orig ) |
| 473 : | cs-push-orig 0 , ; | ||
| 474 : | : >resolve ( addr -- ) here over - swap ! ; | ||
| 475 : | : <resolve ( addr -- ) here - , ; | ||
| 476 : | anton | 1.1 | |
| 477 : | anton | 1.8 | : BUT 1 cs-roll ; immediate restrict |
| 478 : | : YET 0 cs-pick ; immediate restrict | ||
| 479 : | anton | 1.1 | |
| 480 : | \ Structural Conditionals 12dec92py | ||
| 481 : | |||
| 482 : | anton | 1.8 | : AHEAD ( -- orig ) |
| 483 : | POSTPONE branch >mark unreachable ; immediate restrict | ||
| 484 : | |||
| 485 : | : IF ( -- orig ) | ||
| 486 : | POSTPONE ?branch >mark ; immediate restrict | ||
| 487 : | |||
| 488 : | anton | 1.1 | : ?DUP-IF \ general |
| 489 : | \ This is the preferred alternative to the idiom "?DUP IF", since it can be | ||
| 490 : | \ better handled by tools like stack checkers | ||
| 491 : | anton | 1.8 | POSTPONE ?dup POSTPONE if ; immediate restrict |
| 492 : | anton | 1.1 | : ?DUP-NOT-IF \ general |
| 493 : | anton | 1.8 | POSTPONE ?dup POSTPONE 0= POSTPONE if ; immediate restrict |
| 494 : | |||
| 495 : | : THEN ( orig -- ) | ||
| 496 : | dup orig? | ||
| 497 : | dead-code @ | ||
| 498 : | if | ||
| 499 : | dead-orig = | ||
| 500 : | if | ||
| 501 : | >resolve drop | ||
| 502 : | else | ||
| 503 : | >resolve set-locals-size-list dead-code off | ||
| 504 : | then | ||
| 505 : | else | ||
| 506 : | dead-orig = | ||
| 507 : | if | ||
| 508 : | >resolve drop | ||
| 509 : | else \ both live | ||
| 510 : | over list-size adjust-locals-size | ||
| 511 : | >resolve | ||
| 512 : | locals-list @ common-list dup list-size adjust-locals-size | ||
| 513 : | locals-list ! | ||
| 514 : | then | ||
| 515 : | then ; immediate restrict | ||
| 516 : | |||
| 517 : | anton | 1.1 | ' THEN alias ENDIF immediate restrict \ general |
| 518 : | \ Same as "THEN". This is what you use if your program will be seen by | ||
| 519 : | \ people who have not been brought up with Forth (or who have been | ||
| 520 : | \ brought up with fig-Forth). | ||
| 521 : | |||
| 522 : | anton | 1.8 | : ELSE ( orig1 -- orig2 ) |
| 523 : | POSTPONE ahead | ||
| 524 : | 1 cs-roll | ||
| 525 : | POSTPONE then ; immediate restrict | ||
| 526 : | |||
| 527 : | |||
| 528 : | : BEGIN ( -- dest ) | ||
| 529 : | dead-code @ if | ||
| 530 : | \ set up an assumption of the locals visible here | ||
| 531 : | \ currently we just take the top cs-item | ||
| 532 : | \ it would be more intelligent to take the top orig | ||
| 533 : | \ but that can be arranged by the user | ||
| 534 : | dup defstart <> if | ||
| 535 : | dup cs-item? | ||
| 536 : | 2 pick | ||
| 537 : | else | ||
| 538 : | 0 | ||
| 539 : | then | ||
| 540 : | set-locals-size-list | ||
| 541 : | then | ||
| 542 : | cs-push-part dest | ||
| 543 : | dead-code off ; immediate restrict | ||
| 544 : | |||
| 545 : | \ AGAIN (the current control flow joins another, earlier one): | ||
| 546 : | \ If the dest-locals-list is not a subset of the current locals-list, | ||
| 547 : | \ issue a warning (see below). The following code is generated: | ||
| 548 : | \ lp+!# (current-local-size - dest-locals-size) | ||
| 549 : | \ branch <begin> | ||
| 550 : | : AGAIN ( dest -- ) | ||
| 551 : | dest? | ||
| 552 : | over list-size adjust-locals-size | ||
| 553 : | POSTPONE branch | ||
| 554 : | <resolve | ||
| 555 : | check-begin | ||
| 556 : | unreachable ; immediate restrict | ||
| 557 : | |||
| 558 : | \ UNTIL (the current control flow may join an earlier one or continue): | ||
| 559 : | \ Similar to AGAIN. The new locals-list and locals-size are the current | ||
| 560 : | \ ones. The following code is generated: | ||
| 561 : | \ ?branch-lp+!# <begin> (current-local-size - dest-locals-size) | ||
| 562 : | : until-like ( list addr xt1 xt2 -- ) | ||
| 563 : | \ list and addr are a fragment of a cs-item | ||
| 564 : | \ xt1 is the conditional branch without lp adjustment, xt2 is with | ||
| 565 : | >r >r | ||
| 566 : | locals-size @ 2 pick list-size - dup if ( list dest-addr adjustment ) | ||
| 567 : | r> drop r> compile, | ||
| 568 : | swap <resolve ( list adjustment ) , | ||
| 569 : | else ( list dest-addr adjustment ) | ||
| 570 : | drop | ||
| 571 : | r> compile, <resolve | ||
| 572 : | r> drop | ||
| 573 : | then ( list ) | ||
| 574 : | check-begin ; | ||
| 575 : | |||
| 576 : | : UNTIL ( dest -- ) | ||
| 577 : | dest? ['] ?branch ['] ?branch-lp+!# until-like ; immediate restrict | ||
| 578 : | |||
| 579 : | : WHILE ( dest -- orig dest ) | ||
| 580 : | POSTPONE if | ||
| 581 : | 1 cs-roll ; immediate restrict | ||
| 582 : | |||
| 583 : | : REPEAT ( orig dest -- ) | ||
| 584 : | POSTPONE again | ||
| 585 : | POSTPONE then ; immediate restrict | ||
| 586 : | |||
| 587 : | |||
| 588 : | \ counted loops | ||
| 589 : | |||
| 590 : | \ leave poses a little problem here | ||
| 591 : | \ we have to store more than just the address of the branch, so the | ||
| 592 : | \ traditional linked list approach is no longer viable. | ||
| 593 : | \ This is solved by storing the information about the leavings in a | ||
| 594 : | pazsan | 1.9 | \ special stack. |
| 595 : | anton | 1.8 | |
| 596 : | \ !! remove the fixed size limit. 'Tis not hard. | ||
| 597 : | 20 constant leave-stack-size | ||
| 598 : | pazsan | 1.9 | create leave-stack 60 cells allot |
| 599 : | Avariable leave-sp leave-stack 3 cells + leave-sp ! | ||
| 600 : | anton | 1.8 | |
| 601 : | : clear-leave-stack ( -- ) | ||
| 602 : | leave-stack leave-sp ! ; | ||
| 603 : | |||
| 604 : | \ : leave-empty? ( -- f ) | ||
| 605 : | \ leave-sp @ leave-stack = ; | ||
| 606 : | |||
| 607 : | : >leave ( orig -- ) | ||
| 608 : | \ push on leave-stack | ||
| 609 : | leave-sp @ | ||
| 610 : | dup [ leave-stack 60 cells + ] Aliteral | ||
| 611 : | >= abort" leave-stack full" | ||
| 612 : | tuck ! cell+ | ||
| 613 : | tuck ! cell+ | ||
| 614 : | tuck ! cell+ | ||
| 615 : | leave-sp ! ; | ||
| 616 : | |||
| 617 : | : leave> ( -- orig ) | ||
| 618 : | \ pop from leave-stack | ||
| 619 : | leave-sp @ | ||
| 620 : | pazsan | 1.9 | dup leave-stack <= IF |
| 621 : | drop 0 0 0 EXIT THEN | ||
| 622 : | anton | 1.8 | cell - dup @ swap |
| 623 : | cell - dup @ swap | ||
| 624 : | cell - dup @ swap | ||
| 625 : | leave-sp ! ; | ||
| 626 : | |||
| 627 : | pazsan | 1.9 | : DONE ( orig -- ) drop >r drop |
| 628 : | anton | 1.8 | \ !! the original done had ( addr -- ) |
| 629 : | begin | ||
| 630 : | leave> | ||
| 631 : | pazsan | 1.9 | over r@ u>= |
| 632 : | anton | 1.8 | while |
| 633 : | POSTPONE then | ||
| 634 : | repeat | ||
| 635 : | pazsan | 1.9 | >leave rdrop ; immediate restrict |
| 636 : | anton | 1.8 | |
| 637 : | : LEAVE ( -- ) | ||
| 638 : | POSTPONE ahead | ||
| 639 : | pazsan | 1.9 | >leave ; immediate restrict |
| 640 : | anton | 1.8 | |
| 641 : | : ?LEAVE ( -- ) | ||
| 642 : | POSTPONE 0= POSTPONE if | ||
| 643 : | pazsan | 1.9 | >leave ; immediate restrict |
| 644 : | anton | 1.8 | |
| 645 : | : DO ( -- do-sys ) | ||
| 646 : | POSTPONE (do) | ||
| 647 : | POSTPONE begin drop do-dest | ||
| 648 : | pazsan | 1.9 | ( 0 0 0 >leave ) ; immediate restrict |
| 649 : | anton | 1.8 | |
| 650 : | : ?DO ( -- do-sys ) | ||
| 651 : | pazsan | 1.9 | ( 0 0 0 >leave ) |
| 652 : | anton | 1.8 | POSTPONE (?do) |
| 653 : | >mark >leave | ||
| 654 : | pazsan | 1.9 | POSTPONE begin drop do-dest ; immediate restrict |
| 655 : | anton | 1.8 | |
| 656 : | : FOR ( -- do-sys ) | ||
| 657 : | POSTPONE (for) | ||
| 658 : | POSTPONE begin drop do-dest | ||
| 659 : | pazsan | 1.9 | ( 0 0 0 >leave ) ; immediate restrict |
| 660 : | anton | 1.8 | |
| 661 : | \ LOOP etc. are just like UNTIL | ||
| 662 : | |||
| 663 : | : loop-like ( do-sys xt1 xt2 -- ) | ||
| 664 : | pazsan | 1.9 | >r >r 0 cs-pick swap cell - swap 1 cs-roll r> r> rot do-dest? |
| 665 : | anton | 1.8 | until-like POSTPONE done POSTPONE unloop ; |
| 666 : | |||
| 667 : | : LOOP ( do-sys -- ) | ||
| 668 : | pazsan | 1.9 | ['] (loop) ['] (loop)-lp+!# loop-like ; immediate restrict |
| 669 : | anton | 1.8 | |
| 670 : | : +LOOP ( do-sys -- ) | ||
| 671 : | pazsan | 1.9 | ['] (+loop) ['] (+loop)-lp+!# loop-like ; immediate restrict |
| 672 : | anton | 1.8 | |
| 673 : | \ A symmetric version of "+LOOP". I.e., "-high -low ?DO -inc S+LOOP" | ||
| 674 : | \ will iterate as often as "high low ?DO inc S+LOOP". For positive | ||
| 675 : | \ increments it behaves like "+LOOP". Use S+LOOP instead of +LOOP for | ||
| 676 : | \ negative increments. | ||
| 677 : | : S+LOOP ( do-sys -- ) | ||
| 678 : | pazsan | 1.9 | ['] (s+loop) ['] (s+loop)-lp+!# loop-like ; immediate restrict |
| 679 : | anton | 1.5 | |
| 680 : | anton | 1.8 | : NEXT ( do-sys -- ) |
| 681 : | pazsan | 1.9 | ['] (next) ['] (next)-lp+!# loop-like ; immediate restrict |
| 682 : | anton | 1.1 | |
| 683 : | \ Structural Conditionals 12dec92py | ||
| 684 : | |||
| 685 : | anton | 1.8 | : EXIT ( -- ) |
| 686 : | 0 adjust-locals-size | ||
| 687 : | POSTPONE ;s | ||
| 688 : | unreachable ; immediate restrict | ||
| 689 : | anton | 1.1 | |
| 690 : | anton | 1.8 | : ?EXIT ( -- ) |
| 691 : | POSTPONE if POSTPONE exit POSTPONE then ; immediate restrict | ||
| 692 : | anton | 1.1 | |
| 693 : | \ Strings 22feb93py | ||
| 694 : | |||
| 695 : | : ," ( "string"<"> -- ) [char] " parse | ||
| 696 : | here over char+ allot place align ; | ||
| 697 : | : "lit ( -- addr ) | ||
| 698 : | r> r> dup count + aligned >r swap >r ; restrict | ||
| 699 : | : (.") "lit count type ; restrict | ||
| 700 : | : (S") "lit count ; restrict | ||
| 701 : | : SLiteral postpone (S") here over char+ allot place align ; | ||
| 702 : | immediate restrict | ||
| 703 : | : S" [char] " parse state @ IF postpone SLiteral THEN ; | ||
| 704 : | immediate | ||
| 705 : | : ." state @ IF postpone (.") ," align | ||
| 706 : | ELSE [char] " parse type THEN ; immediate | ||
| 707 : | : ( [char] ) parse 2drop ; immediate | ||
| 708 : | : \ source >in ! drop ; immediate | ||
| 709 : | |||
| 710 : | \ error handling 22feb93py | ||
| 711 : | \ 'abort thrown out! 11may93jaw | ||
| 712 : | |||
| 713 : | : (abort") "lit >r IF r> "error ! -2 throw THEN | ||
| 714 : | rdrop ; | ||
| 715 : | : abort" postpone (abort") ," ; immediate restrict | ||
| 716 : | |||
| 717 : | \ Header states 23feb93py | ||
| 718 : | |||
| 719 : | anton | 1.10 | : flag! ( 8b -- ) |
| 720 : | last @ dup 0= abort" last word was headerless" | ||
| 721 : | cell+ tuck c@ xor swap c! ; | ||
| 722 : | anton | 1.1 | : immediate $20 flag! ; |
| 723 : | pazsan | 1.9 | : restrict $40 flag! ; |
| 724 : | \ ' noop alias restrict | ||
| 725 : | anton | 1.1 | |
| 726 : | \ Header 23feb93py | ||
| 727 : | |||
| 728 : | \ input-stream, nextname and noname are quite ugly (passing | ||
| 729 : | \ information through global variables), but they are useful for dealing | ||
| 730 : | \ with existing/independent defining words | ||
| 731 : | |||
| 732 : | defer header | ||
| 733 : | |||
| 734 : | : name, ( "name" -- ) | ||
| 735 : | anton | 1.10 | name c@ |
| 736 : | pazsan | 1.12 | dup $1F u> -&19 and throw ( is name too long? ) |
| 737 : | anton | 1.10 | 1+ chars allot align ; |
| 738 : | anton | 1.1 | : input-stream-header ( "name" -- ) |
| 739 : | \ !! this is f83-implementation-dependent | ||
| 740 : | align here last ! -1 A, | ||
| 741 : | name, $80 flag! ; | ||
| 742 : | |||
| 743 : | : input-stream ( -- ) \ general | ||
| 744 : | \ switches back to getting the name from the input stream ; | ||
| 745 : | ['] input-stream-header IS header ; | ||
| 746 : | |||
| 747 : | ' input-stream-header IS header | ||
| 748 : | |||
| 749 : | \ !! make that a 2variable | ||
| 750 : | anton | 1.5 | create nextname-buffer 32 chars allot |
| 751 : | anton | 1.1 | |
| 752 : | : nextname-header ( -- ) | ||
| 753 : | \ !! f83-implementation-dependent | ||
| 754 : | anton | 1.5 | nextname-buffer count |
| 755 : | anton | 1.1 | align here last ! -1 A, |
| 756 : | dup c, here swap chars dup allot move align | ||
| 757 : | $80 flag! | ||
| 758 : | input-stream ; | ||
| 759 : | |||
| 760 : | \ the next name is given in the string | ||
| 761 : | : nextname ( c-addr u -- ) \ general | ||
| 762 : | pazsan | 1.12 | dup $1F u> -&19 and throw ( is name too long? ) |
| 763 : | anton | 1.5 | nextname-buffer c! ( c-addr ) |
| 764 : | nextname-buffer count move | ||
| 765 : | anton | 1.1 | ['] nextname-header IS header ; |
| 766 : | |||
| 767 : | : noname-header ( -- ) | ||
| 768 : | 0 last ! | ||
| 769 : | input-stream ; | ||
| 770 : | |||
| 771 : | : noname ( -- ) \ general | ||
| 772 : | \ the next defined word remains anonymous. The xt of that word is given by lastxt | ||
| 773 : | ['] noname-header IS header ; | ||
| 774 : | |||
| 775 : | : lastxt ( -- xt ) \ general | ||
| 776 : | \ 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 | ||
| 777 : | lastcfa @ ; | ||
| 778 : | |||
| 779 : | : Alias ( cfa "name" -- ) | ||
| 780 : | Header reveal , $80 flag! ; | ||
| 781 : | |||
| 782 : | : name>string ( nfa -- addr count ) | ||
| 783 : | cell+ count $1F and ; | ||
| 784 : | |||
| 785 : | pazsan | 1.9 | Create ??? 0 , 3 c, char ? c, char ? c, char ? c, |
| 786 : | anton | 1.1 | : >name ( cfa -- nfa ) |
| 787 : | $21 cell do | ||
| 788 : | dup i - count $9F and + aligned over $80 + = if | ||
| 789 : | i - cell - unloop exit | ||
| 790 : | then | ||
| 791 : | cell +loop | ||
| 792 : | drop ??? ( wouldn't 0 be better? ) ; | ||
| 793 : | |||
| 794 : | \ indirect threading 17mar93py | ||
| 795 : | |||
| 796 : | : cfa, ( code-address -- ) | ||
| 797 : | here lastcfa ! | ||
| 798 : | here 0 A, 0 , code-address! ; | ||
| 799 : | : compile, ( xt -- ) A, ; | ||
| 800 : | : !does ( addr -- ) lastcfa @ does-code! ; | ||
| 801 : | : (;code) ( R: addr -- ) r> /does-handler + !does ; | ||
| 802 : | : dodoes, ( -- ) | ||
| 803 : | here /does-handler allot does-handler! ; | ||
| 804 : | |||
| 805 : | \ direct threading is implementation dependent | ||
| 806 : | |||
| 807 : | pazsan | 1.4 | : Create Header reveal [ :dovar ] Literal cfa, ; |
| 808 : | anton | 1.1 | |
| 809 : | \ DOES> 17mar93py | ||
| 810 : | |||
| 811 : | anton | 1.5 | : DOES> ( compilation: -- ) |
| 812 : | state @ | ||
| 813 : | IF | ||
| 814 : | ;-hook postpone (;code) dodoes, | ||
| 815 : | ELSE | ||
| 816 : | dodoes, here !does 0 ] | ||
| 817 : | THEN | ||
| 818 : | :-hook ; immediate | ||
| 819 : | anton | 1.1 | |
| 820 : | \ Create Variable User Constant 17mar93py | ||
| 821 : | |||
| 822 : | : Variable Create 0 , ; | ||
| 823 : | : AVariable Create 0 A, ; | ||
| 824 : | : 2VARIABLE ( "name" -- ) \ double | ||
| 825 : | create 0 , 0 , ; | ||
| 826 : | |||
| 827 : | : User Variable ; | ||
| 828 : | : AUser AVariable ; | ||
| 829 : | |||
| 830 : | pazsan | 1.4 | : (Constant) Header reveal [ :docon ] Literal cfa, ; |
| 831 : | anton | 1.1 | : Constant (Constant) , ; |
| 832 : | : AConstant (Constant) A, ; | ||
| 833 : | anton | 1.5 | |
| 834 : | : 2CONSTANT | ||
| 835 : | create ( w1 w2 "name" -- ) | ||
| 836 : | 2, | ||
| 837 : | does> ( -- w1 w2 ) | ||
| 838 : | 2@ ; | ||
| 839 : | anton | 1.1 | |
| 840 : | \ IS Defer What's Defers TO 24feb93py | ||
| 841 : | |||
| 842 : | anton | 1.5 | : Defer |
| 843 : | Create ( -- ) | ||
| 844 : | ['] noop A, | ||
| 845 : | DOES> ( ??? ) | ||
| 846 : | @ execute ; | ||
| 847 : | anton | 1.1 | |
| 848 : | : IS ( addr "name" -- ) | ||
| 849 : | ' >body | ||
| 850 : | state @ | ||
| 851 : | IF postpone ALiteral postpone ! | ||
| 852 : | ELSE ! | ||
| 853 : | THEN ; immediate | ||
| 854 : | ' IS Alias TO immediate | ||
| 855 : | |||
| 856 : | : What's ( "name" -- addr ) ' >body | ||
| 857 : | state @ IF postpone ALiteral postpone @ ELSE @ THEN ; | ||
| 858 : | immediate | ||
| 859 : | : Defers ( "name" -- ) ' >body @ compile, ; | ||
| 860 : | pazsan | 1.12 | immediate |
| 861 : | anton | 1.1 | |
| 862 : | \ : ; 24feb93py | ||
| 863 : | |||
| 864 : | anton | 1.5 | defer :-hook ( sys1 -- sys2 ) |
| 865 : | defer ;-hook ( sys2 -- sys1 ) | ||
| 866 : | |||
| 867 : | anton | 1.8 | : : ( -- colon-sys ) Header [ :docol ] Literal cfa, defstart ] :-hook ; |
| 868 : | anton | 1.5 | : ; ( colon-sys -- ) ;-hook ?struc postpone exit reveal postpone [ ; |
| 869 : | anton | 1.1 | immediate restrict |
| 870 : | anton | 1.5 | |
| 871 : | anton | 1.10 | : :noname ( -- xt colon-sys ) |
| 872 : | 0 last ! | ||
| 873 : | here [ :docol ] Literal cfa, 0 ] :-hook ; | ||
| 874 : | anton | 1.1 | |
| 875 : | \ Search list handling 23feb93py | ||
| 876 : | |||
| 877 : | AVariable current | ||
| 878 : | |||
| 879 : | : last? ( -- false / nfa nfa ) last @ ?dup ; | ||
| 880 : | anton | 1.5 | : (reveal) ( -- ) |
| 881 : | last? | ||
| 882 : | IF | ||
| 883 : | dup @ 0< | ||
| 884 : | IF | ||
| 885 : | current @ @ over ! current @ ! | ||
| 886 : | ELSE | ||
| 887 : | drop | ||
| 888 : | THEN | ||
| 889 : | THEN ; | ||
| 890 : | anton | 1.1 | |
| 891 : | \ object oriented search list 17mar93py | ||
| 892 : | |||
| 893 : | anton | 1.5 | \ word list structure: |
| 894 : | \ struct | ||
| 895 : | pazsan | 1.7 | \ 1 cells: field find-method \ xt: ( c_addr u wid -- name-id ) |
| 896 : | anton | 1.5 | \ 1 cells: field reveal-method \ xt: ( -- ) |
| 897 : | pazsan | 1.7 | \ 1 cells: field rehash-method \ xt: ( wid -- ) |
| 898 : | anton | 1.5 | \ \ !! what else |
| 899 : | \ end-struct wordlist-map-struct | ||
| 900 : | |||
| 901 : | \ struct | ||
| 902 : | \ 1 cells: field wordlist-id \ not the same as wid; representation depends on implementation | ||
| 903 : | \ 1 cells: field wordlist-map \ pointer to a wordlist-map-struct | ||
| 904 : | pazsan | 1.7 | \ 1 cells: field wordlist-link \ link field to other wordlists |
| 905 : | \ 1 cells: field wordlist-extend \ points to wordlist extensions (eg hash) | ||
| 906 : | anton | 1.5 | \ end-struct wordlist-struct |
| 907 : | |||
| 908 : | pazsan | 1.7 | : f83find ( addr len wordlist -- nfa / false ) @ (f83find) ; |
| 909 : | anton | 1.5 | |
| 910 : | anton | 1.1 | \ Search list table: find reveal |
| 911 : | pazsan | 1.12 | Create f83search ' f83find A, ' (reveal) A, ' drop A, |
| 912 : | pazsan | 1.7 | |
| 913 : | anton | 1.1 | Create forth-wordlist NIL A, G f83search T A, NIL A, NIL A, |
| 914 : | AVariable search G forth-wordlist search T ! | ||
| 915 : | G forth-wordlist current T ! | ||
| 916 : | |||
| 917 : | : (search-wordlist) ( addr count wid -- nfa / false ) | ||
| 918 : | pazsan | 1.7 | dup ( @ swap ) cell+ @ @ execute ; |
| 919 : | anton | 1.1 | |
| 920 : | : search-wordlist ( addr count wid -- 0 / xt +-1 ) | ||
| 921 : | (search-wordlist) dup IF found THEN ; | ||
| 922 : | |||
| 923 : | Variable warnings G -1 warnings T ! | ||
| 924 : | |||
| 925 : | : check-shadow ( addr count wid -- ) | ||
| 926 : | \ prints a warning if the string is already present in the wordlist | ||
| 927 : | \ !! should be refined so the user can suppress the warnings | ||
| 928 : | >r 2dup 2dup r> (search-wordlist) warnings @ and ?dup if | ||
| 929 : | ." redefined " name>string 2dup type | ||
| 930 : | compare 0<> if | ||
| 931 : | ." with " type | ||
| 932 : | else | ||
| 933 : | 2drop | ||
| 934 : | then | ||
| 935 : | space space EXIT | ||
| 936 : | then | ||
| 937 : | 2drop 2drop ; | ||
| 938 : | |||
| 939 : | : find ( addr -- cfa +-1 / string false ) dup | ||
| 940 : | count search @ search-wordlist dup IF rot drop THEN ; | ||
| 941 : | |||
| 942 : | : reveal ( -- ) | ||
| 943 : | last? if | ||
| 944 : | name>string current @ check-shadow | ||
| 945 : | then | ||
| 946 : | current @ cell+ @ cell+ @ execute ; | ||
| 947 : | pazsan | 1.7 | |
| 948 : | : rehash ( wid -- ) dup cell+ @ cell+ cell+ @ execute ; | ||
| 949 : | anton | 1.1 | |
| 950 : | : ' ( "name" -- addr ) name find 0= no.extensions ; | ||
| 951 : | : ['] ( "name" -- addr ) ' postpone ALiteral ; immediate | ||
| 952 : | \ Input 13feb93py | ||
| 953 : | |||
| 954 : | 07 constant #bell | ||
| 955 : | 08 constant #bs | ||
| 956 : | 7F constant #del | ||
| 957 : | 0D constant #cr \ the newline key code | ||
| 958 : | 0A constant #lf | ||
| 959 : | |||
| 960 : | : bell #bell emit ; | ||
| 961 : | |||
| 962 : | : backspaces 0 ?DO #bs emit LOOP ; | ||
| 963 : | : >string ( span addr pos1 -- span addr pos1 addr2 len ) | ||
| 964 : | over 3 pick 2 pick chars /string ; | ||
| 965 : | : type-rest ( span addr pos1 -- span addr pos1 back ) | ||
| 966 : | >string tuck type ; | ||
| 967 : | : (del) ( max span addr pos1 -- max span addr pos2 ) | ||
| 968 : | 1- >string over 1+ -rot move | ||
| 969 : | rot 1- -rot #bs emit type-rest bl emit 1+ backspaces ; | ||
| 970 : | : (ins) ( max span addr pos1 char -- max span addr pos2 ) | ||
| 971 : | >r >string over 1+ swap move 2dup chars + r> swap c! | ||
| 972 : | rot 1+ -rot type-rest 1- backspaces 1+ ; | ||
| 973 : | : ?del ( max span addr pos1 -- max span addr pos2 0 ) | ||
| 974 : | dup IF (del) THEN 0 ; | ||
| 975 : | : (ret) type-rest drop true space ; | ||
| 976 : | : back dup IF 1- #bs emit ELSE #bell emit THEN 0 ; | ||
| 977 : | : forw 2 pick over <> IF 2dup + c@ emit 1+ ELSE #bell emit THEN 0 ; | ||
| 978 : | |||
| 979 : | Create crtlkeys | ||
| 980 : | ] false false back false false false forw false | ||
| 981 : | ?del false (ret) false false (ret) false false | ||
| 982 : | false false false false false false false false | ||
| 983 : | false false false false false false false false [ | ||
| 984 : | |||
| 985 : | : decode ( max span addr pos1 key -- max span addr pos2 flag ) | ||
| 986 : | dup #del = IF drop #bs THEN \ del is rubout | ||
| 987 : | dup bl < IF cells crtlkeys + @ execute EXIT THEN | ||
| 988 : | >r 2over = IF rdrop bell 0 EXIT THEN | ||
| 989 : | r> (ins) 0 ; | ||
| 990 : | |||
| 991 : | \ decode should better use a table for control key actions | ||
| 992 : | \ to define keyboard bindings later | ||
| 993 : | |||
| 994 : | : accept ( addr len -- len ) | ||
| 995 : | dup 0< IF abs over dup 1 chars - c@ tuck type | ||
| 996 : | \ this allows to edit given strings | ||
| 997 : | ELSE 0 THEN rot over | ||
| 998 : | BEGIN key decode UNTIL | ||
| 999 : | 2drop nip ; | ||
| 1000 : | |||
| 1001 : | \ Output 13feb93py | ||
| 1002 : | |||
| 1003 : | DEFER type \ defer type for a output buffer or fast | ||
| 1004 : | \ screen write | ||
| 1005 : | |||
| 1006 : | pazsan | 1.9 | \ : (type) ( addr len -- ) |
| 1007 : | \ bounds ?DO I c@ emit LOOP ; | ||
| 1008 : | anton | 1.1 | |
| 1009 : | ' (TYPE) IS Type | ||
| 1010 : | |||
| 1011 : | pazsan | 1.9 | DEFER Emit |
| 1012 : | anton | 1.1 | |
| 1013 : | pazsan | 1.9 | ' (Emit) IS Emit |
| 1014 : | anton | 1.1 | |
| 1015 : | \ : form ( -- rows cols ) &24 &80 ; | ||
| 1016 : | \ form should be implemented using TERMCAPS or CURSES | ||
| 1017 : | \ : rows form drop ; | ||
| 1018 : | \ : cols form nip ; | ||
| 1019 : | |||
| 1020 : | \ Query 07apr93py | ||
| 1021 : | |||
| 1022 : | : refill ( -- flag ) | ||
| 1023 : | tib /line | ||
| 1024 : | loadfile @ ?dup | ||
| 1025 : | pazsan | 1.12 | IF \ dup file-position throw linestart 2! |
| 1026 : | anton | 1.1 | read-line throw |
| 1027 : | pazsan | 1.12 | ELSE loadline @ 0< IF 2drop false EXIT THEN |
| 1028 : | anton | 1.1 | accept true |
| 1029 : | THEN | ||
| 1030 : | 1 loadline +! | ||
| 1031 : | anton | 1.10 | swap #tib ! 0 >in ! ; |
| 1032 : | anton | 1.1 | |
| 1033 : | anton | 1.10 | : Query ( -- ) 0 loadfile ! refill drop ; |
| 1034 : | anton | 1.1 | |
| 1035 : | \ File specifiers 11jun93jaw | ||
| 1036 : | |||
| 1037 : | |||
| 1038 : | \ 1 c, here char r c, 0 c, 0 c, 0 c, char b c, 0 c, | ||
| 1039 : | \ 2 c, here char r c, char + c, 0 c, | ||
| 1040 : | \ 2 c, here char w c, char + c, 0 c, align | ||
| 1041 : | 4 Constant w/o | ||
| 1042 : | 2 Constant r/w | ||
| 1043 : | 0 Constant r/o | ||
| 1044 : | |||
| 1045 : | \ BIN WRITE-LINE 11jun93jaw | ||
| 1046 : | |||
| 1047 : | \ : bin dup 1 chars - c@ | ||
| 1048 : | \ r/o 4 chars + over - dup >r swap move r> ; | ||
| 1049 : | |||
| 1050 : | : bin 1+ ; | ||
| 1051 : | |||
| 1052 : | create nl$ 1 c, A c, 0 c, \ gnu includes usually a cr in dos | ||
| 1053 : | \ or not unix environments if | ||
| 1054 : | \ bin is not selected | ||
| 1055 : | |||
| 1056 : | : write-line dup >r write-file ?dup IF r> drop EXIT THEN | ||
| 1057 : | nl$ count r> write-file ; | ||
| 1058 : | |||
| 1059 : | \ include-file 07apr93py | ||
| 1060 : | |||
| 1061 : | pazsan | 1.12 | : push-file ( -- ) r> |
| 1062 : | ( linestart 2@ >r >r ) loadline @ >r loadfile @ >r | ||
| 1063 : | blk @ >r >tib @ >r #tib @ dup >r >tib +! >in @ >r >r ; | ||
| 1064 : | |||
| 1065 : | : pop-file ( -- ) r> | ||
| 1066 : | r> >in ! r> #tib ! r> >tib ! r> blk ! | ||
| 1067 : | r> loadfile ! r> loadline ! ( r> r> linestart 2! ) >r ; | ||
| 1068 : | |||
| 1069 : | anton | 1.1 | : include-file ( i*x fid -- j*x ) |
| 1070 : | pazsan | 1.12 | push-file loadfile ! |
| 1071 : | anton | 1.1 | 0 loadline ! blk off |
| 1072 : | BEGIN refill WHILE interpret REPEAT | ||
| 1073 : | loadfile @ close-file throw | ||
| 1074 : | pazsan | 1.12 | pop-file ; |
| 1075 : | anton | 1.1 | |
| 1076 : | : included ( i*x addr u -- j*x ) | ||
| 1077 : | anton | 1.10 | loadfilename 2@ >r >r |
| 1078 : | dup allocate throw over loadfilename 2! | ||
| 1079 : | over loadfilename 2@ move | ||
| 1080 : | r/o open-file throw include-file | ||
| 1081 : | \ don't free filenames; they don't take much space | ||
| 1082 : | \ and are used for debugging | ||
| 1083 : | r> r> loadfilename 2! ; | ||
| 1084 : | anton | 1.1 | |
| 1085 : | \ HEX DECIMAL 2may93jaw | ||
| 1086 : | |||
| 1087 : | : decimal a base ! ; | ||
| 1088 : | : hex 10 base ! ; | ||
| 1089 : | |||
| 1090 : | \ DEPTH 9may93jaw | ||
| 1091 : | |||
| 1092 : | : depth ( -- +n ) sp@ s0 @ swap - cell / ; | ||
| 1093 : | |||
| 1094 : | \ INCLUDE 9may93jaw | ||
| 1095 : | |||
| 1096 : | pazsan | 1.6 | : include ( "file" -- ) |
| 1097 : | bl word count included ; | ||
| 1098 : | anton | 1.1 | |
| 1099 : | \ RECURSE 17may93jaw | ||
| 1100 : | |||
| 1101 : | anton | 1.10 | : recurse ( -- ) |
| 1102 : | lastxt compile, ; immediate restrict | ||
| 1103 : | : recursive ( -- ) | ||
| 1104 : | reveal ; immediate | ||
| 1105 : | anton | 1.1 | |
| 1106 : | \ */MOD */ 17may93jaw | ||
| 1107 : | |||
| 1108 : | anton | 1.13 | \ !! I think */mod should have the same rounding behaviour as / - anton |
| 1109 : | anton | 1.1 | : */mod >r m* r> sm/rem ; |
| 1110 : | |||
| 1111 : | : */ */mod nip ; | ||
| 1112 : | |||
| 1113 : | \ EVALUATE 17may93jaw | ||
| 1114 : | |||
| 1115 : | : evaluate ( c-addr len -- ) | ||
| 1116 : | pazsan | 1.12 | push-file dup #tib ! >tib @ swap move |
| 1117 : | >in off blk off loadfile off -1 loadline ! | ||
| 1118 : | anton | 1.1 | |
| 1119 : | BEGIN interpret >in @ #tib @ u>= UNTIL | ||
| 1120 : | |||
| 1121 : | pazsan | 1.12 | pop-file ; |
| 1122 : | anton | 1.1 | |
| 1123 : | |||
| 1124 : | : abort -1 throw ; | ||
| 1125 : | |||
| 1126 : | \+ environment? true ENV" CORE" | ||
| 1127 : | \ core wordset is now complete! | ||
| 1128 : | |||
| 1129 : | \ Quit 13feb93py | ||
| 1130 : | |||
| 1131 : | Defer 'quit | ||
| 1132 : | Defer .status | ||
| 1133 : | : prompt state @ IF ." compiled" EXIT THEN ." ok" ; | ||
| 1134 : | : (quit) BEGIN .status cr query interpret prompt AGAIN ; | ||
| 1135 : | ' (quit) IS 'quit | ||
| 1136 : | |||
| 1137 : | \ DOERROR (DOERROR) 13jun93jaw | ||
| 1138 : | |||
| 1139 : | anton | 1.10 | : dec. ( n -- ) |
| 1140 : | \ print value in decimal representation | ||
| 1141 : | base @ decimal swap . base ! ; | ||
| 1142 : | |||
| 1143 : | : typewhite ( addr u -- ) | ||
| 1144 : | \ like type, but white space is printed instead of the characters | ||
| 1145 : | 0 ?do | ||
| 1146 : | dup i + c@ 9 = if \ check for tab | ||
| 1147 : | 9 | ||
| 1148 : | else | ||
| 1149 : | bl | ||
| 1150 : | then | ||
| 1151 : | emit | ||
| 1152 : | loop | ||
| 1153 : | drop ; | ||
| 1154 : | |||
| 1155 : | anton | 1.1 | DEFER DOERROR |
| 1156 : | |||
| 1157 : | : (DoError) ( throw-code -- ) | ||
| 1158 : | anton | 1.10 | LoadFile @ |
| 1159 : | IF | ||
| 1160 : | cr loadfilename 2@ type ." :" Loadline @ dec. | ||
| 1161 : | THEN | ||
| 1162 : | cr source type cr | ||
| 1163 : | source drop >in @ -trailing ( throw-code line-start index2 ) | ||
| 1164 : | here c@ 1F min dup >r - 0 max ( throw-code line-start index1 ) | ||
| 1165 : | typewhite | ||
| 1166 : | r> 1 max 0 ?do \ we want at least one "^", even if the length is 0 | ||
| 1167 : | ." ^" | ||
| 1168 : | loop | ||
| 1169 : | dup -2 = | ||
| 1170 : | IF | ||
| 1171 : | "error @ ?dup | ||
| 1172 : | IF | ||
| 1173 : | cr count type | ||
| 1174 : | THEN | ||
| 1175 : | drop | ||
| 1176 : | ELSE | ||
| 1177 : | .error | ||
| 1178 : | THEN | ||
| 1179 : | normal-dp dpp ! ; | ||
| 1180 : | anton | 1.1 | |
| 1181 : | ' (DoError) IS DoError | ||
| 1182 : | |||
| 1183 : | : quit r0 @ rp! handler off >tib @ >r | ||
| 1184 : | anton | 1.5 | BEGIN |
| 1185 : | postpone [ | ||
| 1186 : | ['] 'quit CATCH dup | ||
| 1187 : | WHILE | ||
| 1188 : | DoError r@ >tib ! | ||
| 1189 : | REPEAT | ||
| 1190 : | drop r> >tib ! ; | ||
| 1191 : | anton | 1.1 | |
| 1192 : | \ Cold 13feb93py | ||
| 1193 : | |||
| 1194 : | \ : .name ( name -- ) cell+ count $1F and type space ; | ||
| 1195 : | \ : words listwords @ | ||
| 1196 : | \ BEGIN @ dup WHILE dup .name REPEAT drop ; | ||
| 1197 : | |||
| 1198 : | : >len ( cstring -- addr n ) 100 0 scan 0 swap 100 - /string ; | ||
| 1199 : | : arg ( n -- addr count ) cells argv @ + @ >len ; | ||
| 1200 : | : #! postpone \ ; immediate | ||
| 1201 : | |||
| 1202 : | Variable env | ||
| 1203 : | Variable argv | ||
| 1204 : | Variable argc | ||
| 1205 : | |||
| 1206 : | pazsan | 1.12 | 0 Value script? ( -- flag ) |
| 1207 : | |||
| 1208 : | : ">tib ( addr len -- ) dup #tib ! >in off tib swap move ; | ||
| 1209 : | anton | 1.1 | |
| 1210 : | pazsan | 1.12 | : do-option ( addr1 len1 addr2 len2 -- n ) 2swap |
| 1211 : | 2dup s" -e" compare 0= >r | ||
| 1212 : | 2dup s" -evaluate" compare 0= r> or | ||
| 1213 : | IF 2drop ">tib interpret 2 EXIT THEN | ||
| 1214 : | ." Unknown option: " type cr 2drop 1 ; | ||
| 1215 : | |||
| 1216 : | : process-args ( -- ) argc @ 1 | ||
| 1217 : | ?DO I arg over c@ [char] - <> | ||
| 1218 : | IF true to script? included false to script? 1 | ||
| 1219 : | ELSE I 1+ arg do-option | ||
| 1220 : | THEN | ||
| 1221 : | +LOOP ; | ||
| 1222 : | anton | 1.1 | |
| 1223 : | anton | 1.5 | : cold ( -- ) |
| 1224 : | anton | 1.10 | argc @ 1 > |
| 1225 : | pazsan | 1.12 | IF |
| 1226 : | ['] process-args catch ?dup | ||
| 1227 : | anton | 1.10 | IF |
| 1228 : | pazsan | 1.12 | dup >r DoError cr r> negate (bye) |
| 1229 : | anton | 1.10 | THEN |
| 1230 : | THEN | ||
| 1231 : | anton | 1.13 | cr |
| 1232 : | ." GNU Forth 0.0alpha, Copyright (C) 1994 Free Software Foundation, Inc." cr | ||
| 1233 : | ." GNU Forth comes with ABSOLUTELY NO WARRANTY; for details type `license'" cr | ||
| 1234 : | ." Type `bye' to exit" | ||
| 1235 : | quit ; | ||
| 1236 : | anton | 1.1 | |
| 1237 : | pazsan | 1.12 | : license ( -- ) cr |
| 1238 : | ." This program is free software; you can redistribute it and/or modify" cr | ||
| 1239 : | ." it under the terms of the GNU General Public License as published by" cr | ||
| 1240 : | anton | 1.13 | ." the Free Software Foundation; either version 2 of the License, or" cr |
| 1241 : | ." (at your option) any later version." cr cr | ||
| 1242 : | pazsan | 1.12 | |
| 1243 : | ." This program is distributed in the hope that it will be useful," cr | ||
| 1244 : | ." but WITHOUT ANY WARRANTY; without even the implied warranty of" cr | ||
| 1245 : | ." MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the" cr | ||
| 1246 : | ." GNU General Public License for more details." cr cr | ||
| 1247 : | |||
| 1248 : | ." You should have received a copy of the GNU General Public License" cr | ||
| 1249 : | ." along with this program; if not, write to the Free Software" cr | ||
| 1250 : | ." Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA." cr ; | ||
| 1251 : | |||
| 1252 : | anton | 1.1 | : boot ( **env **argv argc -- ) |
| 1253 : | pazsan | 1.4 | argc ! argv ! env ! main-task up! |
| 1254 : | anton | 1.1 | sp@ dup s0 ! $10 + >tib ! rp@ r0 ! fp@ f0 ! cold ; |
| 1255 : | |||
| 1256 : | pazsan | 1.12 | : bye script? 0= IF cr THEN 0 (bye) ; |
| 1257 : | anton | 1.1 | |
| 1258 : | \ **argv may be scanned by the C starter to get some important | ||
| 1259 : | \ information, as -display and -geometry for an X client FORTH | ||
| 1260 : | \ or space and stackspace overrides | ||
| 1261 : | |||
| 1262 : | \ 0 arg contains, however, the name of the program. |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |