![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to base.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs|
Return to base.fs CVS log | Up to [Qemu by Fabrice Bellard] / qemu / roms / SLOF / slof / fs |
1.1 ! root 1: \ ***************************************************************************** ! 2: \ * Copyright (c) 2004, 2008 IBM Corporation ! 3: \ * All rights reserved. ! 4: \ * This program and the accompanying materials ! 5: \ * are made available under the terms of the BSD License ! 6: \ * which accompanies this distribution, and is available at ! 7: \ * http://www.opensource.org/licenses/bsd-license.php ! 8: \ * ! 9: \ * Contributors: ! 10: \ * IBM Corporation - initial implementation ! 11: \ ****************************************************************************/ ! 12: ! 13: \ Hash for faster lookup ! 14: #include <find-hash.fs> ! 15: ! 16: : >name ( xt -- nfa ) \ note: still has the "immediate" field! ! 17: BEGIN char- dup c@ UNTIL ( @lastchar ) ! 18: dup dup aligned - cell+ char- ( @lastchar lenmodcell ) ! 19: dup >r - ! 20: BEGIN dup c@ r@ <> WHILE ! 21: cell- r> cell+ >r ! 22: REPEAT ! 23: r> drop char- ! 24: ; ! 25: ! 26: \ Words missing in *.in files ! 27: VARIABLE mask -1 mask ! ! 28: ! 29: VARIABLE huge-tftp-load 1 huge-tftp-load ! ! 30: \ Default implementation for sms-get-tftp-blocksize that return 1432 (decimal) ! 31: : sms-get-tftp-blocksize 598 ; ! 32: ! 33: : default-hw-exception s" Exception #" type . ; ! 34: ! 35: ' default-hw-exception to hw-exception-handler ! 36: ! 37: : diagnostic-mode? false ; \ 2B DOTICK'D later in envvar.fs ! 38: ! 39: : memory-test-suite ( addr len -- fail? ) ! 40: diagnostic-mode? IF ! 41: ." Memory test mask value: " mask @ . cr ! 42: ." No memory test suite currently implemented! " cr ! 43: THEN ! 44: false ! 45: ; ! 46: ! 47: : 0.r 0 swap <# 0 ?DO # LOOP #> type ; ! 48: ! 49: \ count the number of bits equal 1 ! 50: \ the idea is to clear in each step the least significant bit ! 51: \ v&(v-1) does exactly this, so count the steps until v == 0 ! 52: : cnt-bits ( 64-bit-value -- #bits=1 ) ! 53: dup IF ! 54: 41 1 DO dup 1- and dup 0= IF drop i LEAVE THEN LOOP ! 55: THEN ! 56: ; ! 57: ! 58: : bcd-to-bin ( bcd -- bin ) ! 59: dup f and swap 4 rshift a * + ! 60: ; ! 61: ! 62: \ calcs the exponent of the highest power of 2 not greater than n ! 63: : 2log ( n -- lb{n} ) ! 64: 8 cells 0 DO 1 rshift dup 0= IF drop i LEAVE THEN LOOP ! 65: ; ! 66: ! 67: \ calcs the exponent of the lowest power of 2 not less than n ! 68: : log2 ( n -- log2-n ) ! 69: 1- 2log 1+ ! 70: ; ! 71: ! 72: \ Standard compliant $find ! 73: : $find ( str len -- xt true | str len false ) ! 74: 2dup $find ! 75: IF ! 76: drop nip nip TRUE ! 77: ELSE ! 78: FALSE ! 79: THEN ! 80: ; ! 81: ! 82: CREATE $catpad 100 allot ! 83: : $cat ( str1 len1 str2 len2 -- str3 len3 ) ! 84: >r >r dup >r $catpad swap move ! 85: r> dup $catpad + r> swap r@ move ! 86: r> + $catpad swap ; ! 87: ! 88: \ WARNING: The following two ($cat-comm & $cat-space) are dirty in a sense ! 89: \ that they add 1 or 2 characters to str1 before executing $cat ! 90: \ The ASSUMPTION is that str1 buffer provides that extra space and it is ! 91: \ responsibility of the code owner to ensure that ! 92: : $cat-comma ( str2 len2 str1 len1 -- "str1, str2" len1+len2+2 ) ! 93: 2dup + s" , " rot swap move 2+ 2swap $cat ! 94: ; ! 95: ! 96: : $cat-space ( str2 len2 str1 len1 -- "str1 str2" len1+len2+1 ) ! 97: 2dup + bl swap c! 1+ 2swap $cat ! 98: ; ! 99: : $cathex ( str len val -- str len' ) ! 100: (u.) $cat ! 101: ; ! 102: ! 103: ! 104: ! 105: : 2CONSTANT CREATE , , DOES> 2@ ; ! 106: : $2CONSTANT $CREATE , , DOES> 2@ ; ! 107: : 2VARIABLE CREATE 0 , 0 , DOES> ; ! 108: ! 109: : (is-user-word) ( name-str name-len xt -- ) -rot $CREATE , DOES> @ execute ; ! 110: ! 111: : zplace ( str len buf -- ) 2dup + 0 swap c! swap move ; ! 112: : rzplace ( str len buf -- ) 2dup + 0 swap rb! swap rmove ; ! 113: ! 114: : strdup ( str len -- dupstr len ) here over allot swap 2dup 2>r move 2r> ; ! 115: ! 116: : str= ( str1 len1 str2 len2 -- equal? ) ! 117: rot over <> IF 3drop false ELSE comp 0= THEN ; ! 118: ! 119: : #aligned ( adr alignment -- adr' ) negate swap negate and negate ; ! 120: : #join ( lo hi #bits -- x ) lshift or ; ! 121: : #split ( x #bits -- lo hi ) 2dup rshift dup >r swap lshift xor r> ; ! 122: ! 123: : /string ( str len u -- str' len' ) ! 124: >r swap r@ chars + swap r> - ; ! 125: : skip ( str len c -- str' len' ) ! 126: >r BEGIN dup WHILE over c@ r@ = WHILE 1 /string REPEAT THEN r> drop ; ! 127: : scan ( str len c -- str' len' ) ! 128: >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN r> drop ; ! 129: : split ( str len char -- left len right len ) ! 130: >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ; ! 131: \ reverse findchar -- search from the end of the string ! 132: : rfindchar ( str len char -- offs true | false ) ! 133: swap 1 - 0 swap do ! 134: over i + c@ ! 135: over dup bl = if <= else = then if ! 136: 2drop i dup dup leave ! 137: then ! 138: -1 +loop = ! 139: ; ! 140: \ reverse split -- split at the last occurence of char ! 141: : rsplit ( str len char -- left len right len ) ! 142: >r 2dup r> rfindchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ; ! 143: ! 144: : left-parse-string ( str len char -- R-str R-len L-str L-len ) ! 145: split 2swap ; ! 146: : replace-char ( str len chout chin -- ) ! 147: >r -rot BEGIN 2dup 4 pick findchar WHILE tuck - -rot + r@ over c! swap REPEAT ! 148: r> 2drop 2drop ! 149: ; ! 150: \ Duplicate string and replace \ with / ! 151: : \-to-/ ( str len -- str' len ) strdup 2dup [char] \ [char] / replace-char ; ! 152: ! 153: : // dup >r 1- + r> / ; \ division, round up ! 154: ! 155: : c@+ ( adr -- c adr' ) dup c@ swap char+ ; ! 156: : 2c@ ( adr -- c1 c2 ) c@+ c@ ; ! 157: : 4c@ ( adr -- c1 c2 c3 c4 ) c@+ c@+ c@+ c@ ; ! 158: : 8c@ ( adr -- c1 c2 c3 c4 c5 c6 c7 c8 ) c@+ c@+ c@+ c@+ c@+ c@+ c@+ c@ ; ! 159: ! 160: ! 161: : 4dup ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 ) 2over 2over ; ! 162: : 4drop ( n1 n2 n3 n4 -- ) 2drop 2drop ; ! 163: ! 164: \ yes sometimes even something like this is needed ! 165: : 6dup ( 1 2 3 4 5 6 -- 1 2 3 4 5 6 1 2 3 4 5 6 ) ! 166: 5 pick 5 pick 5 pick 5 pick 5 pick 5 pick ! 167: ; ! 168: ! 169: \ convert a 32 bit signed into a 64 signed ! 170: \ ( propagate bit 31 to all bits 32:63 ) ! 171: : signed ( n1 -- n2 ) dup 80000000 and IF FFFFFFFF00000000 or THEN ; ! 172: ! 173: : <l@ ( addr -- x ) l@ signed ; ! 174: ! 175: : -leading BEGIN dup WHILE over c@ bl <= WHILE 1 /string REPEAT THEN ; ! 176: : (parse-line) skipws 0 parse ; ! 177: ! 178: ! 179: \ Append two character to hex byte, if possible ! 180: ! 181: : hex-byte ( char0 char1 -- value true|false ) ! 182: 10 digit IF ! 183: swap 10 digit IF ! 184: 4 lshift or true EXIT ! 185: ELSE ! 186: 2drop 0 ! 187: THEN ! 188: ELSE ! 189: drop ! 190: THEN ! 191: false EXIT ! 192: ; ! 193: ! 194: \ Parse hex string within brackets ! 195: ! 196: : parse-hexstring ( dst-adr -- dst-adr' ) ! 197: [char] ) parse cr ( dst-adr str len ) ! 198: bounds ?DO ( dst-adr ) ! 199: i c@ i 1+ c@ hex-byte IF ( dst-adr hex-byte ) ! 200: >r dup r> swap c! 1+ 2 ( dst-adr+1 2 ) ! 201: ELSE ! 202: drop 1 ( dst-adr 1 ) ! 203: THEN ! 204: +LOOP ! 205: ; ! 206: ! 207: \ Add special character to string ! 208: ! 209: : add-specialchar ( dst-adr special -- dst-adr' ) ! 210: over c! 1+ ( dst-adr' ) ! 211: 1 >in +! \ advance input-index ! 212: ; ! 213: ! 214: \ Parse upto next " ! 215: ! 216: : parse-" ( dst-adr -- dst-adr' ) ! 217: [char] " parse dup 3 pick + >r ( dst-adr str len R: dst-adr' ) ! 218: >r swap r> move r> ( dst-adr' ) ! 219: ; ! 220: ! 221: : (") ( dst-adr -- dst-adr' ) ! 222: begin ( dst-adr ) ! 223: parse-" ( dst-adr' ) ! 224: >in @ dup span @ >= IF ( dst-adr' >in-@ ) ! 225: drop ! 226: EXIT ! 227: THEN ! 228: ! 229: ib + c@ ! 230: CASE ! 231: [char] ( OF parse-hexstring ENDOF ! 232: [char] " OF [char] " add-specialchar ENDOF ! 233: dup OF EXIT ENDOF ! 234: ENDCASE ! 235: again ! 236: ; ! 237: ! 238: CREATE "pad 100 allot ! 239: ! 240: \ String with embedded hex strings ! 241: \ Example: " ba"( 12 34,4567)ab" -> >x62x61x12x34x45x67x61x62< ! 242: ! 243: : " ( [text<">< >] -- text-str text-len ) ! 244: state @ IF \ compile sliteral, pstr into dict ! 245: "pad dup (") over - ( str len ) ! 246: ['] sliteral compile, dup c, ( str len ) ! 247: bounds ?DO i c@ c, LOOP ! 248: align ['] count compile, ! 249: ELSE ! 250: pocket dup (") over - \ Interpretation, put string ! 251: THEN \ in temp buffer ! 252: ; immediate ! 253: ! 254: \ Remove command old-name and all subsequent definitions ! 255: ! 256: : $forget ( str len -- ) ! 257: 2dup last @ ( str len str len last-bc ) ! 258: BEGIN ! 259: dup >r ( str len str len last-bc R: last-bc ) ! 260: cell+ char+ count ( str len str len found-str found-len R: last-bc ) ! 261: string=ci IF ( str len R: last-bc ) ! 262: r> @ last ! 2drop clean-hash EXIT ( -- ) ! 263: THEN ! 264: 2dup r> @ dup 0= ( str len str len next-bc next-bc ) ! 265: UNTIL ! 266: drop 2drop 2drop \ clean hash table ! 267: ; ! 268: ! 269: : forget ( "old-name<>" -- ) ! 270: parse-word $forget ! 271: ; ! 272: ! 273: #include <search.fs> ! 274: ! 275: \ The following constants are required in some parts ! 276: \ of the code, mainly instance variables and see. Having to reverse ! 277: \ engineer our own CFAs seems somewhat weird, but we gained a bit speed. ! 278: ! 279: \ Each colon definition is surrounded by colon and semicolon ! 280: \ constant below contain address of their xt ! 281: ! 282: : (function) ; ! 283: defer (defer) ! 284: 0 value (value) ! 285: 0 constant (constant) ! 286: variable (variable) ! 287: create (create) ! 288: alias (alias) (function) ! 289: cell buffer: (buffer:) ! 290: ! 291: ' (function) @ \ ( <colon> ) ! 292: ' (function) cell + @ \ ( ... <semicolon> ) ! 293: ' (defer) @ \ ( ... <defer> ) ! 294: ' (value) @ \ ( ... <value> ) ! 295: ' (constant) @ \ ( ... <constant> ) ! 296: ' (variable) @ \ ( ... <variable> ) ! 297: ' (create) @ \ ( ... <create> ) ! 298: ' (alias) @ \ ( ... <alias> ) ! 299: ' (buffer:) @ \ ( ... <buffer:> ) ! 300: ! 301: \ now clean up the test functions ! 302: forget (function) ! 303: ! 304: \ and remember the constants ! 305: constant <buffer:> ! 306: constant <alias> ! 307: constant <create> ! 308: constant <variable> ! 309: constant <constant> ! 310: constant <value> ! 311: constant <defer> ! 312: constant <semicolon> ! 313: constant <colon> ! 314: ! 315: ' lit constant <lit> ! 316: ' sliteral constant <sliteral> ! 317: ' 0branch constant <0branch> ! 318: ' branch constant <branch> ! 319: ' doloop constant <doloop> ! 320: ' dotick constant <dotick> ! 321: ' doto constant <doto> ! 322: ' do?do constant <do?do> ! 323: ' do+loop constant <do+loop> ! 324: ' do constant <do> ! 325: ' exit constant <exit> ! 326: ' doleave constant <doleave> ! 327: ' do?leave constant <do?leave> ! 328: ! 329: ! 330: \ provide the memory management words ! 331: \ #include <claim.fs> ! 332: \ #include "memory.fs" ! 333: #include <alloc-mem.fs> ! 334: ! 335: #include <node.fs> ! 336: ! 337: : find-substr ( basestr-ptr basestr-len substr-ptr substr-len -- pos ) ! 338: \ if substr-len == 0 ? ! 339: dup 0 = IF ! 340: \ return 0 ! 341: 2drop 2drop 0 exit THEN ! 342: \ if substr-len <= basestr-len ? ! 343: dup 3 pick <= IF ! 344: \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1 ! 345: 2 pick over - 1+ 0 DO dup 0 DO ! 346: \ substr-ptr[i] == basestr-ptr[j+i] ? ! 347: over i + c@ 4 pick j + i + c@ = IF ! 348: \ (I+1) == substr-len ? ! 349: dup i 1+ = IF ! 350: \ return J ! 351: 2drop 2drop j unloop unloop exit THEN ! 352: ELSE leave THEN ! 353: LOOP LOOP ! 354: THEN ! 355: \ if there is no match then exit with basestr-len as return value ! 356: 2drop nip ! 357: ; ! 358: ! 359: : find-isubstr ( basestr-ptr basestr-len substr-ptr substr-len -- pos ) ! 360: \ if substr-len == 0 ? ! 361: dup 0 = IF ! 362: \ return 0 ! 363: 2drop 2drop 0 exit THEN ! 364: \ if substr-len <= basestr-len ? ! 365: dup 3 pick <= IF ! 366: \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1 ! 367: 2 pick over - 1+ 0 DO dup 0 DO ! 368: \ substr-ptr[i] == basestr-ptr[j+i] ? ! 369: over i + c@ lcc 4 pick j + i + c@ lcc = IF ! 370: \ (I+1) == substr-len ? ! 371: dup i 1+ = IF ! 372: \ return J ! 373: 2drop 2drop j unloop unloop exit THEN ! 374: ELSE leave THEN ! 375: LOOP LOOP ! 376: THEN ! 377: \ if there is no match then exit with basestr-len as return value ! 378: 2drop nip ! 379: ; ! 380: ! 381: : find-nextline ( str-ptr str-len -- pos ) ! 382: \ run I from 0 to "str-len"-1 and check str-ptr[i] ! 383: dup 0 ?DO over i + c@ CASE ! 384: \ 0x0a (=LF) found ? ! 385: 0a OF ! 386: \ if current cursor is at end position (I == "str-len"-1) ? ! 387: dup 1- i = IF ! 388: \ return I+1 ! 389: 2drop i 1+ unloop exit THEN ! 390: \ if str-ptr[I+1] == 0x0d (=CR) ? ! 391: over i 1+ + c@ 0d = IF ! 392: \ return I+2 ! 393: 2drop i 2+ ELSE ! 394: \ else return I+1 ! 395: 2drop i 1+ THEN ! 396: unloop exit ! 397: ENDOF ! 398: \ 0x0d (=CR) found ? ! 399: 0d OF ! 400: \ if current cursor is at end position (I == "str-len"-1) ? ! 401: dup 1- i = IF ! 402: \ return I+1 ! 403: 2drop i 1+ unloop exit THEN ! 404: \ str-ptr[I+1] == 0x0a (=LF) ? ! 405: over i 1+ + c@ 0a = IF ! 406: \ return I+2 ! 407: 2drop i 2+ ELSE ! 408: \ return I+1 ! 409: 2drop i 1+ THEN ! 410: unloop exit ! 411: ENDOF ! 412: ENDCASE LOOP nip ! 413: ; ! 414: ! 415: : string-at ( str1-ptr str1-len pos -- str2-ptr str2-len ) ! 416: -rot 2 pick - -rot swap chars + swap ! 417: ; ! 418: ! 419: \ appends the string beginning at addr2 to the end of the string ! 420: \ beginning at addr1 ! 421: \ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!! ! 422: \ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!! ! 423: ! 424: : string-cat ( addr1 len1 addr2 len2 -- addr1 len1+len2 ) ! 425: \ len1 := len1+len2 ! 426: rot dup >r over + -rot ! 427: ( addr1 len1+len2 dest-ptr src-ptr len2 ) ! 428: 3 pick r> chars + -rot ! 429: ( ... dest-ptr src-ptr ) ! 430: 0 ?DO ! 431: 2dup c@ swap c! ! 432: char+ swap char+ swap ! 433: LOOP 2drop ! 434: ; ! 435: ! 436: \ appends a character to the end of the string beginning at addr ! 437: \ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!! ! 438: \ !!! BEGINNING AT ADDR1 (cp. 'strcat' in 'C' ) !!! ! 439: ! 440: : char-cat ( addr len character -- addr len+1 ) ! 441: -rot 2dup >r >r 1+ rot r> r> chars + c! ! 442: ; ! 443: ! 444: \ Returns true if source and destination overlap ! 445: : overlap ( src dest size -- true|false ) ! 446: 3dup over + within IF 3drop true ELSE rot tuck + within THEN ! 447: ; ! 448: ! 449: : parse-2int ( str len -- val.lo val.hi ) ! 450: \ ." parse-2int ( " 2dup swap . . ." -- " ! 451: [char] , split ?dup IF eval ELSE drop 0 THEN ! 452: -rot ?dup IF eval ELSE drop 0 THEN ! 453: \ 2dup swap . . ." )" cr ! 454: ; ! 455: ! 456: \ peek/poke minimal implementation, just to support FCode drivers ! 457: \ Any implmentation with full error detection will be platform specific ! 458: : cpeek ( addr -- false | byte true ) c@ true ; ! 459: : cpoke ( byte addr -- success? ) c! true ; ! 460: : wpeek ( addr -- false | word true ) w@ true ; ! 461: : wpoke ( word addr -- success? ) w! true ; ! 462: : lpeek ( addr -- false | lword true ) l@ true ; ! 463: : lpoke ( lword addr -- success? ) l! true ; ! 464: ! 465: defer reboot ( -- ) ! 466: defer halt ( -- ) ! 467: defer disable-watchdog ( -- ) ! 468: defer reset-watchdog ( -- ) ! 469: defer set-watchdog ( +n -- ) ! 470: defer set-led ( type instance state -- status ) ! 471: defer get-flashside ( -- side ) ! 472: defer set-flashside ( side -- status ) ! 473: defer read-bootlist ( -- ) ! 474: defer furnish-boot-file ( -- adr len ) ! 475: defer set-boot-file ( adr len -- ) ! 476: defer mfg-mode? ( -- flag ) ! 477: defer of-prompt? ( -- flag ) ! 478: defer debug-boot? ( -- flag ) ! 479: defer bmc-version ( -- adr len ) ! 480: defer cursor-on ( -- ) ! 481: defer cursor-off ( -- ) ! 482: ! 483: : nop-reboot ( -- ) ." reboot not available" abort ; ! 484: : nop-halt ( -- ) ." halt not available" abort ; ! 485: : nop-disable-watchdog ( -- ) ; ! 486: : nop-reset-watchdog ( -- ) ; ! 487: : nop-set-watchdog ( +n -- ) drop ; ! 488: : nop-set-led ( type instance state -- status ) drop drop drop ; ! 489: : nop-get-flashside ( -- side ) ." Cannot get flashside" cr ABORT ; ! 490: : nop-set-flashside ( side -- status ) ." Cannot set flashside" cr ABORT ; ! 491: : nop-read-bootlist ( -- ) ; ! 492: : nop-furnish-bootfile ( -- adr len ) s" net:" ; ! 493: : nop-set-boot-file ( adr len -- ) 2drop ; ! 494: : nop-mfg-mode? ( -- flag ) false ; ! 495: : nop-of-prompt? ( -- flag ) false ; ! 496: : nop-debug-boot? ( -- flag ) false ; ! 497: : nop-bmc-version ( -- adr len ) s" XXXXX" ; ! 498: : nop-cursor-on ( -- ) ; ! 499: : nop-cursor-off ( -- ) ; ! 500: ! 501: ' nop-reboot to reboot ! 502: ' nop-halt to halt ! 503: ' nop-disable-watchdog to disable-watchdog ! 504: ' nop-reset-watchdog to reset-watchdog ! 505: ' nop-set-watchdog to set-watchdog ! 506: ' nop-set-led to set-led ! 507: ' nop-get-flashside to get-flashside ! 508: ' nop-set-flashside to set-flashside ! 509: ' nop-read-bootlist to read-bootlist ! 510: ' nop-furnish-bootfile to furnish-boot-file ! 511: ' nop-set-boot-file to set-boot-file ! 512: ' nop-mfg-mode? to mfg-mode? ! 513: ' nop-of-prompt? to of-prompt? ! 514: ' nop-debug-boot? to debug-boot? ! 515: ' nop-bmc-version to bmc-version ! 516: ' nop-cursor-on to cursor-on ! 517: ' nop-cursor-off to cursor-off ! 518: ! 519: : reset-all reboot ; ! 520: ! 521: \ Load base ! 522: 10000000 value load-base ! 523: 2000000 value flash-load-base ! 524: ! 525: \ provide first level debug support ! 526: #include "debug.fs" ! 527: \ provide 7.5.3.1 Dictionary search ! 528: #include "dictionary.fs" ! 529: \ block data access for IO devices - ought to be implemented in engine ! 530: #include "rmove.fs" ! 531: \ provide a simple run time preprocessor ! 532: #include <preprocessor.fs> ! 533: ! 534: : $dnumber base @ >r decimal $number r> base ! ; ! 535: : (.d) base @ >r decimal (.) r> base ! ; ! 536: ! 537: \ IP address conversion ! 538: ! 539: : (ipaddr) ( "a.b.c.d" -- FALSE | n1 n2 n3 n4 TRUE ) ! 540: base @ >r decimal ! 541: over s" 000.000.000.000" comp 0= IF 2drop false r> base ! EXIT THEN ! 542: [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot ! 543: [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot ! 544: [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot ! 545: $number IF false r> base ! EXIT THEN ! 546: true r> base ! ! 547: ; ! 548: ! 549: : (ipformat) ( n1 n2 n3 n4 -- str len ) ! 550: base @ >r decimal ! 551: 0 <# # # # [char] . hold drop # # # [char] . hold ! 552: drop # # # [char] . hold drop # # #s #> ! 553: r> base ! ! 554: ; ! 555: ! 556: : ipformat ( n1 n2 n3 n4 -- ) (ipformat) type ; ! 557: ! 558:
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.