qemu/roms/SLOF/slof/fs/base.fs

   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
  73 CREATE $catpad 400 allot
  74 : $cat ( str1 len1 str2 len2 -- str3 len3 )
  75    >r >r dup >r $catpad swap move
  76    r> dup $catpad + r> swap r@ move
  77    r> + $catpad swap ;
  78
  79 \ WARNING: The following two ($cat-comm & $cat-space) are dirty in a sense
  80 \ that they add 1 or 2 characters to str1 before executing $cat
  81 \ The ASSUMPTION is that str1 buffer provides that extra space and it is
  82 \ responsibility of the code owner to ensure that
  83 : $cat-comma ( str2 len2 str1 len1 -- "str1, str2" len1+len2+2 )
  84         2dup + s" , " rot swap move 2+ 2swap $cat
  85 ;
  86
  87 : $cat-space ( str2 len2 str1 len1 -- "str1 str2" len1+len2+1 )
  88         2dup + bl swap c! 1+ 2swap $cat
  89 ;
  90 : $cathex ( str len val -- str len' )
  91    (u.) $cat
  92 ;
  93
  94
  95 : 2CONSTANT    CREATE , , DOES> [ here ] 2@ ;
  96
  97 \ Save XT of 2CONSTANT, put on the stack by "[ here ]" :
  98 CONSTANT <2constant>
  99
 100 : $2CONSTANT  $CREATE , , DOES> 2@ ;
 101
 102 : 2VARIABLE    CREATE 0 , 0 ,  DOES> ;
 103
 104
 105 : (is-user-word) ( name-str name-len xt -- ) -rot $CREATE , DOES> @ execute ;
 106
 107 : zplace ( str len buf -- )  2dup + 0 swap c! swap move ;
 108 : rzplace ( str len buf -- )  2dup + 0 swap rb! swap rmove ;
 109
 110 : strdup ( str len -- dupstr len ) here over allot swap 2dup 2>r move 2r> ;
 111
 112 : str= ( str1 len1 str2 len2 -- equal? )
 113   rot over <> IF 3drop false ELSE comp 0= THEN ;
 114
 115 : test-string ( param len -- true | false )
 116    0 ?DO
 117       dup i + c@                     \ Get character / byte at current index
 118       dup 20 <  swap 7e >  OR IF     \ Is it out of range 32 to 126 (=ASCII)
 119          drop FALSE UNLOOP EXIT      \ FALSE means: No ASCII string
 120       THEN
 121    LOOP
 122    drop TRUE    \ Only ASCII found --> it is a string
 123 ;
 124
 125 : #aligned ( adr alignment -- adr' ) negate swap negate and negate ;
 126 : #join  ( lo hi #bits -- x )  lshift or ;
 127 : #split ( x #bits -- lo hi )  2dup rshift dup >r swap lshift xor r> ;
 128
 129 : /string ( str len u -- str' len' )
 130   >r swap r@ chars + swap r> - ;
 131 : skip ( str len c -- str' len' )
 132   >r BEGIN dup WHILE over c@ r@ = WHILE 1 /string REPEAT THEN r> drop ;
 133 : scan ( str len c -- str' len' )
 134   >r BEGIN dup WHILE over c@ r@ <> WHILE 1 /string REPEAT THEN r> drop ;
 135 : split ( str len char -- left len right len )
 136   >r 2dup r> findchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
 137 \ reverse findchar -- search from the end of the string
 138 : rfindchar ( str len char -- offs true | false )
 139    swap 1 - 0 swap do
 140       over i + c@
 141       over dup bl = if <= else = then if
 142          2drop i dup dup leave
 143       then
 144    -1 +loop =
 145 ;
 146 \ reverse split -- split at the last occurrence of char
 147 : rsplit ( str len char -- left len right len )
 148   >r 2dup r> rfindchar IF >r over r@ 2swap r> 1+ /string ELSE 0 0 THEN ;
 149
 150 : left-parse-string ( str len char -- R-str R-len L-str L-len )
 151   split 2swap ;
 152 : replace-char ( str len chout chin -- )
 153   >r -rot BEGIN 2dup 4 pick findchar WHILE tuck - -rot + r@ over c! swap REPEAT
 154   r> 2drop 2drop
 155 ;
 156 \ Duplicate string and replace \ with /
 157 : \-to-/ ( str len -- str' len ) strdup 2dup [char] \ [char] / replace-char ;
 158
 159 : isdigit ( char -- true | false )
 160    30 39 between
 161 ;
 162
 163 : ishexdigit ( char -- true | false )
 164    30 39 between 41 46 between OR 61 66 between OR
 165 ;
 166
 167 \ Variant of $number that defaults to decimal unless "0x" is
 168 \ a prefix
 169 : $dh-number ( addr len -- true | number false )
 170    base @ >r
 171    decimal
 172    dup 2 > IF
 173        over dup c@ [char] 0 =
 174        over 1 + c@ 20 or [char] x =
 175        AND IF hex 2 + swap 2 - rot THEN drop
 176    THEN
 177    $number
 178    r> base !
 179 ;
 180
 181 : //  dup >r 1- + r> / ; \ division, round up
 182
 183 : c@+ ( adr -- c adr' )  dup c@ swap char+ ;
 184 : 2c@ ( adr -- c1 c2 )  c@+ c@ ;
 185 : 4c@ ( adr -- c1 c2 c3 c4 )  c@+ c@+ c@+ c@ ;
 186 : 8c@ ( adr -- c1 c2 c3 c4 c5 c6 c7 c8 )  c@+ c@+ c@+ c@+ c@+ c@+ c@+ c@ ;
 187
 188
 189 : 4dup  ( n1 n2 n3 n4 -- n1 n2 n3 n4 n1 n2 n3 n4 )  2over 2over ;
 190 : 4drop  ( n1 n2 n3 n4 -- )  2drop 2drop ;
 191
 192 \ yes sometimes even something like this is needed
 193 : 5dup  ( 1 2 3 4 5 -- 1 2 3 4 5 1 2 3 4 5 )
 194    4 pick 4 pick 4 pick 4 pick 4 pick ;
 195 : 5drop 4drop drop ;
 196 : 5nip
 197   nip nip nip nip nip ;
 198
 199 : 6dup  ( 1 2 3 4 5 6 -- 1 2 3 4 5 6 1 2 3 4 5 6 )
 200    5 pick 5 pick 5 pick 5 pick 5 pick 5 pick ;
 201
 202 \ convert a 32 bit signed into a 64 signed
 203 \ ( propagate bit 31 to all bits 32:63 )
 204 : signed ( n1 -- n2 ) dup 80000000 and IF FFFFFFFF00000000 or THEN ;
 205
 206 : <l@ ( addr -- x ) l@ signed ;
 207
 208 : -leading  BEGIN dup WHILE over c@ bl <= WHILE 1 /string REPEAT THEN ;
 209 : (parse-line)  skipws 0 parse ;
 210
 211
 212 \ Append two character to hex byte, if possible
 213
 214 : hex-byte ( char0 char1 -- value true|false )
 215    10 digit IF
 216       swap 10 digit IF
 217          4 lshift or true EXIT
 218       ELSE
 219          2drop 0
 220       THEN
 221    ELSE
 222       drop
 223    THEN
 224    false EXIT
 225 ;
 226
 227 \ Parse hex string within brackets
 228
 229 : parse-hexstring ( dst-adr -- dst-adr' )
 230    [char] ) parse cr                 ( dst-adr str len )
 231    bounds ?DO                        ( dst-adr )
 232       i c@ i 1+ c@ hex-byte IF       ( dst-adr hex-byte )
 233          >r dup r> swap c! 1+ 2      ( dst-adr+1 2 )
 234       ELSE
 235          drop 1                      ( dst-adr 1 )
 236       THEN
 237    +LOOP
 238 ;
 239
 240 \ Add special character to string
 241
 242 : add-specialchar ( dst-adr special -- dst-adr' )
 243    over c! 1+                        ( dst-adr' )
 244    1 >in +!                          \ advance input-index
 245 ;
 246
 247 \ Parse up to next "
 248
 249 : parse-" ( dst-adr -- dst-adr' )
 250    [char] " parse dup 3 pick + >r    ( dst-adr str len R: dst-adr' )
 251    >r swap r> move r>                ( dst-adr' )
 252 ;
 253
 254 : (") ( dst-adr -- dst-adr' )
 255    begin                             ( dst-adr )
 256       parse-"                        ( dst-adr' )
 257       >in @ dup span @ >= IF         ( dst-adr' >in-@ )
 258          drop
 259          EXIT
 260       THEN
 261
 262       ib + c@
 263       CASE
 264          [char] ( OF parse-hexstring ENDOF
 265          [char] " OF [char] " add-specialchar ENDOF
 266          dup      OF EXIT ENDOF
 267       ENDCASE
 268    again
 269 ;
 270
 271 CREATE "pad 100 allot
 272
 273 \ String with embedded hex strings
 274 \ Example: " ba"( 12 34,4567)ab" -> >x62x61x12x34x45x67x61x62<
 275
 276 : " ( [text<">< >] -- text-str text-len )
 277    state @ IF                        \ compile sliteral, pstr into dict
 278       "pad dup (") over -            ( str len )
 279       ['] sliteral compile, dup c,   ( str len )
 280       bounds ?DO i c@ c, LOOP
 281       align ['] count compile,
 282    ELSE
 283       pocket dup (") over -          \ Interpretation, put string
 284    THEN                              \ in temp buffer
 285 ; immediate
 286
 287
 288 \ Output the carriage-return character
 289 : (cr carret emit ;
 290
 291
 292 \ Remove command old-name and all subsequent definitions
 293
 294 : $forget ( str len -- )
 295    2dup last @            ( str len str len last-bc )
 296    BEGIN
 297       dup >r             ( str len str len last-bc R: last-bc )
 298       cell+ char+ count  ( str len str len found-str found-len R: last-bc )
 299       string=ci IF       ( str len R: last-bc )
 300          r> @ last ! 2drop clean-hash EXIT ( -- )
 301       THEN
 302       2dup r> @ dup 0=   ( str len str len next-bc next-bc )
 303    UNTIL
 304    drop 2drop 2drop            \ clean hash table
 305 ;
 306
 307 : forget ( "old-name<>" -- )
 308     parse-word $forget
 309 ;
 310
 311 #include <search.fs>
 312
 313 \ The following constants are required in some parts
 314 \ of the code, mainly instance variables and see. Having to reverse
 315 \ engineer our own CFAs seems somewhat weird, but we gained a bit speed.
 316
 317 \ Each colon definition is surrounded by colon and semicolon
 318 \ constant below contain address of their xt
 319
 320 : (function) ;
 321 defer (defer)
 322 0 value (value)
 323 0 constant (constant)
 324 variable (variable)
 325 create (create)
 326 alias (alias) (function)
 327 cell buffer: (buffer:)
 328
 329 ' (function) @        \ ( <colon> )
 330 ' (function) cell + @ \ ( ... <semicolon> )
 331 ' (defer) @           \ ( ... <defer> )
 332 ' (value) @           \ ( ... <value> )
 333 ' (constant) @        \ ( ... <constant> )
 334 ' (variable) @        \ ( ... <variable> )
 335 ' (create) @          \ ( ... <create> )
 336 ' (alias) @           \ ( ... <alias> )
 337 ' (buffer:) @         \ ( ... <buffer:> )
 338
 339 \ now clean up the test functions
 340 forget (function)
 341
 342 \ and remember the constants
 343 constant <buffer:>
 344 constant <alias>
 345 constant <create>
 346 constant <variable>
 347 constant <constant>
 348 constant <value>
 349 constant <defer>
 350 constant <semicolon>
 351 constant <colon>
 352
 353 ' lit      constant <lit>
 354 ' sliteral constant <sliteral>
 355 ' 0branch  constant <0branch>
 356 ' branch   constant <branch>
 357 ' doloop   constant <doloop>
 358 ' dotick   constant <dotick>
 359 ' doto     constant <doto>
 360 ' do?do    constant <do?do>
 361 ' do+loop  constant <do+loop>
 362 ' do       constant <do>
 363 ' exit     constant <exit>
 364 ' doleave  constant <doleave>
 365 ' do?leave  constant <do?leave>
 366
 367
 368 \ provide the memory management words
 369 \ #include <claim.fs>
 370 \ #include "memory.fs"
 371 #include <alloc-mem.fs>
 372
 373 #include <node.fs>
 374
 375 : find-substr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
 376   \ if substr-len == 0 ?
 377   dup 0 = IF
 378     \ return 0
 379     2drop 2drop 0 exit THEN
 380   \ if substr-len <= basestr-len ?
 381   dup 3 pick <= IF
 382     \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
 383     2 pick over - 1+ 0 DO dup 0 DO
 384       \ substr-ptr[i] == basestr-ptr[j+i] ?
 385       over i + c@ 4 pick j + i + c@ = IF
 386         \ (I+1) == substr-len ?
 387         dup i 1+ = IF
 388           \ return J
 389           2drop 2drop j unloop unloop exit THEN
 390       ELSE leave THEN
 391     LOOP LOOP
 392   THEN
 393   \ if there is no match then exit with basestr-len as return value
 394   2drop nip
 395 ;
 396
 397 : find-isubstr ( basestr-ptr basestr-len substr-ptr substr-len -- pos )
 398   \ if substr-len == 0 ?
 399   dup 0 = IF
 400     \ return 0
 401     2drop 2drop 0 exit THEN
 402   \ if substr-len <= basestr-len ?
 403   dup 3 pick <= IF
 404     \ run J from 0 to "basestr-len"-"substr-len" and I from 0 to "substr-len"-1
 405     2 pick over - 1+ 0 DO dup 0 DO
 406       \ substr-ptr[i] == basestr-ptr[j+i] ?
 407       over i + c@ lcc 4 pick j + i + c@ lcc = IF
 408         \ (I+1) == substr-len ?
 409         dup i 1+ = IF
 410           \ return J
 411           2drop 2drop j unloop unloop exit THEN
 412       ELSE leave THEN
 413     LOOP LOOP
 414   THEN
 415   \ if there is no match then exit with basestr-len as return value
 416   2drop nip
 417 ;
 418
 419 : find-nextline ( str-ptr str-len -- pos )
 420   \ run I from 0 to "str-len"-1 and check str-ptr[i]
 421   dup 0 ?DO over i + c@ CASE
 422     \ 0x0a (=LF) found ?
 423     0a OF
 424       \ if current cursor is at end position (I == "str-len"-1) ?
 425       dup 1- i = IF
 426         \ return I+1
 427         2drop i 1+ unloop exit THEN
 428         \ if str-ptr[I+1] == 0x0d (=CR) ?
 429       over i 1+ + c@ 0d = IF
 430         \ return I+2
 431         2drop i 2+ ELSE
 432         \ else return I+1
 433         2drop i 1+ THEN
 434       unloop exit
 435     ENDOF
 436     \ 0x0d (=CR) found ?
 437     0d OF
 438       \ if current cursor is at end position (I == "str-len"-1) ?
 439       dup 1- i = IF
 440         \ return I+1
 441         2drop i 1+ unloop exit THEN
 442       \ str-ptr[I+1] == 0x0a (=LF) ?
 443       over i 1+ + c@ 0a = IF
 444         \ return I+2
 445         2drop i 2+ ELSE
 446         \ return I+1
 447         2drop i 1+ THEN
 448       unloop exit
 449     ENDOF
 450   ENDCASE LOOP nip
 451 ;
 452
 453 : string-at ( str1-ptr str1-len pos -- str2-ptr str2-len )
 454   -rot 2 pick - -rot swap chars + swap
 455 ;
 456
 457 \ appends the string beginning at addr2 to the end of the string
 458 \ beginning at addr1
 459 \ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
 460 \ !!!        BEGINNING AT ADDR1 (cp. 'strcat' in 'C' )        !!!
 461
 462 : string-cat ( addr1 len1 addr2 len2 -- addr1 len1+len2 )
 463   \ len1 := len1+len2
 464   rot dup >r over + -rot
 465   ( addr1 len1+len2 dest-ptr src-ptr len2 )
 466   3 pick r> chars + -rot
 467   ( ... dest-ptr src-ptr )
 468   0 ?DO
 469     2dup c@ swap c!
 470     char+ swap char+ swap
 471   LOOP 2drop
 472 ;
 473
 474 \ appends a character to the end of the string beginning at addr
 475 \ !!! THERE MUST BE SUFFICIENT MEMORY RESERVED FOR THE STRING !!!
 476 \ !!!        BEGINNING AT ADDR1 (cp. 'strcat' in 'C' )        !!!
 477
 478 : char-cat ( addr len character -- addr len+1 )
 479   -rot 2dup >r >r 1+ rot r> r> chars + c!
 480 ;
 481
 482 \ Returns true if source and destination overlap
 483 : overlap ( src dest size -- true|false )
 484         3dup over + within IF 3drop true ELSE rot tuck + within THEN
 485 ;
 486
 487 : parse-2int ( str len -- val.lo val.hi )
 488 \ ." parse-2int ( " 2dup swap . . ." -- "
 489         [char] , split ?dup IF eval ELSE drop 0 THEN
 490         -rot ?dup IF eval ELSE drop 0 THEN
 491 \ 2dup swap . . ." )" cr
 492 ;
 493
 494 \ peek/poke minimal implementation, just to support FCode drivers
 495 \ Any implmentation with full error detection will be platform specific
 496 : cpeek ( addr -- false | byte true ) c@ true ;
 497 : cpoke ( byte addr -- success? ) c! true ;
 498 : wpeek ( addr -- false | word true ) w@ true ;
 499 : wpoke ( word addr -- success? ) w! true ;
 500 : lpeek ( addr -- false | lword true ) l@ true ;
 501 : lpoke ( lword addr -- success? ) l! true ;
 502
 503 defer reboot ( -- )
 504 defer halt ( -- )
 505 defer disable-watchdog ( -- )
 506 defer reset-watchdog ( -- )
 507 defer set-watchdog ( +n -- )
 508 defer set-led ( type instance state -- status )
 509 defer get-flashside ( -- side )
 510 defer set-flashside ( side -- status )
 511 defer read-bootlist ( -- )
 512 defer furnish-boot-file ( -- adr len )
 513 defer set-boot-file ( adr len -- )
 514 defer mfg-mode? ( -- flag )
 515 defer of-prompt? ( -- flag )
 516 defer debug-boot? ( -- flag )
 517 defer bmc-version ( -- adr len )
 518 defer cursor-on ( -- )
 519 defer cursor-off ( -- )
 520
 521 : nop-reboot ( -- ) ." reboot not available" abort ;
 522 : nop-halt ( -- ) ." halt not available" abort ;
 523 : nop-disable-watchdog ( -- )  ;
 524 : nop-reset-watchdog ( -- )  ;
 525 : nop-set-watchdog ( +n -- ) drop ;
 526 : nop-set-led ( type instance state -- status ) drop drop drop ;
 527 : nop-get-flashside ( -- side ) ." Cannot get flashside" cr ABORT ;
 528 : nop-set-flashside ( side -- status ) ." Cannot set flashside" cr ABORT ;
 529 : nop-read-bootlist ( -- ) ;
 530 : nop-furnish-bootfile ( -- adr len ) s" net:" ;
 531 : nop-set-boot-file ( adr len -- ) 2drop ;
 532 : nop-mfg-mode? ( -- flag ) false ;
 533 : nop-of-prompt? ( -- flag ) false ;
 534 : nop-debug-boot? ( -- flag ) false ;
 535 : nop-bmc-version ( -- adr len ) s" XXXXX" ;
 536 : nop-cursor-on ( -- ) ;
 537 : nop-cursor-off ( -- ) ;
 538
 539 ' nop-reboot to reboot
 540 ' nop-halt to halt
 541 ' nop-disable-watchdog to disable-watchdog
 542 ' nop-reset-watchdog   to reset-watchdog
 543 ' nop-set-watchdog     to set-watchdog
 544 ' nop-set-led          to set-led
 545 ' nop-get-flashside    to get-flashside
 546 ' nop-set-flashside    to set-flashside
 547 ' nop-read-bootlist    to read-bootlist
 548 ' nop-furnish-bootfile to furnish-boot-file
 549 ' nop-set-boot-file    to set-boot-file
 550 ' nop-mfg-mode?        to mfg-mode?
 551 ' nop-of-prompt?       to of-prompt?
 552 ' nop-debug-boot?      to debug-boot?
 553 ' nop-bmc-version      to bmc-version
 554 ' nop-cursor-on        to cursor-on
 555 ' nop-cursor-off       to cursor-off
 556
 557 : reset-all reboot ;
 558
 559 \ load-base is an env. variable now, but it can
 560 \ be overriden temporarily provided users use
 561 \ get-load-base rather than load-base directly
 562 \
 563 \ default-load-base is set here and can be
 564 \ overriden by the board code. It will be used
 565 \ to set the default value of the envvar "load-base"
 566 \ when booting without a valid nvram
 567
 568 10000000 VALUE default-load-base
 569 2000000 VALUE flash-load-base
 570 0 VALUE load-base-override
 571
 572 : get-load-base
 573   load-base-override 0<> IF load-base-override ELSE
 574     " load-base" evaluate
 575   THEN
 576 ;
 577
 578 \ provide first level debug support
 579 #include "debug.fs"
 580 \ provide 7.5.3.1 Dictionary search
 581 #include "dictionary.fs"
 582 \ block data access for IO devices - ought to be implemented in engine
 583 #include "rmove.fs"
 584 \ provide a simple run time preprocessor
 585 #include <preprocessor.fs>
 586
 587 : $dnumber base @ >r decimal $number r> base ! ;
 588 : (.d) base @ >r decimal (.) r> base ! ;
 589
 590 \ IP address conversion
 591
 592 : (ipaddr) ( "a.b.c.d" -- FALSE | n1 n2 n3 n4 TRUE )
 593    base @ >r decimal
 594    over s" 000.000.000.000" comp 0= IF 2drop false r> base ! EXIT THEN
 595    [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
 596    [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
 597    [char] . left-parse-string $number IF 2drop false r> base ! EXIT THEN -rot
 598    $number IF false r> base ! EXIT THEN
 599    true r> base !
 600 ;
 601
 602 : (ipformat)  ( n1 n2 n3 n4 -- str len )
 603    base @ >r decimal
 604    0 <# # # # [char] . hold drop # # # [char] . hold
 605    drop # # # [char] . hold drop # # #s #>
 606    r> base !
 607 ;
 608
 609 : ipformat  ( n1 n2 n3 n4 -- ) (ipformat) type ;
 610
 611