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

Merge commit 'origin/master' into emacs

db4
Jose A. Ortega Ruiz 2009-01-24 21:38:45 +01:00
parent b6b3e4fb54 29b561a7ee
commit 16ca29410b
81 changed files with 415 additions and 212 deletions
basis
alien/remote-control
bootstrap
compiler
cpu/ppc/assembler
db
http
interval-maps
io
directories/windows
encodings/ascii
files/info/unix
ports
sockets/windows/nt
match
math
mime/multipart
persistent/hashtables/nodes/leaf
prettyprint
regexp
serialize
syndication
ui/gadgets
unicode
unix
x11
xml/data
xmode

2
basis/alien/remote-control/remote-control.factor
View File

@ -15,7 +15,7 @@ IN: alien.remote-control
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
dup compiled>> [ execute ] [ drop f ] if ; inline
dup optimized>> [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv

32
basis/bootstrap/compiler/compiler.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler cpu.architecture vocabs.loader system
sequences namespaces parser kernel kernel.private classes
@ -25,8 +25,8 @@ IN: bootstrap.compiler
enable-compiler
: compile-uncompiled ( words -- )
[ compiled>> not ] filter compile ;
: compile-unoptimized ( words -- )
[ optimized>> not ] filter compile ;
nl
"Compiling..." write flush
@ -48,70 +48,70 @@ nl
wrap probe
namestack*
} compile-uncompiled
} compile-unoptimized
"." write flush
{
bitand bitor bitxor bitnot
} compile-uncompiled
} compile-unoptimized
"." write flush
{
+ 1+ 1- 2/ < <= > >= shift
} compile-uncompiled
} compile-unoptimized
"." write flush
{
new-sequence nth push pop peek flip
} compile-uncompiled
} compile-unoptimized
"." write flush
{
hashcode* = get set
} compile-uncompiled
} compile-unoptimized
"." write flush
{
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
} compile-uncompiled
} compile-unoptimized
"." write flush
{
lines prefix suffix unclip new-assoc update
word-prop set-word-prop 1array 2array 3array ?nth
} compile-uncompiled
} compile-unoptimized
"." write flush
{
malloc calloc free memcpy
} compile-uncompiled
} compile-unoptimized
"." write flush
{ build-tree } compile-uncompiled
{ build-tree } compile-unoptimized
"." write flush
{ optimize-tree } compile-uncompiled
{ optimize-tree } compile-unoptimized
"." write flush
{ optimize-cfg } compile-uncompiled
{ optimize-cfg } compile-unoptimized
"." write flush
{ (compile) } compile-uncompiled
{ (compile) } compile-unoptimized
"." write flush
vocabs [ words compile-uncompiled "." write flush ] each
vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush

2
basis/bootstrap/image/image.factor
View File

@ -433,7 +433,7 @@ M: quotation '
array>> '
quotation type-number object tag-number [
emit ! array
f ' emit ! compiled>>
f ' emit ! compiled
0 emit ! xt
0 emit ! code
] emit-object

2
basis/bootstrap/stage2.factor
View File

@ -42,7 +42,7 @@ SYMBOL: bootstrap-time
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
[ compiled>> ] count-words " compiled words" print
[ optimized>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print

2
basis/compiler/compiler.factor
View File

@ -24,7 +24,7 @@ SYMBOL: compiled
} cond drop ;
: maybe-compile ( word -- )
dup compiled>> [ drop ] [ queue-compile ] if ;
dup optimized>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+

2
basis/compiler/tests/codegen.factor
View File

@ -211,7 +211,7 @@ TUPLE: my-tuple ;
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test

12
basis/compiler/tests/optimizer.factor
View File

@ -9,7 +9,7 @@ IN: optimizer.tests
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
[ t ] [ \ xyz compiled>> ] unit-test
[ t ] [ \ xyz optimized>> ] unit-test
! Test predicate inlining
: pred-test-1
@ -94,7 +94,7 @@ TUPLE: pred-test ;
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
[ t ] [ \ breakage compiled>> ] unit-test
[ t ] [ \ breakage optimized>> ] unit-test
[ breakage ] must-fail
! regression
@ -119,7 +119,7 @@ GENERIC: void-generic ( obj -- * )
! compiling <tuple> with a non-literal class failed
: <tuple>-regression ( class -- tuple ) <tuple> ;
[ t ] [ \ <tuple>-regression compiled>> ] unit-test
[ t ] [ \ <tuple>-regression optimized>> ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
@ -228,7 +228,7 @@ USE: binary-search.private
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
@ -242,7 +242,7 @@ USE: binary-search.private
] if
] if ;
[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
@ -271,7 +271,7 @@ HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
DEFER: recursive-inline-hang-3

4
basis/compiler/tests/peg-regression.factor
View File

@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
USE: tools.test
[ t ] [ \ expr compiled>> ] unit-test
[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
[ t ] [ \ expr optimized>> ] unit-test
[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test

28
basis/compiler/tests/redefine1.factor
View File

@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ;
: hey ( -- ) ;
: there ( -- ) hey ;
[ t ] [ \ hey compiled>> ] unit-test
[ t ] [ \ there compiled>> ] unit-test
[ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ hey compiled>> ] unit-test
[ f ] [ \ there compiled>> ] unit-test
[ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
[ t ] [ \ there compiled>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ;
: bad ( -- ) good ;
: ugly ( -- ) bad ;
[ t ] [ \ good compiled>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
[ f ] [ \ good compiled>> ] unit-test
[ f ] [ \ bad compiled>> ] unit-test
[ f ] [ \ ugly compiled>> ] unit-test
[ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad optimized>> ] unit-test
[ f ] [ \ ugly optimized>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
[ t ] [ \ good compiled>> ] unit-test
[ t ] [ \ bad compiled>> ] unit-test
[ t ] [ \ ugly compiled>> ] unit-test
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test
[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test

4
basis/compiler/tests/redefine3.factor
View File

@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test compiled>> ] unit-test
[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

2
basis/compiler/tests/simple.factor
View File

@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
] unit-test
] times

6
basis/compiler/tests/spilling.factor
View File

@ -47,7 +47,7 @@ IN: compiler.tests
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
[ t ] [ \ float-spill-bug compiled>> ] unit-test
[ t ] [ \ float-spill-bug optimized>> ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
@ -132,7 +132,7 @@ IN: compiler.tests
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@ -159,7 +159,7 @@ IN: compiler.tests
16 narray
] if ;
[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test

8
basis/cpu/ppc/assembler/assembler.factor
View File

@ -97,10 +97,10 @@ X: XOR 0 316 31
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
! XO-form
XO: ADD 0 0 266 31

4
basis/cpu/ppc/assembler/backend/backend.factor
View File

@ -74,8 +74,8 @@ IN: cpu.ppc.assembler.backend
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ;

6
basis/db/postgresql/postgresql.factor
View File

@ -55,8 +55,10 @@ M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
M: postgresql-statement bind-tuple ( tuple statement -- )
tuck in-params>>
[ postgresql-bind-conversion ] with map
[ nip ] [
in-params>>
[ postgresql-bind-conversion ] with map
] 2bi
>>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n )

7
basis/db/tuples/tuples.factor
View File

@ -73,9 +73,10 @@ PRIVATE>
! High level
ERROR: no-slots-named class seq ;
: check-columns ( class columns -- )
tuck
[ [ first ] map ]
[ all-slots [ name>> ] map ] bi* diff
[ nip ] [
[ [ first ] map ]
[ all-slots [ name>> ] map ] bi* diff
] 2bi
[ drop ] [ no-slots-named ] if-empty ;
: define-persistent ( class table columns -- )

4
basis/db/types/types.factor
View File

@ -42,10 +42,10 @@ ERROR: no-slot ;
slot-named dup [ no-slot ] unless offset>> ;
: get-slot-named ( name tuple -- value )
tuck offset-of-slot slot ;
[ nip ] [ offset-of-slot ] 2bi slot ;
: set-slot-named ( value name obj -- )
tuck offset-of-slot set-slot ;
[ nip ] [ offset-of-slot ] 2bi set-slot ;
ERROR: not-persistent class ;

59
basis/http/client/client.factor
View File

@ -7,7 +7,7 @@ io io.sockets io.streams.string io.files io.timeouts
io.pathnames io.encodings io.encodings.string io.encodings.ascii
io.encodings.utf8 io.encodings.8-bit io.encodings.binary
io.streams.duplex fry ascii urls urls.encoding present
http http.parsers ;
http http.parsers http.client.post-data ;
IN: http.client
ERROR: too-many-redirects ;
@ -27,14 +27,6 @@ CONSTANT: max-redirects 10
[ host>> ] [ port>> ] bi dup "http" protocol-port =
[ drop ] [ ":" swap number>string 3append ] if ;
: set-post-data-headers ( header post-data -- header )
[
data>> dup sequence?
[ length "content-length" ]
[ drop "chunked" "transfer-encoding" ] if
pick set-at
] [ content-type>> "content-type" pick set-at ] bi ;
: set-host-header ( request header -- request header )
over url>> url-host "host" pick set-at ;
@ -48,53 +40,6 @@ CONSTANT: max-redirects 10
over cookies>> [ set-cookie-header ] unless-empty
write-header ;
PRIVATE>
GENERIC: >post-data ( object -- post-data )
M: f >post-data ;
M: post-data >post-data ;
M: string >post-data
utf8 encode
"application/octet-stream" <post-data>
swap >>data ;
M: assoc >post-data
"application/x-www-form-urlencoded" <post-data>
swap >>params ;
M: object >post-data
"application/octet-stream" <post-data>
swap >>data ;
<PRIVATE
: normalize-post-data ( request -- request )
dup post-data>> [
dup params>> [
assoc>query ascii encode >>data
] when* drop
] when* ;
: unparse-post-data ( request -- request )
[ >post-data ] change-post-data
normalize-post-data ;
: write-chunk ( chunk -- )
[ length >hex ";\r\n" append ascii encode write ] [ write ] bi ;
: write-chunked ( stream -- )
[ [ write-chunk ] each-block ] with-input-stream
"0;\r\n" ascii encode write ;
: write-post-data ( request -- request )
dup method>> { "POST" "PUT" } member? [
dup post-data>> data>> dup sequence?
[ write ] [ write-chunked ] if
] when ;
: write-request ( request -- )
unparse-post-data
write-request-line
@ -197,7 +142,7 @@ ERROR: download-failed response ;
dup code>> success? [ download-failed ] unless ;
: with-http-request ( request quot -- response )
(with-http-request) check-response ; inline
[ (with-http-request) check-response ] with-destructors ; inline
: http-request ( request -- response data )
[ [ % ] with-http-request ] B{ } make

1
basis/http/client/post-data/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

4
basis/http/client/post-data/post-data-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test http.client.post-data ;
IN: http.client.post-data.tests

91
basis/http/client/post-data/post-data.factor Normal file
View File

@ -0,0 +1,91 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs destructors http io io.encodings.ascii
io.encodings.binary io.encodings.string io.encodings.utf8
io.files io.files.info io.pathnames kernel math.parser
namespaces sequences strings urls.encoding ;
IN: http.client.post-data
TUPLE: measured-stream stream size ;
C: <measured-stream> measured-stream
<PRIVATE
GENERIC: (set-post-data-headers) ( header data -- header )
M: sequence (set-post-data-headers)
length "content-length" pick set-at ;
M: measured-stream (set-post-data-headers)
size>> "content-length" pick set-at ;
M: object (set-post-data-headers)
drop "chunked" "transfer-encoding" pick set-at ;
PRIVATE>
: set-post-data-headers ( header post-data -- header )
[ data>> (set-post-data-headers) ]
[ content-type>> "content-type" pick set-at ] bi ;
<PRIVATE
GENERIC: (write-post-data) ( data -- )
M: sequence (write-post-data) write ;
M: measured-stream (write-post-data)
stream>> [ [ write ] each-block ] with-input-stream ;
: write-chunk ( chunk -- )
[ length >hex ";\r\n" append ascii encode write ] [ write ] bi ;
M: object (write-post-data)
[ [ write-chunk ] each-block ] with-input-stream
"0;\r\n" ascii encode write ;
GENERIC: >post-data ( object -- post-data )
M: f >post-data ;
M: post-data >post-data ;
M: string >post-data
utf8 encode
"application/octet-stream" <post-data>
swap >>data ;
M: assoc >post-data
"application/x-www-form-urlencoded" <post-data>
swap >>params ;
M: object >post-data
"application/octet-stream" <post-data>
swap >>data ;
: pathname>measured-stream ( pathname -- stream )
string>>
[ binary <file-reader> &dispose ]
[ file-info size>> ] bi
<measured-stream> ;
: normalize-post-data ( request -- request )
dup post-data>> [
dup params>> [
assoc>query ascii encode >>data
] when*
dup data>> pathname? [
[ pathname>measured-stream ] change-data
] when
drop
] when* ;
PRIVATE>
: unparse-post-data ( request -- request )
[ >post-data ] change-post-data
normalize-post-data ;
: write-post-data ( request -- request )
dup post-data>> [ data>> (write-post-data) ] when* ;

4
basis/http/server/server.factor
View File

@ -196,8 +196,8 @@ LOG: httpd-hit NOTICE
LOG: httpd-header NOTICE
: log-header ( headers name -- )
tuck header 2array httpd-header ;
: log-header ( request name -- )
[ nip ] [ header ] 2bi 2array httpd-header ;
: log-request ( request -- )
[ [ method>> ] [ url>> ] bi 2array httpd-hit ]

3
basis/interval-maps/interval-maps.factor
View File

@ -31,7 +31,8 @@ PRIVATE>
: interval-at* ( key map -- value ? )
[ drop ] [ array>> find-interval ] 2bi
tuck interval-contains? [ third t ] [ drop f f ] if ;
[ nip ] [ interval-contains? ] 2bi
[ third t ] [ drop f f ] if ;
: interval-at ( key map -- value ) interval-at* drop ;

8
basis/io/directories/windows/windows.factor
View File

@ -33,13 +33,13 @@ M: windows delete-directory ( path -- )
RemoveDirectory win32-error=0/f ;
: find-first-file ( path -- WIN32_FIND_DATA handle )
"WIN32_FIND_DATA" <c-object> tuck
FindFirstFile
"WIN32_FIND_DATA" <c-object>
[ nip ] [ FindFirstFile ] 2bi
[ INVALID_HANDLE_VALUE = [ win32-error-string throw ] when ] keep ;
: find-next-file ( path -- WIN32_FIND_DATA/f )
"WIN32_FIND_DATA" <c-object> tuck
FindNextFile 0 = [
"WIN32_FIND_DATA" <c-object>
[ nip ] [ FindNextFile ] 2bi 0 = [
GetLastError ERROR_NO_MORE_FILES = [
win32-error
] unless drop f

3
basis/io/encodings/ascii/ascii.factor
View File

@ -9,7 +9,8 @@ IN: io.encodings.ascii
: decode-if< ( stream encoding max -- character )
nip swap stream-read1 dup
[ tuck > [ >fixnum ] [ drop replacement-char ] if ] [ 2drop f ] if ; inline
[ [ nip ] [ > ] 2bi [ >fixnum ] [ drop replacement-char ] if ]
[ 2drop f ] if ; inline
PRIVATE>
SINGLETON: ascii

4
basis/io/files/info/unix/freebsd/freebsd.factor
View File

@ -13,7 +13,7 @@ version io-size owner syncreads syncwrites asyncreads asyncwrites ;
M: freebsd new-file-system-info freebsd-file-system-info new ;
M: freebsd file-system-statfs ( path -- byte-array )
"statfs" <c-object> tuck statfs io-error ;
"statfs" <c-object> [ statfs io-error ] keep ;
M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
@ -40,7 +40,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf
} cleave ;
M: freebsd file-system-statvfs ( path -- byte-array )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{

4
basis/io/files/info/unix/linux/linux.factor
View File

@ -14,7 +14,7 @@ namelen ;
M: linux new-file-system-info linux-file-system-info new ;
M: linux file-system-statfs ( path -- byte-array )
"statfs64" <c-object> tuck statfs64 io-error ;
"statfs64" <c-object> [ statfs64 io-error ] keep ;
M: linux statfs>file-system-info ( struct -- statfs )
{
@ -32,7 +32,7 @@ M: linux statfs>file-system-info ( struct -- statfs )
} cleave ;
M: linux file-system-statvfs ( path -- byte-array )
"statvfs64" <c-object> tuck statvfs64 io-error ;
"statvfs64" <c-object> [ statvfs64 io-error ] keep ;
M: linux statvfs>file-system-info ( struct -- statfs )
{

4
basis/io/files/info/unix/macosx/macosx.factor
View File

@ -20,10 +20,10 @@ M: macosx file-systems ( -- array )
M: macosx new-file-system-info macosx-file-system-info new ;
M: macosx file-system-statfs ( normalized-path -- statfs )
"statfs64" <c-object> tuck statfs64 io-error ;
"statfs64" <c-object> [ statfs64 io-error ] keep ;
M: macosx file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: macosx statfs>file-system-info ( file-system-info byte-array -- file-system-info' )
{

2
basis/io/files/info/unix/netbsd/netbsd.factor
View File

@ -16,7 +16,7 @@ idx mount-from ;
M: netbsd new-file-system-info netbsd-file-system-info new ;
M: netbsd file-system-statvfs
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{

4
basis/io/files/info/unix/openbsd/openbsd.factor
View File

@ -14,7 +14,7 @@ owner ;
M: openbsd new-file-system-info freebsd-file-system-info new ;
M: openbsd file-system-statfs
"statfs" <c-object> tuck statfs io-error ;
"statfs" <c-object> [ statfs io-error ] keep ;
M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info' )
{
@ -41,7 +41,7 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info
} cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
"statvfs" <c-object> tuck statvfs io-error ;
"statvfs" <c-object> [ statvfs io-error ] keep ;
M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info' )
{

2
basis/io/ports/ports.factor
View File

@ -99,7 +99,7 @@ TUPLE: output-port < buffered-port ;
output-port <buffered-port> ;
: wait-to-write ( len port -- )
tuck buffer>> buffer-capacity <=
[ nip ] [ buffer>> buffer-capacity <= ] 2bi
[ drop ] [ stream-flush ] if ; inline
M: output-port stream-write1

2
basis/io/sockets/windows/nt/nt.factor
View File

@ -6,7 +6,7 @@ libc math sequences threads system combinators accessors ;
IN: io.sockets.windows.nt
: malloc-int ( object -- object )
"int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
"int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;

2
basis/match/match.factor
View File

@ -80,7 +80,7 @@ MACRO: match-cond ( assoc -- )
(match-first) drop ;
: (match-all) ( seq pattern-seq -- )
tuck (match-first) swap
[ nip ] [ (match-first) swap ] 2bi
[
, [ swap (match-all) ] [ drop ] if*
] [ 2drop ] if* ;

8
basis/math/functions/functions.factor
View File

@ -122,11 +122,9 @@ PRIVATE>
[ * ] 2keep gcd nip /i ; foldable
: mod-inv ( x n -- y )
tuck gcd 1 = [
dup 0 < [ + ] [ nip ] if
] [
"Non-trivial divisor found" throw
] if ; foldable
[ nip ] [ gcd 1 = ] 2bi
[ dup 0 < [ + ] [ nip ] if ]
[ "Non-trivial divisor found" throw ] if ; foldable
: ^mod ( x y n -- z )
over 0 < [

3
basis/math/polynomials/polynomials.factor
View File

@ -68,7 +68,8 @@ PRIVATE>
dup V{ 0 } clone p= [
drop nip
] [
tuck p/mod [ pick p* swap [ swapd p- ] dip ] dip (pgcd)
[ nip ] [ p/mod ] 2bi
[ pick p* swap [ swapd p- ] dip ] dip (pgcd)
] if ;
PRIVATE>

2
basis/math/ratios/ratios.factor
View File

@ -24,7 +24,7 @@ M: integer /
"Division by zero" throw
] [
dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip tuck /i [ /i ] dip fraction>
2dup gcd nip tuck [ /i ] 2bi@ fraction>
] if ;
M: ratio hashcode*

4
basis/mime/multipart/multipart.factor
View File

@ -54,7 +54,9 @@ ERROR: end-of-stream multipart ;
] if ;
: dump-until-separator ( multipart -- multipart )
dup [ current-separator>> ] [ bytes>> ] bi tuck start [
dup
[ current-separator>> ] [ bytes>> ] bi
[ nip ] [ start ] 2bi [
cut-slice
[ mime-write ]
[ over current-separator>> length tail-slice >>bytes ] bi*

3
basis/persistent/hashtables/nodes/leaf/leaf.factor
View File

@ -6,7 +6,8 @@ persistent.hashtables.nodes ;
IN: persistent.hashtables.nodes.leaf
: matching-key? ( key hashcode leaf-node -- ? )
tuck hashcode>> eq? [ key>> = ] [ 2drop f ] if ; inline
[ nip ] [ hashcode>> eq? ] 2bi
[ key>> = ] [ 2drop f ] if ; inline
M: leaf-node (entry-at) [ matching-key? ] keep and ;

3
basis/prettyprint/prettyprint.factor
View File

@ -248,7 +248,8 @@ GENERIC: declarations. ( obj -- )
M: object declarations. drop ;
: declaration. ( word prop -- )
tuck name>> word-prop [ pprint-word ] [ drop ] if ;
[ nip ] [ name>> word-prop ] 2bi
[ pprint-word ] [ drop ] if ;
M: word declarations.
{

2
basis/regexp/dfa/dfa.factor
View File

@ -72,7 +72,7 @@ IN: regexp.dfa
dup
[ nfa-traversal-flags>> ]
[ dfa-table>> transitions>> keys ] bi
[ tuck [ swap at ] with map concat ] with H{ } map>assoc
[ [ nip ] [ [ swap at ] with map concat ] 2bi ] with H{ } map>assoc
>>dfa-traversal-flags drop ;
: construct-dfa ( regexp -- )

2
basis/regexp/parser/parser.factor
View File

@ -63,7 +63,7 @@ left-parenthesis pipe caret dash ;
: cut-out ( vector n -- vector' vector ) cut rest ;
ERROR: cut-stack-error ;
: cut-stack ( obj vector -- vector' vector )
tuck last-index [ cut-stack-error ] unless* cut-out swap ;
[ nip ] [ last-index ] 2bi [ cut-stack-error ] unless* cut-out swap ;
: <possessive-kleene-star> ( obj -- kleene ) possessive-kleene-star boa ;
: <reluctant-kleene-star> ( obj -- kleene ) reluctant-kleene-star boa ;

2
basis/regexp/transition-tables/transition-tables.factor
View File

@ -35,7 +35,7 @@ TUPLE: transition-table transitions start-state final-states ;
H{ } clone >>final-states ;
: maybe-initialize-key ( key hashtable -- )
2dup key? [ 2drop ] [ H{ } clone -rot set-at ] if ;
2dup key? [ 2drop ] [ [ H{ } clone ] 2dip set-at ] if ;
: set-transition ( transition hash -- )
#! set the state as a key

3
basis/serialize/serialize.factor
View File

@ -221,8 +221,7 @@ SYMBOL: deserialized
(deserialize) (deserialize) 2dup lookup
dup [ 2nip ] [
drop
"Unknown word: " -rot
2array unparse append throw
2array unparse "Unknown word: " prepend throw
] if ;
: deserialize-gensym ( -- word )

2
basis/syndication/syndication.factor
View File

@ -9,7 +9,7 @@ USING: xml.utilities kernel assocs xml.generator math.order
IN: syndication
: any-tag-named ( tag names -- tag-inside )
f -rot [ tag-named nip dup ] with find 2drop ;
[ f ] 2dip [ tag-named nip dup ] with find 2drop ;
TUPLE: feed title url entries ;

2
basis/ui/gadgets/editors/editors.factor
View File

@ -350,7 +350,7 @@ M: editor gadget-text* editor-string % ;
dupd editor-select-next mark>caret ;
: editor-select ( from to editor -- )
tuck caret>> set-model mark>> set-model ;
tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ;
: select-elt ( editor elt -- )
[ [ [ editor-caret* ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi

13
basis/ui/gadgets/gadgets.factor
View File

@ -165,7 +165,9 @@ M: gadget dim-changed
in-layout? get [ invalidate ] [ invalidate* ] if ;
M: gadget (>>dim) ( dim gadget -- )
2dup dim>> = [ 2drop ] [ tuck call-next-method dim-changed ] if ;
2dup dim>> =
[ 2drop ]
[ [ nip ] [ call-next-method ] 2bi dim-changed ] if ;
GENERIC: pref-dim* ( gadget -- dim )
@ -250,7 +252,7 @@ M: gadget ungraft* drop ;
f >>parent drop ;
: unfocus-gadget ( child gadget -- )
tuck focus>> eq? [ f >>focus ] when drop ;
[ nip ] [ focus>> eq? ] 2bi [ f >>focus ] when drop ;
SYMBOL: in-layout?
@ -286,10 +288,7 @@ SYMBOL: in-layout?
dup unparent
over >>parent
tuck ((add-gadget))
tuck graft-state>> second
[ graft ]
[ drop ]
if ;
tuck graft-state>> second [ graft ] [ drop ] if ;
: add-gadget ( parent child -- parent )
not-in-layout
@ -316,7 +315,7 @@ SYMBOL: in-layout?
: (screen-rect) ( gadget -- loc ext )
dup parent>> [
[ rect-extent ] dip (screen-rect)
[ tuck v+ ] dip vmin [ v+ ] dip
[ [ nip ] [ v+ ] 2bi ] dip [ vmin ] [ v+ ] 2bi*
] [
rect-extent
] if* ;

2
basis/ui/gadgets/incremental/incremental.factor
View File

@ -23,7 +23,7 @@ M: incremental pref-dim*
] keep orientation>> set-axis ;
: update-cursor ( gadget incremental -- )
tuck next-cursor >>cursor drop ;
[ nip ] [ next-cursor ] 2bi >>cursor drop ;
: incremental-loc ( gadget incremental -- )
[ cursor>> ] [ orientation>> ] bi v*

2
basis/unicode/breaks/breaks.factor
View File

@ -96,7 +96,7 @@ PRIVATE>
: first-grapheme ( str -- i )
unclip-slice grapheme-class over
[ grapheme-class tuck grapheme-break? ] find drop
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
nip swap length or 1+ ;
<PRIVATE

2
basis/unicode/collation/collation.factor
View File

@ -125,7 +125,7 @@ PRIVATE>
: filter-ignorable ( weights -- weights' )
f swap [
tuck primary>> zero? and
[ nip ] [ primary>> zero? and ] 2bi
[ swap ignorable?>> or ]
[ swap completely-ignorable? or not ] 2bi
] filter nip ;

4
basis/unix/unix.factor
View File

@ -155,8 +155,8 @@ FUNCTION: int utime ( char* path, utimebuf* buf ) ;
: change-file-times ( filename access modification -- )
"utimebuf" <c-object>
tuck set-utimbuf-modtime
tuck set-utimbuf-actime
[ set-utimbuf-modtime ] keep
[ set-utimbuf-actime ] keep
[ utime ] unix-system-call drop ;
FUNCTION: int pclose ( void* file ) ;

2
basis/x11/clipboard/clipboard.factor
View File

@ -41,7 +41,7 @@ TUPLE: x-clipboard atom contents ;
] if ;
: own-selection ( prop win -- )
dpy get -rot CurrentTime XSetSelectionOwner drop
[ dpy get ] 2dip CurrentTime XSetSelectionOwner drop
flush-dpy ;
: set-targets-prop ( evt -- )

2
basis/x11/windows/windows.factor
View File

@ -37,7 +37,7 @@ IN: x11.windows
: set-size-hints ( window -- )
"XSizeHints" <c-object>
USPosition over set-XSizeHints-flags
dpy get -rot XSetWMNormalHints ;
[ dpy get ] 2dip XSetWMNormalHints ;
: auto-position ( window loc -- )
{ 0 0 } = [ drop ] [ set-size-hints ] if ;

3
basis/xml/data/data.factor
View File

@ -62,7 +62,8 @@ M: attrs assoc-like
M: attrs clear-assoc
f >>alist drop ;
M: attrs delete-at
tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
[ nip ] [ attr@ drop ] 2bi
[ swap alist>> delete-nth ] [ drop ] if* ;
M: attrs clone
alist>> clone <attrs> ;

2
basis/xmode/marker/marker.factor
View File

@ -100,7 +100,7 @@ DEFER: get-rules
[ ch>upper ] dip rules>> at ?push-all ;
: get-rules ( char ruleset -- seq )
f -rot [ get-char-rules ] keep get-always-rules ;
[ f ] 2dip [ get-char-rules ] keep get-always-rules ;
GENERIC: handle-rule-start ( match-count rule -- )

2
basis/xmode/utilities/utilities.factor
View File

@ -7,7 +7,7 @@ IN: xmode.utilities
: child-tags ( tag -- seq ) children>> [ tag? ] filter ;
: map-find ( seq quot -- result elt )
f -rot
[ f ] 2dip
'[ nip @ dup ] find
[ [ drop f ] unless ] dip ; inline

2
core/assocs/assocs.factor
View File

@ -188,7 +188,7 @@ M: sequence new-assoc drop <vector> ;
M: sequence clear-assoc delete-all ;
M: sequence delete-at
tuck search-alist nip
[ nip ] [ search-alist nip ] 2bi
[ swap delete-nth ] [ drop ] if* ;
M: sequence assoc-size length ;

21
core/bootstrap/primitives.factor
View File

@ -32,17 +32,14 @@ H{ } clone sub-primitives set
! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
H{ } clone new-classes set
H{ } clone changed-definitions set
H{ } clone changed-generics set
H{ } clone remake-generics set
H{ } clone forgotten-definitions set
H{ } clone root-cache set
H{ } clone source-files set
H{ } clone update-map set
H{ } clone implementors-map set
"syntax" vocab vocab-words bootstrap-syntax set {
dictionary
new-classes
changed-definitions changed-generics
remake-generics forgotten-definitions
root-cache source-files update-map implementors-map
} [ H{ } clone swap set ] each
init-caches
! Vocabulary for slot accessors
@ -264,7 +261,7 @@ bi
"vocabulary"
{ "def" { "quotation" "quotations" } initial: [ ] }
"props"
{ "compiled" read-only }
{ "optimized" read-only }
{ "counter" { "fixnum" "math" } }
{ "sub-primitive" read-only }
} define-builtin

2
core/classes/algebra/algebra.factor
View File

@ -215,7 +215,7 @@ M: anonymous-complement (classes-intersect?)
: min-class ( class seq -- class/f )
over [ classes-intersect? ] curry filter
[ drop f ] [
tuck [ class<= ] with all? [ peek ] [ drop f ] if
[ nip ] [ [ class<= ] with all? ] 2bi [ peek ] [ drop f ] if
] if-empty ;
GENERIC: (flatten-class) ( class -- )

2
core/classes/classes.factor
View File

@ -162,7 +162,7 @@ GENERIC: update-methods ( class seq -- )
dup "predicate" word-prop
dup length 1 = [
first
tuck "predicating" word-prop =
[ nip ] [ "predicating" word-prop = ] 2bi
[ forget ] [ drop ] if
] [ 2drop ] if ;

2
core/classes/mixin/mixin.factor
View File

@ -54,7 +54,7 @@ TUPLE: check-mixin-class class ;
#! class-usages of the member, now that it's been added.
[ 2drop ] [
[ [ suffix ] change-mixin-class ] 2keep
tuck [ new-class? ] either? [
[ nip ] [ [ new-class? ] either? ] 2bi [
update-classes/new
] [
update-classes

18
core/compiler/units/units-tests.factor
View File

@ -1,6 +1,6 @@
IN: compiler.units.tests
USING: definitions compiler.units tools.test arrays sequences words kernel
accessors ;
accessors namespaces fry ;
[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
@ -9,8 +9,22 @@ accessors ;
[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
! Non-optimizing compiler bug
! Non-optimizing compiler bugs
[ 1 1 ] [
"A" "B" <word> [ [ 1 ] dip ] >>def dup f 2array 1array f modify-code-heap
1 swap execute
] unit-test
[ "A" "B" ] [
gensym "a" set
gensym "b" set
[
"a" get [ "A" ] define
"b" get "a" get '[ _ execute ] define
] with-compilation-unit
"b" get execute
[
"a" get [ "B" ] define
] with-compilation-unit
"b" get execute
] unit-test

2
core/effects/parser/parser.factor
View File

@ -9,7 +9,7 @@ DEFER: parse-effect
ERROR: bad-effect ;
: parse-effect-token ( end -- token/f )
scan tuck = [ drop f ] [
scan [ nip ] [ = ] 2bi [ drop f ] [
dup { f "(" "((" } member? [ bad-effect ] [
":" ?tail [
scan-word {

3
core/generic/generic.factor
View File

@ -36,7 +36,8 @@ PREDICATE: method-spec < pair
"methods" word-prop keys sort-classes ;
: specific-method ( class generic -- method/f )
tuck order min-class dup [ swap method ] [ 2drop f ] if ;
[ nip ] [ order min-class ] 2bi
dup [ swap method ] [ 2drop f ] if ;
GENERIC: effective-method ( generic -- method )

2
core/hashtables/hashtables.factor
View File

@ -104,7 +104,7 @@ M: hashtable clear-assoc ( hash -- )
[ init-hash ] [ array>> [ drop ((empty)) ] change-each ] bi ;
M: hashtable delete-at ( key hash -- )
tuck key@ [
[ nip ] [ key@ ] 2bi [
[ ((tombstone)) dup ] 2dip set-nth-pair
hash-deleted+
] [

2
core/parser/parser.factor
View File

@ -254,7 +254,7 @@ print-use-hook global [ [ ] or ] change-at
[
[
lines dup parse-fresh
tuck finish-parsing
[ nip ] [ finish-parsing ] 2bi
forget-smudged
] with-source-file
] with-compilation-unit ;

12
core/sequences/sequences.factor
View File

@ -138,15 +138,15 @@ INSTANCE: iota immutable-sequence
: from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
: (2sequence) ( obj1 obj2 seq -- seq )
tuck 1 swap set-nth-unsafe
tuck 0 swap set-nth-unsafe ; inline
[ 1 swap set-nth-unsafe ] keep
[ 0 swap set-nth-unsafe ] keep ; inline
: (3sequence) ( obj1 obj2 obj3 seq -- seq )
tuck 2 swap set-nth-unsafe
[ 2 swap set-nth-unsafe ] keep
(2sequence) ; inline
: (4sequence) ( obj1 obj2 obj3 obj4 seq -- seq )
tuck 3 swap set-nth-unsafe
[ 3 swap set-nth-unsafe ] keep
(3sequence) ; inline
PRIVATE>
@ -723,14 +723,14 @@ PRIVATE>
2dup shorter? [
2drop f
] [
tuck length head-slice sequence=
[ nip ] [ length head-slice ] 2bi sequence=
] if ;
: tail? ( seq end -- ? )
2dup shorter? [
2drop f
] [
tuck length tail-slice* sequence=
[ nip ] [ length tail-slice* ] 2bi sequence=
] if ;
: cut-slice ( seq n -- before-slice after-slice )

7
extra/math/text/english/english.factor
View File

@ -1,7 +1,7 @@
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit grouping kernel math math.parser namespaces
sequences ;
USING: combinators.short-circuit grouping kernel math math.parser
math.text.utils namespaces sequences ;
IN: math.text.english
<PRIVATE
@ -31,9 +31,6 @@ SYMBOL: and-needed?
: negative-text ( n -- str )
0 < "Negative " "" ? ;
: 3digit-groups ( n -- seq )
[ dup 0 > ] [ 1000 /mod ] [ ] produce nip ;
: hundreds-place ( n -- str )
100 /mod over 0 = [
2drop ""

1
extra/math/text/french/authors.txt Normal file
View File

@ -0,0 +1 @@
Samuel Tardieu

6
extra/math/text/french/french-docs.factor Normal file
View File

@ -0,0 +1,6 @@
USING: help.markup help.syntax ;
IN: math.text.french
HELP: number>text
{ $values { "n" "an integer" } { "str" "a string" } }
{ $description "Return the a string describing " { $snippet "n" } " in French. Numbers with absolute value equal to or greater than 10^12 will be returned using their numeric representation." } ;

22
extra/math/text/french/french-tests.factor Normal file
View File

@ -0,0 +1,22 @@
USING: math math.functions math.parser math.text.french sequences tools.test ;
[ "zéro" ] [ 0 number>text ] unit-test
[ "vingt et un" ] [ 21 number>text ] unit-test
[ "vingt-deux" ] [ 22 number>text ] unit-test
[ "deux mille" ] [ 2000 number>text ] unit-test
[ "soixante et un" ] [ 61 number>text ] unit-test
[ "soixante-deux" ] [ 62 number>text ] unit-test
[ "quatre-vingts" ] [ 80 number>text ] unit-test
[ "quatre-vingt-un" ] [ 81 number>text ] unit-test
[ "quatre-vingt-onze" ] [ 91 number>text ] unit-test
[ "deux cents" ] [ 200 number>text ] unit-test
[ "mille deux cents" ] [ 1200 number>text ] unit-test
[ "mille deux cent quatre-vingts" ] [ 1280 number>text ] unit-test
[ "mille deux cent quatre-vingt-un" ] [ 1281 number>text ] unit-test
[ "un billion deux cent vingt milliards quatre-vingts millions trois cent quatre-vingt mille deux cents" ] [ 1220080380200 number>text ] unit-test
[ "un million" ] [ 1000000 number>text ] unit-test
[ "un million un" ] [ 1000001 number>text ] unit-test
[ "moins vingt" ] [ -20 number>text ] unit-test
[ 104 ] [ -1 10 102 ^ - number>text length ] unit-test
! Check that we do not exhaust stack
[ 1484 ] [ 10 100 ^ 1 - number>text length ] unit-test

97
extra/math/text/french/french.factor Normal file
View File

@ -0,0 +1,97 @@
! Copyright (c) 2009 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators kernel math math.functions
math.parser math.text.utils memoize sequences ;
IN: math.text.french
<PRIVATE
DEFER: basic ( n -- str )
CONSTANT: literals
H{ { 0 "zéro" } { 1 "un" } { 2 "deux" } { 3 "trois" } { 4 "quatre" }
{ 5 "cinq" } { 6 "six" } { 7 "sept" } { 8 "huit" } { 9 "neuf" }
{ 10 "dix" } { 11 "onze" } { 12 "douze" } { 13 "treize" }
{ 14 "quatorze" } { 15 "quinze" } { 16 "seize" } { 17 "dix-sept" }
{ 18 "dix-huit" } { 19 "dix-neuf" } { 20 "vingt" } { 30 "trente" }
{ 40 "quarante" } { 50 "cinquante" } { 60 "soixante" }
{ 71 "soixante et onze" } { 80 "quatre-vingts" }
{ 81 "quatre-vingt-un" }
{ 100 "cent" } { 1000 "mille" } }
MEMO: units ( -- seq ) ! up to 10^99
{ "m" "b" "tr" "quadr" "quint" "sext" "sept" "oct"
"non" "déc" "unodéc" "duodéc" "trédéc" "quattuordéc"
"quindéc" "sexdéc" }
[ [ "illion" append ] [ "illiard" append ] bi 2array ] map concat
"mille" prefix ;
! The only plurals we have to remove are "quatre-vingts" and "cents",
! which are also the only strings ending with "ts".
: unpluralize ( str -- newstr ) dup "ts" tail? [ but-last ] when ;
: pluralize ( str -- newstr ) CHAR: s suffix ;
: space-append ( str1 str2 -- str ) " " glue ;
! Small numbers (below 100) use dashes between them unless they are
! separated with "et". Pluralized prefixes must be unpluralized.
: complete-small ( str n -- str )
{ { 0 [ ] }
{ 1 [ " et un" append ] }
[ [ unpluralize ] dip basic "-" glue ] } case ;
: smaller-than-60 ( n -- str )
dup 10 mod [ - ] keep [ basic ] dip complete-small ;
: base-onto ( n b -- str ) [ nip literals at ] [ - ] 2bi complete-small ;
: smaller-than-80 ( n -- str ) 60 base-onto ;
: smaller-than-100 ( n -- str ) 80 base-onto ;
: if-zero ( n quot quot -- )
[ dup zero? ] 2dip [ [ drop ] prepose ] dip if ; inline
: complete ( str n -- newstr )
[ ] [ basic space-append ] if-zero ;
: smaller-than-1000 ( n -- str )
100 /mod
[ "cent" swap dup 1 = [ drop ] [ basic swap space-append ] if ]
[ [ pluralize ] [ basic space-append ] if-zero ] bi* ;
: smaller-than-2000 ( n -- str ) "mille" swap 1000 - complete ;
: smaller-than-1000000 ( n -- str )
1000 /mod [ basic unpluralize " mille" append ] dip complete ;
: n-units ( n unit -- str/f )
{
{ [ over zero? ] [ 2drop f ] }
{ [ over 1 = ] [ [ basic ] dip space-append ] }
[ [ basic ] dip space-append pluralize ]
} cond ;
: over-1000000 ( n -- str )
3digit-groups [ 1+ units nth n-units ] map-index sift
reverse " " join ;
: decompose ( n -- str ) 1000000 /mod [ over-1000000 ] dip complete ;
: basic ( n -- str )
{
{ [ dup literals key? ] [ literals at ] }
{ [ dup 0 < ] [ abs basic "moins " swap append ] }
{ [ dup 60 < ] [ smaller-than-60 ] }
{ [ dup 80 < ] [ smaller-than-80 ] }
{ [ dup 100 < ] [ smaller-than-100 ] }
{ [ dup 1000 < ] [ smaller-than-1000 ] }
{ [ dup 2000 < ] [ smaller-than-2000 ] }
{ [ dup 1000000 < ] [ smaller-than-1000000 ] }
[ decompose ]
} cond ;
PRIVATE>
: number>text ( n -- str )
dup abs 10 102 ^ >= [ number>string ] [ basic ] if ;

1
extra/math/text/french/summary.txt Normal file
View File

@ -0,0 +1 @@
Convert integers to French text

1
extra/math/text/utils/authors.txt Normal file
View File

@ -0,0 +1 @@
Aaron Schaefer

1
extra/math/text/utils/summary.txt Normal file
View File

@ -0,0 +1 @@
Number to text conversion utilities

6
extra/math/text/utils/utils-docs.factor Normal file
View File

@ -0,0 +1,6 @@
USING: help.markup help.syntax ;
IN: math.text.utils
HELP: 3digit-groups
{ $values { "n" "a positive integer" } { "seq" "a sequence" } }
{ $description "Decompose a number into 3 digits groups and return them in a sequence, starting with the units, then the tenths, etc." } ;

3
extra/math/text/utils/utils-tests.factor Normal file
View File

@ -0,0 +1,3 @@
USING: math.text.utils tools.test ;
[ { 1 999 2 } ] [ 2999001 3digit-groups ] unit-test

7
extra/math/text/utils/utils.factor Normal file
View File

@ -0,0 +1,7 @@
! Copyright (c) 2007, 2008 Aaron Schaefer.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math sequences ;
IN: math.text.utils
: 3digit-groups ( n -- seq )
[ dup 0 > ] [ 1000 /mod ] [ ] produce nip ;

4
vm/code_heap.c
View File

@ -315,7 +315,7 @@ void set_word_code(F_WORD *word, F_COMPILED *compiled)
critical_error("bad param to set_word_xt",(CELL)compiled);
word->code = compiled;
word->compiledp = T;
word->optimizedp = T;
}
/* Allocates memory */
@ -326,7 +326,7 @@ void default_word_code(F_WORD *word, bool relocate)
UNREGISTER_UNTAGGED(word);
word->code = untag_quotation(word->def)->code;
word->compiledp = F;
word->optimizedp = F;
}
void primitive_modify_code_heap(void)

5
vm/layouts.h
View File

@ -125,8 +125,9 @@ typedef struct {
CELL def;
/* TAGGED property assoc for library code */
CELL props;
/* TAGGED t or f, depending on if the word is compiled or not */
CELL compiledp;
/* TAGGED t or f, t means its compiled with the optimizing compiler,
f means its compiled with the non-optimizing compiler */
CELL optimizedp;
/* TAGGED call count for profiling */
CELL counter;
/* TAGGED machine code for sub-primitive */

2
vm/quotations.c
View File

@ -535,7 +535,7 @@ void compile_all_words(void)
{
F_WORD *word = untag_word(array_nth(untag_array(words),i));
REGISTER_UNTAGGED(word);
if(word->compiledp == F)
if(word->optimizedp == F)
default_word_code(word,false);
UNREGISTER_UNTAGGED(word);
update_word_xt(word);

2
vm/types.c
View File

@ -48,7 +48,7 @@ F_WORD *allot_word(CELL vocab, CELL name)
word->def = userenv[UNDEFINED_ENV];
word->props = F;
word->counter = tag_fixnum(0);
word->compiledp = F;
word->optimizedp = F;
word->subprimitive = F;
word->profiling = NULL;
word->code = NULL;