Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-02-04 20:32:03 -06:00
commit 7ae06b0d27
30 changed files with 227 additions and 95 deletions

1
.gitignore vendored
View File

@ -11,6 +11,7 @@ Factor/factor
*.image *.image
*.dylib *.dylib
factor factor
factor.com
*#*# *#*#
.DS_Store .DS_Store
.gdb_history .gdb_history

View File

@ -17,9 +17,8 @@ else
CFLAGS += -O3 $(SITE_CFLAGS) CFLAGS += -O3 $(SITE_CFLAGS)
endif endif
ifdef CONFIG CONFIG = $(shell ./build-support/factor.sh config-target)
include $(CONFIG) include $(CONFIG)
endif
ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION) ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
@ -130,18 +129,20 @@ solaris-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64
freetype6.dll: freetype6.dll:
wget http://factorcode.org/dlls/freetype6.dll wget $(DLL_PATH)/freetype6.dll
chmod 755 freetype6.dll chmod 755 freetype6.dll
zlib1.dll: zlib1.dll:
wget http://factorcode.org/dlls/zlib1.dll wget $(DLL_PATH)/zlib1.dll
chmod 755 zlib1.dll chmod 755 zlib1.dll
winnt-x86-32: freetype6.dll zlib1.dll windows-dlls: freetype6.dll zlib1.dll
winnt-x86-32: windows-dlls
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64: winnt-x86-64: windows-dlls
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
@ -167,7 +168,7 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
factor-console: $(DLL_OBJS) $(EXE_OBJS) factor-console: $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS) $(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \ $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS) $(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
clean: clean:
rm -f vm/*.o rm -f vm/*.o

View File

@ -3,17 +3,11 @@
USING: accessors kernel combinators math namespaces make assocs USING: accessors kernel combinators math namespaces make assocs
sequences splitting sorting sets strings vectors hashtables sequences splitting sorting sets strings vectors hashtables
quotations arrays byte-arrays math.parser calendar quotations arrays byte-arrays math.parser calendar
calendar.format present urls calendar.format present urls fry
io io.encodings io.encodings.iana io.encodings.binary io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit io.crlf io.encodings.8-bit io.crlf
unicode.case unicode.categories unicode.case unicode.categories
http.parsers ; http.parsers ;
EXCLUDE: fry => , ;
IN: http IN: http
: (read-header) ( -- alist ) : (read-header) ( -- alist )
@ -217,5 +211,7 @@ TUPLE: post-data data params content-type content-encoding ;
" " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ; " " split harvest [ "=" split1 [ >lower ] dip ] { } map>assoc ;
: parse-content-type ( content-type -- type encoding ) : parse-content-type ( content-type -- type encoding )
";" split1 parse-content-type-attributes "charset" swap at ";" split1
name>encoding over "text/" head? latin1 binary ? or ; parse-content-type-attributes "charset" swap at
[ name>encoding ]
[ dup "text/" head? latin1 binary ? ] if* ;

View File

@ -1,6 +1,21 @@
USING: http http.server math sequences continuations tools.test ; USING: http http.server math sequences continuations tools.test
io.encodings.utf8 io.encodings.binary accessors ;
IN: http.server.tests IN: http.server.tests
[ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test [ t ] [ [ \ + first ] [ <500> ] recover response? ] unit-test
\ make-http-error must-infer \ make-http-error must-infer
[ "text/plain; charset=UTF-8" ] [
<response>
"text/plain" >>content-type
utf8 >>content-charset
unparse-content-type
] unit-test
[ "text/xml" ] [
<response>
"text/xml" >>content-type
binary >>content-charset
unparse-content-type
] unit-test

View File

@ -97,10 +97,8 @@ GENERIC: write-full-response ( request response -- )
tri ; tri ;
: unparse-content-type ( request -- content-type ) : unparse-content-type ( request -- content-type )
[ content-type>> "application/octet-stream" or ] [ content-type>> "application/octet-stream" or ] [ content-charset>> ] bi
[ content-charset>> encoding>name ] dup binary eq? [ drop ] [ encoding>name "; charset=" glue ] if ;
bi
[ "; charset=" glue ] when* ;
: ensure-domain ( cookie -- cookie ) : ensure-domain ( cookie -- cookie )
[ [

View File

@ -1,9 +1,9 @@
! Copyright (C) 2009 Daniel Ehrenberg ! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: xml xml.data kernel io io.encodings interval-maps splitting fry USING: xml xml.data kernel io io.encodings interval-maps splitting fry
math.parser sequences combinators assocs locals accessors math math.parser sequences combinators assocs locals accessors math arrays
arrays values io.encodings.ascii ascii io.files biassocs math.order byte-arrays values io.encodings.ascii ascii io.files biassocs
combinators.short-circuit io.binary io.encodings.iana ; math.order combinators.short-circuit io.binary io.encodings.iana ;
IN: io.encodings.chinese IN: io.encodings.chinese
SINGLETON: gb18030 SINGLETON: gb18030
@ -17,6 +17,14 @@ gb18030 "GB18030" register-encoding
! Resource file from: ! Resource file from:
! http://source.icu-project.org/repos/icu/data/trunk/charset/data/xml/gb-18030-2000.xml ! http://source.icu-project.org/repos/icu/data/trunk/charset/data/xml/gb-18030-2000.xml
! Algorithms from:
! http://www-128.ibm.com/developerworks/library/u-china.html
: linear ( bytes -- num )
! This hard-codes bMin and bMax
reverse first4
10 * + 126 * + 10 * + ; foldable
TUPLE: range ufirst ulast bfirst blast ; TUPLE: range ufirst ulast bfirst blast ;
: b>byte-array ( string -- byte-array ) : b>byte-array ( string -- byte-array )
@ -27,8 +35,8 @@ TUPLE: range ufirst ulast bfirst blast ;
{ {
[ "uFirst" attr hex> ] [ "uFirst" attr hex> ]
[ "uLast" attr hex> ] [ "uLast" attr hex> ]
[ "bFirst" attr b>byte-array ] [ "bFirst" attr b>byte-array linear ]
[ "bLast" attr b>byte-array ] [ "bLast" attr b>byte-array linear ]
} cleave range boa } cleave range boa
] dip push ; ] dip push ;
@ -51,21 +59,13 @@ TUPLE: range ufirst ulast bfirst blast ;
] each-element mapping ranges ] each-element mapping ranges
] ; ] ;
! Algorithms from:
! http://www-128.ibm.com/developerworks/library/u-china.html
: linear ( bytes -- num )
! This hard-codes bMin and bMax
reverse first4
10 * + 126 * + 10 * + ;
: unlinear ( num -- bytes ) : unlinear ( num -- bytes )
B{ HEX: 81 HEX: 30 HEX: 81 HEX: 30 } linear - B{ HEX: 81 HEX: 30 HEX: 81 HEX: 30 } linear -
10 /mod swap [ HEX: 30 + ] dip 10 /mod HEX: 30 + swap
126 /mod swap [ HEX: 81 + ] dip 126 /mod HEX: 81 + swap
10 /mod swap [ HEX: 30 + ] dip 10 /mod HEX: 30 + swap
HEX: 81 + HEX: 81 +
B{ } 4sequence reverse ; 4byte-array dup reverse-here ;
: >interval-map-by ( start-quot end-quot value-quot seq -- interval-map ) : >interval-map-by ( start-quot end-quot value-quot seq -- interval-map )
'[ _ [ @ 2array ] _ tri ] { } map>assoc <interval-map> ; inline '[ _ [ @ 2array ] _ tri ] { } map>assoc <interval-map> ; inline
@ -74,7 +74,7 @@ TUPLE: range ufirst ulast bfirst blast ;
[ ufirst>> ] [ ulast>> ] [ ] >interval-map-by ; [ ufirst>> ] [ ulast>> ] [ ] >interval-map-by ;
: ranges-gb>u ( ranges -- interval-map ) : ranges-gb>u ( ranges -- interval-map )
[ bfirst>> linear ] [ blast>> linear ] [ ] >interval-map-by ; [ bfirst>> ] [ blast>> ] [ ] >interval-map-by ;
VALUE: gb>u VALUE: gb>u
VALUE: u>gb VALUE: u>gb
@ -87,7 +87,7 @@ ascii <file-reader> xml>gb-data
: lookup-range ( char -- byte-array ) : lookup-range ( char -- byte-array )
dup u>gb interval-at [ dup u>gb interval-at [
[ ufirst>> - ] [ bfirst>> linear ] bi + unlinear [ ufirst>> - ] [ bfirst>> ] bi + unlinear
] [ encode-error ] if* ; ] [ encode-error ] if* ;
M: gb18030 encode-char ( char stream encoding -- ) M: gb18030 encode-char ( char stream encoding -- )
@ -109,19 +109,19 @@ M: gb18030 encode-char ( char stream encoding -- )
: decode-quad ( byte-array -- char ) : decode-quad ( byte-array -- char )
dup mapping value-at [ ] [ dup mapping value-at [ ] [
linear dup gb>u interval-at [ linear dup gb>u interval-at [
[ bfirst>> linear - ] [ ufirst>> ] bi + [ bfirst>> - ] [ ufirst>> ] bi +
] [ drop replacement-char ] if* ] [ drop replacement-char ] if*
] ?if ; ] ?if ;
: four-byte ( stream byte1 byte2 -- char ) : four-byte ( stream byte1 byte2 -- char )
rot 2 swap stream-read dup last-bytes? rot 2 swap stream-read dup last-bytes?
[ first2 B{ } 4sequence decode-quad ] [ first2 4byte-array decode-quad ]
[ 3drop replacement-char ] if ; [ 3drop replacement-char ] if ;
: two-byte ( stream byte -- char ) : two-byte ( stream byte -- char )
over stream-read1 { over stream-read1 {
{ [ dup not ] [ 3drop replacement-char ] } { [ dup not ] [ 3drop replacement-char ] }
{ [ dup second-byte? ] [ B{ } 2sequence mapping value-at nip ] } { [ dup second-byte? ] [ 2byte-array mapping value-at nip ] }
{ [ dup quad-2/4? ] [ four-byte ] } { [ dup quad-2/4? ] [ four-byte ] }
[ 3drop replacement-char ] [ 3drop replacement-char ]
} cond ; } cond ;
@ -129,7 +129,7 @@ M: gb18030 encode-char ( char stream encoding -- )
M: gb18030 decode-char ( stream encoding -- char ) M: gb18030 decode-char ( stream encoding -- char )
drop dup stream-read1 { drop dup stream-read1 {
{ [ dup not ] [ 2drop f ] } { [ dup not ] [ 2drop f ] }
{ [ dup ascii? ] [ nip 1array B{ } like mapping value-at ] } { [ dup ascii? ] [ nip 1byte-array mapping value-at ] }
{ [ dup quad-1/3? ] [ two-byte ] } { [ dup quad-1/3? ] [ two-byte ] }
[ 2drop replacement-char ] [ 2drop replacement-char ]
} cond ; } cond ;

View File

@ -1,5 +1,5 @@
USING: io.encodings.iana io.encodings.iana.private USING: io.encodings.iana io.encodings.iana.private
io.encodings.utf8 tools.test assocs ; io.encodings.utf8 tools.test assocs namespaces ;
IN: io.encodings.iana.tests IN: io.encodings.iana.tests
[ utf8 ] [ "UTF-8" name>encoding ] unit-test [ utf8 ] [ "UTF-8" name>encoding ] unit-test
@ -15,9 +15,9 @@ ebcdic-fisea "EBCDIC-FI-SE-A" register-encoding
! Clean up after myself ! Clean up after myself
[ ] [ [ ] [
"EBCDIC-FI-SE-A" n>e-table delete-at "EBCDIC-FI-SE-A" n>e-table get delete-at
"csEBCDICFISEA" n>e-table delete-at "csEBCDICFISEA" n>e-table get delete-at
ebcdic-fisea e>n-table delete-at ebcdic-fisea e>n-table get delete-at
] unit-test ] unit-test
[ "EBCDIC-FI-SE-A" name>encoding ] must-fail [ "EBCDIC-FI-SE-A" name>encoding ] must-fail
[ "csEBCDICFISEA" name>encoding ] must-fail [ "csEBCDICFISEA" name>encoding ] must-fail

View File

@ -1,9 +1,9 @@
! Copyright (C) 2009 Daniel Ehrenberg ! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel io io.files combinators.short-circuit USING: sequences kernel io io.files combinators.short-circuit
math.order values assocs io.encodings io.binary fry strings math.order values assocs io.encodings io.binary fry strings math
math io.encodings.ascii arrays accessors splitting math.parser io.encodings.ascii arrays byte-arrays accessors splitting
biassocs io.encodings.iana ; math.parser biassocs io.encodings.iana ;
IN: io.encodings.japanese IN: io.encodings.japanese
SINGLETON: shift-jis SINGLETON: shift-jis
@ -55,7 +55,7 @@ make-jis to: shift-jis-table
{ [ 0 HEX: 7F between? ] [ HEX: A1 HEX: DF between? ] } 1|| ; { [ 0 HEX: 7F between? ] [ HEX: A1 HEX: DF between? ] } 1|| ;
: write-halfword ( stream halfword -- ) : write-halfword ( stream halfword -- )
h>b/b swap B{ } 2sequence swap stream-write ; h>b/b swap 2byte-array swap stream-write ;
M: jis encode-char M: jis encode-char
swapd ch>jis swapd ch>jis

View File

@ -1,7 +1,7 @@
USING: io.launcher tools.test calendar accessors environment USING: io.launcher tools.test calendar accessors environment
namespaces kernel system arrays io io.files io.encodings.ascii namespaces kernel system arrays io io.files io.encodings.ascii
sequences parser assocs hashtables math continuations eval sequences parser assocs hashtables math continuations eval
io.files.temp io.directories io.pathnames ; io.files.temp io.directories io.pathnames splitting ;
IN: io.launcher.windows.nt.tests IN: io.launcher.windows.nt.tests
[ ] [ [ ] [
@ -23,9 +23,12 @@ IN: io.launcher.windows.nt.tests
[ f ] [ "notepad" get process-running? ] unit-test [ f ] [ "notepad" get process-running? ] unit-test
: console-vm ( -- path )
vm ".exe" ?tail [ ".com" append ] when ;
[ ] [ [ ] [
<process> <process>
vm "-quiet" "-run=hello-world" 3array >>command console-vm "-quiet" "-run=hello-world" 3array >>command
"out.txt" temp-file >>stdout "out.txt" temp-file >>stdout
try-process try-process
] unit-test ] unit-test
@ -36,7 +39,7 @@ IN: io.launcher.windows.nt.tests
[ ] [ [ ] [
<process> <process>
vm "-run=listener" 2array >>command console-vm "-run=listener" 2array >>command
+closed+ >>stdin +closed+ >>stdin
try-process try-process
] unit-test ] unit-test
@ -47,7 +50,7 @@ IN: io.launcher.windows.nt.tests
[ ] [ [ ] [
launcher-test-path [ launcher-test-path [
<process> <process>
vm "-script" "stderr.factor" 3array >>command console-vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout "out.txt" temp-file >>stdout
"err.txt" temp-file >>stderr "err.txt" temp-file >>stderr
try-process try-process
@ -65,7 +68,7 @@ IN: io.launcher.windows.nt.tests
[ ] [ [ ] [
launcher-test-path [ launcher-test-path [
<process> <process>
vm "-script" "stderr.factor" 3array >>command console-vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout "out.txt" temp-file >>stdout
+stdout+ >>stderr +stdout+ >>stderr
try-process try-process
@ -79,7 +82,7 @@ IN: io.launcher.windows.nt.tests
[ "output" ] [ [ "output" ] [
launcher-test-path [ launcher-test-path [
<process> <process>
vm "-script" "stderr.factor" 3array >>command console-vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr "err2.txt" temp-file >>stderr
ascii <process-reader> lines first ascii <process-reader> lines first
] with-directory ] with-directory
@ -92,7 +95,7 @@ IN: io.launcher.windows.nt.tests
[ t ] [ [ t ] [
launcher-test-path [ launcher-test-path [
<process> <process>
vm "-script" "env.factor" 3array >>command console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval
@ -102,7 +105,7 @@ IN: io.launcher.windows.nt.tests
[ t ] [ [ t ] [
launcher-test-path [ launcher-test-path [
<process> <process>
vm "-script" "env.factor" 3array >>command console-vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode +replace-environment+ >>environment-mode
os-envs >>environment os-envs >>environment
ascii <process-reader> contents ascii <process-reader> contents
@ -114,7 +117,7 @@ IN: io.launcher.windows.nt.tests
[ "B" ] [ [ "B" ] [
launcher-test-path [ launcher-test-path [
<process> <process>
vm "-script" "env.factor" 3array >>command console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
ascii <process-reader> contents ascii <process-reader> contents
] with-directory eval ] with-directory eval
@ -125,7 +128,7 @@ IN: io.launcher.windows.nt.tests
[ f ] [ [ f ] [
launcher-test-path [ launcher-test-path [
<process> <process>
vm "-script" "env.factor" 3array >>command console-vm "-script" "env.factor" 3array >>command
{ { "USERPROFILE" "XXX" } } >>environment { { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode +prepend-environment+ >>environment-mode
ascii <process-reader> contents ascii <process-reader> contents
@ -151,7 +154,7 @@ IN: io.launcher.windows.nt.tests
2 [ 2 [
launcher-test-path [ launcher-test-path [
<process> <process>
vm "-script" "append.factor" 3array >>command console-vm "-script" "append.factor" 3array >>command
"append-test" temp-file <appender> >>stdout "append-test" temp-file <appender> >>stdout
try-process try-process
] with-directory ] with-directory

View File

@ -70,7 +70,7 @@ IN: stack-checker.transforms
[ [
[ no-case ] [ no-case ]
] [ ] [
dup peek quotation? [ dup peek callable? [
dup peek swap but-last dup peek swap but-last
] [ ] [
[ no-case ] swap [ no-case ] swap

View File

@ -1 +1,2 @@
Daniel Ehrenberg Daniel Ehrenberg
Slava Pestov

View File

@ -0,0 +1,41 @@
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup strings math kernel ;
IN: wrap
ABOUT: "wrap"
ARTICLE: "wrap" "Word wrapping"
"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. There is support for simple string wrapping, with the following words:"
{ $subsection wrap-lines }
{ $subsection wrap-string }
{ $subsection wrap-indented-string }
"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called words."
{ $subsection wrap }
{ $subsection word }
{ $subsection <word> } ;
HELP: wrap-lines
{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } }
{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
HELP: wrap-string
{ $values { "string" string } { "width" integer } { "newstring" string } }
{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
HELP: wrap-indented-string
{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } }
{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ;
HELP: wrap
{ $values { "words" { "a sequence of " { $instance word } "s" } } { "width" integer } { "lines" "a sequence of sequences of words" } }
{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given width. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ;
HELP: word
{ $class-description "A word, for the purposes of " { $vocab-link "wrap" } ", is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link <word> } "." }
{ $see-also wrap } ;
HELP: <word>
{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } }
{ $description "Creates a " { $link word } " object with the given parameters." }
{ $see-also wrap } ;

View File

@ -1,5 +1,7 @@
IN: wrap.tests ! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test wrap multiline sequences ; USING: tools.test wrap multiline sequences ;
IN: wrap.tests
[ [
{ {
@ -23,6 +25,32 @@ USING: tools.test wrap multiline sequences ;
} 35 wrap [ { } like ] map } 35 wrap [ { } like ] map
] unit-test ] unit-test
[
{
{
T{ word f 1 10 f }
T{ word f 2 10 f }
T{ word f 3 9 t }
T{ word f 3 9 t }
T{ word f 3 9 t }
}
{
T{ word f 4 10 f }
T{ word f 5 10 f }
}
}
] [
{
T{ word f 1 10 f }
T{ word f 2 10 f }
T{ word f 3 9 t }
T{ word f 3 9 t }
T{ word f 3 9 t }
T{ word f 4 10 f }
T{ word f 5 10 f }
} 35 wrap [ { } like ] map
] unit-test
[ [
<" This is a <" This is a
long piece long piece
@ -46,3 +74,9 @@ word wrap.">
<" This is a long piece of text that we wish to word wrap."> 12 <" This is a long piece of text that we wish to word wrap."> 12
" " wrap-indented-string " " wrap-indented-string
] unit-test ] unit-test
[ "this text\nhas lots of\nspaces" ]
[ "this text has lots of spaces" 12 wrap-string ] unit-test
[ "hello\nhow\nare\nyou\ntoday?" ]
[ "hello how are you today?" 3 wrap-string ] unit-test

View File

@ -1,3 +1,5 @@
! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel namespaces make splitting USING: sequences kernel namespaces make splitting
math math.order fry assocs accessors ; math math.order fry assocs accessors ;
IN: wrap IN: wrap
@ -15,12 +17,25 @@ SYMBOL: width
: break-here? ( column word -- ? ) : break-here? ( column word -- ? )
break?>> not [ width get > ] [ drop f ] if ; break?>> not [ width get > ] [ drop f ] if ;
: walk ( n words -- n )
! If on a break, take the rest of the breaks
! If not on a break, go back until you hit a break
2dup bounds-check? [
2dup nth break?>>
[ [ break?>> not ] find-from drop ]
[ [ break?>> ] find-last-from drop 1+ ] if
] [ drop ] if ;
: find-optimal-break ( words -- n ) : find-optimal-break ( words -- n )
[ 0 ] dip [ [ width>> + dup ] keep break-here? ] find drop nip ; [ 0 ] keep
[ [ width>> + dup ] keep break-here? ] find drop nip
[ 1 max swap walk ] [ drop f ] if* ;
: (wrap) ( words -- ) : (wrap) ( words -- )
[
dup find-optimal-break dup find-optimal-break
[ 1 max cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* ; [ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if*
] unless-empty ;
: intersperse ( seq elt -- seq' ) : intersperse ( seq elt -- seq' )
[ '[ _ , ] [ , ] interleave ] { } make ; [ '[ _ , ] [ , ] interleave ] { } make ;
@ -34,9 +49,7 @@ SYMBOL: width
: join-words ( wrapped-lines -- lines ) : join-words ( wrapped-lines -- lines )
[ [
[ break?>> ] [ break?>> ] trim-slice
[ trim-head-slice ]
[ trim-tail-slice ] bi
[ key>> ] map concat [ key>> ] map concat
] map ; ] map ;

View File

@ -236,7 +236,7 @@ find_word_size() {
set_factor_binary() { set_factor_binary() {
case $OS in case $OS in
winnt) FACTOR_BINARY=factor-console.exe;; winnt) FACTOR_BINARY=factor.com;;
*) FACTOR_BINARY=factor;; *) FACTOR_BINARY=factor;;
esac esac
} }
@ -260,6 +260,7 @@ echo_build_info() {
$ECHO FACTOR_BINARY=$FACTOR_BINARY $ECHO FACTOR_BINARY=$FACTOR_BINARY
$ECHO FACTOR_LIBRARY=$FACTOR_LIBRARY $ECHO FACTOR_LIBRARY=$FACTOR_LIBRARY
$ECHO FACTOR_IMAGE=$FACTOR_IMAGE $ECHO FACTOR_IMAGE=$FACTOR_IMAGE
$ECHO CONFIG_TARGET=$CONFIG_TARGET
$ECHO MAKE_TARGET=$MAKE_TARGET $ECHO MAKE_TARGET=$MAKE_TARGET
$ECHO BOOT_IMAGE=$BOOT_IMAGE $ECHO BOOT_IMAGE=$BOOT_IMAGE
$ECHO MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET $ECHO MAKE_IMAGE_TARGET=$MAKE_IMAGE_TARGET
@ -289,20 +290,30 @@ set_build_info() {
if [[ $OS == macosx && $ARCH == ppc ]] ; then if [[ $OS == macosx && $ARCH == ppc ]] ; then
MAKE_IMAGE_TARGET=macosx-ppc MAKE_IMAGE_TARGET=macosx-ppc
MAKE_TARGET=macosx-ppc MAKE_TARGET=macosx-ppc
CONFIG_TARGET=macosx.ppc
elif [[ $OS == linux && $ARCH == ppc ]] ; then elif [[ $OS == linux && $ARCH == ppc ]] ; then
MAKE_IMAGE_TARGET=linux-ppc MAKE_IMAGE_TARGET=linux-ppc
MAKE_TARGET=linux-ppc MAKE_TARGET=linux-ppc
CONFIG_TARGET=linux.ppc
elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
MAKE_IMAGE_TARGET=winnt-x86.64 MAKE_IMAGE_TARGET=winnt-x86.64
MAKE_TARGET=winnt-x86-64 MAKE_TARGET=winnt-x86-64
CONFIG_TARGET=windows.nt.x86.64
elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then
MAKE_IMAGE_TARGET=winnt-x86.32
MAKE_TARGET=winnt-x86-32
CONFIG_TARGET=windows.nt.x86.32
elif [[ $ARCH == x86 && $WORD == 64 ]] ; then elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
MAKE_IMAGE_TARGET=unix-x86.64 MAKE_IMAGE_TARGET=unix-x86.64
MAKE_TARGET=$OS-x86-64 MAKE_TARGET=$OS-x86-64
CONFIG_TARGET=$OS.x86.64
else else
MAKE_IMAGE_TARGET=$ARCH.$WORD MAKE_IMAGE_TARGET=$ARCH.$WORD
MAKE_TARGET=$OS-$ARCH-$WORD MAKE_TARGET=$OS-$ARCH-$WORD
CONFIG_TARGET=$OS.$ARCH.$WORD
fi fi
BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image BOOT_IMAGE=boot.$MAKE_IMAGE_TARGET.image
CONFIG_TARGET=vm/Config.$CONFIG_TARGET
} }
parse_build_info() { parse_build_info() {
@ -570,5 +581,6 @@ case "$1" in
dlls) get_config_info; maybe_download_dlls;; dlls) get_config_info; maybe_download_dlls;;
net-bootstrap) get_config_info; update_boot_images; bootstrap ;; net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;; make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
config-target) ECHO=false; find_build_info; echo $CONFIG_TARGET ;;
*) usage ;; *) usage ;;
esac esac

View File

@ -9,3 +9,5 @@ USING: tools.test byte-arrays sequences kernel ;
[ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test [ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test
[ -10 B{ } resize-byte-array ] must-fail [ -10 B{ } resize-byte-array ] must-fail
[ B{ 123 } ] [ 123 1byte-array ] unit-test

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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private alien.accessors sequences USING: accessors kernel kernel.private alien.accessors sequences
sequences.private math ; sequences.private math ;
@ -19,7 +19,7 @@ M: byte-array resize
INSTANCE: byte-array sequence INSTANCE: byte-array sequence
: 1byte-array ( x -- byte-array ) 1 <byte-array> [ set-first ] keep ; inline : 1byte-array ( x -- byte-array ) B{ } 1sequence ; inline
: 2byte-array ( x y -- byte-array ) B{ } 2sequence ; inline : 2byte-array ( x y -- byte-array ) B{ } 2sequence ; inline

View File

@ -1,6 +1,6 @@
USING: alien strings kernel math tools.test io prettyprint USING: alien strings kernel math tools.test io prettyprint
namespaces combinators words classes sequences accessors namespaces combinators words classes sequences accessors
math.functions ; math.functions arrays ;
IN: combinators.tests IN: combinators.tests
! Compiled ! Compiled
@ -314,3 +314,13 @@ IN: combinators.tests
\ test-case-7 must-infer \ test-case-7 must-infer
[ "plus" ] [ \ + test-case-7 ] unit-test [ "plus" ] [ \ + test-case-7 ] unit-test
! Some corner cases (no pun intended)
DEFER: corner-case-1
<< \ corner-case-1 2 [ + ] curry 1array [ case ] curry (( a -- b )) define-declared >>
[ t ] [ \ corner-case-1 optimized>> ] unit-test
[ 4 ] [ 2 corner-case-1 ] unit-test
[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test

View File

@ -59,13 +59,13 @@ ERROR: no-case ;
] [ ] [
dup wrapper? [ wrapped>> ] when dup wrapper? [ wrapped>> ] when
] if = ] if =
] [ quotation? ] if ] [ callable? ] if
] find nip ; ] find nip ;
: case ( obj assoc -- ) : case ( obj assoc -- )
case-find { case-find {
{ [ dup array? ] [ nip second call ] } { [ dup array? ] [ nip second call ] }
{ [ dup quotation? ] [ call ] } { [ dup callable? ] [ call ] }
{ [ dup not ] [ no-case ] } { [ dup not ] [ no-case ] }
} cond ; } cond ;

View File

@ -246,8 +246,8 @@ HELP: retry
{ $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." } { $description "Tries the quotation up to " { $snippet "n" } " times until it returns true. Retries the quotation if an exception is thrown or if the quotation returns " { $link f } ". The quotation is expected to have side effects that may fail, such as generating a random name for a new file until successful." }
{ $examples { $examples
"Try to get a 0 as a random number:" "Try to get a 0 as a random number:"
{ $unchecked-example "USING: continuations math prettyprint ;" { $unchecked-example "USING: continuations math prettyprint random ;"
"[ 5 random 0 = ] 5 retry t" "[ 5 random 0 = ] 5 retry"
"t" "t"
} }
} ; } ;

View File

@ -207,6 +207,10 @@ HELP: first4-unsafe
{ $values { "seq" sequence } { "first" "the first element" } { "second" "the second element" } { "third" "the third element" } { "fourth" "the fourth element" } } { $values { "seq" sequence } { "first" "the first element" } { "second" "the second element" } { "third" "the third element" } { "fourth" "the fourth element" } }
{ $contract "Unsafe variant of " { $link first4 } " that does not perform bounds checks." } ; { $contract "Unsafe variant of " { $link first4 } " that does not perform bounds checks." } ;
HELP: 1sequence
{ $values { "obj" object } { "exemplar" sequence } { "seq" sequence } }
{ $description "Creates a one-element sequence of the same type as " { $snippet "exemplar" } "." } ;
HELP: 2sequence HELP: 2sequence
{ $values { "obj1" object } { "obj2" object } { "exemplar" sequence } { "seq" sequence } } { $values { "obj1" object } { "obj2" object } { "exemplar" sequence } { "seq" sequence } }
{ $description "Creates a two-element sequence of the same type as " { $snippet "exemplar" } "." } ; { $description "Creates a two-element sequence of the same type as " { $snippet "exemplar" } "." } ;

View File

@ -137,9 +137,12 @@ INSTANCE: iota immutable-sequence
: from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline : from-end ( seq n -- seq n' ) [ dup length ] dip - ; inline
: (1sequence) ( obj seq -- seq )
[ 0 swap set-nth-unsafe ] keep ; inline
: (2sequence) ( obj1 obj2 seq -- seq ) : (2sequence) ( obj1 obj2 seq -- seq )
[ 1 swap set-nth-unsafe ] keep [ 1 swap set-nth-unsafe ] keep
[ 0 swap set-nth-unsafe ] keep ; inline (1sequence) ; inline
: (3sequence) ( obj1 obj2 obj3 seq -- seq ) : (3sequence) ( obj1 obj2 obj3 seq -- seq )
[ 2 swap set-nth-unsafe ] keep [ 2 swap set-nth-unsafe ] keep
@ -151,6 +154,9 @@ INSTANCE: iota immutable-sequence
PRIVATE> PRIVATE>
: 1sequence ( obj exemplar -- seq )
1 swap [ (1sequence) ] new-like ; inline
: 2sequence ( obj1 obj2 exemplar -- seq ) : 2sequence ( obj1 obj2 exemplar -- seq )
2 swap [ (2sequence) ] new-like ; inline 2 swap [ (2sequence) ] new-like ; inline

View File

@ -97,3 +97,5 @@ IN: vectors.tests
[ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test [ fixnum ] [ 1 >bignum V{ } new-sequence length class ] unit-test
[ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test [ fixnum ] [ 1 >bignum [ ] V{ } map-as length class ] unit-test
[ V{ "lulz" } ] [ "lulz" 1vector ] unit-test

View File

@ -40,7 +40,7 @@ M: sequence new-resizable drop <vector> ;
INSTANCE: vector growable INSTANCE: vector growable
: 1vector ( x -- vector ) 1array >vector ; : 1vector ( x -- vector ) V{ } 1sequence ;
: ?push ( elt seq/f -- seq ) : ?push ( elt seq/f -- seq )
[ 1 <vector> ] unless* [ push ] keep ; [ 1 <vector> ] unless* [ push ] keep ;

View File

@ -53,7 +53,6 @@ IN: reports.noise
{ nipd 3 } { nipd 3 }
{ nkeep 5 } { nkeep 5 }
{ npick 6 } { npick 6 }
{ nrev 5 }
{ nrot 5 } { nrot 5 }
{ nslip 5 } { nslip 5 }
{ ntuck 6 } { ntuck 6 }

View File

@ -2,6 +2,7 @@ CFLAGS += -DWINDOWS -mno-cygwin
LIBS = -lm LIBS = -lm
PLAF_DLL_OBJS += vm/os-windows.o PLAF_DLL_OBJS += vm/os-windows.o
EXE_EXTENSION=.exe EXE_EXTENSION=.exe
CONSOLE_EXTENSION=.com
DLL_EXTENSION=.dll DLL_EXTENSION=.dll
LINKER = $(CC) -shared -mno-cygwin -o LINKER = $(CC) -shared -mno-cygwin -o
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)

View File

@ -6,4 +6,5 @@ PLAF_EXE_OBJS += vm/resources.o
PLAF_EXE_OBJS += vm/main-windows-nt.o PLAF_EXE_OBJS += vm/main-windows-nt.o
CFLAGS += -mwindows CFLAGS += -mwindows
CFLAGS_CONSOLE += -mconsole CFLAGS_CONSOLE += -mconsole
CONSOLE_EXTENSION = .com
include vm/Config.windows include vm/Config.windows

View File

@ -1,3 +1,4 @@
DLL_PATH=http://factorcode.org/dlls
WINDRES=windres WINDRES=windres
include vm/Config.windows.nt include vm/Config.windows.nt
include vm/Config.x86.32 include vm/Config.x86.32

View File

@ -1,3 +1,5 @@
#error "lol"
DLL_PATH=http://factorcode.org/dlls/64
CC=$(WIN64_PATH)-gcc.exe CC=$(WIN64_PATH)-gcc.exe
WINDRES=$(WIN64_PATH)-windres.exe WINDRES=$(WIN64_PATH)-windres.exe
include vm/Config.windows.nt include vm/Config.windows.nt

View File

@ -109,17 +109,6 @@ const F_CHAR *default_image_path(void)
snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path); snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path);
temp_path[sizeof(temp_path) - 1] = 0; temp_path[sizeof(temp_path) - 1] = 0;
if(!windows_stat(temp_path)) {
unsigned int len = wcslen(full_path);
F_CHAR magic[] = L"-console";
unsigned int magic_len = wcslen(magic);
if(!wcsncmp(full_path + len - magic_len, magic, MIN(len, magic_len)))
full_path[len - magic_len] = 0;
snwprintf(temp_path, sizeof(temp_path)-1, L"%s.image", full_path);
temp_path[sizeof(temp_path) - 1] = 0;
}
return safe_strdup(temp_path); return safe_strdup(temp_path);
} }