190 lines
4.3 KiB
Factor
190 lines
4.3 KiB
Factor
IN: aim-internals
|
|
USING: kernel sequences lists prettyprint strings namespaces math threads vectors errors parser interpreter test io crypto arrays ;
|
|
|
|
SYMBOL: big-endian t big-endian set
|
|
SYMBOL: unscoped-stream
|
|
SYMBOL: unscoped-stack
|
|
|
|
! Examples:
|
|
! 1 2 3 4 4 >nvector .
|
|
! { 1 2 3 4 }
|
|
|
|
! { 1 2 3 4 } { >byte >short >int >long } papply .
|
|
! "\u0001\0\u0002\0\0\0\u0003\0\0\0\0\0\0\0\u0004"
|
|
|
|
! [ 1 >short 6 >long ] make-packet .
|
|
! "\0\u0001\0\0\0\0\0\0\0\u0006"
|
|
|
|
: int>ip ( n -- str )
|
|
[ HEX: ff000000 over bitand -24 shift unparse % CHAR: . ,
|
|
HEX: 00ff0000 over bitand -16 shift unparse % CHAR: . ,
|
|
HEX: 0000ff00 over bitand -8 shift unparse % CHAR: . ,
|
|
HEX: 000000ff bitand unparse % ] "" make ;
|
|
|
|
|
|
! doesn't compile
|
|
! : >nvector ( elems n -- )
|
|
! { } clone swap [ drop swap add ] each reverse ;
|
|
|
|
: 4vector ( elems -- )
|
|
V{ } clone 4 [ drop swap add ] each reverse ;
|
|
|
|
! TODO: make this work for types other than ""
|
|
: papply ( seq seq -- seq )
|
|
[ [ 2array >list call % ] 2each ] "" make ;
|
|
|
|
: writeln ( string -- )
|
|
write terpri ;
|
|
|
|
! NEEDS REFACTORING, GOSH!
|
|
! Hexdump
|
|
: (print-offset) ( lineno -- )
|
|
16 * >hex 8 CHAR: 0 pad-left write "h: " write ;
|
|
|
|
: (print-hex-digit) ( digit -- )
|
|
>hex 2 CHAR: 0 pad-left write ;
|
|
|
|
: (print-hex-line) ( lineno string -- )
|
|
over (print-offset)
|
|
dup length dup 16 =
|
|
[ [ 2dup swap nth (print-hex-digit) " " write ] repeat ] ! full line
|
|
[ ! partial line
|
|
[ 2dup swap nth (print-hex-digit) " " write ] repeat
|
|
dup length 16 swap - [ " " write ] repeat
|
|
] if
|
|
dup length
|
|
[ 2dup swap nth dup printable? [ write1 ] [ "." write drop ] if ] repeat
|
|
terpri drop ;
|
|
|
|
: (num-full-lines) ( bytes -- )
|
|
length 16 / floor ;
|
|
|
|
: (get-slice) ( lineno bytes -- <slice> )
|
|
>r dup 16 * dup 16 + r> <slice> ;
|
|
|
|
: (get-last-slice) ( bytes -- <slice> )
|
|
dup length dup 16 mod - over length rot <slice> ;
|
|
|
|
: (print-bytes) ( bytes -- )
|
|
dup (num-full-lines) [ over (get-slice) (print-hex-line) ] repeat
|
|
dup (num-full-lines) over (get-last-slice) dup empty? [ 3drop ] [ (print-hex-line) 2drop ] if ;
|
|
|
|
: (print-length) ( len -- )
|
|
[
|
|
"Length: " %
|
|
dup unparse %
|
|
", " %
|
|
>hex %
|
|
"h\n" %
|
|
] "" make write ;
|
|
|
|
: hexdump ( str -- )
|
|
dup length (print-length) (print-bytes) ;
|
|
|
|
|
|
|
|
: save-current-scope
|
|
unscoped-stack get [ V{ } clone unscoped-stack set ] unless
|
|
swap dup unscoped-stream set unscoped-stack get push ;
|
|
|
|
: set-previous-scope
|
|
unscoped-stack get dup length 1 > [
|
|
[ pop ] keep nip peek unscoped-stream set ] [
|
|
pop drop
|
|
] if ;
|
|
|
|
: with-unscoped-stream ( stream quot -- )
|
|
save-current-scope catch set-previous-scope
|
|
[ dup [ unscoped-stream get stream-close ] when rethrow ] when ;
|
|
|
|
: close-unscoped-stream ( -- )
|
|
unscoped-stream get stream-close ;
|
|
|
|
: >endian ( obj n -- str )
|
|
big-endian get [ >be ] [ >le ] if ;
|
|
|
|
: endian> ( obj n -- str )
|
|
big-endian get [ be> ] [ le> ] if ;
|
|
|
|
: (>byte) ( byte -- str )
|
|
unit >string ;
|
|
|
|
: (>short) ( short -- str )
|
|
2 >endian ;
|
|
|
|
: (>int) ( int -- str )
|
|
4 >endian ;
|
|
|
|
: (>longlong) ( longlong -- str )
|
|
8 >endian ;
|
|
|
|
: (>u128) ( u128 -- str )
|
|
16 >endian ;
|
|
|
|
: (>cstring) ( str -- str )
|
|
"\0" append ;
|
|
|
|
: >byte ( byte -- )
|
|
(>byte) % ;
|
|
|
|
: >short ( short -- )
|
|
(>short) % ;
|
|
|
|
: >int ( int -- )
|
|
(>int) % ;
|
|
|
|
: >longlong ( longlong -- )
|
|
(>longlong) % ;
|
|
|
|
: >u128 ( u128 -- )
|
|
(>u128) % ;
|
|
|
|
: >cstring ( str -- )
|
|
(>cstring) % ;
|
|
|
|
|
|
! doesn't compile
|
|
! : make-packet ( quot -- )
|
|
! depth >r call depth r> - [ drop append ] each ;
|
|
: make-packet
|
|
"" make ;
|
|
|
|
: (head-short) ( str -- short )
|
|
2 swap head endian> ;
|
|
: (head-int) ( str -- int )
|
|
4 swap head endian> ;
|
|
: (head-longlong) ( str -- longlong )
|
|
8 swap head endian> ;
|
|
: (head-u128) ( str -- u128 )
|
|
16 swap head endian> ;
|
|
|
|
! 8 bits
|
|
: head-byte ( -- byte )
|
|
1 unscoped-stream get stream-read first ;
|
|
|
|
! 16 bits
|
|
: head-short ( -- short )
|
|
2 unscoped-stream get stream-read (head-short) ;
|
|
|
|
! 32 bits
|
|
: head-int ( -- int )
|
|
4 unscoped-stream get stream-read (head-int) ;
|
|
|
|
! 64 bits
|
|
: head-longlong ( -- longlong )
|
|
8 unscoped-stream get stream-read (head-longlong) ;
|
|
|
|
! 128 bits
|
|
: head-u128 ( -- u128 )
|
|
16 unscoped-stream get stream-read (head-u128) ;
|
|
|
|
: head-string ( n -- str )
|
|
unscoped-stream get stream-read >string ;
|
|
|
|
! : head-cstring ( -- str )
|
|
! head-byte ]
|
|
|
|
: head-contents ( -- str )
|
|
unscoped-stream get contents ;
|
|
|