\ # File: ipcalc.fs   Copyright (c) 1999 by Jim Lynch.
\ # First inkling of a useful IP calculator in FORTH.
\ #
\ # This software comes with NO WARRANTY and NO RECOURSE WHATSOEVER. The 
\ # ONLY way you get to use or distribute it, is to completely agree to this.
\ #
\ # This program is free software; you can redistribute it and/or modify
\ #    it under the terms of the GNU General Public License as published by
\ #    the Free Software Foundation; version 2 dated June, 1991, or, at your
\ #    option, any LATER version.
\ #
\ #    This program is distributed in the hope that it will be useful,
\ #    but WITHOUT ANY WARRANTY; without even the implied warranty of
\ #    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
\ #    GNU General Public License for more details.
\ #
\ #    You should have received a copy of the GNU General Public License
\ #    along with this program;  if not, write to the Free Software
\ #    Foundation, Inc., 675 Mass Ave., Cambridge, MA 02139, USA.
\ #
\ # On Debian Linux systems, the complete text of the GNU General
\ # Public License can be found in `/usr/doc/copyright/GPL'.

\ gives complement of top item of stack.

: compl ( n -> ~n. bitwise complement. )
 -1 xor
;

\ prints data stack contents without disturbing said stack 
\ (items are printed unsigned, hence the u in the name)

: .su 
 ." stack: " 
 depth ?dup if 
               0 do 
                     depth i - 
                     1- pick u. 
               loop 
            else 
               ." empty " 
            endif 
;

\ prints data stack contents without disturbing said stack 
\ (items are printed unsigned binary, hence the ub in the name)

: .sub
 base @ >r 2 base !
 .su
 r> base !
;

\ prints a binary number from top of stack (and consumes it)

: ub. base @ 2 base ! swap u. base ! ;

: paren. 0 <# begin # 2dup or 0= until #> type ;

\ given number of "1" bits in mask, produces that mask.

: bits>mask ( number of "1" bits in mask -> netmask. )
 ?dup 
 if
    32 swap -

    -1 swap

    ?dup 
    if
        lshift
    endif     
 else
    0
 endif
;

\ given mask, produces number of "1" bits in that mask

: mask>bits ( netmask -> number of "1" bits in mask. )
 ( search from right end to left for first "1" bit )
 32 ( flag)
 32 0 do
         over 1 and 
         if 
            drop i leave 
         else
            swap  1 rshift  swap
         endif
 loop

 ( now make sure all other bits are "1" bits, otherwise mask is 'weird' )
 32 swap - ( supposedly the answer, IF all other bits are "1"s. )
 ?dup 
 if 
    0 ( weird mask flag )
    over 0 do
         2 pick  1 and  0=
         if 
            ." mask>bits: mask is weird "  drop true leave
         else
            >r >r  1 rshift  r> r>
         endif
    loop
    rot drop

    if ( weird mask? )
       drop quit
    endif
 endif
 ( assuming these other bits are "1"s, top of stack counts them )
;

\ prints the low 8 binary digits of the top of stack

: 8b.  ( number -->.  Prints low 8 of number in 8 fixed binary digits. )
 base @ >r  
 2 base !

 0 
 <# 
   8 0 
   do 
      # 
   loop 
 #> 
 type  

 r> base ! 
;

: 256/  8 rshift ;
: 256*  8 lshift ;


\ splits an IP into separate byte-sized chunks (probably for printing)

: ip> ( 32-bit a.b.c.d -> d c b a )
 4 0 do dup 255 and swap 256/ loop
 drop
;

\ takes a split IP and combines it

: >ip ( d c b a -> 32-bit a.b.c.d )
 0
 4 0 do
        256*
        +
 loop 
;

\ print top of stack to look like an IP addr.

: ip.  ( IPv4 addr -->.  Prints addr as xxx.xxx.xxx.xxx, i.e., decimal. )
 ip>
 paren.
 3 0 do ." ." paren. loop
 space
;

\ print top of stack to look like an IP addr, in binary.

: bip.  ( IPv4 addr -->.  Prints addr as xxxxxxxx.xxxxxxxx.xxxxxxxx.xxxxxxxx. )
 ip>
 8b.
 3 0 do ." ." 8b. loop
 space
;

\ gives network address

: net-addr ( IPv4addr maskbits --> addrOfNet. )
 bits>mask
 and
;

\ gives broadcast adress

: bcast-addr ( IPv4addr maskbits --> bcastAddr. )
 bits>mask invert
 or
;

\ usage: ip< 12.3.45.6
\ pushes that IP onto stack

: ip< ( "a.b.c.d" --> IPv4addr. )
 46  parse    s>number  drop  >r
 46  parse    s>number  drop  >r
 46  parse    s>number  drop  >r
 bl  parse    s>number  drop    r> r> r>

 >ip
;