Detecting the mode of the ARM processor from Forth

Detecting the ARM processor mode from Forth.
Modern ARM processors have no 26Bit mode, they do support an emulator

To detect the mode you are running in.

code 32bit?
stmfd sp !, { tos }
teq r0, r0
teq pc, pc
mvn eq tos, # 0
mov ne tos, # 0
next c;

Returns true if 32bit or false otherwise.

This example is from WimpForth for RISCOS (a version that runs on StrongARM) can be found at http://www.leginda.com

Compare in forth

Compare is a string comparison word in Forth
compare (c-addr-1 len1 c-addr-2 len2 -- n )

This takes two strings and leaves a flag. (0 for a match. -1 less than. +1 greater than.)
Typically this is written in either C or Assembler and documented in some kind of psuedo-pascal such as source-index := source-index + 1;

Ping from forth (Swiftforth)

---

\
\ ping sites from swiftforth by Alban 7/10/2007
\
REQUIRES winsock
LIBRARY ICMP.DLL OPENDLLS
0 IMPORT: IcmpCreateFile
8 IMPORT: IcmpSendEcho
1 IMPORT: IcmpCloseHandle

CLASS ICMP_OPTIONS
CVARIABLE TTL
CVARIABLE TOS
CVARIABLE Flags
CVARIABLE Size
VARIABLE Data

: init
32 TTL C!
0 TOS C!
0 Flags C!
0 Size C!
0 Data ! ;

END-CLASS



CLASS ICMP_ECHO_REPLY
VARIABLE Address
VARIABLE Status
VARIABLE RTTime
HVARIABLE DataSize
HVARIABLE Reserved
VARIABLE DataPtr
ICMP_OPTIONS BUILDS OPTS
64 BUFFER: Data
: init
32 DataSize H!
Data DataPtr ! ;
END-CLASS

CLASS PINGER
VARIABLE hICMP
VARIABLE ipAddress
VARIABLE lastStatus
VARIABLE timeout
ICMP_OPTIONS BUILDS OPTS
ICMP_ECHO_REPLY BUILDS ER
256 BUFFER: Request-data
: init-socks
$101 PAD :: WSAStartup drop ;
: init-send-buffer
z" 0123456789 ABCDEFGHIJKLMNOPQRSTUVWXYZ 9876543210"
zcount Request-data zplace ;

: >address ( z" -- )
ZCOUNT PAD ZPLACE
PAD :: inet_addr DUP 1+ ?EXIT
DROP
PAD :: gethostbyname DUP IF 3 CELLS + @ @ @ THEN
DUP 0= IF -1 ABORT" PINGER invalid host error" THEN
ipAddress ! ;

: create-file :: IcmpCreateFile hICMP ! ;

: init init-socks create-file init-send-buffer
OPTS init ER init
5000 timeout ! ;

: close hICMP @ :: IcmpCloseHandle ;

: send-ping hICMP @ ipAddress @ Request-Data 32
OPTS TTL ER Address 62 timeout @ :: IcmpSendEcho lastStatus ! ;

: rtt er RTTime c@ ;

: results rtt ." ms " . ;

: ping PAD 64 ERASE ( ping named site )
BL WORD HERE COUNT PAD SWAP CMOVE
PAD >address
send-ping drop
results ;
END-CLASS


PINGER BUILDS ICMP
ICMP init

\ usage examples
\ icmp ping www.apple.com
\ icmp ping www.bbc.co.uk
\ z" 10.10.10.1" icmp >address
\ icmp send-ping icmp rtt .

duped by forth

Forth being a stack language a common exercise is writing a definition of 2DUP that copies the top two items on the stack.

It is cheating to look into the guts of your favourite forth compiler.

I figured quickly that -

: 2DUP dup rot dup rot swap ;

Would work - but it is not exactly going to be fast to execute five steps.

It is a bad sign that dup rot is in there twice so is there some word that does dup rot already?
Well there doesn’t seem to be.

However the word over is also a kind of dup but it duplicates the 2nd value on the stack and brings it the top.

So my second attempt is : 2DUP (n1 n2 - - n1 n2 n1 n2 ) over over ;

This decompiles as:-
8 # EBP SUB EBX 4 [EBP] MOV 8 [EBP] EAX MOV EAX 0 [EBP] MOV
so has to be quite good..

This decompiles the same as the built in definition on the system that I am using (which uses EBP as the data stack and ESP as the return stack.)
There other bad ways of writing 2DUP one way is to use tuck instead of the first over

: 2DUP tuck over ;

This also works but is worse code as tuck does more work than over does.

One annoying thing about forth is that forth kernels tend to be written in assembly language – there is a long tradition of doing that for performance.

It is a shame that more use is not made of optimizing meta-compilers so that more of Forth can be written in Forth and then we could see how the experts would write these standard words.

Lisping IP addresses

Here is some no-doubt badly written lisp for working with IP addresses.


;; converted from a C function that looks rather a lot like the MIT bit counter.
( defun count-bits ( x )
( setq x ( - x ( logand ( ash x -1 ) #x55555555)))
( setq x ( + ( logand x #x33333333 ) (logand ( ash x -2 ) #x33333333)))
( setq x ( logand ( + x ( ash x -4 )) #x0F0F0F0F))
( setq x ( + x ( ash x -8))) ( setq x ( + x ( ash x -16)))
( logand x #x0000003F))

;; this has no need to be fast as it is cached below.
(defun power-of-2 (x)
( let ((result 1))
( dotimes (i x result)
(setq result ( * 2 result)))))

;; keep a table of powers of 2.
(defparameter *little-powers-of-2*
( let ( final )
(setq final (make-array 128 :fill-pointer 0))
( dotimes ( value 127 final )
(vector-push (power-of-2 value ) final ))))

;; accessor for powers of 2, x must be < 128 but no checking done.
( defun po-2 (x) ( elt *little-powers-of-2* x))

;;
( defun ip-to-number (ip) " vector or list to number"
( + ( ash (elt ip 0) 24)
( ash (elt ip 1) 16)
( ash (elt ip 2) 8)
(elt ip 3)))

;; a mask is a contiguous run of bits.
;; this mask maker is hardly efficient so is cached.
( defun make-mask (n)
( let (mask)
( setq mask 0)
( dotimes ( value n mask )
(setq mask (+ (po-2 (- 31 value)) mask )))))

;; valid masks
( defparameter *masks*
( let ( my-masks )
(setq my-masks (make-array 33 :fill-pointer 0))
( dotimes ( value 33 my-masks)
(vector-push ( make-mask value) my-masks))))

;; return ip as a vector
( defun make-ip (a b c d)
( make-array 4 :element-type 'byte :initial-contents (list a b c d )))

( defun make-sm (a b c d)
( make-array 4 :element-type 'byte :initial-contents (list a b c d )))

;; looks up the mask for given prefix
( defun prefix-to-mask (prefix) "convenience accessor returns number"
( elt *masks* prefix))

;; different from sm-to-prefix
;; in this case mask is a natural number
( defun mask-to-prefix (mask) " mask is number, return prefix 0-32"
( count-bits mask))

;;
( position mask *masks*))

;; turn a natural number into a vector
( defun number-to-ip ( number ) "make a number into an ip address vector"
( let ( result n )
( setq result (make-array 4 :fill-pointer 0 :element-type 'byte))
( setq n number)
( dotimes ( value 4 result )
( vector-push ( logand n #xFF ) result )
( setq n ( ash n -8)))
(reverse result)))

;; swap between formats for sm masks.
( defun sm-to-prefix (sm) "sm is a vector like 255 255 248 0 prefix is a number like 21" (mask-to-prefix
( ip-to-number sm)))

( defun prefix-to-sm ( prefix ) " prefix is number like 23 , sm is vector like 255 255 254 0"
( number-to-ip
( prefix-to-mask prefix)))

;; might be good to remove this..
;; apply mask to ip returning network part.
see also logandip that works on two vectors.
( defun mask (ip sm ) " convert the ip and sm from vector to number, mask them returning a number"
( logand (ip-to-number sm)
(ip-to-number ip )))

;; used to add an offset to an ip address.
( defun incr-ip (ip n) "returns ip as vector incremented by n"
( number-to-ip (+ (ip-to-number ip) n)))

;; calc the hosts from the available host bits in an ip address.
( defun ip-hosts-from-prefix (p)
( po-2 (- 32 p)))

;; convenience to correct results.
( defun subtracting-broadcast (n)
( - n 1))

( defun subtracting-network (n)
( - n 1))

;; return the class of this ip where ip is a list or vector
( defun ip-to-class ( ip )
( let ( n )
( setq n (elt ip 0))
( cond
( ( >= n 240 ) "E")
( ( >= n 224 ) "D")
( ( >= n 192 ) "C")
( ( >= n 128 ) "B")
( ( >= n 1 ) "A"))))

;; natural is classful.
( defun ip-natural-prefix ( ip ) "class full"
( let ( n )
( setq n (elt ip 0))
( cond
( ( >= n 240 ) 24)
( ( >= n 224 ) 24)
( ( >= n 192 ) 24)
( ( >= n 128 ) 16)
( ( >= n 1 ) 8))))

;; combines the above
( defun ip-class-and-prefix ( ip )
( let ( n )
( setq n (elt ip 0))
( cond
( ( >= n 240 ) ( list 24 "E" ))
( ( >= n 224 ) ( list 24 "D" ))
( ( >= n 192 ) ( list 24 "C" ))
( ( >= n 128 ) ( list 16 "B" ))
( ( >= n 1 ) ( list 8 "A" )))))

;; various ways of working out the subnets

( defun subnets-from-reserv-with-prefix ( reserv prefix ) "the total number of subnets available"
(po-2 ( abs ( - reserv prefix))))
( defun subnets-from-ip-with-prefix ( ip prefix ) "the total number of subnets available for an ip of a given class"
( subnets-from-reserv-with-prefix ( ip-natural-prefix ip) prefix))

( defun classfull-subnets-from-ip-mask ( ip sm ) "the total number of subnets available for a given class"
( subnets-from-reserv-with-prefix
( ip-natural-prefix ip)
(sm-to-prefix sm)))

;; operations on ip addresses and masks as pairs of vectors.
;; operations on single elements
( defun logandelt (v1 v2 element)
( logand (elt v1 element)
(elt v2 element)))

( defun equalelt (v1 v2 element)
( = (elt v1 element) (elt v2 element)))

;; operations on 4 element vectors or lists (nn nn nn nn )
( defun logandip (v1 v2 ) "and an ip address and mask - return network address"
( vector
( logandelt v1 v2 0)
( logandelt v1 v2 1)
( logandelt v1 v2 2)
( logandelt v1 v2 3)))

( defun equalip ( v1 v2 ) " compare one ip with another"
( and
( equalelt v1 v2 0)
( equalelt v1 v2 1)
( equalelt v1 v2 2)
( equalelt v1 v2 3)))

( defun network-address-of-ip-and-sm (v1 v2) "works on ip & sm as vector, returns vector" ( logandip v1 v2))

( defun network-address-of-ip-and-prefix ( ip prefix) "works on ip as vector and prefix as number, returns vector"
( logandip ip (number-to-ip ( prefix-to-mask prefix))))

( defun classfull-network-base ( ip ) " what is the base class network"
( network-address-of-ip-and-prefix ip (ip-natural-prefix ip) ))

;; subnet is a class that contains useful information about ip subnets.;;(defclass subnet () ((ipaddress
;; normally an array of bytes or a list.
:accessor ip-address
:initform (make-ip 192 168 0 0)
:initarg :set-ipaddress)
(prefix ;; a small value 0-32
:accessor prefix
:initform 'undefined
:initarg :set-prefix)
(reserv ;; a small value 0-32, the natural prefix of this ip
:accessor reserv :initform 'undefined
:initarg :set-reserv)
(mask ;; a subnet mask, normally an array of bytes
:accessor mask
:initform 'undefined
:initarg :set-mask)
(ip-class ;; A,B,C,D,E
:accessor ip-class
:initform 'undefined
:initarg :set-mask) )
( :documentation "Instances of Subnet store network and mask information" ))

;; how many subnets are there, within the natural network..
( defmethod nets (( net subnet))
(subnets-from-reserv-with-prefix
(reserv net)
(prefix net)))

;; how many are hosts per subnet ?
( defmethod hosts (( net subnet))
(ip-hosts-from-prefix
(prefix net)))

;; find this net, make a network by masking out the host bits to return this networks network address
( defmethod thisnet (( net subnet ))
( make-instance 'subnet
:set-ipaddress ( network-address-of-ip-and-sm ( ip-address net) ( mask net))
:set-prefix ( prefix net) ))

;; find base network, make a network by classfully determining network 0 in this range of subnets.
( defmethod basenet (( net subnet ))
( make-instance 'subnet
:set-ipaddress ( classfull-network-base ( ip-address net) )
:set-prefix ( prefix net) ))

;; make a network with an IP address set to the broadcast address of thisnet.
( defmethod broadcast (( net subnet ))
( make-instance 'subnet
:set-ipaddress ( incr-ip ( ip-address ( thisnet net ) ) (- ( hosts net) 1))
:set-prefix ( prefix net)))

;; make a network by classfully determining the base network.
;; Then finding the nth subnet.
( defmethod nth-net (( thenet subnet ) n )
( make-instance 'subnet
:set-ipaddress ( incr-ip ( ip-address (basenet thenet) ) ( * (hosts thenet) n) )
:set-prefix ( prefix thenet)))

;; test for equality - if prefix, ip and sm are the same - we are equal
( defun equalnet ( n1 n2 )
( and ( equal ( prefix n1) ( prefix n2))
( equalip ( ip-address n1 ) ( ip-address n2) )
( equalip ( mask n1) ( mask n2))))

;; computes some helpful default values when a subnet is created.
( defmethod initialize-instance :after (( net subnet) &key )
( let (( ip ( slot-value net 'ipaddress )))
( progn
( cond (( eq (slot-value net 'prefix) 'undefined )
(setf ( slot-value net 'prefix)
( ip-natural-prefix ip ))))
( cond (( eq (slot-value net 'reserv) 'undefined )
(setf ( slot-value net 'reserv)
( ip-natural-prefix ip ))))
( cond (( eq (slot-value net 'mask) 'undefined )
(setf ( slot-value net 'mask)
( prefix-to-sm (slot-value net 'prefix )))))
( cond (( eq (slot-value net 'ip-class) 'undefined )
(setf ( slot-value net 'ip-class)
( ip-to-class ip )))))))

;; ip-cursors are created on a subnet.
;; a cursor moves over an IP address range
;; knowing the base network, the start of this network, the broadcast address it moves across the hosts within
;; a subnet, providing next-host, previous-host and host-at methods.
;;
(defclass ip-cursor ()
((subnet ;; a subnet
:accessor subnet
:initform ( make-instance 'subnet :set-ipaddress (make-ip 192 168 0 0 ))
:initarg :set-subnet )
(offset ;; and a position
:accessor offset
:initform 0
:initarg :set-offset))
( :documentation "ip-cursor is used to move across a subnet" ))

( defun make-cursor-on-subnet ( net )
( make-instance 'ip-cursor :set-subnet ( thisnet net)))
( defmethod next-ip (( cursor ip-cursor ))
( setf (offset cursor) (+ ( offset cursor) 1))
( make-instance 'subnet
:set-ipaddress ( incr-ip ( ip-address ( subnet cursor))
(offset cursor))
:set-prefix ( prefix ( subnet cursor))))

( defmethod previous-ip (( cursor ip-cursor ))
( setf (offset cursor) (- ( offset cursor) 1))
( make-instance 'subnet
:set-ipaddress ( incr-ip ( ip-address ( subnet cursor)) (offset cursor))
:set-prefix ( prefix ( subnet cursor))))

Grab your own wan ip from record route.

Traceroute -R can sometimes provide your external IP address.
(This should be moe efficient that fetching a remote web page.)

Here is an example line.

ping -R www.cw.net -c 2 cat -n awk '{if ($1==4) print $2}'

shell script to update dynamic dns using record route.

You do not need to fetch a page from whatismyip.com to get your own public IP address, traceroute -R (record route) may also give you the address of your WAN information.

A shell script like this might work if you add it to a cron job.
Be careful not to get banned. You must only update your records if your address has changed.
Read the rules at dyndns.org.

#!/bin/sh
ping -R www.cw.net -c 2 cat -n awk '{if ($1==4) print $2}' > newip
if [ `cat newip` != `cat previp` ]; then
wget http://"username:password@members.dyndns.org/nic/update?system=dyndns&hostname=www.yyyyyyy.com,yyyyyy.com&myip=`cat newip`"cat update*system*rm update*system*
fi
cp newip previp
exit

Delphi code to fetch your own public IP address

function whatismyip(): String;
var anurl: String;
var r:TregExpr;
var myip: string;
begin
anurl := IdHTTP1.Get('http:\\www.whatismyip.com');
r:= TregExpr.Create;
r.Expression := '\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}';
if r.Exec(anurl) then myip := r.Match[0];
r.Destroy;
whatismyip:=myip;
end;

This snippet requires indy and also regular expressions from http://regexpstudio.com/

There is a version using windows sockets here :-
http://www.delphifusion.com/forum/showthread.php?t=247

Power basic to fetch your own external IP address.

This Power Basic 8.0 snippet fetches your external IP address OR beeps.

' find our ip address by fetching a page from whatismyip.com
hTCP&=FREEFILE
TCP OPEN "www" AT "www.whatismyip.com" AS hTCP&
IF ERR THEN
BEEP
ELSE
TCP PRINT hTCP&,_
"GET / HTTP/1.1" +CHR$(13)+CHR$(10)+_
"Host: www.whatismyip.com" +CHR$(13)+CHR$(10)+_
"Accept: text/html, */*" +CHR$(13)+CHR$(10)+_
"Accept-Encoding: identity"+CHR$(13)+CHR$(10)+_
"User-Agent: Mozilla/3.0" +CHR$(13)+CHR$(10)
TCP RECV hTCP&, 2048, buffer$
TCP CLOSE hTCP&

REGEXPR "[0-9]+\.[0-9]+\.[0-9]+\.[0-9]+" IN buffer$ TO iPOS&, iLEN&

IF iPOS&>0 THEN ' save the present ip..
myip$ = MID$(buffer$,iPOS&, iLEN&)
CONTROL SET TEXT CBHNDL, %IDC_TEXTBOX1, myip$
outfile&=FREEFILE
OPEN "oldip.txt" FOR OUTPUT AS #outfile&
WRITE #outfile&, myip$
CLOSE #outfile&
END IF
END IF