steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Updated to work with the new vector/hashtable syntax

cvs
Doug Coleman 2005-11-02 08:30:38 +00:00
parent a80f3453b4
commit e0a03a7769
2 changed files with 16 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
contrib/aim/aim.factor
View File

@ -73,11 +73,6 @@ H{
[[ 12 "Translate" ]] [[ 19 "SSI" ]] [[ 21 "ICQ" ]] [[ 12 "Translate" ]] [[ 19 "SSI" ]] [[ 21 "ICQ" ]]
[[ 34 "Unknown Family" ]] } ; [[ 34 "Unknown Family" ]] } ;
: ch>lower ( int -- int ) dup LETTER? [ HEX: 20 + ] when ;
: ch>upper ( int -- int ) dup letter? [ HEX: 20 - ] when ;
: >lower ( seq -- seq ) [ ch>lower ] map ;
: >upper ( seq -- seq ) [ ch>upper ] map ;
: sanitize-name ( name -- name ) HEX: 20 swap remove >lower ; : sanitize-name ( name -- name ) HEX: 20 swap remove >lower ;
: hash-swap ( hash -- hash ) : hash-swap ( hash -- hash )
@ -182,12 +177,14 @@ H{
conn get swap with-unscoped-stream ; conn get swap with-unscoped-stream ;
: read-aim ( -- bc ) : read-aim ( -- bc )
[ [ [
[
head-byte drop head-byte drop
head-byte drop head-byte drop
head-short drop head-short drop
head-short head-string head-short head-string
] with-aim ] catch [ "Socket error" print throw ] when ] with-aim
] catch [ "Socket error" print throw ] when
"Received: " write dup hexdump ; "Received: " write dup hexdump ;
: make-snac ( fam subtype flags req-id -- ) : make-snac ( fam subtype flags req-id -- )
@ -729,11 +726,11 @@ SYMBOL: type
type get type get
{ {
{ [ dup 0 = ] [ drop name get bid get gid get { } clone f f <buddy> { [ dup 0 = ] [ drop name get bid get gid get V{ } clone f f <buddy>
dup name get sanitize-name buddy-hash-name get set-hash bid get buddy-hash-id get set-hash ] } dup name get sanitize-name buddy-hash-name get set-hash bid get buddy-hash-id get set-hash ] }
{ [ dup 1 = ] [ drop name get dup length 0 = [ drop ] [ gid get <group> { [ dup 1 = ] [ drop name get dup length 0 = [ drop ] [ gid get <group>
dup name get sanitize-name group-hash-name get set-hash gid get group-hash-id get set-hash ] if ] } dup name get sanitize-name group-hash-name get set-hash gid get group-hash-id get set-hash ] if ] }
{ [ dup 3 = ] [ drop name get bid get gid get { } clone f f <buddy> { [ dup 3 = ] [ drop name get bid get gid get V{ } clone f f <buddy>
dup name get sanitize-name banned-hash-name get set-hash bid get banned-hash-id get set-hash ] } dup name get sanitize-name banned-hash-name get set-hash bid get banned-hash-id get set-hash ] }
{ [ t ] [ drop "Unknown 19-6 type" print ] } { [ t ] [ drop "Unknown 19-6 type" print ] }
} cond } cond

18
contrib/aim/net-bytes.factor
View File

@ -22,14 +22,12 @@ SYMBOL: unscoped-stack
HEX: 000000ff bitand unparse % ] "" make ; HEX: 000000ff bitand unparse % ] "" make ;
! doesn't compile ! doesn't compile
! : >nvector ( elems n -- ) ! : >nvector ( elems n -- )
! { } clone swap [ drop swap add ] each reverse ; ! { } clone swap [ drop swap add ] each reverse ;
: 4vector ( elems -- ) : 4vector ( elems -- )
{ } clone 4 [ drop swap add ] each reverse ; V{ } clone 4 [ drop swap add ] each reverse ;
! TODO: make this work for types other than "" ! TODO: make this work for types other than ""
: papply ( seq seq -- seq ) : papply ( seq seq -- seq )
@ -38,7 +36,6 @@ SYMBOL: unscoped-stack
: writeln ( string -- ) : writeln ( string -- )
write terpri ; write terpri ;
! wrote this months and months ago..
! NEEDS REFACTORING, GOSH! ! NEEDS REFACTORING, GOSH!
! Hexdump ! Hexdump
: (print-offset) ( lineno -- ) : (print-offset) ( lineno -- )
@ -82,21 +79,15 @@ SYMBOL: unscoped-stack
] "" make write ; ] "" make write ;
: hexdump ( str -- ) : hexdump ( str -- )
! drop ;
dup length (print-length) (print-bytes) ; dup length (print-length) (print-bytes) ;
: save-current-scope : save-current-scope
unscoped-stack get [ { } clone unscoped-stack set ] unless unscoped-stack get [ V{ } clone unscoped-stack set ] unless
swap dup unscoped-stream set unscoped-stack get push ; swap dup unscoped-stream set unscoped-stack get push ;
: set-previous-scope : set-previous-scope
! unscoped-stream get contents .
! [
! "UNREAD BYTES" writeln
! hexdump
! ] when
unscoped-stack get dup length 1 > [ unscoped-stack get dup length 1 > [
[ pop ] keep nip peek unscoped-stream set ] [ [ pop ] keep nip peek unscoped-stream set ] [
pop drop pop drop
@ -167,16 +158,19 @@ SYMBOL: unscoped-stack
: (head-u128) ( str -- u128 ) : (head-u128) ( str -- u128 )
16 swap head endian> ; 16 swap head endian> ;
! 8 bits
: head-byte ( -- byte ) : head-byte ( -- byte )
1 unscoped-stream get stream-read first ; 1 unscoped-stream get stream-read first ;
! 16 bits
: head-short ( -- short ) : head-short ( -- short )
2 unscoped-stream get stream-read (head-short) ; 2 unscoped-stream get stream-read (head-short) ;
! 32 bits
: head-int ( -- int ) : head-int ( -- int )
4 unscoped-stream get stream-read (head-int) ; 4 unscoped-stream get stream-read (head-int) ;
! 64 bits
: head-longlong ( -- longlong ) : head-longlong ( -- longlong )
8 unscoped-stream get stream-read (head-longlong) ; 8 unscoped-stream get stream-read (head-longlong) ;