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

math.parser: cleanup uses of 16/8/2 >base/base>.

db4
John Benediktsson 2011-10-14 10:09:12 -07:00
parent e76bcd36c9
commit 312704ae68
6 changed files with 42 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
basis/prettyprint/backend/backend.factor
View File

@ -48,9 +48,9 @@ M: method pprint*
M: real pprint* M: real pprint*
number-base get { number-base get {
{ 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] } { 16 [ \ HEX: [ >hex text ] pprint-prefix ] }
{ 8 [ \ OCT: [ 8 >base text ] pprint-prefix ] } { 8 [ \ OCT: [ >oct text ] pprint-prefix ] }
{ 2 [ \ BIN: [ 2 >base text ] pprint-prefix ] } { 2 [ \ BIN: [ >bin text ] pprint-prefix ] }
[ drop number>string text ] [ drop number>string text ]
} case ; } case ;
@ -59,7 +59,7 @@ M: float pprint*
\ NAN: [ fp-nan-payload >hex text ] pprint-prefix \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
] [ ] [
number-base get { number-base get {
{ 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] } { 16 [ \ HEX: [ >hex text ] pprint-prefix ] }
[ drop number>string text ] [ drop number>string text ]
} case } case
] if ; ] if ;

4
basis/tools/disassembler/utils/utils.factor
View File

@ -6,14 +6,14 @@ IN: tools.disassembler.utils
: complete-address ( n seq -- str ) : complete-address ( n seq -- str )
[ nip owner>> unparse-short ] [ entry-point>> - ] 2bi [ nip owner>> unparse-short ] [ entry-point>> - ] 2bi
[ 16 >base 0x " + " glue ] unless-zero ; [ >hex 0x " + " glue ] unless-zero ;
: search-xt ( addr -- str/f ) : search-xt ( addr -- str/f )
dup lookup-return-address dup lookup-return-address
dup [ complete-address ] [ 2drop f ] if ; dup [ complete-address ] [ 2drop f ] if ;
: resolve-xt ( str -- str' ) : resolve-xt ( str -- str' )
[ 0x ] [ 16 base> ] bi [ 0x ] [ hex> ] bi
[ search-xt [ " (" ")" surround append ] when* ] when* ; [ search-xt [ " (" ")" surround append ] when* ] when* ;
: resolve-call ( str -- str' ) : resolve-call ( str -- str' )

2
basis/uuid/uuid.factor
View File

@ -48,7 +48,7 @@ IN: uuid
[ CHAR: - 8 ] dip insert-nth ; [ CHAR: - 8 ] dip insert-nth ;
: string>uuid ( string -- n ) : string>uuid ( string -- n )
[ CHAR: - = not ] filter 16 base> ; [ CHAR: - = not ] filter hex> ;
PRIVATE> PRIVATE>

12
core/math/parser/parser.factor
View File

@ -279,6 +279,11 @@ PRIVATE>
GENERIC# >base 1 ( n radix -- str ) GENERIC# >base 1 ( n radix -- str )
: number>string ( n -- str ) 10 >base ; inline
: >bin ( n -- str ) 2 >base ; inline
: >oct ( n -- str ) 8 >base ; inline
: >hex ( n -- str ) 16 >base ; inline
<PRIVATE <PRIVATE
SYMBOL: radix SYMBOL: radix
@ -345,7 +350,7 @@ M: ratio >base
-0.0 double>bits bitand zero? "" "-" ? ; -0.0 double>bits bitand zero? "" "-" ? ;
: float>hex-value ( mantissa -- str ) : float>hex-value ( mantissa -- str )
16 >base 13 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail >hex 13 CHAR: 0 pad-head [ CHAR: 0 = ] trim-tail
[ "0" ] [ ] if-empty "1." prepend ; [ "0" ] [ ] if-empty "1." prepend ;
: float>hex-expt ( mantissa -- str ) : float>hex-expt ( mantissa -- str )
@ -383,9 +388,4 @@ M: float >base
[ float>base ] [ float>base ]
} cond ; } cond ;
: number>string ( n -- str ) 10 >base ; inline
: >bin ( n -- str ) 2 >base ; inline
: >oct ( n -- str ) 8 >base ; inline
: >hex ( n -- str ) 16 >base ; inline
: # ( n -- ) number>string % ; inline : # ( n -- ) number>string % ; inline

54
extra/cpu/8080/emulator/emulator.factor
View File

@ -400,7 +400,7 @@ CONSTANT: sign-flag HEX: 80
: interrupt ( number cpu -- ) : interrupt ( number cpu -- )
#! Perform a hardware interrupt #! Perform a hardware interrupt
! "***Interrupt: " write over 16 >base print ! "***Interrupt: " write over >hex print
dup f>> interrupt-flag bitand 0 = not [ dup f>> interrupt-flag bitand 0 = not [
dup push-pc dup push-pc
pc<< pc<<
@ -528,32 +528,32 @@ SYMBOL: rom-root
[ pc>> ] keep read-byte instructions nth first ; [ pc>> ] keep read-byte instructions nth first ;
: cpu. ( cpu -- ) : cpu. ( cpu -- )
[ " PC: " write pc>> 16 >base 4 CHAR: \s pad-head write ] keep [ " PC: " write pc>> >hex 4 CHAR: \s pad-head write ] keep
[ " B: " write b>> 16 >base 2 CHAR: \s pad-head write ] keep [ " B: " write b>> >hex 2 CHAR: \s pad-head write ] keep
[ " C: " write c>> 16 >base 2 CHAR: \s pad-head write ] keep [ " C: " write c>> >hex 2 CHAR: \s pad-head write ] keep
[ " D: " write d>> 16 >base 2 CHAR: \s pad-head write ] keep [ " D: " write d>> >hex 2 CHAR: \s pad-head write ] keep
[ " E: " write e>> 16 >base 2 CHAR: \s pad-head write ] keep [ " E: " write e>> >hex 2 CHAR: \s pad-head write ] keep
[ " F: " write f>> 16 >base 2 CHAR: \s pad-head write ] keep [ " F: " write f>> >hex 2 CHAR: \s pad-head write ] keep
[ " H: " write h>> 16 >base 2 CHAR: \s pad-head write ] keep [ " H: " write h>> >hex 2 CHAR: \s pad-head write ] keep
[ " L: " write l>> 16 >base 2 CHAR: \s pad-head write ] keep [ " L: " write l>> >hex 2 CHAR: \s pad-head write ] keep
[ " A: " write a>> 16 >base 2 CHAR: \s pad-head write ] keep [ " A: " write a>> >hex 2 CHAR: \s pad-head write ] keep
[ " SP: " write sp>> 16 >base 4 CHAR: \s pad-head write ] keep [ " SP: " write sp>> >hex 4 CHAR: \s pad-head write ] keep
[ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep
[ " " write peek-instruction name>> write " " write ] keep [ " " write peek-instruction name>> write " " write ] keep
nl drop ; nl drop ;
: cpu*. ( cpu -- ) : cpu*. ( cpu -- )
[ " PC: " write pc>> 16 >base 4 CHAR: \s pad-head write ] keep [ " PC: " write pc>> >hex 4 CHAR: \s pad-head write ] keep
[ " B: " write b>> 16 >base 2 CHAR: \s pad-head write ] keep [ " B: " write b>> >hex 2 CHAR: \s pad-head write ] keep
[ " C: " write c>> 16 >base 2 CHAR: \s pad-head write ] keep [ " C: " write c>> >hex 2 CHAR: \s pad-head write ] keep
[ " D: " write d>> 16 >base 2 CHAR: \s pad-head write ] keep [ " D: " write d>> >hex 2 CHAR: \s pad-head write ] keep
[ " E: " write e>> 16 >base 2 CHAR: \s pad-head write ] keep [ " E: " write e>> >hex 2 CHAR: \s pad-head write ] keep
[ " F: " write f>> 16 >base 2 CHAR: \s pad-head write ] keep [ " F: " write f>> >hex 2 CHAR: \s pad-head write ] keep
[ " H: " write h>> 16 >base 2 CHAR: \s pad-head write ] keep [ " H: " write h>> >hex 2 CHAR: \s pad-head write ] keep
[ " L: " write l>> 16 >base 2 CHAR: \s pad-head write ] keep [ " L: " write l>> >hex 2 CHAR: \s pad-head write ] keep
[ " A: " write a>> 16 >base 2 CHAR: \s pad-head write ] keep [ " A: " write a>> >hex 2 CHAR: \s pad-head write ] keep
[ " SP: " write sp>> 16 >base 4 CHAR: \s pad-head write ] keep [ " SP: " write sp>> >hex 4 CHAR: \s pad-head write ] keep
[ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep [ " cycles: " write cycles>> number>string 5 CHAR: \s pad-head write ] keep
nl drop ; nl drop ;
: register-lookup ( string -- vector ) : register-lookup ( string -- vector )
@ -1396,11 +1396,11 @@ SYMBOL: last-opcode
SYNTAX: INSTRUCTION: ";" parse-tokens parse-instructions ; SYNTAX: INSTRUCTION: ";" parse-tokens parse-instructions ;
SYNTAX: cycles SYNTAX: cycles
#! Set the number of cycles for the last instruction that was defined. #! Set the number of cycles for the last instruction that was defined.
scan-token string>number last-opcode get-global instruction-cycles set-nth ; scan-token string>number last-opcode get-global instruction-cycles set-nth ;
SYNTAX: opcode ( -- ) SYNTAX: opcode ( -- )
#! Set the opcode number for the last instruction that was defined. #! Set the opcode number for the last instruction that was defined.
last-instruction get-global 1quotation scan-token 16 base> last-instruction get-global 1quotation scan-token hex>
dup last-opcode set-global set-instruction ; dup last-opcode set-global set-instruction ;

4
unmaintained/dns/dns.factor
View File

@ -127,7 +127,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
: ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ; : ip->ba ( ip -- ba ) "." split [ string>number ] map >byte-array ;
: ipv6->ba ( ip -- ba ) ":" split [ 16 base> ] map [ 2 >be ] map concat ; : ipv6->ba ( ip -- ba ) ":" split [ hex> ] map [ 2 >be ] map concat ;
: label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ; : label->ba ( label -- ba ) [ >byte-array ] [ length ] bi prefix ;
@ -341,7 +341,7 @@ SYMBOLS: NO-ERROR FORMAT-ERROR SERVER-FAILURE NAME-ERROR NOT-IMPLEMENTED
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: get-ipv6 ( ba i -- ip ) : get-ipv6 ( ba i -- ip )
dup 16 + subseq 2 group [ be> 16 >base ] map ":" join ; dup 16 + subseq 2 group [ be> >hex ] map ":" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!